(** Set theory without infinity axiom: hereditarily finite sets *)

Require Export Setoid Morphisms.
Require Import List.
Require Import Bool.

Lemma in_map_inv : forall (A B:Set) (f:A->B) x l,
  In x (map f l) -> exists2 y, In y l & x = f y.
Proof.
induction l; simpl in |- *; intros.
 elim H.
 destruct H.
  exists a; auto.
  elim IHl; intros; trivial.
    exists x0; auto.
Qed.

(*****************)

Inductive hf : Set := HF (elts : list hf).

Definition hf_elts (x:hf) := let (lx) := x in lx.

Lemma hf_elts_ext : forall x, HF (hf_elts x) = x.
destruct x; reflexivity.
Qed.

Lemma hf_ind2 : forall P : hf -> Prop,
  (forall l, (forall x, In x l -> P x) -> P (HF l)) ->
  forall x, P x.
Proof.
intros P Pnode.
fix hf_ind 1.
destruct x.
apply Pnode.
induction elts; simpl in |- *; intros.
 elim H.

 destruct H.
  elim H.
    apply hf_ind.
  apply IHelts; trivial.
Qed.

(*****************)

Definition forall_elt P x :=
  fold_right (fun y b => P y && b) true (hf_elts x).

Definition exists_elt P x :=
  negb (forall_elt (fun x => negb (P x)) x).

Lemma forall_elt_case :
  forall P x,
  forall_elt P x = true /\ (forall y, In y (hf_elts x) -> P y = true) \/
  forall_elt P x = false /\ (exists2 y, In y (hf_elts x) & P y = false).
Proof.
unfold forall_elt in |- *.
destruct x as (lx); simpl.
induction lx; simpl in |- *; intros.
 left.
   split; trivial.
   destruct 1.
 elimtype (P a = true \/ P a = false); intros.
   rewrite H; simpl in |- *.
    elim IHlx; intros.
   left.
     destruct H0; split; trivial.
     destruct 1; auto.
     elim H2; auto.
   right.
     destruct H0.
     split; auto.
     destruct H1.
     exists x; auto.
   rewrite H; simpl in |- *.
    right.
    split; auto.
    exists a; auto.
  destruct (P a); auto.
Qed.

Lemma forall_elt_true_intro :
  forall P x,
  (forall y, In y (hf_elts x) -> P y = true) ->
  forall_elt P x = true.
intros.
elim forall_elt_case with P x; intros.
 destruct H0; trivial.
 destruct H0.
   destruct H1.
    rewrite (H _ H1) in H2;  discriminate.
Qed.

Lemma forall_elt_false_intro :
  forall P y x,
  In y (hf_elts x) ->
  P y = false ->
  forall_elt P x = false.
intros.
elim forall_elt_case with P x; intros.
 destruct H1.
    rewrite (H2 _ H) in H0;  discriminate.
 destruct H1; trivial.
Qed.

Lemma forall_elt_true_elim :
  forall P y x,
  forall_elt P x = true ->
  In y (hf_elts x) ->
  P y = true.
intros.
elim forall_elt_case with P x; intros.
 destruct H1; auto.
 destruct H1.
    rewrite H1 in H;  discriminate.
Qed.

Lemma forall_elt_false_elim :
  forall P x,
  forall_elt P x = false ->
  exists2 y, In y (hf_elts x) & P y = false.
intros.
elim forall_elt_case with P x; intros.
 destruct H0.
    rewrite H0 in H;  discriminate.
 destruct H0; trivial.
Qed.

Lemma exists_elt_true_intro :
  forall P y x,
  In y (hf_elts x) ->
  P y = true ->
  exists_elt P x = true.
intros.
unfold exists_elt in |- *.
 rewrite forall_elt_false_intro with (fun x => negb (P x)) y x; trivial.
 rewrite H0; trivial.
Qed.

Lemma exists_elt_true_elim :
  forall P x,
  exists_elt P x = true ->
  exists2 y, In y (hf_elts x) & P y = true.
intros.
elim forall_elt_false_elim with (fun x => negb (P x)) x; intros.
 exists x0; trivial.
    rewrite <- (negb_elim (P x0)).
    rewrite H1; trivial.
 fold (negb true) in |- *.
   apply negb_sym; trivial.
   symmetry  in |- *; trivial.
Qed.

(** Equality *)

Fixpoint eq_hf (x y: hf) {struct x} : bool :=
  forall_elt (fun x1 => exists_elt (fun y1 => eq_hf x1 y1) y) x &&
  forall_elt (fun y1 => exists_elt (fun x1 => eq_hf x1 y1) x) y.

Definition Eq_hf x y := eq_hf x y = true.

Lemma eq_hf_intro :
  forall x y,
  (forall x', In x' (hf_elts x) ->
   exists2 y', In y' (hf_elts y) & Eq_hf x' y') ->
  (forall y', In y' (hf_elts y) ->
   exists2 x', In x' (hf_elts x) & Eq_hf x' y') ->
  Eq_hf x y.
Proof.
unfold Eq_hf.
destruct x as (lx); simpl; intros.
apply andb_true_intro; split; apply forall_elt_true_intro; intros.
 elim H with (1 := H1); intros.
   apply exists_elt_true_intro with x; auto.
 elim H0 with (1 := H1); intros.
   apply exists_elt_true_intro with x; auto.
Qed.

Lemma eq_hf_elim1 :
  forall x' x y,
  Eq_hf x y ->
  In x' (hf_elts x) ->
  exists2 y', In y' (hf_elts y) & Eq_hf x' y'.
Proof.
unfold Eq_hf.
destruct x as (lx); simpl in |- *; intros.
elim andb_prop with (1 := H); clear H; intros.
specialize forall_elt_true_elim with (1 := H) (2 := H0); intros.
apply exists_elt_true_elim with (P := fun y' => eq_hf x' y').
trivial.
Qed.

Lemma eq_hf_elim2 :
  forall y' x y,
  Eq_hf x y ->
  In y' (hf_elts y) ->
  exists2 x', In x' (hf_elts x) & Eq_hf x' y'.
Proof.
unfold Eq_hf.
destruct x as (lx); destruct y as (ly); simpl in |- *; intros.
elim andb_prop with (1 := H); clear H; intros.
specialize forall_elt_true_elim with (1 := H1) (2 := H0); intros.
change lx with (hf_elts (HF lx)).
apply exists_elt_true_elim with (P := fun x1 => eq_hf x1 y').
trivial.
Qed.

Instance eq_hf_refl : Reflexive Eq_hf.
red; intro.
elim x using hf_ind2; intros.
apply eq_hf_intro; intros.
 exists x'; auto.
 exists y'; auto.
Qed.

Instance eq_hf_sym : Symmetric Eq_hf.
red; intros x.
elim x using hf_ind2; destruct y; intros.
apply eq_hf_intro; intros.
 elim eq_hf_elim2 with (1 := H0) (2 := H1); intros.
   exists x0; auto.
 elim eq_hf_elim1 with (1 := H0) (2 := H1); intros.
   exists x0; auto.
Qed.

Instance eq_hf_trans : Transitive Eq_hf.
red; intros x.
elim x using hf_ind2; destruct y; destruct z; intros.
apply eq_hf_intro; intros.
 elim eq_hf_elim1 with (1 := H0) (2 := H2); intros.
   elim eq_hf_elim1 with (1 := H1) (2 := H3); intros.
   exists x1;  eauto.
 elim eq_hf_elim2 with (1 := H1) (2 := H2); intros.
   elim eq_hf_elim2 with (1 := H0) (2 := H3); intros.
   exists x1;  eauto.
Qed.

Instance eq_hf_equiv : Equivalence Eq_hf. (* why is it needed? *)
constructor; auto with *.
Qed.

Instance eq_hf_morph : Proper (Eq_hf ==> Eq_hf ==> @eq bool) eq_hf.
repeat red; intros.
apply bool_1.
fold (Eq_hf x x0) (Eq_hf y y0).
rewrite H; rewrite H0; reflexivity.
Qed.

(** Membership *)

Definition in_hf (x y: hf) : bool := exists_elt (fun y1 => eq_hf x y1) y.

Definition In_hf x y := in_hf x y = true.

Lemma in_hf_intro : forall x x' y,
  Eq_hf x x' ->
  In x' (hf_elts y) ->
  In_hf x y.
intros.
unfold In_hf, in_hf.
apply exists_elt_true_intro with x'; auto.
Qed.

Lemma in_hf_elim : forall x y,
  In_hf x y ->
  exists2 x', In x' (hf_elts y) & Eq_hf x x'.
unfold In_hf, in_hf.
intros.
apply exists_elt_true_elim with (1:=H).
Qed.

Lemma in_hf_reg_l: forall a a' b,
  Eq_hf a a' -> In_hf a b -> In_hf a' b.
intros.
elim in_hf_elim with (1:=H0); intros.
apply in_hf_intro with x; trivial.
transitivity a; trivial; symmetry; trivial.
Qed.

Lemma in_hf_reg_r :
  forall a x y,
  Eq_hf x y ->
  In_hf a x ->
  In_hf a y.
intros.
elim in_hf_elim with (1:=H0); intros.
elim eq_hf_elim1 with (1:=H) (2:=H1); intros.
apply in_hf_intro with x1; trivial.
transitivity x0; trivial.
Qed.

Instance In_hf_morph : Proper (Eq_hf ==> Eq_hf ==> iff) In_hf.
split; intros.
 apply in_hf_reg_l with x; trivial.
 apply in_hf_reg_r with x0; trivial.

 symmetry in H, H0.
 apply in_hf_reg_l with y; trivial.
 apply in_hf_reg_r with y0; trivial.
Qed.

Instance in_hf_morph : Proper (Eq_hf ==> Eq_hf ==> @eq _) in_hf.
repeat red; intros.
apply bool_1.
fold (In_hf x x0) (In_hf y y0).
rewrite H; rewrite H0; reflexivity.
Qed.

Lemma In_hf_head : forall x y l,
  Eq_hf x y ->
  In_hf x (HF (y::l)).
intros.
apply in_hf_intro with y; simpl; auto.
Qed.

Lemma In_hf_tail : forall x y l,
  In_hf x (HF l) ->
  In_hf x (HF (y::l)).
intros.
elim in_hf_elim with (1:=H); intros.
apply in_hf_intro with x0; simpl; auto.
Qed.

Lemma In_hf_elim : forall x y l,
  In_hf x (HF (y::l)) ->
  Eq_hf x y \/ In_hf x (HF l).
Proof.
intros.
elim in_hf_elim with (1:=H); simpl; intros.
destruct H0.
 subst x0; auto.
 right; apply in_hf_intro with x0; trivial.
Qed.

Lemma In_app_left : forall x l1 l2,
  In_hf x (HF l1) ->
  In_hf x (HF (l1 ++ l2)).
Proof.
induction l1; simpl; intros.
 inversion H.

 elim In_hf_elim with (1:=H); intros.
  apply In_hf_head; trivial.
  apply In_hf_tail; auto.
Qed.

Lemma In_app_right : forall x l1 l2,
  In_hf x (HF l2) ->
  In_hf x (HF (l1 ++ l2)).
Proof.
induction l1; simpl; intros; auto.
 apply In_hf_tail; auto.
Qed.

Lemma In_app_elim : forall x l1 l2,
  In_hf x (HF (l1 ++ l2)) ->
  In_hf x (HF l1) \/ In_hf x (HF l2).
induction l1; simpl; intros; auto.
elim In_hf_elim with (1:=H); intros.
 left.
 apply In_hf_head; trivial.

 elim IHl1 with (1:=H0); intros; auto.
 left.
 apply In_hf_tail; trivial.
Qed.

Definition incl_hf x y :=
  forall_elt (fun x1 => in_hf x1 y) x.

Definition Incl_hf x y := forall a, In_hf a x -> In_hf a y.

Instance incl_hf_morph : Proper (Eq_hf ==> Eq_hf ==> iff) Incl_hf.
unfold Incl_hf; split; intros.
 rewrite <- H0; rewrite <- H in H2; auto.
 rewrite H0; rewrite H in H2; auto.
Qed.

Lemma incl_hf_sound : forall x y,
  incl_hf x y = true -> Incl_hf x y.
unfold incl_hf, Incl_hf.
intros.
elim in_hf_elim with (1:=H0); intros.
specialize forall_elt_true_elim with (1:=H) (2:=H1); intros.
apply in_hf_reg_l with x0; trivial.
symmetry; trivial.
Qed.

Lemma incl_hf_complete :  forall x y,
  Incl_hf x y -> incl_hf x y = true.
unfold incl_hf, Incl_hf; intros.
apply forall_elt_true_intro; intros.
apply H.
apply in_hf_intro with y0; trivial; reflexivity.
Qed.

Lemma Eq_hf_intro : forall x y,
  Incl_hf x y -> Incl_hf y x -> Eq_hf x y.
intros.
apply eq_hf_intro; intros.
 apply in_hf_elim.
 apply H.
 apply in_hf_intro with x'; trivial; reflexivity.

 elim (in_hf_elim y' x); intros.
  exists x0; trivial; symmetry; trivial.

  apply H0.
  apply in_hf_intro with y'; trivial; reflexivity.
Qed.

Lemma Eq_hf_cons : forall x1 x2 l1 l2,
  Eq_hf x1 x2 ->
  Eq_hf (HF l1) (HF l2) ->
  Eq_hf (HF (x1::l1)) (HF (x2::l2)).
Proof.
intros.
apply Eq_hf_intro; red; simpl in |- *; intros.
 elim In_hf_elim with (1:=H1); intros.
  apply In_hf_head; transitivity x1; trivial.
  apply In_hf_tail; apply in_hf_reg_r with (HF l1); trivial.

 elim In_hf_elim with (1:=H1); intros.
  apply In_hf_head; transitivity x2; trivial.
  symmetry; trivial.

  apply In_hf_tail; apply in_hf_reg_r with (HF l2); trivial.
  symmetry; trivial.
Qed.

Lemma Eq_hf_split : forall l1 l1' l2 l2',
  Eq_hf (HF l1) (HF l1') ->
  Eq_hf (HF l2) (HF l2') ->
  Eq_hf (HF(l1++l2)) (HF(l1'++l2')).
intros.
apply Eq_hf_intro; red; intros.
 elim In_app_elim with (1:=H1); intros.
  apply In_app_left.
  apply in_hf_reg_r with (HF l1); auto.

  apply In_app_right.
  apply in_hf_reg_r with (HF l2); auto.

 elim In_app_elim with (1:=H1); intros.
  apply In_app_left.
  apply in_hf_reg_r with (HF l1'); auto.
  symmetry; auto.

  apply In_app_right.
  apply in_hf_reg_r with (HF l2'); auto.
  symmetry; auto.
Qed.

Lemma hf_size_ind : forall (P:hf->Type) x,
  P (HF nil) ->
  (forall x' y,
   In_hf x' x ->
   Incl_hf y x ->
   P y -> P (HF(x'::hf_elts y))) ->
  P x.
Proof.
destruct x as (x).
intro Pnil.
elim x; intros; trivial.
change l with (hf_elts (HF l)).
apply  X0.
 apply In_hf_head; reflexivity.

 red; intros; apply In_hf_tail; trivial.

 apply X; intros.
 apply X0; trivial.
  apply In_hf_tail; trivial.
  red; intros; apply In_hf_tail; auto.
Qed.

(** Cancelling redundancies *)

Lemma cancel_repeat : forall a l,
  In_hf a (HF l) -> Eq_hf (HF(a::l)) (HF l).
intros.
apply Eq_hf_intro; red; intros.
 elim In_hf_elim with (1:=H0); intros; auto.
 rewrite H1; trivial.

 apply In_hf_tail; trivial.
Qed.

Definition cons_hf x l := if in_hf x (HF l) then l else x :: l.

Lemma cons_hf_cons :
  forall x l, Eq_hf (HF(cons_hf x l)) (HF(cons x l)).
unfold cons_hf.
intros.
case_eq (in_hf x (HF l)); intro.
 symmetry; apply cancel_repeat; trivial.
 reflexivity.
Qed.

Lemma In_hf_head_hf : forall x y l,
  Eq_hf x y ->
  In_hf x (HF (cons_hf y l)).
Proof.
intros.
rewrite cons_hf_cons.
apply In_hf_head; trivial.
Qed.

Lemma In_hf_tail_hf : forall x y l,
  In_hf x (HF l) ->
  In_hf x (HF (cons_hf y l)).
Proof.
intros.
rewrite cons_hf_cons.
apply In_hf_tail; trivial.
Qed.

Lemma In_hf_elim_hf : forall x y l,
  In_hf x (HF (cons_hf y l)) ->
  Eq_hf x y \/ In_hf x (HF l).
intros.
rewrite cons_hf_cons in H.
apply In_hf_elim; trivial.
Qed.

Lemma Eq_hf_cons_hf : forall x1 x2 l1 l2,
  Eq_hf x1 x2 ->
  Eq_hf (HF l1) (HF l2) ->
  Eq_hf (HF (cons_hf x1 l1)) (HF (cons_hf x2 l2)).
Proof.
intros.
do 2 rewrite cons_hf_cons.
apply Eq_hf_cons; trivial.
Qed.

Fixpoint app_hf (l1 l2:list hf) {struct l1} : list hf :=
  match l1 with
    nil => l2
  | cons x l' => cons_hf x (app_hf l' l2)
  end.

Lemma In_app_hf_left : forall x l1 l2,
  In_hf x (HF l1) ->
  In_hf x (HF (app_hf l1 l2)).
Proof.
induction l1; simpl; intros.
 inversion H.

 elim In_hf_elim with (1:=H); intros.
  apply In_hf_head_hf; trivial.
  apply In_hf_tail_hf; auto.
Qed.

Lemma In_app_hf_right : forall x l1 l2,
  In_hf x (HF l2) ->
  In_hf x (HF (app_hf l1 l2)).
Proof.
induction l1; simpl; intros; auto.
 apply In_hf_tail_hf; auto.
Qed.

Lemma In_app_hf_elim : forall x l1 l2,
  In_hf x (HF (app_hf l1 l2)) ->
  In_hf x (HF l1) \/ In_hf x (HF l2).
induction l1; simpl; intros; auto.
elim In_hf_elim_hf with (1:=H); intros.
 left.
 apply In_hf_head; trivial.

 elim IHl1 with (1:=H0); intros; auto.
 left.
 apply In_hf_tail; trivial.
Qed.

Definition fold_set (X:Type) (f:hf->X->X) (x:hf) (acc:X) : X :=
  let fix F (l:list hf) : X :=
    match l with
      nil => acc
    | cons x l' => if in_hf x (HF l') then F l' else f x (F l')
    end in
  F (hf_elts x).

Lemma fold_set_unfold : forall X f x l acc,
  fold_set X f (HF(x::l)) acc =
  if in_hf x (HF l) then fold_set X f (HF l) acc
  else f x (fold_set X f (HF l) acc).
reflexivity.
Qed.

Lemma fold_set_ind : forall X (P:hf->X->Prop) f x acc,
  P (HF nil) acc ->
  (forall x' y acc, In_hf x' x -> In_hf x' y -> P y acc ->
   P (HF(x'::hf_elts y)) acc) ->
  (forall x' y acc, In_hf x' x -> ~ In_hf x' y -> P y acc ->
   P (HF(x'::hf_elts y)) (f x' acc)) ->
  P x (fold_set X f x acc).
Proof.
destruct x.
induction elts; simpl; intros; auto.
rewrite fold_set_unfold.
case_eq (in_hf a (HF elts)); intro.
 change elts with (hf_elts (HF elts)).
 apply H0; trivial.
  apply In_hf_head; reflexivity.

  simpl in IHelts; apply (IHelts acc); intros; trivial.
   apply H0; trivial.
   apply In_hf_tail; trivial.

   apply H1; trivial.
   apply In_hf_tail; trivial.

 change elts with (hf_elts (HF elts)).
 apply H1; trivial.
  apply In_hf_head; reflexivity.

  unfold In_hf; rewrite H2; discriminate.

  simpl in IHelts; apply (IHelts acc); intros; trivial.
   apply H0; trivial.
   apply In_hf_tail; trivial.

   apply H1; trivial.
   apply In_hf_tail; trivial.
Qed.

Fixpoint canonical (x:hf) : hf :=
  HF (fold_set _ (fun y cl => canonical y :: cl) x nil).

Lemma canonical_correct : forall x, Eq_hf (canonical x) x.
Proof.
intro.
elim x using hf_ind2; intros.
unfold canonical in |- *; fold canonical in |- *.
induction l; simpl in |- *; intros.
 compute; reflexivity.

 rewrite fold_set_unfold.
 case_eq (in_hf a (HF l)); intro.
  apply eq_hf_trans with (HF l); auto with *.
  symmetry; apply cancel_repeat; trivial.

  apply Eq_hf_cons; auto with *.
Qed.

Hint Resolve In_hf_head In_hf_head_hf In_hf_head_hf In_hf_tail_hf.

(** Notations *)

Notation "{ l }" := (HF l) (at level 0, l at level 99).

Notation EMPTY := {nil}.
Notation ONE := {EMPTY::nil}.
Notation TWO := {EMPTY::ONE::nil}.

Infix ":::" := cons_hf (at level 60, right associativity).
Infix "+++" := app_hf (at level 60, right associativity).

(* *)
Notation "x ∈ y" := (In_hf x y) (at level 60).
Notation "x == y" := (Eq_hf x y) (at level 70).

Notation morph1 := (Proper (Eq_hf ==> Eq_hf)).
Notation morph2 := (Proper (Eq_hf ==> Eq_hf ==> Eq_hf)).
Notation morph3 := (Proper (Eq_hf ==> Eq_hf ==> Eq_hf ==> Eq_hf)).

(** Set theoretical operators *)

Definition empty := HF nil.
Definition singl x := HF (x:::nil).
Definition pair x y := HF (x:::y:::nil).

Definition union (x:hf) :=
  HF (fold_set _ (fun y l => hf_elts y+++l) x nil).

Definition power (x:hf) :=
  HF (fold_set _
          (fun y pow p => pow p ++ pow (y::p)) x
           (fun p => HF (rev p) :: nil) nil).

Definition subset (x:hf) (P:hf->bool) :=
  HF (fold_set _ (fun y l => if P y then y :: l else l) x nil).

Definition repl (x:hf) (f:hf->hf) :=
  HF (map f (hf_elts x)).

Instance singl_morph : morph1 singl.
Proof.
unfold singl in |- *; do 2 red; intros.
apply Eq_hf_cons_hf; trivial.
reflexivity.
Qed.

Instance pair_morph : morph2 pair.
Proof.
unfold pair in |- *; do 3 red; intros.
repeat apply Eq_hf_cons_hf; trivial.
reflexivity.
Qed.

Definition eq_hf_fun (x:hf) (f1 f2:hf->hf) :=
  forall y1 y2, y1 ∈ x -> y1 == y2 -> f1 y1 == f2 y2.

Lemma eq_hf_fun_sym : forall x f1 f2,
  eq_hf_fun x f1 f2 -> eq_hf_fun x f2 f1.
Proof.
unfold eq_hf_fun in |- *; intros.
symmetry  in |- *.
apply H.
 apply in_hf_reg_l with y1; trivial.
 symmetry  in |- *; trivial.
Qed.

Lemma eq_hf_fun_trans : forall x f1 f2 f3,
   eq_hf_fun x f1 f2 -> eq_hf_fun x f2 f3 -> eq_hf_fun x f1 f3.
Proof.
unfold eq_hf_fun in |- *; intros.
transitivity (f2 y1); auto.
apply H; trivial.
reflexivity.
Qed.

Lemma eq_hf_fun_left : forall x f1 f2,
  eq_hf_fun x f1 f2 -> eq_hf_fun x f1 f1.
Proof.
unfold eq_hf_fun in |- *; intros.
transitivity (f2 y2); auto.
symmetry  in |- *.
apply H.
 apply in_hf_reg_l with y1; trivial.
 reflexivity.
Qed.

Definition hf_pred_morph x P :=
  forall y1 y2, y1 ∈ x -> y1 == y2 -> P y1 = true -> P y2 = true.

Definition eq_hf_pred (x:hf) (f1 f2:hf->bool) :=
  forall y1 y2, y1 ∈ x -> y1 == y2 -> f1 y1 = f2 y2.

(* *)

Lemma empty_elim : forall x, ~ x ∈ empty.
compute in |- *; intros;  discriminate.
Qed.

Lemma empty_ext : forall a, (forall x, ~ x ∈ a) -> a == empty.
intros.
apply Eq_hf_intro; red; intros.
 elim H with a0; trivial.
 elim empty_elim with a0; trivial.
Qed.

Lemma singl_intro : forall x y, x == y -> x ∈ singl y.
unfold singl in |- *; auto.
Qed.

Lemma singl_elim : forall x a, x ∈ singl a -> x == a.
unfold singl in |- *; intros.
elim In_hf_elim_hf with (1 := H); intros; auto.
discriminate H0.
Qed.

Lemma singl_ext :
  forall y x,
  x ∈ y ->
  (forall z, z ∈ y -> z == x) ->
  y == singl x.
Proof.
intros; apply Eq_hf_intro; red; intros.
 apply singl_intro; auto.
 apply in_hf_reg_l with x; trivial.
  symmetry  in |- *; apply singl_elim; trivial.
Qed.

Lemma pair_elim : forall x a b,
  x ∈ pair a b -> x == a \/ x == b.
intros.
unfold pair in H.
elim In_hf_elim_hf with (1 := H); intros; auto.
right.
elim In_hf_elim_hf with (1 := H0); intros; auto.
 discriminate H1.
Qed.

Lemma pair_intro1 : forall x a b, x == a -> x ∈ pair a b.
Proof.
unfold pair;auto.
Qed.

Lemma pair_intro2 : forall x a b, x == b -> x ∈ pair a b.
Proof.
unfold pair;auto.
Qed.

Lemma union_intro : forall x y z, x ∈ y -> y ∈ z -> x ∈ union z.
Proof.
intros x y z H.
unfold union.
pattern z, (fold_set _ (fun y0 l => hf_elts y0 +++ l) z nil).
apply fold_set_ind; intros.
 discriminate.

 apply H2.
 rewrite cancel_repeat in H3; auto.

 elim In_hf_elim with (1:=H3); intros.
  apply In_app_hf_left.
  rewrite hf_elts_ext.
  rewrite <- H4; trivial.

  apply In_app_hf_right.
  rewrite hf_elts_ext in H4.
  auto.
Qed.

Lemma union_elim : forall x z, x ∈ union z -> exists2 y, x ∈ y & y ∈ z.
unfold union.
intros x z.
pattern z, (fold_set _ (fun y l => hf_elts y +++ l) z nil).
apply fold_set_ind; intros.
 discriminate.

 destruct H1; trivial.
 exists x0; trivial.
 rewrite cancel_repeat; auto.

 elim In_app_hf_elim with (1:=H2); intros.
  rewrite hf_elts_ext in H3.
  exists x'; trivial.
  apply In_hf_head; reflexivity.

  elim H1 with (1:=H3); intros.
  exists x0; trivial.
  apply In_hf_tail.
  rewrite hf_elts_ext; trivial.
Qed.

Lemma union_ext :
  forall u z,
  (forall x y, x ∈ y -> y ∈ z -> x ∈ u) ->
  (forall x, x ∈ u -> exists2 y, x ∈ y & y ∈ z) ->
  u == union z.
intros.
apply Eq_hf_intro; red; intros.
 elim H0 with (1:=H1); intros.
 apply union_intro with x; trivial.

 elim union_elim with (1:=H1); intros.
 eauto.
Qed.

Instance union_morph : morph1 union.
do 2 red; intros.
apply union_ext; intros.
 apply union_intro with y0; trivial.
 rewrite H; trivial.

 elim union_elim with (1 := H0); intros.
 exists x1; trivial.
 rewrite <- H; trivial.
Qed.

Lemma union_singl : forall x, union (singl x) == x.
intros.
symmetry; apply union_ext; intros.
 apply singl_elim in H0.
 rewrite <- H0; trivial.

 exists x; trivial.
 apply singl_intro; reflexivity.
Qed.

(** power properties *)

Lemma power_intro :
  forall x y, Incl_hf x y -> x ∈ power y.
unfold power.
set (g := fun y0 (pow:list hf ->list hf) p => pow p ++ pow (y0 :: p)).
set (h := fun p => HF(rev p) :: nil).
intros x y.
assert (forall x l, Incl_hf (HF (rev l)) x ->
 Incl_hf x (HF(rev l ++ hf_elts y)) ->
 x ∈ HF(fold_set _ g y h l)).
clear x.
pattern y, (fold_set _ g y h).
apply fold_set_ind; intros.
 unfold h; simpl.
 apply In_hf_head.
 apply Eq_hf_intro; trivial.
 red; intros.
 elim In_app_elim with (1:=H0 _ H1); intros; auto.
 elim empty_elim with a; trivial.

 apply H1; trivial.
 red; intros.
 elim In_app_elim with (1:=H3 _ H4); intros.
  apply In_app_left; trivial.

  apply In_app_right.
  rewrite hf_elts_ext in H5.
  elim In_hf_elim with (1:=H5); intros; trivial.
  rewrite H6; trivial.

 unfold g; simpl.
 case_eq (in_hf x' x); intros.
  apply In_app_right.
  apply H1.
   red; simpl; intros.
   elim In_app_elim with (1:=H5); intros; auto.
   elim In_hf_elim with (1:=H6); simpl; intros.
    rewrite H7; trivial.
    elim empty_elim with a; trivial.

  simpl.
  rewrite app_ass; simpl.
  trivial.

 apply In_app_left.
 apply H1; trivial.
 red; intros.
 elim In_app_elim with (1:=H3 _ H5); simpl; intros.
  apply In_app_left; trivial.

  apply In_app_right.
  elim In_hf_elim with (1:=H6); intros; auto.
  rewrite H7 in H5; unfold In_hf in H5; rewrite H5 in H4; discriminate.

intro; apply H; simpl.
 red; intros.
 elim empty_elim with a; trivial.

 rewrite hf_elts_ext; trivial.
Qed.

Lemma power_elim : forall x y z, x ∈ power y -> z ∈ x -> z ∈ y.
unfold power.
set (g := fun y0 (pow:list hf ->list hf) p => pow p ++ pow (y0 :: p)).
set (h := fun p => HF(rev p) :: nil).
intros x y.
assert (forall l,
 x ∈ HF(fold_set _ g y h l) ->
 forall z, z ∈ x -> ~ z ∈ (HF(rev l)) -> z ∈ y).
 pattern y, (fold_set _ g y h).
 apply fold_set_ind; intros.
  unfold h in H.
  elim H1.
  apply in_hf_reg_r with (2:=H0).
  apply singl_elim.
  assumption.

 apply In_hf_tail.
 rewrite hf_elts_ext.
 eauto.

 unfold g in H2.
 elim In_app_elim with (1:=H2);intros.
  apply In_hf_tail; rewrite hf_elts_ext.
  apply H1 with l; trivial.

  case_eq (eq_hf z x'); intro.
   apply In_hf_head; trivial.

   apply In_hf_tail; rewrite hf_elts_ext.
   apply H1 with (1:=H5); trivial.
   simpl; red; intros; apply H4.
   elim In_app_elim with (1:=H7); intros; trivial.
   replace (eq_hf z x') with true in H6; try discriminate.
   symmetry; apply singl_elim.
   assumption.

intros.
apply H with (l:=@nil hf); trivial.
red; intros; discriminate.
Qed.

Lemma power_ext :
  forall p a,
  (forall x, (forall y, y ∈ x -> y ∈ a) -> x ∈ p) ->
  (forall x y, x ∈ p -> y ∈ x -> y ∈ a) ->
  p == power a.
intros.
apply Eq_hf_intro; red; intros.
 apply power_intro; red; intros; eauto.

 apply H; intros.
 eapply power_elim; eauto.
Qed.

Lemma power_morph : morph1 power.
do 2 red; intros.
apply power_ext; intros.
 apply power_intro.
 rewrite H; trivial.

 rewrite <- H.
 apply power_elim with (1 := H0); trivial.
Qed.

Lemma subset_intro_gen : forall a (P:hf->bool) x,
  x ∈ a -> (forall x', x==x' -> P x' = true) -> x ∈ subset a P.
unfold subset.
intros a P x in_a in_P; revert in_a.
set (g := fun y l => if P y then y :: l else l).
pattern a, (fold_set _ g a nil).
apply fold_set_ind; simpl; intros; auto.
 apply H1; trivial.
 rewrite cancel_repeat in in_a; auto.

 unfold g.
 elim In_hf_elim with (1:=in_a);intros.
  rewrite in_P; trivial.
  apply In_hf_head; trivial.

  destruct (P x'); auto.
  apply In_hf_tail; auto.
Qed.

Lemma subset_intro : forall a (P:hf->bool) x,
  hf_pred_morph a P ->
  x ∈ a -> P x = true -> x ∈ subset a P.
intros.
apply subset_intro_gen; trivial.
intros.
red in H.
apply H with (2:=H2); trivial.
Qed.

Lemma subset_elim1 : forall a (P:hf->bool) x, x ∈ subset a P -> x ∈ a.
unfold subset.
intros a P x.
set (g := fun y l => if P y then y :: l else l).
pattern a, (fold_set _ g a nil).
apply fold_set_ind; simpl; intros; auto.

rewrite cancel_repeat; auto.

unfold g in H2.
destruct (P x').
 elim In_hf_elim with (1:=H2); intros.
  apply In_hf_head; trivial.
  apply In_hf_tail; auto.

 apply In_hf_tail; auto.
Qed.

Lemma subset_elim2_gen : forall a (P:hf->bool) x,
  x ∈ subset a P ->
  exists2 x', x==x' & P x' = true.
unfold subset.
intros a P x.
set (g := fun y l => if P y then y :: l else l).
pattern a, (fold_set _ g a nil).
apply fold_set_ind; simpl; intros; auto.
 discriminate.

 unfold g in H2.
 case_eq (P x'); intro.
  rewrite H3 in H2.
  elim In_hf_elim with (1:=H2); intros; auto.
  exists x'; trivial.

  rewrite H3 in H2; auto.
Qed.

Lemma subset_elim2 : forall a (P:hf->bool) x,
  hf_pred_morph a P ->
  x ∈ subset a P ->
  P x = true.
unfold subset.
intros a P x Pmorph.
set (g := fun y l => if P y then y :: l else l).
pattern a, (fold_set _ g a nil).
apply fold_set_ind; simpl; intros; auto.
 discriminate.

 unfold g in H2.
 case_eq (P x'); intro.
  rewrite H3 in H2.
  elim In_hf_elim with (1:=H2); intros; auto.
  apply Pmorph with x'; auto.
  symmetry; trivial.

  rewrite H3 in H2; auto.
Qed.

Lemma subset_ext :
  forall s a (P:hf->bool),
  hf_pred_morph a P ->
  (forall x, x ∈ a -> P x = true -> x ∈ s) ->
  (forall x, x ∈ s -> x ∈ a) ->
  (forall x, x ∈ s -> P x = true) ->
  s == subset a P.
intros.
apply Eq_hf_intro; red; intros.
 apply subset_intro; auto.

 apply H0.
  apply subset_elim1 with (1:=H3); trivial.
  apply subset_elim2 with (2:=H3); trivial.
Qed.

Lemma subset_morph_ext : forall x1 x2 y1 y2,
  x1 == x2 -> eq_hf_pred x1 y1 y2 -> subset x1 y1 == subset x2 y2.
intros.
assert (hf_pred_morph x1 y1).
 red; intros.
 red in H0.
 rewrite H0 with y3 y3; trivial.
  rewrite <- H0 with y0 y3; trivial.
  apply in_hf_reg_l with y0; auto.
  reflexivity.
assert (hf_pred_morph x2 y2).
 red; intros.
 red in H0.
 rewrite <- H0 with y0 y3; trivial.
  rewrite H0 with y0 y0; trivial.
   apply in_hf_reg_r with x2; auto.
   symmetry; trivial.
   reflexivity.
  apply in_hf_reg_r with x2; auto.
  symmetry; trivial.
apply subset_ext; intros; trivial.
 apply subset_intro; trivial.
  apply in_hf_reg_r with x2; auto.
  symmetry; trivial.

  rewrite H0 with x x; trivial.
   apply in_hf_reg_r with x2; auto.
   symmetry; trivial.

   reflexivity.

 apply in_hf_reg_r with x1; auto.
 apply subset_elim1 with (1:=H3).

 rewrite <- H0 with x x.
  apply subset_elim2 with (2:=H3); trivial.

  apply subset_elim1 with (1:=H3).

  reflexivity.
Qed.

Lemma subset_empty1 : forall P, subset empty P == empty.
intros.
apply empty_ext; red; intros.
apply subset_elim1 in H.
elim empty_elim with x; trivial.
Qed.

Lemma subset_singl : forall x a (P:hf->bool),
  x ∈ a ->
  P x = true ->
  (forall x', x' ∈ a -> (x==x' <-> P x' = true)) ->
  subset a P == singl x.
intros.
apply singl_ext; intros.
 apply subset_intro_gen; trivial; intros.
 apply -> H1; trivial.
 rewrite <- H2; trivial.

 elim subset_elim2_gen with (1:=H2); intros.
 transitivity x0; trivial.
 symmetry; apply <- H1; trivial.
 rewrite <- H3.
 apply subset_elim1 in H2; trivial.
Qed.

(** replacement properties *)

Lemma repl_intro : forall a f y x,
  eq_hf_fun a f f ->
  y ∈ a -> x == f y -> x ∈ repl a f.
Proof.
unfold repl.
intros a f y x.
destruct a as (a); simpl.
elim a; simpl; intros.
 elim empty_elim with y; trivial.

 elim In_hf_elim with (1:=H1); intros.
  apply In_hf_head.
  rewrite H2; auto.

  apply In_hf_tail.
  apply H; trivial.
  red; intros; apply H0; trivial.
  apply In_hf_tail; trivial.
Qed.

Lemma repl_elim : forall a f x,
  eq_hf_fun a f f ->
  x ∈ repl a f -> exists2 y, y ∈ a & x == f y.
Proof.
unfold repl.
intros a f x.
destruct a as (a); elim a; simpl; intros.
 elim empty_elim with x; trivial.

 elim In_hf_elim with (1:=H1); intros.
  exists a0; trivial.
  apply In_hf_head; reflexivity.

  elim H with (2:=H2); intros.
   exists x0; trivial.
   apply In_hf_tail; trivial.

   red; intros; apply H0; trivial.
   apply In_hf_tail; trivial.
Qed.

Lemma repl_ext : forall x a f,
  eq_hf_fun a f f ->
  (forall y, y ∈ a -> f y ∈ x) ->
  (forall y, y ∈ x -> exists2 z, z ∈ a & y == f z) ->
  x == repl a f.
intros.
apply Eq_hf_intro; red; intros.
 elim H1 with (1:=H2); intros.
 apply repl_intro with x0 ;trivial.

 elim repl_elim with (2:=H2); intros; trivial.
 apply in_hf_reg_l with (f x0); auto.
 symmetry; trivial.
Qed.

Lemma repl_morph :
  forall x1 x2 f1 f2,
  x1 == x2 ->
  eq_hf_fun x1 f1 f2 ->
  repl x1 f1 == repl x2 f2.
unfold eq_hf_fun, repl.
intros.
apply eq_hf_intro; simpl; intros.
 elim in_map_inv with (1 := H1); intros.
   elim eq_hf_elim1 with (1 := H) (2 := H2); intros.
   exists (f2 x0).
  apply in_map; trivial.
   rewrite H3.
    apply H0; auto.
    apply in_hf_intro with x; trivial; reflexivity.
 elim in_map_inv with (1 := H1); intros.
   elim eq_hf_elim2 with (1 := H) (2 := H2); intros.
   exists (f1 x0).
  apply in_map; trivial.
   rewrite H3.
    apply H0; auto.
    apply in_hf_intro with x0; trivial; reflexivity.
Qed.

(** bool *)
Definition hf_false := empty.
Definition hf_true := singl hf_false.
Definition hf_bool := pair hf_false hf_true.

(** couples *)
Definition couple x y := pair (singl x) (pair x y).
Definition fst p := union (subset (union p) (fun x => in_hf (singl x) p)).
Definition snd p :=
  union (subset (union p) (fun y => eq_hf (pair (fst p) y) (union p))).

Lemma union_couple_eq : forall a b, union (couple a b) == pair a b.
Proof.
intros; unfold couple in |- *; symmetry  in |- *.
apply union_ext; intros.
 elim pair_elim with (1 := H0); intro y_eq;  rewrite y_eq in H; trivial.
 apply pair_intro1.
 apply singl_elim; trivial.

 elim pair_elim with (1 := H); intro.
  exists (singl a).
   apply singl_intro; auto.
   apply pair_intro1; reflexivity.

  exists (pair a b).
   apply pair_intro2; trivial.
   apply pair_intro2; reflexivity.
Qed.

Instance couple_morph : morph2 couple.
unfold couple; do 3 red; intros.
rewrite H; rewrite H0; reflexivity.
Qed.

Instance fst_morph : morph1 fst.
unfold fst; do 2 red; intros.
apply union_morph.
apply subset_morph_ext.
 apply union_morph; trivial.

 red in |- *; intros.
 rewrite H; rewrite H1; trivial.
Qed.

Lemma fst_def : forall x y, fst (couple x y) == x.
unfold fst.
intros.
assert (hf_pred_morph (union (couple x y))
         (fun x0 => in_hf (singl x0) (couple x y))).
 red; intros.
 change (singl y2 ∈ couple x y).
 rewrite <- H0; trivial.
symmetry.
apply union_ext; intros.
 apply in_hf_reg_r with y0; trivial.
 specialize subset_elim2 with (1:=H) (2:=H1); clear H1; intro.
 unfold couple in H1.
 elim pair_elim with (1:=H1); clear H1; intros.
  apply singl_elim.
  apply in_hf_reg_r with (singl y0); auto.
  apply singl_intro; reflexivity.

  symmetry; apply singl_elim.
  apply in_hf_reg_r with (pair x y).
   symmetry; trivial.
   apply pair_intro1; reflexivity.

 exists x; trivial.
 apply subset_intro; trivial.
  apply union_intro with (singl x).
   apply singl_intro; reflexivity.
   unfold couple; apply pair_intro1; reflexivity.

  unfold couple; apply pair_intro1; reflexivity.
Qed.

Instance snd_morph : morph1 snd.
unfold snd; do 2 red; intros.
apply union_morph.
apply subset_morph_ext.
 apply union_morph; trivial.

 red in |- *; intros.
 rewrite H; rewrite H1; trivial.
Qed.

Lemma snd_def : forall x y, snd (couple x y) == y.
intros; unfold snd in |- *.
assert (hf_pred_morph (union (couple x y))
    (fun y0 => eq_hf (pair (fst (couple x y)) y0) (union (couple x y)))).
 red; intros.
 change (pair (fst (couple x y)) y2 == union (couple x y)).
 rewrite <- H0; trivial.
transitivity (union (singl y)).
 apply union_morph.
   apply singl_ext; intros.
  apply subset_intro; trivial.
    rewrite union_couple_eq.
    apply pair_intro2; reflexivity.

    rewrite fst_def.
    apply eq_hf_sym.
    apply union_couple_eq.

  specialize subset_elim2 with (1 := H) (2:=H0); intro.
  generalize H1.
  rewrite fst_def.
  clear H0; intro.
  rewrite union_couple_eq in H0.
  elim pair_elim with z x y; intros; trivial.
   rewrite H2 in H0 |- *; clear H2.
   symmetry.
   elim pair_elim with y x x; intros; trivial.
   apply in_hf_reg_r with (pair x y).
    symmetry; trivial.
    apply pair_intro2; reflexivity.

  apply in_hf_reg_r with (pair x z); trivial.
  apply pair_intro2; reflexivity.

 symmetry; apply union_ext; intros.
  apply in_hf_reg_r with y0; trivial.
  apply singl_elim; trivial.

  exists y; trivial.
  apply singl_intro; reflexivity.
Qed.

Lemma snd_ext : forall p x y,
 p == couple x y ->
 y == snd p.
intros.
rewrite H; rewrite snd_def; reflexivity.
Qed.

(* example *)

(*
Definition hf_negb :=
 lam hf_bool (fun b => if eq_hf b hf_true then hf_false else hf_true).

Eval compute in (eq_hf hf_true (app hf_negb hf_false)).
Eval compute in (eq_hf hf_false (app hf_negb hf_true)).
Eval compute in
 (eq_hf hf_negb {couple hf_true hf_false:::couple hf_false hf_true ::: nil}).
*)

(** regularity *)

Lemma raw_choose_elt : forall x, {y | In y (hf_elts x)}+{x==empty}.
intros ([|h l]); simpl; [right;compute;reflexivity|left;exists h; auto].
Qed.

Lemma choose_elt : forall x, {y | y ∈ x}+{x==empty}.
intros ([|h l]); [right;compute;reflexivity|left;exists h].
apply in_hf_intro with h; simpl; auto; reflexivity.
Qed.

Lemma regularity_ax: forall a a0, a0 ∈ a ->
    exists2 b, b ∈ a & ~(exists2 c, c ∈ a & c ∈ b).
induction a0 using hf_ind2; intros.
set (a0 := HF l) in *.
pose (A := subset a0 (fun y => in_hf y a)).
destruct (choose_elt A).
 destruct s.
 subst A.
 specialize subset_elim1 with (1:=i); intro.
 apply in_hf_elim in H1.
 destruct H1.
 rewrite H2 in i; clear H2 x.
 assert (x0 ∈ a).
  apply subset_elim2 with (2:=i).
  red; intros.
  rewrite H3 in H4; trivial.
 eauto.

 exists a0; trivial.
 red; destruct 1.
 assert (x ∈ A).
  apply subset_intro; trivial.
  red; intros.
  rewrite H4 in H5; trivial.
 rewrite e in H3; elim empty_elim with (1:=H3).
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Decimal numbers *)

(** These numbers coded in base 10 will be used for parsing and printing
    other Coq numeral datatypes in an human-readable way.
    See the [Numeral Notation] command.
    We represent numbers in base 10 as lists of decimal digits,
    in big-endian order (most significant digit comes first). *)

(** Unsigned integers are just lists of digits.
    For instance, ten is (D1 (D0 Nil)) *)

Inductive uint :=
 | Nil
 | D0 (_:uint)
 | D1 (_:uint)
 | D2 (_:uint)
 | D3 (_:uint)
 | D4 (_:uint)
 | D5 (_:uint)
 | D6 (_:uint)
 | D7 (_:uint)
 | D8 (_:uint)
 | D9 (_:uint).

(** [Nil] is the number terminator. Taken alone, it behaves as zero,
    but rather use [D0 Nil] instead, since this form will be denoted
    as [0], while [Nil] will be printed as [Nil]. *)

Notation zero := (D0 Nil).

(** For signed integers, we use two constructors [Pos] and [Neg]. *)

Inductive int := Pos (d:uint) | Neg (d:uint).

Delimit Scope uint_scope with uint.
Bind Scope uint_scope with uint.
Delimit Scope int_scope with int.
Bind Scope int_scope with int.

(** This representation favors simplicity over canonicity.
    For normalizing numbers, we need to remove head zero digits,
    and choose our canonical representation of 0 (here [D0 Nil]
    for unsigned numbers and [Pos (D0 Nil)] for signed numbers). *)

(** [nzhead] removes all head zero digits *)

Fixpoint nzhead d :=
  match d with
  | D0 d => nzhead d
  | _ => d
  end.

(** [unorm] : normalization of unsigned integers *)

Definition unorm d :=
  match nzhead d with
  | Nil => zero
  | d => d
  end.

(** [norm] : normalization of signed integers *)

Definition norm d :=
  match d with
  | Pos d => Pos (unorm d)
  | Neg d =>
    match nzhead d with
    | Nil => Pos zero
    | d => Neg d
    end
  end.

(** A few easy operations. For more advanced computations, use the conversions
    with other Coq numeral datatypes (e.g. Z) and the operations on them. *)

Definition opp (d:int) :=
  match d with
  | Pos d => Neg d
  | Neg d => Pos d
  end.

(** For conversions with binary numbers, it is easier to operate
    on little-endian numbers. *)

Fixpoint revapp (d d' : uint) :=
  match d with
  | Nil => d'
  | D0 d => revapp d (D0 d')
  | D1 d => revapp d (D1 d')
  | D2 d => revapp d (D2 d')
  | D3 d => revapp d (D3 d')
  | D4 d => revapp d (D4 d')
  | D5 d => revapp d (D5 d')
  | D6 d => revapp d (D6 d')
  | D7 d => revapp d (D7 d')
  | D8 d => revapp d (D8 d')
  | D9 d => revapp d (D9 d')
  end.

Definition rev d := revapp d Nil.

Module Little.

(** Successor of little-endian numbers *)

Fixpoint succ d :=
  match d with
  | Nil => D1 Nil
  | D0 d => D1 d
  | D1 d => D2 d
  | D2 d => D3 d
  | D3 d => D4 d
  | D4 d => D5 d
  | D5 d => D6 d
  | D6 d => D7 d
  | D7 d => D8 d
  | D8 d => D9 d
  | D9 d => D0 (succ d)
  end.

(** Doubling little-endian numbers *)

Fixpoint double d :=
  match d with
  | Nil => Nil
  | D0 d => D0 (double d)
  | D1 d => D2 (double d)
  | D2 d => D4 (double d)
  | D3 d => D6 (double d)
  | D4 d => D8 (double d)
  | D5 d => D0 (succ_double d)
  | D6 d => D2 (succ_double d)
  | D7 d => D4 (succ_double d)
  | D8 d => D6 (succ_double d)
  | D9 d => D8 (succ_double d)
  end

with succ_double d :=
  match d with
  | Nil => D1 Nil
  | D0 d => D1 (double d)
  | D1 d => D3 (double d)
  | D2 d => D5 (double d)
  | D3 d => D7 (double d)
  | D4 d => D9 (double d)
  | D5 d => D1 (succ_double d)
  | D6 d => D3 (succ_double d)
  | D7 d => D5 (succ_double d)
  | D8 d => D7 (succ_double d)
  | D9 d => D9 (succ_double d)
  end.

End Little.

(** Pseudo-conversion functions used when declaring
    Numeral Notations on [uint] and [int]. *)

Definition uint_of_uint (i:uint) := i.
Definition int_of_int (i:int) := i.


(*|
###############################################
How to use a custom induction principle in Coq?
###############################################

:Link: https://stackoverflow.com/q/33071903
|*)

(*|
Question
********

I read that the induction principle for a type is just a theorem about
a proposition ``P``. So I constructed an induction principle for
``List`` based on the right (or reverse) list constructor.
|*)

Definition rcons {X : Type} (l : list X) (x : X) : list X :=
  l ++ x :: nil.

(*| The induction principle itself is: |*)

Definition true_for_nil {X : Type} (P : list X -> Prop) : Prop :=
  P nil.

Definition true_for_list {X : Type} (P : list X -> Prop) : Prop :=
  forall xs, P xs.

Definition preserved_by_rcons {X : Type} (P : list X -> Prop) : Prop :=
  forall xs' x, P xs' -> P (rcons xs' x).

Theorem list_ind_rcons :
  forall {X : Type} (P : list X -> Prop),
    true_for_nil P ->
    preserved_by_rcons P ->
    true_for_list P.
Proof. Admitted.

(*|
But now, I am having trouble using the theorem. I don't how to invoke
it to achieve the same as the ``induction`` tactic.

For example, I tried:
|*)

Require Import List. (* .none *)
Theorem rev_app_dist : forall {X} (l1 l2 : list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  Fail induction l2 using list_ind_rcons. (* .fails *)

(*| But in the last line, I got: |*)

  Fail induction l2 using list_ind_rcons. (* .unfold .messages *)

(*|
What are the correct steps to define and apply a custom induction
principle like ``list_ind_rcons``?
|*)

(*|
Answer (Anton Trunov)
*********************

If one would like to preserve the intermediate definitions, then one
could use the ``Section`` mechanism, like so:
|*)

Reset Initial. (* .none *)
Require Import Coq.Lists.List. Import ListNotations.

Definition rcons {X : Type} (l : list X) (x : X) : list X :=
  l ++ [x].

Section custom_induction_principle.
  Variable X : Type.
  Variable P : list X -> Prop.

  Hypothesis true_for_nil : P nil.
  Hypothesis true_for_list : forall xs, P xs.
  Hypothesis preserved_by_rcons : forall xs' x, P xs' -> P (rcons xs' x).

  Fixpoint list_ind_rcons (xs : list X) : P xs. Admitted.
End custom_induction_principle.

(*|
Coq substitutes the definitions and ``list_ind_rcons`` has the needed
type and ``induction ... using ...`` works:
|*)

Theorem rev_app_dist : forall {X} (l1 l2 : list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l2 using list_ind_rcons.
Abort.

(*|
By the way, this induction principle is present in the standard
library (`List <https://coq.inria.fr/library/Coq.Lists.List.html>`__
module):
|*)

Check rev_ind. (* .unfold *)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

What you did was mostly correct. The problem is that Coq has some
trouble recognizing that what you wrote is an induction principle,
because of the intermediate definitions. This, for instance, works
just fine:

.. coq:: none
|*)

Reset Initial.

Definition rcons {X : Type} (l : list X) (x : X) : list X :=
  l ++ x :: nil.

Definition true_for_nil {X : Type} (P : list X -> Prop) : Prop :=
  P nil.

Definition true_for_list {X : Type} (P : list X -> Prop) : Prop :=
  forall xs, P xs.

Definition preserved_by_rcons {X : Type} (P : list X -> Prop) : Prop :=
  forall xs' x, P xs' -> P (rcons xs' x).

Require Import List.

(*||*)

Theorem list_ind_rcons :
  forall {X : Type} (P : list X -> Prop),
    P nil ->
    (forall x l, P l -> P (rcons l x)) ->
    forall l, P l.
Proof. Admitted.

Theorem rev_app_dist : forall {X} (l1 l2 : list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l2 using @list_ind_rcons.

(*|
I don't know if Coq not being able to automatically unfold the
intermediate definitions should be considered a bug or not, but at
least there is a workaround.

----

**A:** In Coq, there is long standing disrespect for definitional
equality in the implementation of tactics. Whilst this is
questionable, ideologically, it is far too late to do anything about
it in practice.
|*)


Load "IFIDEMP".

(*****************IFMORPH************************************************************************************)
(*******f ( ...., if b then x else y,...........) = if b then f(......,x,.........) else f (.....,y,.....)****)
(****** f(u, if b then x else y, z) = if b then f(u, x, z) else f(u,y,z)**************************************)

(*Theorem IFMORPH_M:  forall (m n n1 :nat) (ml1 : mylist  m)(x y:message) (ml2 : mylist n) (f: mylist (m + (1+n)) ->message),
                ( f (ml1 ++[msg (if_then_elsem_ (Bvar n)  x y)] ++ ml2) ) # (if_then_elsem_ (Bvar n) (f(ml1 ++[msg x]++ml2)) (f(ml1 ++[msg y]++ml2))).
Proof.
intros.
rewrite <- IFSAME_M with (b:= (Bvar n)) (x:= f (ml1 ++[msg (if_then_elsem_ (Bvar n)  x y)] ++ ml2 )).
simpl.
rewrite IFEVAL_M.
rewrite subinlist with (n:= n)(b:= TRue)(f:=f) (ml := (ml1 ++ (msg (if_then_elsem_ (Bvar n) x y) :: ml2))).
rewrite subconct.
simpl.
rewrite subinmsg.
simpl.
rewrite <- beq_nat_refl.
pose proof(IFEVAL_M).

(***setoid_replace  (if_then_elsem_ TRue ((n := TRue)(x)) ((n := TRue)(y))) with ((n := TRue)(x)) using relation EQm.
setoid_replace (if_then_elsem_ TRue ((n := TRue)(x)) ((n := TRue)(y))) with ((n := TRue)(x)) using relation EQm.**)
(*rewrite IFTRUE_M *)
rewrite subinlist with (n:= n)(b:= FAlse)(f:=f) (ml := (ml1 ++ (msg (if_then_elsem_ (Bvar n) x y) :: ml2))).
rewrite subconct.
simpl.
rewrite subinmsg. simpl.
rewrite <- beq_nat_refl.
(*rewrite IFFALSE_M.*)
rewrite IFEVAL_M with (t1:= (f (ml1 ++ msg x :: ml2)))(t2 := (f (ml1 ++ msg y :: ml2))).
rewrite subinlist with (n:= n)(b:= TRue)(f:=f) (ml := (ml1 ++ (msg  x ) :: ml2)).
rewrite subconct.
simpl.
rewrite subinmsg.
rewrite subinlist with (n:= n)(b:= FAlse)(f:=f) (ml := (ml1 ++ (msg  y ) :: ml2)).
rewrite subconct.
simpl.
rewrite subinmsg.
pose proof(IFTRUE_M ((n := TRue)(x)) ((n := TRue)(y))).
assert(H1 : (msg (if_then_elsem_ TRue ((n := TRue)(x)) ((n := TRue)(y)))) ### (msg ((n := TRue)(x)))).
rewrite H0. reflexivity.
rewrite H1.
assert( H2 : (msg (if_then_elsem_ FAlse ((n := FAlse)(x)) ((n := FAlse)(y)))) ### (msg ((n := FAlse)(y)))).
rewrite IFFALSE_M.
reflexivity.
rewrite H2. reflexivity.
Qed.

Theorem IFMORPH_B:  forall (m n n1 :nat) (ml1 : mylist  m)(b1 b2: Bool) (ml2 : mylist n) (f: mylist (m + (1+n)) ->Bool),
             ( f (ml1 ++[bol (if_then_elseb_ (Bvar n)  b1 b2)] ++ ml2) ) ## (if_then_elseb_ (Bvar n) (f(ml1 ++[bol  b1]++ml2)) (f(ml1 ++[bol b2]++ml2))).

Proof.
intros.
rewrite <- IFSAME_B with (b:= (Bvar n)) (b1:= f (ml1 ++[bol (if_then_elseb_ (Bvar n)  b1 b2)] ++ ml2 )).
simpl.
rewrite IFEVAL_B.
rewrite subinlist1 with (n:= n)(b:= TRue)(f:=f) (ml := (ml1 ++ (bol (if_then_elseb_ (Bvar n) b1 b2) :: ml2))).
rewrite subconct.
simpl. simpl.
 simpl.
rewrite subinbol.
simpl.
rewrite <- beq_nat_refl.
rewrite subinlist1 with (n:= n)(b:= FAlse)(f:=f) (ml := (ml1 ++ (bol (if_then_elseb_ (Bvar n) b1 b2) :: ml2))).
rewrite subconct.
simpl.
rewrite subinbol. simpl.
rewrite <- beq_nat_refl.
rewrite IFEVAL_B with (b1:= (f (ml1 ++ bol b1 :: ml2)))(b2 := (f (ml1 ++ bol b2 :: ml2))).
rewrite subinlist1 with (n:= n)(b:= TRue)(f:=f) (ml := (ml1 ++ (bol b1 ) :: ml2)).
rewrite subconct.
simpl.
rewrite subinbol.
rewrite subinlist1 with (n:= n)(b:= FAlse)(f:=f) (ml := (ml1 ++ (bol  b2) :: ml2)).
rewrite subconct.
simpl.
rewrite subinbol.
pose proof(IFTRUE_B ([n := TRue](b1)) ([n := TRue](b2))).
assert(H1 : (bol (if_then_elseb_ TRue ([n := TRue](b1)) ([n := TRue](b2)))) ### (bol ([n := TRue](b1)))).
rewrite H. reflexivity.
rewrite H1.
assert( H2 : (bol (if_then_elseb_ FAlse ([n := FAlse](b1)) ([n := FAlse](b2)))) ### (bol ([n := FAlse](b2)))).
pose proof(IFFALSE_B ([n := FAlse](b1)) ([n := FAlse](b2))).
rewrite H0.
reflexivity.
rewrite H2. reflexivity.
Qed.
*)

Theorem IFMORPH_M1: forall ( x y z : message) (n1 n2:nat),
(if_then_else_M (Bvar n2)(if_then_else_M (Bvar n1)  x y) z) # (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2)  x  z) (if_then_else_M  (Bvar n2) y z) ).
Proof.
intros.
rewrite <- IFSAME_M with (b:= (Bvar n1)) (x:= (if_then_else_M (Bvar n2) (if_then_else_M (Bvar n1) x y) z)).
rewrite IFEVAL_M.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_M with (t1:= (if_then_else_M (Bvar n2) x z))(t2:= (if_then_else_M (Bvar n2) y z)).
simpl.
reflexivity.
Qed.

Theorem IFMORPH_B1: forall ( b b1 b2 : Bool) (n1 n2:nat) ,
 (if_then_else_B (Bvar n2)(if_then_else_B (Bvar n1)  b b1) b2)  ## (if_then_else_B (Bvar n1) (if_then_else_B (Bvar n2)  b  b2) (if_then_else_B  (Bvar n2) b1 b2) ).
Proof.
  intros.
  Check b.
  SearchAbout b.
rewrite <- IFSAME_B with (b:= (Bvar n1)) (b1:= (if_then_else_B (Bvar n2) (if_then_else_B (Bvar n1) b b1) b2)).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (n:=n1)(b1:= (if_then_else_B (Bvar n2) b b2))(b2:= (if_then_else_B (Bvar n2) b1 b2)).
simpl.
reflexivity.
Qed.
(************f(if b then x else y, z , z1) = if b then f(x,z,z1) else f(x,y,z1)****************)

Theorem IFMORPH_B2: forall (n:nat)(b1 b2 b3 b4 : Bool) ,
(if_then_else_B (if_then_else_B (Bvar n) b1 b2 ) b3 b4)  ##  (if_then_else_B (Bvar n) (if_then_else_B  b1  b3 b4 ) (if_then_else_B  b2 b3 b4) ).
Proof.
intros.
pose proof (IFSAME_B).
rewrite <- IFSAME_B with (b:= (Bvar n)) (b1:=(if_then_else_B (if_then_else_B (Bvar n) b1 b2 ) b3 b4)).
pose proof(IFEVAL_B).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (b1 := (if_then_else_B b1 b3 b4))(b2:= (if_then_else_B b2 b3 b4)).
simpl.
reflexivity.
Qed.

Theorem IFMORPH_M2: forall (n:nat)(b1 b2 :Bool)(y z : message),
 (if_then_else_M (if_then_else_B (Bvar n) b1 b2 ) y z)  #(if_then_else_M (Bvar n) (if_then_else_M  b1  y z ) (if_then_else_M  b2 y z) ).
Proof.
intros.
rewrite <- IFSAME_M with (b:=(Bvar n))(x:= if_then_else_M (if_then_else_B (Bvar n) b1 b2) y z).
rewrite IFEVAL_M.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_M with (t1:=  (if_then_else_M b1 y z))(t2:= (if_then_else_M b2 y z)).
simpl.
reflexivity.
Qed.

(***************f(if b then x else y, z)= if b then f(x,z) else f(y,z)**************************************)

Theorem IFMORPH_B3: forall  (n n1 n2 n3 :nat), ( EQ_B (if_then_else_B (Bvar n) (Bvar n1) (Bvar n2)) (Bvar n3)) ##  (if_then_else_B (Bvar n) (EQ_B (Bvar n1) (Bvar n3) ) (EQ_B (Bvar n2) (Bvar n3))).
Proof.
intros.
rewrite <- IFSAME_B with (b:=(Bvar n))( b1:= EQ_B (if_then_else_B (Bvar n) (Bvar n1) (Bvar n2)) (Bvar n3)).
rewrite IFEVAL_B.
simpl. rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (b1:= (EQ_B (Bvar n1) (Bvar n3)))(b2:= (EQ_B (Bvar n2) (Bvar n3))).
simpl.
reflexivity.
Qed.

Theorem IFMORPH_M3: forall  (n n1 n2 n3 :nat), ( EQ_M (if_then_else_M (Bvar n) (Mvar n1) (Mvar n3))  (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3))) ## ( if_then_else_B (Bvar n) (EQ_M (Mvar n1)  (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3) )) (EQ_M (Mvar n3)  (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3)))).
Proof.
intros.
rewrite <- IFSAME_B with (b:=(Bvar n))( b1:= EQ_M (if_then_else_M (Bvar n) (Mvar n1) (Mvar n3))  (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3))).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M .
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_B with (b1:= (EQ_M (Mvar n1) (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3))))(b2:= (EQ_M (Mvar n3) (if_then_else_M (Bvar n) (Mvar n2) (Mvar n3)))).
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
reflexivity.
Qed.

Theorem IFMORPH_M5 : forall (n1 n2 n3 :nat) (m1 m2 m3 m4: message),  (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1 m2 ) (if_then_else_M (Bvar n3) m3 m4)) # (if_then_else_M (Bvar n2) (if_then_else_M (Bvar n1) m1 (if_then_else_M (Bvar n3) m3 m4)) (if_then_else_M (Bvar n1) m2 (if_then_else_M (Bvar n3) m3 m4))).

Proof. intros.
pose proof(IFSAME_M (Bvar n2) (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1 m2 ) (if_then_else_M (Bvar n3) m3 m4))).
rewrite IFEVAL_M with (n:= n2) (t1:= (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1 m2 ) (if_then_else_M (Bvar n3) m3 m4))) (t2 := (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1 m2 ) (if_then_else_M (Bvar n3) m3 m4))) in H.
simpl in H.
repeat rewrite <- beq_nat_refl in H.
rewrite <-H.

rewrite IFEVAL_M with (n:= n2) (t1:= (if_then_else_M (Bvar n1) m1 (if_then_else_M (Bvar n3) m3 m4))) (t2 := (if_then_else_M (Bvar n1) m2 (if_then_else_M (Bvar n3) m3 m4))).
simpl. rewrite  IFTRUE_M, IFFALSE_M.
reflexivity. Qed.

Theorem IFMORPH_M6 : forall(n1 n2 :nat) (m1 m2 m3:message), (if_then_else_M (Bvar n1) m1 (if_then_else_M (Bvar n2) m2 m3)) # (if_then_else_M (Bvar n2) (if_then_else_M (Bvar n1) m1 m2) (if_then_else_M (Bvar n1)  m1 m3)).

Proof. intros.  pose proof(IFSAME_M (Bvar n2)  (if_then_else_M (Bvar n1) m1 (if_then_else_M (Bvar n2) m2 m3))).
rewrite IFEVAL_M in H.

simpl in H. repeat rewrite <- beq_nat_refl in H.
rewrite  IFTRUE_M, IFFALSE_M in H.
rewrite <-H. clear H.
rewrite IFEVAL_M with (t1:= (if_then_else_M (Bvar n1) m1 m2)).
simpl. reflexivity. Qed.

Axiom IFMORPH_B4: forall  (n1:nat) (b1 b2 b3:Bool), (if_then_else_B (Bvar n1) b1 (if_then_else_B (Bvar (n1+1)) b2 b3))  ## (if_then_else_B (Bvar (n1+1)) (if_then_else_B (Bvar n1) b1 b2) (if_then_else_B (Bvar n1) b1 b3)) .


(** * QuickChickInterface: QuickChick Reference Manual *)

From QuickChick Require Import QuickChick.
Require Import ZArith Strings.Ascii Strings.String.

From ExtLib.Structures Require Import Functor Applicative.

(** QuickChick provides a large collection of combinators and
    notations for writing property-based random tests.  This file
    documents the entire public interface (the module type
    [QuickChickSig]). *)

Module Type QuickChickSig.

(* #################################################################### *)
(** * The [Show] Typeclass *)

(** [Show] typeclass allows the test case to be printed as a string. *)
(** [[
    Class Show (A : Type) : Type :=
      {
        show : A -> string
      }.
]]
*)

(** Here are some [Show] instances for some basic types: *)
Declare Instance showNat    : Show nat.
Declare Instance showBool   : Show bool.
Declare Instance showZ      : Show Z.
Declare Instance showString : Show string.

Declare Instance showList :
  forall {A : Type} `{Show A}, Show (list A).
Declare Instance showPair :
  forall {A B : Type} `{Show A} `{Show B}, Show (A * B).
Declare Instance showOpt :
  forall {A : Type} `{Show A}, Show (option A).
Declare Instance showEx :
  forall {A} `{Show A} P, Show ({x : A | P x}).

(** When defining [Show] instance for your own datatypes, you sometimes need to
    start a new line for better printing. [nl] is a shorthand for it. *)
Definition nl : string := String (ascii_of_nat 10) EmptyString.

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

(* #################################################################### *)
(** ** Fundamental Types *)

(** A [RandomSeed] represents a particular starting point in a
    pseudo-random sequence. *)
Parameter RandomSeed : Type.

(** [G A] is the type of random generators for type [A]. *)
Parameter G : Type -> Type.

(** Run a generator with a size parameter (a natural number denoting
    the maximum depth of the generated A) and a random seed. *)
Parameter run  : forall {A : Type}, G A -> nat -> RandomSeed -> A.

(** The semantics of a generator is its set of possible outcomes. *)
Parameter semGen : forall {A : Type} (g : G A), set A.
Parameter semGenSize : forall {A : Type} (g : G A) (size : nat), set A.
(* SOONER: Where does [set] come from?? Where can I read about what
   operations / theorems are available? *)
(* SOONER: [set] comes from src/Sets.v. I think Maxime/Zoe wrote most
   of that file quite a while ago (during her thesis at Catalin). It
   is not really documented... would you want all of that file
   here? *)
(* SOONER: I want this file to be a complete description of what most
   people need to know to use QC.  One possible approach could be to
   split this interface into a "programming interface" for most users
   and a "proving interface" for people that also want to do proofs
   involving the QC semantics.  Then the functions from Sets.v would
   be relevant only to the second.  (I actually kind of like this
   idea, as it would streamline what most people need to think
   about.) *)
(* SOONER: It *is* a complete description of what _the vast majority_ people need
   to know to use QC. There are exactly three uses of the set library:
   1) Allow derivation of correctness proofs. Here, the user doesn't
      need to know all the lemmas that the proof uses in order to enjoy
      the benefits of an end-to-end specification (but the lemmas
      need to be exposed).
   2) Allow manual correctness proofs. I don't think anyone has ever
      done that outside of ourselves to practice before writing the
      generic derivation of proofs. Writing correctness proofs for
      generators is hard and not really worth it from the user's
      perspective.
   3) The only potential use of the set library from a user would
      be in forAllProof variants to define dependently typed data. However,
      this intrinsic verification approach is very rarely used and
      comes with more severe testing problems than an undocumented
      set library.

   My thinking was to have [semGen] and [forAllProof] here as a small
   glance into the world of generator semantics. I do think that
   presenting the view that a generator is characterized by its set of
   outcomes is a very useful notion, even if a user never has to
   actively play with that notion. Do you want to just remove every
   mention to [set]/[semGen] from this file to keep it a "programming
   only" interface?

   Besides, what would the "proving interface" entail?
   We can't really document the entirety of the sets library. That's like
   200 low-level lemmas that are only expanded to facilitate proof
   derivation... For example, we have lemmas like the following:

[[
Lemma isSome_subset {A : Type} (s1 s2 s1' s2' : set (option A)) :
  isSome :&: s1 \subset isSome :&: s2 ->
  isSome :&: (s1 :|: ([set None] :&: s1')) \subset isSome :&: (s2 :|: ([set None] :&: s2')).
]]

   This says that if the set of all "Some"s in s1 is a subset of all the
   "Some"s in s2, then the set of all "Some"s in the the union of s1 with
   [the intersection of {None} and s1'] is a subset of the set of all somes in
   the union of s2 with [the intersection of {None} and s2']. Of course, the intersection of
   {None} with any set is at most {None}, and that none will be filtered
   out by [isSome], so this looks like a completely useless lemma. However,
   we do need this lemma because of the particular structure of the
   proofs involving the backtrack combinator. How can we explain this
   lemma and its point to a user if we turn this file into a complete
   documentation of everything that needs to be exposed?

   BCP: Ok, ok... :-)

   So what about moving all the stuff involving semantics to its own section at the
   end of the file?
 *)

(* #################################################################### *)
(** ** Structural Combinators *)

(** Generators are also instances of several generic typeclasses.
    Many handy generator combinators can be found in the [Monad],
    [Functor], [Applicative], [Foldable], and [Traversable] modules in
    the [ExtLib.Structures] library from [coq-ext-lib]. *)

Declare Instance Monad_G : Monad G.
Declare Instance Functor_G : Functor G.
Declare Instance Applicative_G : Applicative G.

(** A variant of monadic bind where the continuation also takes a
    _proof_ that the value received is within the set of outcomes of
    the first generator. *)
Parameter bindGen' : forall {A B : Type} (g : G A),
    (forall (a : A), (a \in semGen g) -> G B) -> G B.

(** A variant of bind for the [(G (option --))] monad.  Useful for
    chaining generators that can fail / backtrack. *)
Parameter bindGenOpt : forall {A B : Type},
    G (option A) -> (A -> G (option B)) -> G (option B).

(* #################################################################### *)
(** ** Basic Generator Combinators *)

(** The [listOf] and [vectorOf] combinators construct generators for
    [list A], provided a generator [g] for type [A]: [listOf g] yields
    an arbitrary-sized list (which might be empty), while [vectorOf n
    g] yields a list of fixed size [n]. *)
Parameter listOf : forall {A : Type}, G A -> G (list A).
Parameter vectorOf : forall {A : Type}, nat -> G A -> G (list A).

(** [elems_ a l] constructs a generator from a list [l] and a
    default element [a]. If [l] is non-empty, the generator picks an
    element from [l] uniformly; otherwise it always yields [a]. *)
Parameter elems_ : forall {A : Type}, A -> list A -> G A.

(** Similar to [elems_], instead of choosing from a list of [A]s,
    [oneOf_ g l] returns [g] if [l] is empty; otherwise it uniformly
    picks a generator for [A] in [l]. *)
Parameter oneOf_ : forall {A : Type}, G A -> list (G A) -> G A.

(** We can also choose generators with distributions other than the
    uniform one. [freq_ g l] returns [g] if [l] is empty;
    otherwise it chooses a generator from [l], where the first field
    indicates the chance that the second field is chosen. For example,
    [freq_ z [(2, x); (3, y)]] has 40%% probability of choosing
    [x] and 60%% probability of choosing [y]. *)
Parameter freq_ :
  forall {A : Type}, G A -> list (nat * G A) -> G A.

(** Try all generators until one returns a [Some] value or all failed once with
    [None]. The generators are picked at random according to their weights
    (like [frequency]), and each one is run at most once. *)
Parameter backtrack :
  forall {A : Type}, list (nat * G (option A)) -> G (option A).

(** Internally, the G monad hides a [size] parameter that can be accessed by
    generators. The [sized] combinator provides such access. The [resize]
    combinator sets it. *)
Parameter sized : forall {A: Type}, (nat -> G A) -> G A.
Parameter resize : forall {A: Type}, nat -> G A -> G A.

(** Generate-and-test approach to generate data with preconditions. *)
Parameter suchThatMaybe :
  forall {A : Type}, G A -> (A -> bool) -> G (option A).
Parameter suchThatMaybeOpt :
  forall {A : Type}, G (option A) -> (A -> bool) -> G (option A).

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

(** The [elems_], [oneOf_], and [freq_] combinators all take
    default values; these are only used if their list arguments are
    empty, which should not normally happen. The [QcDefaultNotation]
    sub-module exposes notation (without the underscores) to hide this default.
*)

Module QcDefaultNotation.

  (** [elems] is a shorthand for [elems_] without a default argument. *)
  Notation " 'elems' [ x ] " :=
    (elems_ x (cons x nil)) : qc_scope.
  Notation " 'elems' [ x ; y ] " :=
    (elems_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'elems' [ x ; y ; .. ; z ] " :=
    (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'elems' ( x ;; l ) " :=
    (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope.

  (** [oneOf] is a shorthand for [oneOf_] without a default argument. *)
  Notation " 'oneOf' [ x ] " :=
    (oneOf_ x (cons x nil)) : qc_scope.
  Notation " 'oneOf' [ x ; y ] " :=
    (oneOf_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'oneOf' [ x ; y ; .. ; z ] " :=
    (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'oneOf' ( x ;; l ) " :=
    (oneOf_ x (cons x l))  (at level 1, no associativity) : qc_scope.

  (** [freq] is a shorthand for [freq_] without a default argument. *)
  Notation " 'freq' [ x ] " :=
    (freq_ x (cons x nil)) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ] " :=
    (freq_ x (cons (n, x) (cons y nil))) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " :=
    (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'freq' ( ( n , x ) ;; l ) " :=
    (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope.

End QcDefaultNotation.

(** The original version of QuickChick used [elements], [oneof] and [frequency]
    as the default-argument versions of the corresponding combinators.
    These have since been deprecated in favor of a more consistent
    naming scheme.
*)

(* #################################################################### *)
(** ** Choosing from Intervals *)

(** The combinators above allow us to generate elements by enumeration
    and lifting. However, for numeric data types, we sometimes hope to
    choose from an interval without writing down all the possible
    values.

    Such intervals can be defined on ordered data types, instances of
    [OrdType], whose ordering [leq] satisfies reflexive, transitive,
    and antisymmetric predicates. *)

Existing Class OrdType.

Declare Instance OrdBool : OrdType bool.
Declare Instance OrdNat  : OrdType nat.
Declare Instance OrdZ    : OrdType Z.

(** We also expect the random function to be able to pick every element in any
    given interval. *)

Existing Class ChoosableFromInterval.

(** QuickChick has provided some instances for ordered data types that are
    choosable from intervals, including [bool], [nat], and [Z]. *)
Declare Instance ChooseBool : ChoosableFromInterval bool.
Declare Instance ChooseNat : ChoosableFromInterval nat.
Declare Instance ChooseZ : ChoosableFromInterval Z.

(** [choose l r] generates a value between [l] and [r], inclusive the two
    extremes. It causes a runtime error if [r < l]. *)
Parameter choose :
  forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A.

(* #################################################################### *)
(** ** The [Gen] and [GenSized] Typeclasses *)

(** [GenSized] and [Gen] are typeclasses whose instances can be generated
    randomly. More specifically, [GenSized] depends on a generator for any given
    natural number that indicate the size of output. *)
(** [[
    Class GenSized (A : Type) := { arbitrarySized : nat -> G A }.
    Class Gen (A : Type) := { arbitrary : G A }.
]]
*)

(** Given an instance of [GenSized], we can convert it to [Gen] automatically,
    using [sized] function. *)
Declare Instance GenOfGenSized {A} `{GenSized A} : Gen A.

(** Here are some basic instances for generators: *)
Declare Instance genBoolSized : GenSized bool.
Declare Instance genNatSized  : GenSized nat.
Declare Instance genZSized    : GenSized Z.

Declare Instance genListSized :
  forall {A : Type} `{GenSized A}, GenSized (list A).
Declare Instance genList :
  forall {A : Type} `{Gen A}, Gen (list A).
Declare Instance genOption :
  forall {A : Type} `{Gen A}, Gen (option A).
Declare Instance genPairSized :
  forall {A B : Type} `{GenSized A} `{GenSized B}, GenSized (A*B).
Declare Instance genPair :
  forall {A B : Type} `{Gen A} `{Gen B}, Gen (A * B).

(* #################################################################### *)
(** ** Generators for Data Satisfying Inductive Predicates *)

(** Just as QuickChick provides the [GenSized] and [Gen] typeclasses
    for generators of type [A], it provides constrained variants for
    generators of type [A] such that [P : A -> Prop] holds of all
    generated values.  Since it is not guaranteed that any such [A]
    exist, these generators are partial.  *)
(** [[
     Class GenSizedSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitrarySizeST : nat -> G (option A)
       }.

     Class GenSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitraryST : G (option A)
       }.
]]
 *)

(** So, for example, if you have a typing relation
    [has_type : exp -> type -> Prop] for some language, you could,
    given some type [T] as input, write (or derive as we will see later on)
    an instance of [GenSizedSuchThat (fun e => has_type e T)], that produces
    an expression of with type [T].

    Calling [arbitraryST] through such an instance would require
    making an explicit application to [@arbitraryST] as follows:
[[
    @arbitraryST _ (fun e => has_type e T) _
]]
    where the first placeholder is the type of expressions [exp]
    and the second placeholder is the actual instance to be inferred.

    To avoid this, QuickChick also provides convenient notation to call
    by providing only the predicate [P] that constraints the generation.
    The typeclass constraint is inferred. *)

Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).

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

(** ** The [Shrink] Typeclass *)

(** [Shrink] is a typeclass whose instances have an operation for
    shrinking larger elements to smaller ones, allowing QuickChick to
    search for a minimal counter example when errors occur. *)
(** [[
    Class Shrink (A : Type) :=
      {
        shrink : A -> list A
      }.
]]
*)

(** Default shrinkers for some basic datatypes: *)
Declare Instance shrinkBool : Shrink bool.
Declare Instance shrinkNat : Shrink nat.
Declare Instance shrinkZ : Shrink Z.

Declare Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A).
Declare Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B).
Declare Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A).

(* #################################################################### *)
(** ** The [Arbitrary] Typeclass *)

(** The [Arbitrary] typeclass combines generation and shrinking. *)
(** [[
    Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.
]]
*)

(* #################################################################### *)
(** ** The Generator Typeclass Hierarchy *)

(** [[
                            GenSized
                               |
                               |
                              Gen   Shrink
                                \    /
                                 \  /
                               Arbitrary
]]
*)

(** If a type has a [Gen] and a [Shrink] instance, it automatically gets
    an [Arbitrary] one. *)
Declare Instance ArbitraryOfGenShrink :
  forall {A} `{Gen A} `{Shrink A}, Arbitrary A.

(* #################################################################### *)
(** * Checkers *)

(** ** Basic Definitions *)

(** [Checker] is the opaque type of QuickChick properties. *)
Parameter Checker : Type.

(** The [Checkable] class indicates we can check a type A. *)
(** [[
    Class Checkable (A : Type) : Type :=
      {
        checker : A -> Checker
      }.
]]
*)

(** Boolean checkers always pass or always fail. *)
Declare Instance testBool : Checkable bool.

(** The unit checker is always discarded (that is, it represents a
    useless test).  It is used, for example, in the implementation of
    the "implication [Checker]" combinator [==>]. *)
Declare Instance testUnit : Checkable unit.

(** Given a generator for showable [A]s, construct a [Checker]. *)
Parameter forAll :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : A -> prop), Checker.

(** A variant of [forAll] that provides evidence that the generated
    values are members of the semantics of the generator. (Such evidence
    can be useful when constructing dependently typed data, such as
    bounded integers.) *)
(* SOONER: That's exactly the sort of concise explanation that I'm
   looking for throughout!  (And it makes me realize that separating
   the interface into "operations for programmers" and "operations for
   provers" may not be so simple!  Though it may still make sense to
   lump dependently typed programming in with proving.  So one
   interface could be called QCBasicInterface and the other
   QCPowerUsersInterface :-) *)
(* SOONER: This file indeed used to be called QCBasicInterface :-) *)
Parameter forAllProof :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : forall (x : A), semGen gen x -> prop), Checker.

(** Given a generator and a shrinker for showable [A]s, construct a
    [Checker]. *)
Parameter forAllShrink :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A) (shrinker : A -> list A) (pf : A -> prop), Checker.

(** Lift ([Show], [Gen], [Shrink]) instances for [A]
    to a [Checker] for functions [A] -> prop.  This is what makes it
    possible to write (for some example property [foo := fun x => x >?
    0], say) [QuickChick foo] instead of [QuickChick (forAllShrink
    arbitrary shrink foo)]. *)
Declare Instance testFun :
  forall {A prop : Type} `{Show A} `{Arbitrary A} `{Checkable prop},
    Checkable (A -> prop).

(** Lift products similarly. *)
Declare Instance testProd :
  forall {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A}
         `{forall x : A, Checkable (prop x)},
    Checkable (forall (x : A), prop x).

(** Lift polymorphic functions by instantiating to 'nat'. :-) *)
Declare Instance testPolyFun :
  forall {prop : Type -> Type} `{Checkable (prop nat)},
    Checkable (forall T, prop T).

(* #################################################################### *)
(** ** Checker Combinators *)

(** Print a specific string if the property fails. *)
Parameter whenFail :
  forall {prop : Type} `{Checkable prop} (str : string), prop -> Checker.

(** Record an expectation that a property should fail, i.e.
    the property will fail if all the tests succeed. *)
(* SOONER: Don't understand this explanation. A Checker, in my model
   of the world, maps a random seed to the outcome of a *single* test.
   This seems to suggest that an expectFailure checker somehow knows
   the value of the test on *all* random seeds... *)
(* SOONER: I think I need help with the phrasing here. What I mean is
   QuickChick will run its default number of tests (whether that is
   100 or 10000000 doesn't matter). If all of those 100 or 10000000
   tests succeed, then an [expectFailure property] is considered to
   fail because a failure was expected but not found.  Does this make
   sense?

   BCP: Sort of, but not really.  E.g., can I nest uses of
   expectFailure?  What happens then?  (How many tests get run?)  Or,
   what happens if I conjoin an expectFailure with some other
   checkers?  I guess I need a model for how it is
   implemented.  (Which I think we didn't give in QC.v, right?)*)
Parameter expectFailure :
  forall {prop: Type} `{Checkable prop} (p: prop), Checker.

(** Collect statistics across all tests. *)
Parameter collect :
  forall {A prop : Type} `{Show A} `{Checkable prop} (x : A),
    prop -> Checker.

(** Set the reason for failure.  Will only count shrinks as valid if
    they preserve the tag. *)
(* SOONER: Explain better. *)
Parameter tag :
  forall {prop : Type} `{Checkable prop} (t : string), prop -> Checker.

(** Form the conjunction / disjunction of a list of checkers. *)
(* SOONER: We are not very consistent about when we name arguments and
   when we do not.  E.g. [l] here: *)
(* SOONER: We name all non-implicit/Typeclass ones, no? *)
(* SOONER: whenFail does not.  Nor does, for example (of many) resize. *)
(* SOONER: What convention would you prefer to keep? Delete all names?
   Keep all non-implicit names? Something else? I can do a consistency
   pass after we fix everything. *)
(* SOONER: BCP: I think keeping is best. *)
Parameter conjoin : forall (l : list Checker), Checker.
Parameter disjoin : forall (l : list Checker), Checker.

(** Define a checker for a conditional property. Invalid generated
    inputs (ones for which the antecedent fails) are discarded. *)
Parameter implication :
  forall {prop : Type} `{Checkable prop} (b : bool) (p : prop), Checker.

(** Notation for implication. Clashes with many other notations in
    other libraries, so it lives in its own module. Note that this
    includes the notations for the generator combinators above
    to avoid needing to import two modules.
 *)
Module QcNotation.
  Export QcDefaultNotation.

  Notation "x ==> y" :=
    (implication x y) (at level 55, right associativity)
    : Checker_scope.
End QcNotation.

(* #################################################################### *)
(** * Decidability *)

(** ** The [Dec] Typeclass *)
(** Decidability typeclass using ssreflect's 'decidable'. *)
(** [[
     Class Dec (P : Prop) : Type := { dec : decidable P }.
]]
*)

(** Decidable properties are Checkable. *)
Declare Instance testDec {P} `{H : Dec P} : Checkable P.

(** Logic Combinator instances. *)
Declare Instance Dec_neg {P} {H : Dec P} : Dec (~ P).
Declare Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q).
Declare Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q).

(* SOONER: We had discussed changing this to the partial decision procedure at some point. *)
(** A convenient notation for coercing a decidable proposition to a [bool]. *)
Notation "P '?'" := (match (@dec P _) with
                     | left _ => true
                     | right _ => false
                     end) (at level 100).

(** ** The [Dec_Eq] Typeclass *)

(** [[
     Class Dec_Eq (A : Type) :=
       {
         dec_eq : forall (x y : A), decidable (x = y)
       }.
]]
*)

(** Automation and conversions for Dec. *)
Declare Instance Eq__Dec {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y).

(** Since deciding equalities is a very common requirement in testing,
    QuickChick provides a tactic that can define instances of the form
    [Dec (x = y)].
*)
(** [[
     Ltac dec_eq.
]]
*)

(** QuickChick also lifts common decidable instances to the [Dec] typeclass. *)
Declare Instance Dec_eq_bool (x y : bool) : Dec (x = y).
Declare Instance Dec_eq_nat (m n : nat) : Dec (m = n).
Declare Instance Dec_eq_opt (A : Type) (m n : option A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).
Declare Instance Dec_eq_prod (A B : Type) (m n : A * B)
`{_ : forall (x y : A), Dec (x = y)}
`{_ : forall (x y : B), Dec (x = y)}
: Dec (m = n).
Declare Instance Dec_eq_list (A : Type) (m n : list A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).

Declare Instance Dec_ascii (m n : Ascii.ascii) : Dec (m = n).
Declare Instance Dec_string (m n : string) : Dec (m = n).

(* #################################################################### *)
(** * Automatic Instance Derivation *)

(** QuickChick allows the automatic derivation of typeclass instances
    for simple types:
[[
       Derive <class> for T.
]]
    Here [<class>] must be one of [GenSized], [Shrink], [Arbitrary],
    or [Show], and [T] must be an inductive defined datatype (think
    Haskell/OCaml).

    To derive multiple classes at once, write:
[[
       Derive (<class>,...,<class>) for T.
]]
*)

(** QuickChick also allows for the automatic derivation of generators
    satisfying preconditions in the form of inductive relations:

     Derive ArbitrarySizedSuchThat for (fun x => P x1 ... x .... xn).

    <P> must be an inductively defined relation.
    <x> is the function to be generated.
    <x1...xn> are (implicitly universally quantified) variable names.
*)

(** QuickChick also allows automatic derivations of proofs of
    correctness of its derived generators! For more, look
    at:

    - A paper on deriving QuickChick generators for a large class of
      inductive relations.
      {http://www.cis.upenn.edu/~llamp/pdf/GeneratingGoodGenerators.pdf}

    - Leo's PhD dissertation.
      {https://lemonidas.github.io/pdf/Leo-PhD-Thesis.pdf}

    - examples/DependentTest.v

*)

(* #################################################################### *)
(** * Top-level Commands and Settings *)

(** QuickChick provides a series of toplevel commands to sample
    generators, test properties, and derive useful typeclass
    instances. *)

(** The [Sample] command samples a generator. The argument [g] needs
    to have type [G A] for some showable type [A]. *)
(** [[
    Sample g.
]]
*)

(** The main testing command, [QuickChick], runs a test. The argument
    [prop] must belong to a type that is an instance of [Checkable]. *)
(** [[
     QuickChick prop.
]]
*)

(** QuickChick uses arguments to customize execution. *)
Record Args :=
  MkArgs
    {
      (* Re-execute a test. *)
      (* Default: None *)
      replay     : option (RandomSeed * nat);
      (* Maximum number of successful tests to run. *)
      (* Default: 10000 *)
      maxSuccess : nat;
      (* Maximum number of discards to accept. *)
      (* Default: 20000 *)
      maxDiscard : nat;
      (* Maximum number of shrinks to perform before terminating. *)
      (* Default : 1000 *)
      maxShrinks : nat;
      (* Maximum size of terms to generate (depth). *)
      (* Default : 7 *)
      maxSize    : nat;
      (* Verbosity. Note: Doesn't do much... *)
      (* Default true. *)
      chatty     : bool
    }.

(** Instead of record updates, you should overwrite extraction constants. *)
(** [[
   Extract Constant defNumTests    => "10000".
   Extract Constant defNumDiscards => "(2 * defNumTests)".
   Extract Constant defNumShrinks  => "1000".
   Extract Constant defSize        => "7".
]]
*)

(* #################################################################### *)
(** * The [quickChick] Command-Line Tool *)

(** QuickChick comes with a command-line tool that supports:
      - Batch processing, compilation and execution of tests
      - Mutation testing
      - Sectioning of tests and mutants

    Comments that begin with an exclamation mark are special to the
    QuickChick command-line tool parser and signify a test, a section,
    or a mutant. *)

(** ** Test Annotations *)

(** A test annotation is just a [QuickChick] command wrapped inside
    a comment with an exclamation mark.
[[
    (*! QuickChick prop. *)
]]
   Only tests that are annotated this way will be processed. Only property
   names are allowed. *)

(** ** Mutant Annotations *)

(** A mutant annotation consists of 4 components. First an anottation
    that signifies the beginning of the mutant [(*! *)]. That is followed
    by the actual code. Then, we can include an optional annotation
    (in a comment with double exclamation marks) that corresponds to
    the mutant names. Finally, we can add a list of mutations inside
    normal annotated comments. Each mutant should be able to be
    syntactically substituted in for the normal code.

[[
    (*! *)
    Normal code
    (*!! mutant-name *)
    (*! mutant 1 *)
    (*! mutant 2 *)
    ... etc ...
]]
*)

(** ** Section Annotations *)

(** To organize larger developments better, we can group together
    different tests and mutants in sections. A section annotation is
    a single annotation that defines the beginning of the section
    (which lasts until the next section or the end of the file).
[[
      (*! Section section-name *)
]]
    Optionally, one can include an extends clause
[[
      (*! Section section-name *)(*! extends other-section-name *)
]]
   This signifies that the section being defined also
   contains all tests and mutants from [other-section-name].
*)

(** ** Command-Line Tool Flags *)

(** The QuickChick command line tool can be passed the following options:
    - [-s <section>]: Specify which sections properties and mutants to test
    - [-v]: Verbose mode for debugging
    - [-failfast]: Stop as soon as a problem is detected
    - [-color]: Use colors on an ANSI-compatible terminal
    - [-cmd <command>]: What compile command is used to compile the current directory
      if it is not [make]
    - [-top <name>]: Specify the name of the top-level logical module. That should
      be the same as the [-Q] or [-R] directive in [_CoqProject] or [Top]
      which is the default
    - [-ocamlbuild <args>]: Any arguments necessary to pass to ocamlbuild when
      compiling the extracted code (e.g. linked libraries)
    - [-nobase]: Pass this option to not test the base mutant
    - [-m <number>]: Pass this to only test a mutant with a specific id number
    - [-tag <name>]: Pass this to only test a mutant with a specific tag
    - [-include <name>]: Specify a to include in the compilation
    - [-exclude <names>]: Specify files to be excluded from compilation. Must be the last argument passed.
*)

(* #################################################################### *)
(** * Deprecated Features *)

(** The following features are retained for backward compatibility,
    but their use is deprecated. *)

(** Use the monad notations from [coq-ext-lib] instead of the
    [QcDoNotation] sub-module: *)
Module QcDoNotation.
  Notation "'do!' X <- A ; B" :=
    (bindGen A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
  Notation "'do\'' X <- A ; B" :=
    (bindGen' A (fun X H => B))
    (at level 200, X ident, A at level 100, B at level 200).
  Notation "'doM!' X <- A ; B" :=
    (bindGenOpt A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
End QcDoNotation.

End QuickChickSig.


From Coq Require Export String Ascii List NArith Arith.
From Coq Require Import Permutation.

Set Implicit Arguments.

Import ListNotations.

#[global] Open Scope string_scope.
#[global] Open Scope N_scope.

Infix "::" := String.String.

Fixpoint _rev_string (r s : string) : string :=
  match s with
  | "" => r
  | c :: s => _rev_string (c :: r) s
  end.

Definition rev_string : string -> string := _rev_string "".

Definition is_empty (w : string) : bool :=
  match w with
  | "" => true
  | _ => false
  end.

Fixpoint _split_on (c0 : ascii) (w s : string) : list string :=
  match s with
  | "" => if is_empty w then [] else [rev_string w]
  | c :: s =>
    if Ascii.eqb c0 c then
      if is_empty w then _split_on c0 w s else rev_string w :: _split_on c0 "" s
    else
      _split_on c0 (c :: w) s
  end.

(* Drops empty words! *)
Definition split_on (c0 : ascii) : string -> list string := _split_on c0 "".

Definition words : string -> list string := split_on " ".
Definition lines : string -> list string := split_on "010".

Definition raw_signal : Type := string.
Definition signal : Type := list bool. (* length 7 *)

Fixpoint char_of (c : ascii) (w : string) : bool :=
  match w with
  | "" => false
  | cw :: w => Ascii.eqb c cw || char_of c w
  end.

Definition word_to_signal (w : raw_signal) : signal :=
  map (fun c => char_of c w) ["a"; "b"; "c"; "d"; "e"; "f"; "g"]%char.

Definition Line : Type := (list raw_signal * list raw_signal).

Definition input (s : string) : list Line :=
  let input_line l :=
    match words l with
    | [s0; s1; s2; s3; s4; s5; s6; s7; s8; s9; vbar; t0; t1; t2; t3] =>
        if String.eqb "|" vbar then
          ([s0; s1; s2; s3; s4; s5; s6; s7; s8; s9], [t0; t1; t2; t3])
        else ([],[])
    | _ => ([],[])
    end in
  map input_line (lines s).

Definition example := Eval cbv in input
  "be cfbegad cbdgef fgaecd cgeb fdcge agebfd fecdb fabcd edb | fdgacbe cefdb cefbgd gcbe
edbfga begcd cbg gc gcadebf fbgde acbgfd abcde gfcbed gfec | fcgedb cgb dgebacf gc
fgaebd cg bdaec gdafb agbcfd gdcbef bgcad gfac gcb cdgabef | cg cg fdcagb cbg
fbegcd cbd adcefb dageb afcb bc aefdc ecdab fgdeca fcdbega | efabcd cedba gadfec cb
aecbfdg fbg gf bafeg dbefa fcge gcbea fcaegb dgceab fcbdga | gecf egdcabf bgf bfgea
fgeab ca afcebg bdacfeg cfaedg gcfdb baec bfadeg bafgc acf | gebdcfa ecba ca fadegcb
dbcfg fgd bdegcaf fgec aegbdf ecdfab fbedc dacgb gdcebf gf | cefg dcbef fcge gbcadfe
bdfegc cbegaf gecbf dfcage bdacg ed bedf ced adcbefg gebcd | ed bcgafe cdgba cbgef
egadfb cdbfeg cegd fecab cgb gbdefca cg fgcdab egfdb bfceg | gbdfcae bgc cg cgb
gcafb gcf dcaebfg ecagb gf abcdeg gaef cafbge fdbac fegbdc | fgae cfgab fg bagce".

Definition sum_with {A} (f : A -> N) : list A -> N :=
  fold_right (fun x => N.add (f x)) 0.

Definition count_1478 : list Line -> N :=
  sum_with (fun '(_, y) =>
    sum_with (fun s =>
      if ((String.length s =? 2) || (String.length s =? 3) ||
          (String.length s =? 4) || (String.length s =? 7))%nat%bool
      then 1 else 0) y).

Definition solve := count_1478.

(* Compute solve example. *)

(*
 aaaa
b    c
b    c
 dddd
e    f
e    f
 gggg

Number of digits where segment is active:
a 8
b 6
c 8
d 7
e 4
f 9
g 7

c occurs in the digit 1, and a doesn't
d occurs in the digit 4, and g doesn't
*)

Definition count (c : ascii) (xs : list raw_signal) : N :=
  sum_with (fun s => if char_of c s then 1 else 0) xs.

Definition occurs_in_1 (c : ascii) (xs : list raw_signal) : bool :=
  existsb (fun s => (String.length s =? 2)%nat && char_of c s)%bool xs.

Definition occurs_in_4 (c : ascii) (xs : list raw_signal) : bool :=
  existsb (fun s => (String.length s =? 4)%nat && char_of c s)%bool xs.

Definition decode (xs : list raw_signal) : list (ascii * ascii) :=
  map (fun c =>
    (c, let n := count c xs in
        if n =? 4 then "e"
        else if n =? 6 then "b"
        else if n =? 9 then "f"
        else if n =? 7 then
          if occurs_in_4 c xs then "d" else "g"
        else if n =? 8 then
          if occurs_in_1 c xs then "c" else "a"
        else "?")%N%char) ["a"; "b"; "c"; "d"; "e"; "f"; "g"]%char.

Definition lookup_char {A} (def : A) (c : ascii) (xs : list (ascii * A)) : A :=
  match List.find (fun w => c =? fst w)%char xs with
  | Some y => snd y
  | None => def
  end.

Fixpoint map_string (f : ascii -> ascii) (s : string) : string :=
  match s with
  | "" => ""
  | c :: s => f c :: map_string f s
  end.

Definition decipher (d : list (ascii * ascii)) (xs : raw_signal) : raw_signal :=
  map_string (fun c => lookup_char "?"%char c d) xs.

Notation t := true (only parsing).
Notation f := false (only parsing).

Definition raw_signal_to_digit (s : raw_signal) : N :=
  match word_to_signal s with
  | [t;t;t;f;t;t;t] => 0
  | [f;f;t;f;f;t;f] => 1
  | [t;f;t;t;t;f;t] => 2
  | [t;f;t;t;f;t;t] => 3
  | [f;t;t;t;f;t;f] => 4
  | [t;t;f;t;f;t;t] => 5
  | [t;t;f;t;t;t;t] => 6
  | [t;f;t;f;f;t;f] => 7
  | [t;t;t;t;t;t;t] => 8
  | [t;t;t;t;f;t;t] => 9
  | _ => 10000000 (* Blow up if wrong *)
  end.

Fixpoint _from_decimal (d : N) (s : list N) : N :=
  match s with
  | [] => d
  | c :: s => _from_decimal (d * 10 + c) s
  end%list.

Definition from_decimal : list N -> N := _from_decimal 0.

Definition outsig_to_num (s : list raw_signal) : N :=
  from_decimal (map raw_signal_to_digit s).

Definition decipher_line '((x,y) : Line) : N :=
  let d := decode x in
  let y := map (decipher d) y in
  outsig_to_num y.

Definition example1 := input "acedgfb cdfbe gcdfa fbcad dab cefabd cdfgeb eafb cagedb ab | cdfeb fcadb cdfeb cdbaf".

(* Compute map decipher_line example1. *)

Definition solve2 : list Line -> N :=
  sum_with decipher_line.

(* Compute solve2 example. *)

Definition solve12 (xs : list Line) : N * N :=
  (solve xs, solve2 xs).

(* Spec, no proofs *)

Definition digits : list raw_signal :=
  ["cf"; "acdeg"; "acdfg"; "bcdf"; "abdfg"; "abdefg"; "acf"; "abcdefg"; "abcdfg"]%string.

(* The seven segments *)
Definition segs : list ascii := ["a"; "b"; "c"; "d"; "e"; "f"; "g"]%char.

Definition mapping {A B} (xs : list A) (ys : list B) (x : A) (y : B) :=
  List.In (x, y) (List.combine xs ys).

Fixpoint Forall2_string (F : ascii -> ascii -> Prop) (s1 s2 : string) : Prop :=
  match s1, s2 with
  | "", "" => True
  | c1 :: s1, c2 :: s2 => F c1 c2 /\ Forall2_string F s1 s2
  | _, _ => False
  end.

Definition Permutation_string (s1 s2 : string) : Prop :=
  Permutation (list_ascii_of_string s1) (list_ascii_of_string s2).

Definition index {A} (xs : list A) (n : nat) (x : A) : Prop :=
  (n < length xs)%nat /\ nth n xs x = x.

(* A well-formed input line [l] is related to the "canonical" representation of segments
   [segs] and [digits] as follows. *)
Record LineSpec (l : Line) : Type :=
  { (* (1) The display segments are scrambled *)
    ssegs : list ascii  (* scrambled display lines *)
  ; ssegs_P : Permutation segs ssegs

    (* (2) We apply the segment scrambling to the digits *)
  ; sdigits : list raw_signal
  ; sdigits_P : Forall2 (Forall2_string (mapping segs ssegs)) digits sdigits

    (* (3) The digits are shuffled *)
  ; ssdigits : list raw_signal
  ; ssdigits_P : Permutation sdigits ssdigits

    (* (4) The order of segments in each digit is shuffled,
       this yields the first half of our input. *)
  ; sssdigits : list raw_signal := fst l
  ; sssdigits_P : Forall2 Permutation_string ssdigits sssdigits

    (* (5) The second half of the input is 4 digits *)
  ; outs : list nat
  ; outs_length : length outs = 4%nat

    (* (6) The digits are mapped to their 7-segment display
       (this implies the elements of [outs] are actually digits) *)
  ; douts : list raw_signal
  ; douts_X : Forall2 (index digits) outs douts

    (* (7) Apply the segment scrambling (like (2)) *)
  ; sdouts : list raw_signal
  ; sdouts_P : Forall2 (Forall2_string (mapping segs ssegs)) douts sdouts

    (* (8) The segments are shuffled, that's the second half of the input. *)
  ; ssdouts : list raw_signal := snd l
  ; ssdouts_P : Forall2 Permutation_string sdouts ssdouts
  }.

(* [decipher_line] reconstructs the 4 digits in [outs]. *)
Theorem decipher_correct (l : Line) (ls : LineSpec l)
  : decipher_line l = from_decimal (map N.of_nat (outs ls)).
Proof.
  (* Good luck *)
Abort.