(* $Id: Setoid_ex.v,v 1.2 1999/10/05 10:35:40 boulme Exp $ *)
Set Implicit Arguments.
Unset Strict Implicit.

Inductive Label : Set :=
  | T : Label
  | EQ : Label
  | EQ_refl : Label
  | NEQ : Label
  | NEQ_spec : Label
  | NEQ_nrefl : Label.


Lemma eqLabel_dec : forall x y : Label, {x = y} + {x <> y}.
  intros x y; case x; case y; auto; right; discriminate.
Defined.


Require Import Mixtels.
Require Import Tools.
Require Import Wellmixed.


Definition setoid_mix :=
  Amix T
    (f:=fun T : Type =>
        Csig EQ
          (fun EQ : T -> T -> Prop =>
           Csig EQ_refl
             (fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ NEQ x x => Esig Label))))))
    (fun T : Type =>
     Amix EQ
       (f:=fun EQ : T -> T -> Prop =>
           Csig EQ_refl
             (fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ NEQ x x => Esig Label)))))
       (fun EQ : T -> T -> Prop =>
        Amix EQ_refl
          (f:=fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ NEQ x x => Esig Label))))
          (fun EQ_refl : forall x : T, EQ x x =>
           Mmix NEQ
             (f:=fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ NEQ x x => Esig Label)))
             (fun NEQ : T -> T -> Prop =>
              Amix NEQ_spec
                (f:=fun _ : forall x y : T, NEQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ NEQ x x => Esig Label))
                (fun NEQ_spec : forall x y : T, NEQ x y -> ~ EQ x y =>
                 Mmix NEQ_nrefl
                   (f:=fun _ : forall x : T, ~ NEQ x x => Esig Label)
                   (fun _ : forall x : T, ~ NEQ x x => Emix Label)
                   (y:=fun (x : T) (H : NEQ x x) =>
                       NEQ_spec x x H (EQ_refl x)) 
                   (Emix Label))) (y:=fun x y : T => ~ EQ x y)
             (Mmix NEQ_spec
                (f:=fun _ : forall x y : T, ~ EQ x y -> ~ EQ x y =>
                    Csig NEQ_nrefl
                      (fun _ : forall x : T, ~ ~ EQ x x => Esig Label))
                (fun NEQ_spec : forall x y : T, ~ EQ x y -> ~ EQ x y =>
                 Mmix NEQ_nrefl
                   (f:=fun _ : forall x : T, ~ ~ EQ x x => Esig Label)
                   (fun _ : forall x : T, ~ ~ EQ x x => Emix Label)
                   (y:=fun (x : T) (H : ~ EQ x x) =>
                       NEQ_spec x x H (EQ_refl x)) 
                   (Emix Label)) (y:=fun (x y : T) (H : ~ EQ x y) => H)
                (Mmix NEQ_nrefl
                   (f:=fun _ : forall x : T, ~ ~ EQ x x => Esig Label)
                   (fun _ : forall x : T, ~ ~ EQ x x => Emix Label)
                   (y:=fun (x : T) (H : EQ x x -> False) => H (EQ_refl x))
                   (Emix Label)))))).


Definition toto := 0.

Ltac WellFormed :=
  unfold wellmixed in |- *; simpl in |- *; intros;
   repeat
    ((intros; simpl in |- *) || trivial) ||
      constructor 1 || refine (existT _ (refl_identity _) _).


Definition setoid_wp : wellpre (pre_of_mix setoid_mix).
  WellFormed.
Defined.


Definition setoid_wm : wellmixed setoid_wp setoid_mix.
  WellFormed.
Defined.


Definition setoid_sig := sig_of_mix setoid_mix.
Definition setoid := impltel setoid_sig.

Identity Coercion setoid2impltel : setoid >-> impltel.

Require Import Access.

Notation "i -@ f" := (fieldimpl eqLabel_dec f (s:=sig_of_impl i) i)  (at level 50, left associativity).

(***************************************)
(*** Exemple : Le setoide des Types ****)
Definition Type_setoid_base :=
  Mmix T
    (f:=fun T : Type =>
        Csig EQ
          (fun EQ : T -> T -> Prop =>
           Csig EQ_refl (fun _ : forall x : T, EQ x x => Esig Label)))
    (fun T : Type =>
     Amix EQ
       (f:=fun EQ : T -> T -> Prop =>
           Csig EQ_refl (fun _ : forall x : T, EQ x x => Esig Label))
       (fun EQ : T -> T -> Prop =>
        Amix EQ_refl (f:=fun _ : forall x : T, EQ x x => Esig Label)
          (fun _ : forall x : T, EQ x x => Emix Label))) (y:=Type)
    (Mmix EQ
       (f:=fun EQ : Type -> Type -> Prop =>
           Csig EQ_refl (fun _ : forall x : Type, EQ x x => Esig Label))
       (fun EQ : Type -> Type -> Prop =>
        Amix EQ_refl (f:=fun _ : forall x : Type, EQ x x => Esig Label)
          (fun _ : forall x : Type, EQ x x => Emix Label)) (y:=
       eq (A:=Type))
       (Mmix EQ_refl (f:=fun _ : forall x : Type, x = x :>Type => Esig Label)
          (fun _ : forall x : Type, x = x :>Type => Emix Label)
          (y:=refl_equal (A:=Type)) (Emix Label))).

Definition Type_setoid_base_wp : wellpre (pre_of_mix Type_setoid_base).
  WellFormed.
Defined.


Definition Type_setoid_base_wm :
  wellmixed Type_setoid_base_wp Type_setoid_base.
  WellFormed.
Defined.


Require Import Arith.

Definition Type_setoid_mix :=
  merge_mix setoid_mix
    (lift_mix (nfirst_subsig 3 setoid_sig) Type_setoid_base).

(*
Definition Type_setoid_mix_wp: (wellpre (pre_of_mix Type_setoid_mix)).
  WellFormed.
Defined.

Definition Type_setoid_mix_wm: (wellmixed Type_setoid_mix_wp Type_setoid_mix).
  WellFormed.
Defined.
*)

Definition Type_setoid : setoid :=
  new (p:=pre_of_mix Type_setoid_mix) I Type_setoid_mix.

Eval compute in (Type_setoid -@ NEQ).
Eval compute in (Type_setoid -@ NEQ_spec).
Eval compute in (Type_setoid -@ NEQ_nrefl).


(* Petit lemme de Benjamin *)
Definition Discr (X : Type) :=
  exists x : X, (exists y : X, (forall z : X, z = x \/ z = y)).

Lemma Discr_bool : Discr bool.
exists true; exists false; intros b; elim b; auto.
Qed.


Lemma Discr_nat : ~ Discr nat.
unfold not in |- *; simple destruct 1; intros x; simple destruct 1;
 intros y hy.
elim (hy 0); intros; elim (hy 1); intros; elim (hy 2); intros.
cut (0 = 1); try discriminate; eauto.
apply trans_eq with x; auto.
cut (0 = 1); try discriminate; apply trans_eq with x; auto.
cut (0 = 2); try discriminate; apply trans_eq with x; auto.
cut (1 = 2); try discriminate; apply trans_eq with y; auto.
cut (1 = 2); try discriminate; apply trans_eq with x; auto.
cut (0 = 2); try discriminate; apply trans_eq with y; auto.
cut (0 = 1); try discriminate; apply trans_eq with y; auto.
cut (0 = 1); try discriminate; apply trans_eq with y; auto.
Qed.

Lemma Benjamin :
 (Type_setoid -@ NEQ) nat bool.
  compute in |- *; intros H; apply Discr_nat.
  rewrite H; exact Discr_bool.
Qed.

(*****************************************)
(*** Exemple : Les setoides des Bools ****)
Require Import Bool.

Definition eqbP (b1 b2 : bool) := Is_true (eqb b1 b2).
Definition eqbP_refl (b : bool) :=
  if b as b0 return (eqbP b0 b0) then I else I.

Definition neqbP (b1 b2 : bool) := Is_true (negb (eqb b1 b2)).
Definition neqbP_spec : forall b1 b2 : bool, neqbP b1 b2 -> ~ eqbP b1 b2.
  intros b1 b2; case b1; case b2; simpl in |- *; auto.
Defined.

Definition Bool_setoid_base2 :=
  Mmix T
    (f:=fun T : Type =>
        Csig EQ
          (fun EQ : T -> T -> Prop =>
           Csig EQ_refl
             (fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y => Esig Label)))))
    (fun T : Type =>
     Amix EQ
       (f:=fun EQ : T -> T -> Prop =>
           Csig EQ_refl
             (fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y => Esig Label))))
       (fun EQ : T -> T -> Prop =>
        Amix EQ_refl
          (f:=fun _ : forall x : T, EQ x x =>
              Csig NEQ
                (fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y => Esig Label)))
          (fun EQ_refl : forall x : T, EQ x x =>
           Amix NEQ
             (f:=fun NEQ : T -> T -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : T, NEQ x y -> ~ EQ x y => Esig Label))
             (fun NEQ : T -> T -> Prop =>
              Amix NEQ_spec
                (f:=fun _ : forall x y : T, NEQ x y -> ~ EQ x y => Esig Label)
                (fun NEQ_spec : forall x y : T, NEQ x y -> ~ EQ x y =>
                 Emix Label))))) (y:=bool)
    (Mmix EQ
       (f:=fun EQ : bool -> bool -> Prop =>
           Csig EQ_refl
             (fun _ : forall x : bool, EQ x x =>
              Csig NEQ
                (fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ EQ x y =>
                    Esig Label))))
       (fun EQ : bool -> bool -> Prop =>
        Amix EQ_refl
          (f:=fun _ : forall x : bool, EQ x x =>
              Csig NEQ
                (fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ EQ x y =>
                    Esig Label)))
          (fun EQ_refl : forall x : bool, EQ x x =>
           Amix NEQ
             (f:=fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ EQ x y =>
                    Esig Label))
             (fun NEQ : bool -> bool -> Prop =>
              Amix NEQ_spec
                (f:=fun _ : forall x y : bool, NEQ x y -> ~ EQ x y =>
                    Esig Label)
                (fun _ : forall x y : bool, NEQ x y -> ~ EQ x y => Emix Label))))
       (y:=eqbP)
       (Mmix EQ_refl
          (f:=fun _ : forall x : bool, eqbP x x =>
              Csig NEQ
                (fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                    Esig Label)))
          (fun _ : forall x : bool, eqbP x x =>
           Amix NEQ
             (f:=fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                    Esig Label))
             (fun NEQ : bool -> bool -> Prop =>
              Amix NEQ_spec
                (f:=fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                    Esig Label)
                (fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                 Emix Label))) (y:=eqbP_refl)
          (Mmix NEQ
             (f:=fun NEQ : bool -> bool -> Prop =>
                 Csig NEQ_spec
                   (fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                    Esig Label))
             (fun NEQ : bool -> bool -> Prop =>
              Amix NEQ_spec
                (f:=fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                    Esig Label)
                (fun _ : forall x y : bool, NEQ x y -> ~ eqbP x y =>
                 Emix Label)) (y:=neqbP)
             (Mmix NEQ_spec
                (f:=fun _ : forall x y : bool, neqbP x y -> ~ eqbP x y =>
                    Esig Label)
                (fun _ : forall x y : bool, neqbP x y -> ~ eqbP x y =>
                 Emix Label) (y:=neqbP_spec) (Emix Label))))).

 
Definition Bool_setoid_base2_wp : wellpre (pre_of_mix Bool_setoid_base2).
  WellFormed.
Defined.


Definition Bool_setoid_base2_wm :
  wellmixed Bool_setoid_base2_wp Bool_setoid_base2.
  WellFormed.
Defined.


Definition Bool_setoid1_mix :=
  merge_mix setoid_mix
    (lift_mix (nfirst_subsig 5 setoid_sig) Bool_setoid_base2).

(*
Definition Bool_setoid1_mix_wp: (wellpre (pre_of_mix Bool_setoid1_mix)).
  WellFormed.
Defined.

Definition Bool_setoid1_mix_wm: (wellmixed Bool_setoid1_mix_wp Bool_setoid1_mix).
  WellFormed.
Defined.
*)
 
Definition Bool_setoid1 : setoid :=
  new (p:=pre_of_mix Bool_setoid1_mix) I Bool_setoid1_mix.


Definition Bool_setoid2_mix :=
  merge_mix (lift_mix (nfirst_subsig 5 setoid_sig) Bool_setoid_base2)
    setoid_mix.

(*
Definition Bool_setoid2_mix_wp: (wellpre (pre_of_mix Bool_setoid2_mix)).
  WellFormed.
Defined.


Definition Bool_setoid2_mix_wm: (wellmixed Bool_setoid2_mix_wp Bool_setoid2_mix).
  WellFormed.
Defined.
*)

Definition Bool_setoid2 : setoid :=
  new (p:=pre_of_mix Bool_setoid2_mix) I Bool_setoid2_mix.

Eval compute in (Bool_setoid1 -@ NEQ).
Eval compute in (Bool_setoid2 -@ NEQ).
Eval compute in (Bool_setoid1 -@ NEQ_spec).
Eval compute in (Bool_setoid2 -@ NEQ_spec).
Eval compute in (Bool_setoid1 -@ NEQ_nrefl).
Eval compute in (Bool_setoid2 -@ NEQ_nrefl).

(* Une preuve en n'utilisant que l'information de type *)
Lemma trivial1 :
 forall b : bool,
 (Bool_setoid1 -@ NEQ) true b ->
 ~ (Bool_setoid1 -@ NEQ) false b.
  intros b; case b.
    unfold not in |- *; intros H1 H2;
     exact
       ((Bool_setoid1 -@ NEQ_spec) true true H1 
             ((Bool_setoid1 -@ EQ_refl) true)).
    intros; exact ((Bool_setoid1 -@ NEQ_nrefl) false). 
Qed.






