(** 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)) .


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.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Typeclass-based relations, tactics and standard instances

   This is the basic theory needed to formalize morphisms and setoids.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Export Coq.Classes.Init.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Relations.Relation_Definitions.

Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.

(** We allow to unfold the [relation] definition while doing morphism search. *)

Section Defs.
  Context {A : Type}.

  (** We rebind relational properties in separate classes to be able to overload each proof. *)

  Class Reflexive (R : relation A) :=
    reflexivity : forall x : A, R x x.

  Definition complement (R : relation A) : relation A := fun x y => R x y -> False.

  (** Opaque for proof-search. *)
  Typeclasses Opaque complement.

  (** These are convertible. *)
  Lemma complement_inverse R : complement (flip R) = flip (complement R).
  Proof. reflexivity. Qed.

  Class Irreflexive (R : relation A) :=
    irreflexivity : Reflexive (complement R).

  Class Symmetric (R : relation A) :=
    symmetry : forall {x y}, R x y -> R y x.

  Class Asymmetric (R : relation A) :=
    asymmetry : forall {x y}, R x y -> R y x -> False.

  Class Transitive (R : relation A) :=
    transitivity : forall {x y z}, R x y -> R y z -> R x z.

  (** Various combinations of reflexivity, symmetry and transitivity. *)

  (** A [PreOrder] is both Reflexive and Transitive. *)

  Class PreOrder (R : relation A) : Prop := {
    PreOrder_Reflexive :> Reflexive R | 2 ;
    PreOrder_Transitive :> Transitive R | 2 }.

  (** A [StrictOrder] is both Irreflexive and Transitive. *)

  Class StrictOrder (R : relation A) : Prop := {
    StrictOrder_Irreflexive :> Irreflexive R ;
    StrictOrder_Transitive :> Transitive R }.

  (** By definition, a strict order is also asymmetric *)
  Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R.
  Proof. firstorder. Qed.

  (** A partial equivalence relation is Symmetric and Transitive. *)

  Class PER (R : relation A) : Prop := {
    PER_Symmetric :> Symmetric R | 3 ;
    PER_Transitive :> Transitive R | 3 }.

  (** Equivalence relations. *)

  Class Equivalence (R : relation A) : Prop := {
    Equivalence_Reflexive :> Reflexive R ;
    Equivalence_Symmetric :> Symmetric R ;
    Equivalence_Transitive :> Transitive R }.

  (** An Equivalence is a PER plus reflexivity. *)

  Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 :=
    { }.

  (** An Equivalence is a PreOrder plus symmetry. *)

  Global Instance Equivalence_PreOrder {R} `(E:Equivalence R) : PreOrder R | 10 :=
    { }.

  (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)

  Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) :=
    antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.

  Class subrelation (R R' : relation A) : Prop :=
    is_subrelation : forall {x y}, R x y -> R' x y.

  (** Any symmetric relation is equal to its inverse. *)

  Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R.
  Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed.

  Section flip.

    Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R).
    Proof. tauto. Qed.

    Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) :=
      irreflexivity (R:=R).

    Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) :=
      fun x y H => symmetry (R:=R) H.

    Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) :=
      fun x y H H' => asymmetry (R:=R) H H'.

    Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) :=
      fun x y z H H' => transitivity (R:=R) H' H.

    Program Definition flip_Antisymmetric `(Antisymmetric eqA R) :
      Antisymmetric eqA (flip R).
    Proof. firstorder. Qed.

    (** Inversing the larger structures *)

    Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R).
    Proof. firstorder. Qed.

    Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R).
    Proof. firstorder. Qed.

    Lemma flip_PER `(PER R) : PER (flip R).
    Proof. firstorder. Qed.

    Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R).
    Proof. firstorder. Qed.

  End flip.

  Section complement.

    Definition complement_Irreflexive `(Reflexive R)
      : Irreflexive (complement R).
    Proof. firstorder. Qed.

    Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R).
    Proof. firstorder. Qed.
  End complement.

  (** Rewrite relation on a given support: declares a relation as a rewrite
   relation for use by the generalized rewriting tactic.
   It helps choosing if a rewrite should be handled
   by the generalized or the regular rewriting tactic using leibniz equality.
   Users can declare an [RewriteRelation A RA] anywhere to declare default
   relations. This is also done automatically by the [Declare Relation A RA]
   commands. *)

  Class RewriteRelation (RA : relation A).

  (** Any [Equivalence] declared in the context is automatically considered
   a rewrite relation. *)

  Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA.

  (** Leibniz equality. *)
  Section Leibniz.
    Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A.
    Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A.
    Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A.

    (** Leibinz equality [eq] is an equivalence relation.
        The instance has low priority as it is always applicable
        if only the type is constrained. *)

    Global Program Instance eq_equivalence : Equivalence (@eq A) | 10.
  End Leibniz.

End Defs.

(** Default rewrite relations handled by [setoid_rewrite]. *)
Instance: RewriteRelation impl.
Instance: RewriteRelation iff.

(** Hints to drive the typeclass resolution avoiding loops
 due to the use of full unification. *)
Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances.

Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances.
Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances.
Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances.

Hint Extern 4 (subrelation (flip _) _) =>
  class_apply @subrelation_symmetric : typeclass_instances.

Arguments irreflexivity {A R Irreflexive} [x] _.
Arguments symmetry {A} {R} {_} [x] [y] _.
Arguments asymmetry {A} {R} {_} [x] [y] _ _.
Arguments transitivity {A} {R} {_} [x] [y] [z] _ _.
Arguments Antisymmetric A eqA {_} _.

Hint Resolve irreflexivity : ord.

Unset Implicit Arguments.

(** A HintDb for relations. *)

Ltac solve_relation :=
  match goal with
  | [ |- ?R ?x ?x ] => reflexivity
  | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H
  end.

Hint Extern 4 => solve_relation : relations.

(** We can already dualize all these properties. *)

(** * Standard instances. *)

Ltac reduce_hyp H :=
  match type of H with
    | context [ _ <-> _ ] => fail 1
    | _ => red in H ; try reduce_hyp H
  end.

Ltac reduce_goal :=
  match goal with
    | [ |- _ <-> _ ] => fail 1
    | _ => red ; intros ; try reduce_goal
  end.

Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid.

Ltac reduce := reduce_goal.

Tactic Notation "apply" "*" constr(t) :=
  first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) |
    refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ].

Ltac simpl_relation :=
  unfold flip, impl, arrow ; try reduce ; program_simpl ;
    try ( solve [ dintuition ]).

Local Obligation Tactic := simpl_relation.

(** Logical implication. *)

Program Instance impl_Reflexive : Reflexive impl.
Program Instance impl_Transitive : Transitive impl.

(** Logical equivalence. *)

Instance iff_Reflexive : Reflexive iff := iff_refl.
Instance iff_Symmetric : Symmetric iff := iff_sym.
Instance iff_Transitive : Transitive iff := iff_trans.

(** Logical equivalence [iff] is an equivalence relation. *)

Program Instance iff_equivalence : Equivalence iff.

(** We now develop a generalization of results on relations for arbitrary predicates.
   The resulting theory can be applied to homogeneous binary relations but also to
   arbitrary n-ary predicates. *)

Local Open Scope list_scope.

(** A compact representation of non-dependent arities, with the codomain singled-out. *)

(* Note, we do not use [list Type] because it imposes unnecessary universe constraints *)
Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist.
Local Infix "::" := Tcons.

Fixpoint arrows (l : Tlist) (r : Type) : Type :=
  match l with
    | Tnil => r
    | A :: l' => A -> arrows l' r
  end.

(** We can define abbreviations for operation and relation types based on [arrows]. *)

Definition unary_operation A := arrows (A::Tnil) A.
Definition binary_operation A := arrows (A::A::Tnil) A.
Definition ternary_operation A := arrows (A::A::A::Tnil) A.

(** We define n-ary [predicate]s as functions into [Prop]. *)

Notation predicate l := (arrows l Prop).

(** Unary predicates, or sets. *)

Definition unary_predicate A := predicate (A::Tnil).

(** Homogeneous binary relations, equivalent to [relation A]. *)

Definition binary_relation A := predicate (A::A::Tnil).

(** We can close a predicate by universal or existential quantification. *)

Fixpoint predicate_all (l : Tlist) : predicate l -> Prop :=
  match l with
    | Tnil => fun f => f
    | A :: tl => fun f => forall x : A, predicate_all tl (f x)
  end.

Fixpoint predicate_exists (l : Tlist) : predicate l -> Prop :=
  match l with
    | Tnil => fun f => f
    | A :: tl => fun f => exists x : A, predicate_exists tl (f x)
  end.

(** Pointwise extension of a binary operation on [T] to a binary operation
   on functions whose codomain is [T].
   For an operator on [Prop] this lifts the operator to a binary operation. *)

Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
  (l : Tlist) : binary_operation (arrows l T) :=
  match l with
    | Tnil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      fun x => pointwise_extension op tl (R x) (R' x)
  end.

(** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *)

Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : Tlist) : binary_relation (predicate l) :=
  match l with
    | Tnil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      forall x, pointwise_lifting op tl (R x) (R' x)
  end.

(** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *)

Definition predicate_equivalence {l : Tlist} : binary_relation (predicate l) :=
  pointwise_lifting iff l.

(** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *)

Definition predicate_implication {l : Tlist} :=
  pointwise_lifting impl l.

(** Notations for pointwise equivalence and implication of predicates. *)

Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope.
Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope.

Local Open Scope predicate_scope.

(** The pointwise liftings of conjunction and disjunctions.
   Note that these are [binary_operation]s, building new relations out of old ones. *)

Definition predicate_intersection := pointwise_extension and.
Definition predicate_union := pointwise_extension or.

Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope.
Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope.

(** The always [True] and always [False] predicates. *)

Fixpoint true_predicate {l : Tlist} : predicate l :=
  match l with
    | Tnil => True
    | A :: tl => fun _ => @true_predicate tl
  end.

Fixpoint false_predicate {l : Tlist} : predicate l :=
  match l with
    | Tnil => False
    | A :: tl => fun _ => @false_predicate tl
  end.

Notation "∙⊤∙" := true_predicate : predicate_scope.
Notation "∙⊥∙" := false_predicate : predicate_scope.

(** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *)

Program Instance predicate_equivalence_equivalence :
  Equivalence (@predicate_equivalence l).

  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    fold pointwise_lifting.
    induction l. firstorder.
    intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)).
    firstorder.
  Qed.

Program Instance predicate_implication_preorder :
  PreOrder (@predicate_implication l).
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l. firstorder.
    unfold predicate_implication in *. simpl in *.
    intro. pose (IHl (x x0) (y x0) (z x0)). firstorder.
  Qed.

(** We define the various operations which define the algebra on binary relations,
   from the general ones. *)

Section Binary.
  Context {A : Type}.

  Definition relation_equivalence : relation (relation A) :=
    @predicate_equivalence (_::_::Tnil).

  Global Instance: RewriteRelation relation_equivalence.

  Definition relation_conjunction (R : relation A) (R' : relation A) : relation A :=
    @predicate_intersection (A::A::Tnil) R R'.

  Definition relation_disjunction (R : relation A) (R' : relation A) : relation A :=
    @predicate_union (A::A::Tnil) R R'.

  (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)

  Global Instance relation_equivalence_equivalence :
    Equivalence relation_equivalence.
  Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed.

  Global Instance relation_implication_preorder : PreOrder (@subrelation A).
  Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed.

  (** *** Partial Order.
   A partial order is a preorder which is additionally antisymmetric.
   We give an equivalent definition, up-to an equivalence relation
   on the carrier. *)

  Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
    partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)).

  (** The equivalence proof is sufficient for proving that [R] must be a
   morphism for equivalence (see Morphisms).  It is also sufficient to
   show that [R] is antisymmetric w.r.t. [eqA] *)

  Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R.
  Proof with auto.
    reduce_goal.
    pose proof partial_order_equivalence as poe. do 3 red in poe.
    apply <- poe. firstorder.
  Qed.

  Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R).
  Proof. firstorder. Qed.
End Binary.

Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances.

(** The partial order defined by subrelation and relation equivalence. *)

Program Instance subrelation_partial_order :
  ! PartialOrder (relation A) relation_equivalence subrelation.

Next Obligation.
Proof.
  unfold relation_equivalence in *. compute; firstorder.
Qed.

Typeclasses Opaque arrows predicate_implication predicate_equivalence
            relation_equivalence pointwise_lifting.


Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Lia.
Require Import Metalib.LibTactics.
Require Import Language Tactical.

(** * Definitions *)

Inductive ordinary : type -> Prop :=
| Ord_Top : ordinary Top
| Ord_Tnt : ordinary Int
| Ord_Arr : forall A B,
    ordinary B -> ordinary (Arr A B)
| Ord_Rcd : forall l A,
    ordinary A ->
    ordinary (Rcd l A).

Hint Constructors ordinary : core.

Inductive splitable : type -> type -> type -> Prop :=
| Spl_And : forall A B,
    splitable (And A B) A B
| Spl_Arr : forall A B B1 B2,
    splitable B B1 B2 ->
    splitable (Arr A B) (Arr A B1) (Arr A B2)
| Spl_Rcd : forall l A A1 A2,
    splitable A A1 A2 ->
    splitable (Rcd l A) (Rcd l A1) (Rcd l A2).

Hint Constructors splitable : core.

Notation "A1 ↩ A ↪ A2" := (splitable A A1 A2) (at level 40).

(** * Splitable and Ordinary *)

(** splitable is not ordinary *)

Lemma splitable_not_ordinary :
  forall A A1 A2,
    splitable A A1 A2 -> ~ ordinary A.
Proof.
  introv Spl Ord. gen A1 A2.
  dependent induction Ord; intros; try solve [inversion Spl; eauto | eauto].
Qed.

(** * Automations *)

(** add this lemma to hint base to exclude absurd cases *)

Ltac solve_splitable :=
  match goal with
  | H1: splitable ?A _ _, H2: ordinary ?A |- _ =>
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra; contradiction
  | H1: splitable (Arr _ ?B) _ _, H2: ordinary ?B |- _ =>
      dependent destruction H1;
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra;
      contradiction
  | H1: splitable (Rcd _ ?A) _ _, H2: ordinary ?A |- _ =>
      dependent induction H1;
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra;
      contradiction
  | H: splitable Int _ _ |- _ => inversion H
  | H: splitable Top _ _ |- _ => inversion H
  end.

Hint Extern 5 => solve_splitable : core.

Ltac solve_ordinary :=
  match goal with
  | [H: ordinary (And _ _) |- _] =>
      (inversion H)
  end.

Hint Extern 5 => solve_ordinary : core.

(** [contra_ordinary] solves contradiction cases of ordinary *)

Ltac contra_ordinary :=
  match goal with
  | H1: ordinary ?A, H2: not (ordinary ?A) |- _ => contradiction
  | H1: ordinary (Arr _ ?A), H2: not (ordinary ?A) |- _ =>
      dependent destruction H1; contradiction
  | H1: ordinary (Rcd _ ?A), H2: not (ordinary ?A) |- _ =>
      dependent destruction H1; contradiction
  end.

(** * Splitable or Ordinary *)

(** For any type A, it's [ordinary] or [splitable] **)

Lemma splitable_or_ordinary :
  forall A,
    ordinary A \/ exists A1 A2, splitable A A1 A2.
Proof.
  introv. dependent induction A; eauto.
  - destruct IHA1; destruct IHA2; eauto.
    + right. destruct_conjs; eauto.
    + right. destruct_conjs; eauto.
  - destruct IHA; eauto.
    right. destruct_conjs; eauto.
Qed.

(** * Determinism of Splitable *)

Lemma splitable_determinism :
  forall A A1 A2 A3 A4,
    splitable A A1 A2 -> splitable A A3 A4 ->
    A1 = A3 /\ A2 = A4.
Proof.
  introv Spl1 Spl2. gen A3 A4.
  dependent induction Spl1; eauto; intros.
  - dependent destruction Spl2.
    split; eauto.
  - dependent destruction Spl2.
    split; f_equal; eapply IHSpl1; eauto.
  - dependent induction Spl2.
    split; f_equal; eapply IHSpl1; eauto.
Qed.

(** * Unify Splitable Varialbes *)

(** unify variables into same names *)

Ltac subst_splitable :=
  match goal with
  | H1: splitable ?A ?A1 ?A2, H2: splitable ?A ?A3 ?A4 |- _ =>
      pose proof (splitable_determinism _ _ _ _ _ H1 H2) as Eqs;
      destruct Eqs; subst; clear H1
  end.

(** * Decidablility of Ordinary *)

Lemma ordinary_decidable :
  forall A,
    ordinary A \/ not (ordinary A).
Proof.
  introv. induction A; eauto.
  - destruct IHA1; destruct IHA2; eauto.
    + right. intros Contra. contra_ordinary.
    + right. intros Contra. contra_ordinary.
  - destruct IHA; eauto.
    right. intros Contra. contra_ordinary.
Qed.

(** * Splitable & Size *)

(** If A can split into A1 and A2, the size of A1 and A2 is smaller than A *)

Lemma splitable_decrease_size:
  forall A A1 A2,
    splitable A A1 A2 -> size_type A1 < size_type A /\ size_type A2 < size_type A.
Proof.
  introv H. dependent induction H; simpl; lia.
Qed.


Lemma option_dec : forall A (x:option A), (exists a, x = Some a) \/ x = None.
intros. destruct x; [left;exists a|right];trivial.
Save.
Implicit Arguments option_dec [A].

Definition option_map : forall (A B:Type), (A->B) -> option A -> option B :=
  fun A B f oa => match oa with
  | None => None
  | Some a => Some (f a)
  end.
Implicit Arguments option_map [A B].

Inductive option_incl (A:Type) : option A -> option A -> Prop :=
| o_inc_1 : option_incl A None None
| o_inc_2 : forall a, option_incl A None (Some a)
| o_inc_3 : forall a, option_incl A (Some a) (Some a).
Implicit Arguments option_incl [A].

Lemma option_incl_refl : forall (A:Type) (o:option A), option_incl o o.
intros. destruct o. apply o_inc_3. apply o_inc_1.
Save.

Lemma option_incl_trans : forall (A:Type) (o1 o2 o3:option A), option_incl o1 o2 -> option_incl o2 o3 -> option_incl o1 o3.
intros.
destruct H; inversion H0.
apply o_inc_1. apply o_inc_2. apply o_inc_2. apply o_inc_3.
Save.

Definition option_eq_dec : forall (A:Type) (A_eq_dec:forall (a b:A), {a=b}+{a<>b}) (o1 o2:option A), {o1=o2}+{o1<>o2}.
intros A A_eq_dec. decide equality.
Defined.

Definition option_to_bool : forall A, option A -> bool :=
  fun A o => match o with
  | None => false
  | Some _ => true
  end.
Implicit Arguments option_to_bool [A].

Definition option_mult : forall A, option (option A) -> option A :=
  fun A o => match o with
  | None => None
  | Some f => f
  end.
Implicit Arguments option_mult [A].

Definition option_informative : forall (A:Type) (o:option A), {a:A | o = Some a} + {o = None}.
intros. destruct o. left. exists a. trivial. right. trivial.
Defined.
Implicit Arguments option_informative [A].

Lemma Some_isnt_None : forall (A:Type) x (a:A),
  x = Some a -> x <> None.
unfold not. intros. subst. discriminate.
Save.
Implicit Arguments Some_isnt_None [A x a].


(* Spaces whose points are compact sets
   i.e., some version of Smyth power domains
   See Vickers' *Topology via Logic*

   We should have

   pt : A ~~> P+(A)
   OR : P+(A) * P+(A) ~~> P+(A)

   approx : Approximator A X -> Approximator P+(A) X

   which behaves by arbitrarily choosing an option
   in the powerdomain. *)

(* It appears that there is a formulation of the Smyth powerdomain
   in formal topology in Vickers' 2005
   "Some constructive roads to Tychonoff"
*)

Require Import
  FormTopC.FormTop
  Algebra.SetsC
  Algebra.OrderC
  FormTopC.Join
  FormTopC.Cont.

Set Asymmetric Patterns.
Set Universe Polymorphism.
Local Open Scope Subset.

Module Compact.
Section Defn.

Context {S : PreISpace.t}
        {POS : PreO.t (le S)}.

Definition le := JoinTop.leL (le := le S).

Instance PO : PreO.t le := JoinTop.joinPreO.

Require Import Coq.Lists.List Types.List.
Import ListNotations.

Inductive Splits : list S -> list S -> list S -> Type :=
  | SplitNil : Splits nil nil nil
  | SplitL : forall a {xs ys zs}, Splits xs ys zs
           -> Splits (a :: xs) ys (a :: zs)
  | SplitR : forall b {xs ys zs}, Splits xs ys zs
           -> Splits xs (b :: ys) (b :: zs).

Definition IxS := PreISpace.Ix S.

Inductive Ix {xs : list S} : Type :=
  | MkIx : forall a s : list S, Each IxS a
   -> Splits a s xs -> Ix.

Arguments Ix : clear implicits.

Definition Ixnil : Ix nil.
Proof.
econstructor. apply Each_nil.
apply SplitNil.
Defined.

Inductive KFinite {U : S -> Type} : list S -> Type :=
  | KNil : KFinite nil
  | KCons : forall x, U x -> forall {xs}, KFinite xs -> KFinite (x :: xs).

Arguments KFinite : clear implicits.

Require Import CMorphisms.
Lemma KFinite_Proper_impl : Proper (Same_set ==> eq ==> arrow)
  KFinite.
Proof.
unfold Proper, respectful, arrow. intros.
subst. induction X0. apply KNil.
apply KCons. apply X. assumption. assumption.
Qed.

Instance KFinite_Proper : Proper (Same_set ==> eq ==> iffT)
  KFinite.
Proof.
unfold Proper, respectful. intros. split; intros.
- eapply KFinite_Proper_impl; eassumption.
- eapply KFinite_Proper_impl. symmetry. eassumption.
  symmetry. eassumption. assumption.
Qed.

Definition Each_get {A B} {xs : list A} {x : A}
  (e : Each B xs)
  (mem : member x xs) : B x.
Proof.
induction e.
- inv mem.
- inv mem. assumption. apply IHe. assumption.
Defined.

Definition CS := PreISpace.C S.

Inductive axunion {a : list S} {axioms : Each IxS a}
  : Subset S :=
  | Mkaxunion : forall (s : S) x (el : member x a),
  CS _ (Each_get axioms el) s -> axunion s.

Arguments axunion {a} axioms _.

Lemma axunion_nil_false : forall s,
  axunion Each_nil s -> False.
Proof.
intros. induction X.
inv el.
Qed.

Lemma axunion_nil : axunion Each_nil === fun _ => False.
Proof.
apply Same_set_iff. intros. split; intros.
- eapply axunion_nil_false; eassumption.
- contradiction.
Qed.

Inductive Covering {a s : list S} {axioms : Each IxS a}
  {s' : list S} : Type :=
  | MkCovering : forall t, Splits t s s' ->
    forall u, KFinite (axunion axioms) u -> le t u -> Covering.

Arguments Covering : clear implicits.

Definition C (xs : list S) (split : Ix xs) : Subset (list S) :=
  match split with
  | MkIx a s axioms mem => Covering a s axioms
  end.

Definition CompactPreO : FormTop.PreOrder :=
  {| PO_car := list S
   ; FormTop.le := le |}.

Definition Compact : PreISpace.t :=
  {| PreISpace.S := CompactPreO
   ; PreISpace.Ix := Ix
   ; PreISpace.C := C |}.

Lemma member_le : forall a b, member a b -> [a] <=[Compact] b.
Proof.
intros. simpl. unfold le, JoinTop.leL. intros.
inv X0. Focus 2. inv X1.
exists a. split. reflexivity. assumption.
Qed.

Lemma leS_le : forall a b, a <=[S] b -> [a] <=[Compact] [b].
Proof.
intros. simpl. unfold le, JoinTop.leL. intros.
inv X0. Focus 2. inv X1. exists b. split. assumption.
constructor.
Qed.

Lemma SplitsR_All xs : Splits nil xs xs.
Proof.
induction xs. constructor. constructor. assumption.
Qed.

Lemma Splits_KFinite {U xs ys zs} :
  Splits xs ys zs -> KFinite U xs -> KFinite U ys
  -> KFinite U zs.
Proof.
intros. induction X.
- assumption.
- inv X0. apply KCons. assumption. apply IHX; assumption.
- inv X1. apply KCons. assumption. apply IHX; assumption.
Qed.

Lemma KFinite_nil {xs} :
  KFinite (fun _ : S => False) xs -> xs = nil.
Proof.
intros H. induction H. reflexivity.
contradiction.
Qed.

Lemma le_nil {xs} : le xs [] -> xs = [].
Proof.
intros. induction xs.
- reflexivity.
- unfold le, JoinTop.leL in X.
  destruct (X a here). destruct p. inv m.
Qed.

Lemma Splits_length {xs ys zs} : Splits xs ys zs
  -> length xs + length ys = length zs.
Proof.
intros H. induction H.
- reflexivity.
- simpl. rewrite IHSplits. reflexivity.
- simpl. rewrite <- plus_n_Sm. rewrite IHSplits.
  reflexivity.
Qed.

Lemma Splits_nil {xs} : Splits [] [] xs
  -> xs = [].
Proof.
intros H. apply Splits_length in H. simpl in H.
apply length_zero_iff_nil. symmetry. assumption.
Qed.

Lemma C_nil {xs} : C [] Ixnil xs -> xs = [].
Proof.
simpl. intros.
induction X.
eapply KFinite_Proper in k.
2: symmetry. 2: apply axunion_nil.
2: reflexivity. pose proof (KFinite_nil k).
subst. pose proof (le_nil l). subst.
apply Splits_nil in s. subst.
reflexivity.
Qed.

Hypothesis locS : FormTop.localized S.

Lemma Splits_nil_opp {xs ys} : Splits xs ys []
  -> xs = [] /\ ys = [].
Proof.
intros H. inv H. auto.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Inductive Empty {A} : list A -> Prop :=
  | IsEmpty : Empty [].

Lemma Each_nil_unique_helper {A B} {xs : list A}
  (e : @Each A B xs) :
  match xs as xs' return @Each A B xs' -> Type with
  | [] => fun e => e = Each_nil
  | _ => fun _ => True
  end e.
Proof.
induction e. reflexivity. auto.
Qed.

Lemma Each_nil_unique {A B}
  (e : @Each A B []) : e = Each_nil.
Proof.
apply (Each_nil_unique_helper e).
Qed.

Lemma SplitNil_unique_helper {xs ys zs : list S}
  (s : Splits xs ys zs) :
  (match zs with
  | [] => match xs with
    | [] => match ys with
      | [] => fun e => e = SplitNil
      | _ => fun _ => True
      end
    | _ => fun _ => True
    end
  | _ => fun _ => True
  end) s.
Proof.
induction s; (reflexivity || auto).
Qed.

Lemma SplitNil_unique
  (s : Splits [] [] []) : s = SplitNil.
Proof.
apply (SplitNil_unique_helper s).
Qed.

Lemma Ixnil_unique : forall (i : Ix []), i = Ixnil.
Proof.
intros. induction i. unfold Ixnil.
destruct (Splits_nil_opp s0). subst.
pose proof (Each_nil_unique e). subst.
pose proof (SplitNil_unique s0). subst.
reflexivity.
Qed.

Lemma loc : FormTop.localized Compact.
Proof.
unfold FormTop.localized.
intros.
unfold FormTop.localized in locS.
generalize dependent a.
induction c.
- intros. apply le_nil in X. subst.
  exists Ixnil. intros.
  pose proof (C_nil X). subst.
  exists []. split.
  Focus 2. split; reflexivity.
  pose proof (Ixnil_unique i). subst.
  assumption.
- intros. induction i. simpl.
Abort.

Definition inj : Cont.map S Compact := fun xs x => [x] <=[Compact] xs.

Definition inj_cont : IGCont.t S Compact inj.
Proof.
constructor; intros.
- apply FormTop.grefl. exists [a]. unfold SetsC.In. constructor.
  unfold inj. reflexivity.
- unfold inj in *. apply FormTop.grefl.
  exists [a]. 2: reflexivity. split; assumption.
- unfold inj in *. etransitivity. apply leS_le.
  eassumption. eassumption.
- unfold inj in *. etransitivity; eassumption.
- induction j. simpl. induction a0.
  + apply FormTop.grefl. unfold inj in *.
    exists (a :: s). 2: apply member_le; constructor.
    simpl in X.
    econstructor. apply SplitL. apply SplitsR_All.
    2: eassumption. apply (Splits_KFinite s0).
    apply KNil.
unfold inj in *.
Admitted.

Definition Ix_singleton {a} (i : IxS a) : Ix [a].
Proof.
econstructor. 2: eapply SplitL. 2: econstructor.
econstructor. assumption. econstructor.
Defined.

Axiom undefined : forall A, A.

Require Import CRelationClasses.
Lemma lift_Cov_Ax : forall a (i : IxS a) u,
  CS a i u -> C [a] (Ix_singleton i) [u].
Proof.
intros. simpl. econstructor. apply SplitL. econstructor.
  2: reflexivity. econstructor.
  constructor 1 with a here. apply X.
  constructor.
Qed.

Local Open Scope FT.

Lemma Cov_nil {U} : [] <|[Compact] U.
Proof.
apply FormTop.ginfinity with Ixnil.
simpl. intros. induction X.
  eapply KFinite_Proper in k.
  2: symmetry. 2: apply axunion_nil.
  2: reflexivity. pose proof (KFinite_nil k).
  subst. pose proof (le_nil l). subst.
  apply Splits_nil in s. subst.
Abort.

Lemma Cov_each : forall U (xs : list S),
  (forall x : S, member x xs -> [x] <|[Compact] U)
  -> xs <|[Compact] U.
Proof.
intros. induction xs.
- apply FormTop.ginfinity with Ixnil.
  simpl. intros. induction X0.
  eapply KFinite_Proper in k.
  2: symmetry. 2: apply axunion_nil.
  2: reflexivity. pose proof (KFinite_nil k).
  subst. pose proof (le_nil l). subst.
  apply Splits_nil in s. subst.
Abort.

Lemma lift_Cov : forall a U, a <|[S] U
  -> [a] <|[Compact] Each U.
Proof.
intros.
induction X.
- apply FormTop.grefl. constructor. assumption.
  constructor.
- simpl in *. eapply FormTop.gle_left. 2: eassumption.
  apply leS_le. assumption.
- unshelve eapply FormTop.ginfinity.
  apply Ix_singleton. assumption.
  simpl. intros.
  induction X0.
econstructor.
Abort.

(** This actually doesn't work, because the
    empty compact set is a valid point of the space. *)
Definition nondet_run : forall a U, FormTop.GCov S a U
  -> forall (F : Subset (list S)), IGCont.pt Compact F
  -> SetsC.In F [a] -> { b : S & SetsC.In U b }.
Proof.
intros.
induction X.
- exists a. assumption.
- apply IHX. unfold SetsC.In.
  eapply (IGCont.pt_le_right (T := Compact) (F := F) X0).
  eassumption. apply leS_le. assumption.
- pose proof (IGCont.pt_cov X0 X1 (Ix_singleton i)) as H.
  induction H.
Abort.

End Defn.
End Compact.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.abgroups.Qabgroup.
Require Import CoRN.algebra.CRings.
Require Import CoRN.model.rings.Zring.

Local Open Scope Q_scope.

(**
** Example of a ring: $\langle$#⟨#[Q],[[+]],[[*]]$\rangle$#⟩#
Because [Q] forms an abelian group with addition, a monoid with
multiplication and it satisfies the distributive law, it is a ring.
*)

Lemma Q_mult_plus_is_dist : distributive Qmult_is_bin_fun Qplus_is_bin_fun.
Proof.
 red in |- *.
 simpl in |- *.
 exact Qmult_plus_distr_r.
Qed.

Definition Q_is_CRing : is_CRing Q_as_CAbGroup 1 Qmult_is_bin_fun.
Proof.
 apply Build_is_CRing with Qmult_is_assoc.
    apply Q_mul_is_CMonoid.
   apply Qmult_is_commut.
  apply Q_mult_plus_is_dist.
 apply Q_apart_0_1.
Defined.

Definition Q_as_CRing := Build_CRing _ _ _ Q_is_CRing.

Canonical Structure Q_as_CRing.

(** The following lemmas are used in the proof that [Q] is Archimeadian.
*)

Lemma injz_Nring : forall n,
 nring (R:=Q_as_CRing) n[=]inject_Z (nring (R:=Z_as_CRing) n).
Proof.
 intro n.
 induction  n as [| n Hrecn].
  change (([0]:Q_as_CRing)[=][0]) in |- *.
  apply eq_reflexive_unfolded.
 change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (nring (R:=Z_as_CRing) n[+][1])) in |- *.
 Step_final ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+][1]).
 astepl ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+] inject_Z ([1]:Z_as_CRing)).
 apply eq_symmetric_unfolded.
 apply injz_plus.
Qed.

Lemma injZ_eq : forall x y : Z, x = y -> (inject_Z x:Q_as_CRing)[=]inject_Z y.
Proof.
 intros.
 unfold inject_Z in |- *.
 simpl in |- *.
 red in |- *.
 simpl in |- *.
 rewrite H; trivial.
Qed.

Lemma nring_Q : forall n : nat, nring (R:=Q_as_CRing) n[=]inject_Z n.
Proof.
 intro n.
 induction  n as [| n Hrecn].
  change (Qmake 0%Z 1%positive==Qmake 0%Z 1%positive) in |- *.
  change ([0][=]([0]:Q_as_CRing)) in |- *.
  apply eq_reflexive_unfolded.
 change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (S n)) in |- *.
 Step_final ((inject_Z n:Q_as_CRing)[+][1]).
 astepl ((inject_Z n:Q_as_CRing)[+]inject_Z 1).
 simpl in |- *.
 red in |- *.
 unfold Qplus in |- *.
 simpl in |- *.
 rewrite Zpos_mult_morphism in |- *.
 rewrite succ_nat in |- *.
 ring.
Qed.

Lemma zring_Q : forall z, zring (R:=Q_as_CRing) z[=]inject_Z z.
Proof.
 destruct z; simpl; try reflexivity.
  rewrite -> pring_convert.
  rewrite -> nring_Q.
  now rewrite convert_is_POS.
 rewrite -> pring_convert.
 rewrite -> nring_Q.
 unfold Qeq. simpl.
 ring_simplify.
 rewrite min_convert_is_NEG.
 now rewrite Pmult_comm.
Qed.