(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                     Rohit Chadha <chadhar@missouri.edu>              *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

Load "definitions1".

(** This library defines indistinguishability and all morphisms *)

(*Indistinguishability Relation ~*)
(*Definition Ind_Relation := forall n , mylist n -> mylist n -> Prop.*)

(** Indistinguishability relation [EQI]:
[[

forall n, relation (mylist n).
]]

 *)
Parameter EQI : forall {n }, relation (mylist n).

Notation "ml1 '~' ml2" := (EQI  ml1 ml2) (at level 0, right associativity).

Axiom EQI_equiv: forall n, equiv (mylist n) (@EQI n).

Instance EQI_Equiv :forall n, Equivalence  (@EQI n).
Proof.
split;
repeat apply EQI_equiv.
Qed.

Theorem EQI_ref: forall {n:nat} (ml: mylist n), ml ~ ml.
Proof.
intros m.
apply EQI_equiv.
Qed.

Theorem EQI_sym: forall {n:nat} (ml1 ml2 : mylist n), ml1 ~ ml2 -> ml2 ~ ml1 .
Proof.
intros.
apply EQI_equiv.
assumption.
Qed.

Theorem EQI_trans : forall {n:nat} (ml1 ml2 ml3: mylist n), ml1 ~ ml2 -> ml2 ~ ml3 -> ml1 ~ ml3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

Add Parametric Relation n : (mylist n) (@EQI n)
reflexivity proved by (EQI_ref)
symmetry proved by (EQI_sym)
transitivity proved by (EQI_trans)
as EQI_rel.

(** Equivalence relation [EQm] defined on [message] type.  *)

Definition EQm : relation message := fun (m1:message)  (m2: message) =>  [bol (EQ_M m1 m2)] ~ [ bol TRue].

Notation "ml1 '#' ml2" := (EQm ml1 ml2) (at level 5).

Axiom EQm_equiv: equiv message EQm.

Instance EQm_Equiv : Equivalence  EQm.
Proof.
split;
repeat apply EQm_equiv.
Qed.

Theorem EQm_ref: forall m:message, m # m.
Proof.
intros m.
apply EQm_equiv.
reflexivity.
Qed.

Theorem EQm_sym: forall m1 m2: message, m1 # m2 -> m2 # m1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQm_trans : forall m1 m2 m3 : message, m1 # m2 -> m2 # m3 -> m1 # m3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQb] defined on [Bool] type.  *)

Definition EQb : relation Bool := fun (b1:Bool)  (b2: Bool) =>  [bol (EQ_B b1 b2)] ~ [ bol TRue].
Notation "b1 '##' b2" := (EQb b1 b2) (at level 5).

Axiom BolEQ: equiv Bool EQb.

Instance Bol_Equ_Equiv : Equivalence  EQb.
Proof.
split;
repeat apply BolEQ.
Qed.

Theorem EQb_sym: forall b1 b2:Bool, b1 ## b2 -> b2 ## b1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQb_ref: forall b:Bool, b ## b.
Proof.
intros.
reflexivity.
Qed.

Theorem EQb_trans : forall b1 b2 b3 : Bool, b1 ## b2 -> b2 ## b3 -> b1 ## b3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQos] on [oursum] type. *)

Inductive EQos :  relation oursum :=
|  eqm: forall (m1 m2: message), m1 # m2 ->  EQos (msg m1) (msg m2)
|  eqb: forall (b1 b2: Bool), b1 ## b2 ->  EQos (bol b1) (bol b2).

Notation "ml1 '###' ml2" := (EQos ml1 ml2) (at level 5).

Instance os_Equ_Equiv : Equivalence  EQos.
Proof.
split.
unfold Reflexive;
intros;
destruct x;
try apply eqm; try apply eqb;
reflexivity.
unfold Symmetric; intros; destruct H;
    try apply eqm; try apply eqb; symmetry; assumption.
unfold Transitive; intros.
  inversion H; subst;
  inversion H0; subst;
  try apply  eqm; try apply eqb;
  rewrite H1;
  apply H3.

Qed.

Theorem EQos_sym: forall b1 b2: oursum, b1 ### b2 -> b2 ### b1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQos_ref: forall b:oursum, b ### b.
Proof.
intros.
reflexivity.
Qed.

Theorem EQos_trans : forall b1 b2 b3 : oursum, b1 ### b2 -> b2 ### b3 -> b1 ### b3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQosl] is defined on [mylist n] for a natural number [n]. *)

Inductive EQosl: forall {n:nat}, relation (mylist n) :=
| eqnos :  EQosl  (Nil _) (Nil _)
| eqconos: forall (m:nat)(os1 os2:oursum)(l1 l2: mylist m), os1 ### os2 -> (EQosl  l1  l2) -> EQosl (os1 :: l1) (os2::l2).

Notation "ml1 '####' ml2" := (EQosl ml1 ml2) (at level 0).

Axiom eqlistos_ind: forall (n:nat) (l1 l2: mylist n), l1 #### l2 ->  l1 ~ l2.

Instance osl_Equ_Equiv {n}: Equivalence  (@EQosl n).
Proof.
split.
  unfold Reflexive.
  induction x.
   apply eqnos.
   apply eqconos. reflexivity. apply IHx.
 unfold Symmetric.
intros  x y H.
induction H.
apply eqnos.
apply eqconos.
rewrite H. reflexivity. apply IHEQosl.
unfold Transitive.
 intros x y z H1 H2.
 induction H1. assumption.
  + dependent destruction z.
     - apply eqconos;    inversion H2; subst. rewrite H. apply H6.
        dependent destruction H2. apply   IHEQosl . assumption.
Qed.

(** Equivalence relation [EQlm] defined on [list message] type. *)

Inductive EQlm:  relation (list message) :=
| eqnm :  EQlm nil nil
| eqconm: forall (m1 m2 : message)(l1 l2: list message),  m1 # m2 -> (EQlm  l1  l2) -> EQlm (cons m1 l1) (cons m2 l2).
Notation "ml1 '#@' ml2" := (EQlm ml1 ml2) (at level 0).
Axiom eqlistm_ind: forall  (l1 l2:  list message ), l1 #@ l2 ->  (f l1) # (f l2).
Instance EQlm_Equ_Equiv : Equivalence  (EQlm).
Proof.
split.
  unfold Reflexive.
  induction x.
   apply eqnm.
   apply eqconm. reflexivity. apply IHx.
 unfold Symmetric.
intros  x y H.
induction H.
apply eqnm.
apply eqconm.
rewrite H. reflexivity. apply IHEQlm.
unfold Transitive.
 intros x y z H1 H2.
 induction H1. assumption.
  Admitted.

Axiom EQlm_equiv:  equiv (list message) (EQlm).

Instance lm_Eqlm_Equiv : Equivalence  (EQlm ).
Proof.
split;
repeat apply EQlm_equiv.
Qed.

(** * Morhphisms *)

Axiom eq_msg_mylist_cong :  forall  (n n1 :nat) (m1 m2: message) (l1 l2: mylist n), m1 # m2 -> l1 #### l2 ->  (submsg_mylist n1 m1 l1) ~ (submsg_mylist n1 m2 l2).

Add Parametric Morphism{n}: (@ submsg_mylist n ) with
  signature eq ==> EQm ==> EQosl ==> EQI as submsg_mor.
 Proof.   intros. apply eq_msg_mylist_cong; assumption. Qed.

Axiom f_cong_l : forall (l1 l2: list message) (m1 m2:message), m1 # m2 -> l1 #@ l2   -> (cons m1 l1 ) #@ (cons m2 l2).
Add Parametric Morphism : cons  with
  signature EQm ==> EQlm ==> EQlm as cons_m.
 Proof.    intros. apply f_cong_l. assumption.  assumption. Qed.

Add Parametric Morphism : f  with
  signature EQlm ==> EQm as f_m.
 Proof.    intros. apply eqlistm_ind. assumption.   Qed.

(**split.
  unfold Reflexive.
  induction x.
   apply EQNm.

   apply EQCONSm. reflexivity. apply IHx.

 unfold Symmetric.

intros  x y H.

induction H.
apply EQNm.
apply EQCONSm.
rewrite H. reflexivity. apply IHEQlm.

unfold Transitive.
 intros x y z H1 H2.
 induction H1.
   +  apply H2.
  + dependent destruction z.
     - rewrite <- H2. apply EQCONSm;    inversion H2; subst. rewrite H. apply H6.
        dependent destruction H2. apply   IHEQosl . assumption.
Qed.

Qed.*)

(** * [message] *)

(** [exp_mor] *)
Axiom exp_cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (exp m1 m2 m3) # (exp m1' m2' m3').
Add Parametric Morphism: (@ exp) with
  signature EQm ==> EQm ==> EQm ==> EQm as exp_mor.
 Proof.   intros. apply exp_cong; assumption. Qed.

(** [pair_mor] *)

Axiom pair_cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (pair m1 m2) # (pair m1' m2').
Add Parametric Morphism: (@ pair) with
  signature EQm ==> EQm ==> EQm as pair_mor.
 Proof.   intros. apply pair_cong; assumption. Qed.

(** [pi1_mor] *)

Axiom pi1_cong: forall (m1 m1' : message), m1 # m1' -> (pi1 m1) # (pi1 m1' ).
Add Parametric Morphism: (@ pi1) with
  signature EQm ==> EQm as pi1_mor.
 Proof.   intros. apply pi1_cong; assumption. Qed.

(** [pi2_mor] *)

Axiom pi2_cong: forall (m1 m1' : message), m1 # m1' -> (pi2 m1) # (pi2 m1' ).
Add Parametric Morphism: (@ pi2) with
  signature EQm ==> EQm as pi2_mor.
 Proof.   intros. apply pi2_cong; assumption. Qed.

(** [ggen_mor] *)

Axiom ggen_cong: forall (m1 m1' : message), m1 # m1' -> (ggen m1) # (ggen m1' ).
Add Parametric Morphism: (@ ggen) with
  signature EQm ==> EQm as ggen_mor.
 Proof.   intros. apply ggen_cong; assumption. Qed.

(** [r_mor] *)

Axiom r_cong: forall (m1 m1' : nat), m1 = m1' -> (r m1) # (r m1' ).
Add Parametric Morphism: (@ r) with
  signature eq ==> EQm as r_mor.
Proof. intros. apply r_cong. reflexivity. Qed.

(** [rs_mor] *)

Axiom rs_cong: forall (m1 m1' : message), m1 # m1' -> (rs m1) # (rs m1' ).
Add Parametric Morphism: (@ rs) with
  signature EQm ==> EQm as rs_mor.
 Proof.   intros. apply rs_cong; assumption. Qed.

(** [act_mor] *)

Axiom act_cong: forall (m1 m1' : message), m1 # m1' -> (act m1) # (act m1' ).
Add Parametric Morphism: (@ act) with
  signature EQm ==> EQm as act_mor.
 Proof.   intros. apply act_cong; assumption. Qed.

(** [m_mor] *)

Axiom m_cong: forall (m1 m1' : message), m1 # m1' -> (m m1) # (m m1' ).
Add Parametric Morphism: (@ m) with
  signature EQm ==> EQm as m_mor.
 Proof.   intros. apply m_cong; assumption. Qed.

(** [nonce_mor] *)

Axiom nonce_cong: forall (m1 m1' : message), m1 # m1' -> (nc m1) # (nc m1' ).
Add Parametric Morphism: (@ nc) with
  signature EQm ==> EQm as nonce_mor.
Proof. intros. apply nonce_cong. assumption.  Qed.

(** [to_mor] *)

Axiom to_cong: forall (m1 m1' : message), m1 # m1' -> (to m1) # (to m1' ).
Add Parametric Morphism: (@ to) with
  signature EQm ==> EQm as to_mor.
 Proof.   intros. apply to_cong; assumption. Qed.

 (** [reveal_mor] *)

Axiom reveal_cong: forall (m1 m1' : message), m1 # m1' -> (reveal m1) # (reveal m1' ).
Add Parametric Morphism: (@ reveal) with
  signature EQm ==> EQm as reveal_mor.
 Proof.   intros. apply reveal_cong; assumption. Qed.
(*
(******************reveal signature**********************)
Axiom revsign_cong: forall (m1 m1' : nat), m1 = m1' -> (revsign m1) ## (revsign m1' ).
Add Parametric Morphism: (@ revsign) with
  signature eq ==> EQb as revsign_mor.
 Proof.   intros. apply revsign_cong. reflexivity. Qed.
*)
 (** [sign_mor] *)

Axiom sign_cong: forall (m1 m1' m2 m2' : message), m1 # m1' -> m2 # m2' -> (sign m1 m2) # (sign m1' m2' ).
Add Parametric Morphism: (@sign) with
  signature EQm ==> EQm ==> EQm as sign_mor.
Proof.   intros. apply sign_cong; assumption. Qed.

Axiom bsign_cong: forall (m1 m1' m2 m2' : message), m1 # m1' -> m2 # m2' -> (bsign m1 m2) # (bsign m1' m2' ).
Add Parametric Morphism: (@bsign) with
  signature EQm ==> EQm ==> EQm as bsign_mor.
Proof.   intros. apply bsign_cong; assumption. Qed.

 (** [enc_mor] *)

Axiom enc_cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3'  -> (enc m1 m2 m3) # (enc m1' m2' m3').
Add Parametric Morphism: (@ enc) with
  signature EQm ==> EQm ==> EQm ==> EQm as enc_mor.
Proof.   intros. apply enc_cong; assumption. Qed.

(** [L_mor] *)

Axiom L_cong: forall (m1  m1'  : message), m1 # m1'  -> (L m1) # (L m1').
Add Parametric Morphism: (@ L) with
  signature EQm ==> EQm as L_mor.
 Proof.   intros. apply L_cong; assumption. Qed.

 (** [dec_mor] *)

Axiom dec_cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (dec m1 m2) # (dec m1' m2').
Add Parametric Morphism: (@ dec) with
  signature EQm ==> EQm ==> EQm as dec_mor.
 Proof.   intros. apply dec_cong; assumption. Qed.

(** [k_mor] *)

Axiom k_cong: forall (m1 m1' : message), m1 # m1' -> (k m1) # (k m1' ).
Add Parametric Morphism: (@ k) with
  signature EQm ==> EQm as k_mor.
 Proof.   intros. apply k_cong; assumption. Qed.

(** [pk_mor] *)

Axiom pk_cong: forall (m1 m1' : message), m1 # m1' -> (pk m1) # (pk m1' ).
Add Parametric Morphism: (@ pk) with
  signature EQm ==> EQm as pk_mor.
 Proof.   intros. apply pk_cong. assumption. Qed.

(** [sk_mor] *)

Axiom sk_cong: forall (m1 m1' : message), m1 # m1' -> (sk m1) # (sk m1' ).
Add Parametric Morphism: (@ sk) with
  signature EQm ==> EQm as sk_mor.
 Proof.   intros. apply sk_cong. assumption. Qed.

 (** [f_mor] *)

Axiom f_cong: forall (l1 l1' : list message), ( l1) #@ ( l1') -> (f  l1) # (f  l1' ).
Add Parametric Morphism : ( f ) with
  signature EQlm ==> EQm as f_mor.
Proof.   intros. apply f_cong. assumption. Qed.

(** foo function symbols *)
(** [comit_mor] *)

Axiom commit_cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3'  -> (commit m1 m2 m3) # (commit m1' m2' m3').
Add Parametric Morphism: (@ commit) with
    signature EQm ==> EQm ==> EQm ==> EQm as comit_mor.
Proof.   intros. apply commit_cong; assumption. Qed.

(** [opne_mor] *)

Axiom open_cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3'  -> (open m1 m2 m3) # (open m1' m2' m3').
Add Parametric Morphism: (@ open) with
  signature EQm ==> EQm ==> EQm ==> EQm as open_mor.
Proof.   intros. apply open_cong; assumption. Qed.

(** [blind_mor] *)

Axiom blind_cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (blind m1 m2) # (blind m1' m2').
Add Parametric Morphism: (@ blind) with
  signature EQm ==> EQm ==> EQm as blind_mor.
Proof.   intros. apply blind_cong; assumption. Qed.

(** [ublind_mor] *)

Axiom unblind_cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (unblind m1 m2) # (unblind m1' m2').
Add Parametric Morphism: (@ unblind) with
  signature EQm ==> EQm ==> EQm as ublind_mor.
 Proof.   intros. apply unblind_cong; assumption. Qed.

(** [v_mor] vote *)

Axiom v_cong: forall (m1 m1' : message), m1 # m1' -> (v m1) # (v m1' ).
Add Parametric Morphism: (@ v) with
  signature EQm ==> EQm as v_mor.
Proof. intros. apply v_cong. assumption. Qed.
(** [V_mor] Voter *)

Axiom V_cong: forall (n n' : nat), n =  n' -> (V n) # (V n' ).
Add Parametric Morphism: (@ V) with
  signature eq ==> EQm as V_mor.
Proof. intros. apply V_cong. reflexivity. Qed.

(** * [Bool] *)

(** [ifb_mor] *)

Axiom IFB_cong: forall (b1 b2 b3 b1' b2' b3': Bool), b1 ## b1' -> b2 ## b2' -> b3 ## b3' -> (if_then_else_B b1 b2 b3) ## (if_then_else_B b1' b2' b3').
Add Parametric Morphism: (@if_then_else_B) with
  signature EQb ==> EQb ==> EQb ==> EQb as ifb_mor.
 Proof.   intros. apply IFB_cong; assumption. Qed.

(** [ifm_mor] *)

 Axiom IFM_cong: forall (b b' : Bool) ( m1 m2 m1' m2': message), (b ## b') -> m1 # m1' -> m2 # m2' -> (if_then_else_M b m1 m2) # (if_then_else_M b' m1' m2').
Add Parametric Morphism: (@if_then_else_M) with
  signature EQb ==> EQm ==> EQm ==> EQm as ifm_mor.
 Proof.   intros. apply IFM_cong; assumption. Qed.

 (** [EQ_B_mor] *)

Axiom EQ_B_cong: forall (b1 b2 b1' b2': Bool),  b1 ## b1' -> b2 ## b2' ->  (EQ_B b1 b2) ## (EQ_B b1' b2').
Add Parametric Morphism: (@EQ_B) with
signature EQb ==> EQb ==> EQb as EQ_B_mor.
Proof.   intros. apply EQ_B_cong; assumption. Qed.

(** [EQ_M_mor] *)

Axiom EQ_M_cong: forall (m1 m2 m1' m2' : message), m1 # m1' -> m2 # m2' -> (EQ_M m1 m2) ## (EQ_M m1' m2').

Add Parametric Morphism: (@EQ_M) with
  signature EQm ==> EQm ==> EQb as EQ_M_mor.
 Proof.   intros. apply EQ_M_cong; assumption. Qed.

(** [EQ_L_mor] *)
Axiom EQL_cong : forall (m1 m2 m1' m2' : message), m1 # m1' -> m2 # m2' -> (EQL m1 m2 ) ## (EQL m1' m2').
Add Parametric Morphism: (@EQL) with
  signature EQm ==> EQm ==> EQb as EQL_mor.
Proof.   intros. apply EQL_cong; assumption. Qed.

(** [ver_mor] *)

Axiom ver_cong : forall (m1 m2  m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (ver m1 m2 m3 ) ## (ver m1' m2' m3').
Add Parametric Morphism: (@ver) with
  signature EQm ==> EQm ==> EQm ==> EQb as ver_mor.
Proof.   intros. apply ver_cong; assumption. Qed.

(** [bver_mor] *)

Axiom bver_cong : forall (m1 m2  m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (bver m1 m2 m3 ) ## (bver m1' m2' m3').
Add Parametric Morphism: (@bver) with
  signature EQm ==> EQm ==> EQm ==> EQb as bver_mor.
Proof.   intros. apply bver_cong; assumption. Qed.
(** [bacc_mor] *)

Axiom bacc_cong : forall (m1 m2  m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (bacc m1 m2 m3 ) ## (bacc m1' m2' m3').
Add Parametric Morphism: (@bacc) with
  signature EQm ==> EQm ==> EQm ==> EQb as bacc_mor.
Proof.   intros. apply bacc_cong; assumption. Qed.

(** * Morphisms on substitution functions *)

(** [substbl_bl_mor] *)

Axiom substbl_bl_cong : forall (b1 b2 b1' b2' : Bool) (n: nat), b1 ## b1' -> b2 ## b2' -> (subbol_bol n b1 b2) ## (subbol_bol n b1' b2').

Add Parametric Morphism : (@subbol_bol) with
signature eq ==> EQb ==> EQb ==> EQb as substbl_bl_mor.
Proof. intros.  apply substbl_bl_cong. apply H. apply H0.
Qed.

(** [substbl_msg_mor] *)

Axiom substbl_msg_cong : forall (b1 b1' : Bool)(m2 m2' : message) (n: nat), b1 ## b1' -> m2 # m2' -> (subbol_msg n b1 m2) # (subbol_msg n b1' m2').

Add Parametric Morphism : (@subbol_msg) with
signature eq ==> EQb ==> EQm ==> EQm as substbl_msg_mor.
Proof. intros.  apply substbl_msg_cong. apply H. apply H0.
Qed.

(** [substmsg_Bool_mor] *)

Axiom substmsg_Bool_cong : forall (m1 m1' : message) (b1 b1' : Bool) (n: nat), m1 # m1' -> b1 ## b1' -> (submsg_bol n m1 b1) ## (submsg_bol n m1' b1').

Add Parametric Morphism : (@submsg_bol) with
signature eq ==> EQm ==> EQb ==> EQb as substmsg_Bool_mor.
Proof. intros.  apply substmsg_Bool_cong. apply H. apply H0.
Qed.

(** [substmsg_msg_mor] *)

Axiom substmsg_msg_cong : forall (m1 m2 m1' m2' : message) (n: nat), m1 # m1' -> m2 # m2' -> (submsg_msg n m1 m2) # (submsg_msg n m1' m2').

Add Parametric Morphism : (@submsg_msg) with
signature eq ==> EQm ==> EQm ==> EQm as substmsg_msg_mor.
Proof. intros.  apply substmsg_msg_cong. apply H. apply H0.
Qed.

(** [subbol_msg'_mor] *)

Axiom clos_subbol_cong : forall ( b1 b2 b3 b4: Bool) (t1 t2:message), b1 ## b2 -> b3 ## b4 -> t1 # t2 -> (subbol_msg' b1 b3 t1) # (subbol_msg' b2 b4 t2).

Add Parametric Morphism : subbol_msg'  with
  signature EQb ==> EQb ==> EQm ==> EQm as subbol_msg'_mor.
 Proof.   intros. apply clos_subbol_cong; try assumption. Qed.

(** * [oursum] *)
(** [msg_mor] *)

Axiom msg_cong: forall (m1 m1'  : message), m1 # m1'  -> (msg m1 ) ### (msg m1').

Add Parametric Morphism : (@msg ) with
signature EQm ==> EQos as msg_mor.
Proof. intros. apply eqm. apply H. Qed.

(** [bol_mor] *)

Axiom bol_cong: forall (b1 b1'  : Bool), b1 ## b1'  -> (bol b1 ) ### (bol b1').

Add Parametric Morphism : (@bol ) with
signature EQb ==> EQos as bol_mor.
Proof.  intros. apply eqb. apply H. Qed.

(** [Cons_mor] *)

Add Parametric Morphism {n}: (Cons oursum n) with
signature EQos ==> EQosl ==> EQosl  as Cons_mor.
Proof. intros. apply eqconos. apply H. apply H0. Qed.

(** [app_EQml_mor] *)

Axiom app_EQml_cong : forall (n1 n2:nat)(l1 l1'  : mylist n1) (l2 l2': mylist n2), l1 #### l1' -> l2 ####l2' -> (l1 ++ l2) #### (l1' ++ l2').

Add Parametric Morphism {n1} {n2}: (@app_mylist n1 n2 ) with
signature  EQosl ==> EQosl ==> EQosl  as app_EQml_mor.
Proof. intros. apply app_EQml_cong. apply H. apply H0. Qed.

(** [ml_EQI_mor] *)

Axiom ml_EQI_cong: forall (n : nat) (l1 l2 : mylist n) (os1 os2 : oursum), os1 ### os2 -> l1 ####l2 -> (Cons oursum n os1 l1 ) ~ (Cons  oursum n os2 l2) .

Add Parametric Morphism {n}: (Cons oursum n) with
signature EQos ==> EQosl ==> EQI  as ml_EQI_mor.

Proof. intros. apply ml_EQI_cong with (os1:=x) (os2:=y) (l1:= x0) (l2:= y0). apply H. apply H0. Qed.

(** [app_EQI_mor] *)

Axiom app_EQI_cong : forall (n1 n2:nat)(l1 l1'  : mylist n1) (l2 l2': mylist n2), l1 #### l1' -> l2 ####l2' -> (l1 ++ l2) ~ (l1' ++ l2').

Add Parametric Morphism {n1} {n2}: (@app_mylist n1 n2 ) with
signature  EQosl ==> EQosl ==> EQI  as app_EQI_mor.
Proof. intros. apply app_EQI_cong. apply H. apply H0. Qed.

(** Equivalence relation [EQml] on [ilist message n] for given [n]. *)

Definition EQml {n:nat} (l1 l1': ilist message n) :=  (EQosl (conv_mlist_mylist l1) (conv_mlist_mylist l1')).

Notation "ml1 '==' ml2" := (EQml ml1 ml2) (at level 0).

Theorem eqlistm_ind': forall (n:nat) (l1 l2: ilist message n), (l1 == l2) ->  (conv_mlist_mylist l1) ~ (conv_mlist_mylist l2).
Proof. intros. apply eqlistos_ind. apply H. Qed.

Instance ml_Equ_Equiv {n}: Equivalence  (@EQml n).
Proof.
split.
unfold EQml.
unfold Reflexive. reflexivity.
unfold EQml. unfold Symmetric. intros. rewrite H. reflexivity.
unfold EQml. unfold Transitive. intros. rewrite H, H0. reflexivity.
Qed.

(** andB_mor *)

Axiom andB_cong: forall (b1 b2 b1' b2' : Bool), b1 ## b1' -> b2 ## b2' -> (b1 & b2) ## (b1' & b2').

Add Parametric Morphism:(@ andB) with
signature EQb ==> EQb ==> EQb as andB_mor.
Proof. intros. apply andB_cong;assumption. Qed.

(** notb_mor *)

Axiom notb_cong : forall (b1 b1' : Bool), b1 ## b1' -> (notb b1) ## (notb b1').

Add Parametric Morphism: (@ notb) with
signature EQb ==> EQb as notb_mor.
Proof.
intros.
apply notb_cong.
assumption. Qed.

(** Equality of [Bool] terms using indistinguishability. *)

Definition EQI_bol (b1 b2: Bool) := [ bol (EQ_B b1 b2)] ~ [bol TRue].

Notation "b1 ## b2" := (EQI_bol b1 b2)(at level 5).

(** Equality of [message] terms using indistinguishability. *)

Definition EQI_msg (x y : message) :=  [ bol (EQ_M x y)] ~ [ bol TRue] .

Notation "m1 # m2" := (EQI_msg m1 m2)(at level 5).

(** Attacker starts new session. *)

Definition Att_new_session:= forall x:message,  (EQ_M (act x) new)  ## TRue .


Require Import FO_BiInt_Syntax.
Require Import List.
Export ListNotations.

Require Import existsT.
Require Import PeanoNat.
Require Import Lia.

Section Remove.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

Lemma In_dec : forall l (a : form) , (In a l) + ((In a l) -> False).
Proof.
induction l.
- right. intro. destruct H.
- intro a0. pose (IHl a0). destruct s.
  * left. apply in_cons. assumption.
  * destruct (eq_dec_form a a0).
    + subst. left. apply in_eq.
    + right. intro. inversion H.
      { apply n. assumption. }
      { apply f. assumption. }
Qed.

(* Let us prove some lemmas about remove. *)

Lemma in_not_touched_remove : forall l1 a0 a1,
        In a0 l1 -> a0 <> a1 -> In a0 (remove eq_dec_form a1 l1).
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form a1 a).
  * subst. apply IHl1. inversion H. exfalso. apply H0. auto. assumption. assumption.
  * inversion H. subst. apply in_eq. apply in_cons. apply IHl1. assumption. assumption.
Qed.

Lemma remove_dist_app {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
        forall (a : A) l1 l2, (@remove A eq_dec a (l1 ++ l2)) =
                              (@remove A eq_dec a l1) ++ (@remove A eq_dec a l2).
Proof.
intros a l1. induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec a a0).
  * apply IHl1.
  * simpl. rewrite IHl1. reflexivity.
Qed.

Lemma remove_not_in_anymore : forall l A,
          (In A (remove eq_dec_form A l)) -> False.
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. simpl in H. destruct (eq_dec_form A a). subst. apply IHl in H. assumption.
  inversion H. apply n. symmetry. assumption. apply IHl in H0. assumption.
Qed.

Lemma in_remove_in_init : forall l A B,
    In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l.
- intros. simpl. inversion H.
- intros. destruct (eq_dec_form A a). subst. apply in_eq. apply in_cons.
  pose (IHl A B). apply i. simpl in H. destruct (eq_dec_form B a).
  * subst. assumption.
  * inversion H. exfalso. apply n. symmetry. assumption. assumption.
Qed.

Lemma remove_preserv_NoDup : forall l A, NoDup l -> NoDup (remove eq_dec_form A l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply IHl. inversion H. assumption.
  * apply NoDup_cons. intro. apply in_remove_in_init in H0. inversion H. apply H3. assumption.
    apply IHl. inversion H. assumption.
Qed.

Lemma NoDup_destr_split : forall l1 l2 (A : form), NoDup (l1 ++ A :: l2) -> NoDup (l1 ++ l2).
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_l in H. inversion H. assumption.
- intros. simpl. apply NoDup_cons. intro. inversion H. subst. apply H3. apply in_app_or in H0.
  destruct H0. apply in_or_app. left. assumption. apply in_or_app. right. apply in_cons.
  assumption. simpl in H. inversion H. subst. apply IHl1 with (A:=A). assumption.
Qed.

Lemma remove_le_length : forall l A, length (remove eq_dec_form A l) <= length l.
Proof.
induction l.
- intros. simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply le_S. apply IHl.
  * simpl. apply le_n_S. apply IHl.
Qed.

Lemma remove_In_smaller_length : forall l A,
                                 In A l -> length (remove eq_dec_form A l) < length l.
Proof.
induction l.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. unfold lt. apply le_n_S. apply remove_le_length.
  * simpl. apply Lt.lt_n_S. apply IHl. inversion H. subst. exfalso. apply n. auto.
    assumption.
Qed.

Lemma double_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a l, (@remove A eq_dec a (@remove A eq_dec a l)) = (@remove A eq_dec a l).
Proof.
intros a l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a a0).
  * subst. apply IHl.
  * simpl. destruct (eq_dec a a0).
    + exfalso. apply n. assumption.
    + rewrite IHl. reflexivity.
Qed.

Lemma permut_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a0 a1 l, (@remove A eq_dec a0 (@remove A eq_dec a1 l)) =
                      (@remove A eq_dec a1 (@remove A eq_dec a0 l)).
Proof.
intros a0 a1 l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a1 a).
  * subst. simpl. destruct (eq_dec a0 a).
    + subst. reflexivity.
    + simpl. destruct (eq_dec a a). apply IHl. exfalso. apply n0. reflexivity.
  * simpl. destruct (eq_dec a0 a).
    + subst. assumption.
    + simpl. destruct (eq_dec a1 a). exfalso. apply n. assumption.
      rewrite IHl. reflexivity.
Qed.

Lemma In_remove_diff : forall l A B, In A (remove eq_dec_form B l) -> A <> B.
Proof.
induction l ; intros.
- intro. simpl in H. assumption.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply IHl. assumption.
  * inversion H.
    + subst. intro. apply n. symmetry. assumption.
    + apply IHl. assumption.
Qed.

(* Now we define remove_list and prove some lemmas about it. *)

Fixpoint remove_list (l1 l2: list form) : list form :=
match l1 with
  | nil => l2
  | h1 :: t1 => remove eq_dec_form h1 (remove_list t1 l2)
end.

Lemma remove_list_of_nil : forall (l : list form), remove_list l nil = nil.
Proof.
induction l.
- simpl. reflexivity.
- simpl. rewrite IHl. simpl. reflexivity.
Qed.

Lemma app_remove_list : forall (l1 l2 l3 : list form),
        remove_list (l1 ++ l2) l3 = remove_list l1 (remove_list l2 l3).
Proof.
induction l1.
- simpl. firstorder.
- induction l2.
  * intro l3. rewrite app_nil_r. simpl. reflexivity.
  * intro l3. simpl. pose (IHl1 (a0 :: l2) l3). simpl in e.
    rewrite e. reflexivity.
Qed.

Lemma remove_list_preserv_NoDup : forall l1 l2, NoDup l2 -> NoDup (remove_list l1 l2).
Proof.
induction l1.
- intros. simpl. assumption.
- intros. simpl. apply IHl1 in H. apply remove_preserv_NoDup with (A:=a) in H.
  assumption.
Qed.

Lemma remove_list_cont : forall l1 A, In A l1 -> (forall l2, In A (remove_list l1 l2) -> False).
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl in H0. apply remove_not_in_anymore in H0. assumption.
  * simpl in H0. pose (IHl1 A H1 l2). apply f. apply in_remove_in_init with (B:= a). assumption.
Qed.

Lemma remove_list_dist_app : forall (l1 l2 l3 : list form),
        remove_list l1 (l2 ++ l3) = (remove_list l1 l2) ++ (remove_list l1 l3).
Proof.
induction l1.
- intros. simpl. reflexivity.
- simpl. intros. rewrite IHl1. simpl. rewrite remove_dist_app. reflexivity.
Qed.

Lemma permut_remove_remove_list : forall a (l1 l2 : list form),
      remove eq_dec_form a (remove_list l1 l2) =
      remove_list l1 (remove eq_dec_form a l2).
Proof.
intros a l1. generalize dependent a. induction l1 ; simpl.
- reflexivity.
- intros. rewrite permut_remove. rewrite IHl1. reflexivity.
Qed.

Lemma swap_remove_list : forall (l1 l2 l3 : list form),
      remove_list (l1 ++ l2) l3 = remove_list (l2 ++ l1) l3.
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
- induction l2.
  * rewrite app_nil_l. rewrite app_nil_r. reflexivity.
  * intro l3. simpl. rewrite IHl1. simpl. rewrite permut_remove.
    rewrite <- IHl2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma redund_remove_remove_list : forall a (l1 l2 : list form),
      remove eq_dec_form a (remove_list (remove eq_dec_form a l1) l2) =
      remove eq_dec_form a (remove_list l1 l2).
Proof.
intro a. induction l1.
- intro l2. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec_form a a0).
  * rewrite IHl1. subst. rewrite double_remove. reflexivity.
  * simpl. rewrite permut_remove. rewrite IHl1. apply permut_remove.
Qed.

Lemma redund_remove : forall (l1 l2 l3 : list form) a,
      remove eq_dec_form a (remove_list l1 (remove_list (remove eq_dec_form a l2) l3)) =
      remove eq_dec_form a (remove_list l1 (remove_list l2 l3)).
Proof.
intros. repeat rewrite <- app_remove_list. rewrite swap_remove_list.
rewrite app_remove_list. rewrite redund_remove_remove_list. rewrite <- app_remove_list.
rewrite swap_remove_list. reflexivity.
Qed.

Lemma redund_remove_list : forall (l1 l2 l3 : list form),
      remove_list l1 (remove_list (remove_list l1 l2) l3) = remove_list l1 (remove_list l2 l3).
Proof.
induction l1 ; intros ; simpl.
- reflexivity.
- rewrite redund_remove. rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_in_single : forall (l1 : list form) a, (In a l1) -> remove_list l1 (a :: nil) = nil.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a0 a0).
    apply remove_list_of_nil. exfalso. apply n. reflexivity.
  * apply IHl1 in H0. simpl. rewrite H0. simpl. reflexivity.
Qed.

Lemma not_removed_remove_list : forall l2 l1 A, In A l2 -> (In A l1 -> False) -> In A (remove_list l1 l2).
Proof.
induction l2.
- intros. inversion H.
- induction l1.
  * intros. simpl. assumption.
  * intros. simpl. pose (in_not_touched_remove (remove_list l1 (a :: l2))). pose (i A).
    pose (i0 a0). apply i1. apply IHl1. assumption. intro. apply H0. apply in_cons. assumption.
    clear i1. clear i0. clear i. destruct (eq_dec_form A a0). intro. apply H0. subst. apply in_eq.
    assumption.
Qed.

Lemma add_remove_list_preserve_NoDup : forall (l1 l2 : list form),
            NoDup l1 -> NoDup l2 -> NoDup (l1 ++ (remove_list l1 l2)).
Proof.
induction l1.
- intros. rewrite app_nil_l. simpl. assumption.
- intros. simpl. apply NoDup_cons.
  * intro. apply in_app_or in H1. destruct H1. inversion H. apply H4. assumption.
    apply remove_not_in_anymore in H1. assumption.
  * rewrite permut_remove_remove_list. apply IHl1. inversion H. assumption.
    apply remove_preserv_NoDup. assumption.
Qed.

Lemma remove_list_is_in : forall l1 l2 A, In A l1 -> In A (l2 ++ (remove_list l2 l1)).
Proof.
intros. pose (In_dec l2 A). destruct s.
- apply in_or_app. left. assumption.
- apply in_or_app. right. apply not_removed_remove_list ; assumption.
Qed.

Lemma In_remove_same : forall l1 l2 A, In A l1 ->
                remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A).
    rewrite permut_remove_remove_list. reflexivity. exfalso. apply n. reflexivity.
  * simpl. pose (IHl1 l2 A H0). rewrite e. reflexivity.
Qed.

Lemma In_remove_length_same : forall l1 l2 A, In A l1 ->
                length (remove_list l1 (A :: l2)) = length (remove_list l1 l2).
Proof.
intros. rewrite In_remove_same. reflexivity. assumption.
Qed.

Lemma length_le_remove_list : forall (l1 l2 : list form), length (remove_list l1 l2) <= length l2.
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite permut_remove_remove_list. pose (IHl1 (remove eq_dec_form a l2)).
  apply Nat.le_trans with (m:=length (remove eq_dec_form a l2)). assumption.
  apply remove_le_length.
Qed.

Lemma remove_list_singl_id_or_nil : forall l A, remove_list l (A :: nil) = nil \/ remove_list l (A :: nil) = [A].
Proof.
induction l.
- intros. right. auto.
- intros. pose (IHl A). destruct o. left. simpl. rewrite H. auto.
  simpl. rewrite H. destruct (eq_dec_form A a).
  * subst. left. simpl. destruct (eq_dec_form a a). reflexivity. exfalso. apply n.
    reflexivity.
  * right. simpl. destruct (eq_dec_form a A). exfalso. apply n. symmetry. assumption.
    reflexivity.
Qed.

Lemma remove_list_non_empty_inter_smaller_length : forall l2 l1 A,
                                 In A l1 -> In A l2 -> length (remove_list l1 l2) < length l2.
Proof.
induction l2.
- intros. inversion H0.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. rewrite In_remove_length_same. 2: assumption. unfold lt. apply le_n_S.
    apply length_le_remove_list.
  * inversion H0.
    + exfalso. apply n. symmetry. assumption.
    + assert (a :: l2 = [a] ++ l2). auto. rewrite H2. rewrite remove_list_dist_app.
      rewrite app_length. pose (remove_list_singl_id_or_nil l1 a). destruct o.
      rewrite H3. simpl. apply Nat.lt_lt_succ_r. apply IHl2 with (A:=A) ; assumption.
      rewrite H3. simpl. apply Lt.lt_n_S. apply IHl2 with (A:=A) ; assumption.
Qed.

Lemma remove_list_delete_head : forall l1 l2 l3 A, remove_list (l1 ++ A :: l2) (A :: l3) = remove_list (l1 ++ A :: l2) l3.
Proof.
induction l1 ; intros ; simpl.
- rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A). symmetry. apply permut_remove_remove_list.
  exfalso. apply n. reflexivity.
- rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_delete_head_In : forall l1 l2 A, In A l1 -> remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
intros. pose (In_split A l1 H). destruct e. destruct H0. subst. apply remove_list_delete_head.
Qed.

Lemma remove_list_in_nil : forall l1 l2 l3 A,
        remove_list l1 (l2 ++ A :: l3) = nil ->
        (existsT2 l4 l5, l1 = l4 ++ A :: l5).
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a A).
    + subst. exists nil. exists l1. auto.
    + pose (IHl1 nil (remove eq_dec_form a l3)). simpl in s. apply s in H. destruct H. destruct s0.
      exists ([a] ++ x). exists x0. subst. auto.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
    + subst. pose (IHl2 l3 A). apply s. rewrite <- permut_remove_remove_list in H. simpl. assumption.
    + pose (IHl1 nil (remove eq_dec_form a (l2 ++ A :: l3)) a0). pose (s H). repeat destruct s0.
      subst. apply IHl2 with (l3:= l3). simpl. rewrite permut_remove_remove_list.
      rewrite remove_list_delete_head in H. assumption.
Qed.

Lemma remove_list_is_nil : forall l1 l2, (remove_list l1 l2 = nil <-> (forall A, (In A l2) -> (In A l1))).
Proof.
induction l1.
- intro l2. split.
  * intros. simpl in H. rewrite <- H. assumption.
  * intros. simpl. destruct l2.
    + reflexivity.
    + exfalso. pose (H f). assert (In f (f :: l2)). apply in_eq. apply i in H0. inversion H0.
- induction l2.
  * split.
    + intros. inversion H0.
    + intros. apply remove_list_of_nil.
  * split.
    + intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
      subst. inversion H0. subst. apply in_eq. rewrite <- permut_remove_remove_list in H. simpl in IHl2.
      rewrite IHl2 in H. apply H in H1. destruct H1. subst. apply in_eq. apply in_cons. assumption.
      inversion H0. subst. apply in_cons. pose (remove_list_in_nil l1 nil (remove eq_dec_form a l2) A).
      simpl in s. apply s in H. destruct H. destruct s0. subst. apply in_or_app. right. apply in_eq.
      apply IHl2. 2: assumption. simpl. rewrite permut_remove_remove_list.
      pose (app_eq_nil (remove_list l1 (a0 :: nil)) (remove_list l1 (remove eq_dec_form a l2))). simpl in a1.
      assert (H2: remove_list l1 (a0 :: nil) ++ remove_list l1 (remove eq_dec_form a l2) = nil).
      rewrite <- remove_list_dist_app. simpl. assumption. apply a1 in H2. destruct H2. assumption.
    + intros. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a a0).
      { subst. rewrite <- permut_remove_remove_list. simpl in IHl2. rewrite IHl2. intros.
        pose (H A). apply i. apply in_cons. assumption. }
      { assert (H1: (forall (A : form), In A l2 -> In A (a :: l1))). intros. apply H.
        apply in_cons. assumption. apply IHl2 in H1.
        assert (H2: a0 :: remove eq_dec_form a l2 = [a0] ++ remove eq_dec_form a l2). auto.
        rewrite H2. rewrite remove_list_dist_app. clear H2. rewrite <- permut_remove_remove_list.
        simpl in H1. rewrite H1. rewrite app_nil_r. apply remove_list_in_single. pose (H a0).
        assert (H3: In a0 (a0 :: l2)). apply in_eq. apply i in H3. inversion H3. exfalso. apply n.
        assumption. assumption. }
Qed.

Lemma remove_delete_origin : forall l1 l2 (A B : form), (A <> B) ->
            length (remove eq_dec_form A (l1 ++ B :: l2)) = S (length (remove eq_dec_form A (l1 ++ l2))).
Proof.
induction l1.
- intros. repeat rewrite app_nil_l. simpl. destruct (eq_dec_form A B). exfalso. apply H. assumption.
  simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * apply IHl1. assumption.
  * simpl. apply eq_S. apply IHl1. assumption.
Qed.

Lemma keep_list_delete_head_not_origin : forall l1 l2 l3 A, ((In A l1) -> False) ->
                length (remove_list l1 (l2 ++ A :: l3)) = S (length (remove_list l1 (l2 ++ l3))).
Proof.
induction l1.
- intros. simpl. rewrite app_length. simpl. rewrite app_length. auto.
- intros. simpl. repeat rewrite remove_list_dist_app. assert (In A l1 -> False).
  intro. apply H. apply in_cons. assumption. assert (A :: l3 = [A] ++ l3).
  auto. rewrite H1. rewrite remove_list_dist_app. pose (remove_list_singl_id_or_nil l1 A).
  destruct o. exfalso. rewrite remove_list_is_nil in H2. apply H0. apply H2.
  apply in_eq. rewrite H2. apply remove_delete_origin. intro. apply H. subst. apply in_eq.
Qed.

Lemma keep_list_delete_head_not_In : forall l1 l2 A, ((In A l1) -> False) ->
                length (remove_list l1 (A :: l2)) = S (length (remove_list l1 l2)).
Proof.
intros. pose (@keep_list_delete_head_not_origin l1 nil l2 A H). repeat rewrite app_nil_l in e.
assumption.
Qed.

Lemma In_remove_In_list : forall (A B : form) l, In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l ; intros.
- simpl in H. destruct H.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply in_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma In_remove_list_In_list : forall A l1 l2, In A (remove_list l1 l2) -> In A l2.
Proof.
intro A. induction l1 ; intros.
- simpl in H. assumption.
- simpl in H. apply In_remove_In_list in H. apply IHl1. assumption.
Qed.

Lemma In_remove_list_In_list_not_In_remove_list : forall A l1 l2,
            In A (remove_list l1 l2) -> (In A l2 /\ ((In A l1) -> False)).
Proof.
intro A. induction l1 ; intros.
- simpl in H. split. assumption. intro. inversion H0.
- simpl in H. split. apply In_remove_In_list in H. apply IHl1. assumption. intro.
  inversion H0.
  * subst. apply remove_not_in_anymore in H. assumption.
  * apply In_remove_In_list in H. apply IHl1 in H. destruct H. apply H2. assumption.
Qed.

Lemma remove_list_incr_decr3 : forall (l3 l2 l1 : list form),
              (incl l1 l2) ->
              length (remove_list l2 l3) <= length (remove_list l1 l3).
Proof.
induction l3 ; intros.
- repeat rewrite remove_list_of_nil. auto.
- destruct (In_dec l2 a).
  + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
    * rewrite remove_list_delete_head_In. 2: assumption. apply IHl3 ; auto.
    * rewrite keep_list_delete_head_not_In. 2: assumption. apply Nat.le_le_succ_r.
      apply IHl3. assumption.
  + repeat rewrite keep_list_delete_head_not_In. apply le_n_S. apply IHl3 ; auto.
    intro. apply f. apply H. assumption. assumption.
Qed.

Lemma remove_list_incr_decr1 : forall (l3 l1 l2: list form),
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              length (remove_list l2 l3) < length (remove_list l1 l3).
Proof.
induction l3.
- intros. destruct H. destruct H. destruct H1. exfalso. inversion H1.
- intros. destruct H. destruct H. destruct H1. destruct (eq_dec_form a x).
  * subst. rewrite remove_list_delete_head_In. 2: assumption.
    rewrite keep_list_delete_head_not_In. 2: assumption. unfold lt.
    apply le_n_S. apply remove_list_incr_decr3. assumption.
  * inversion H1. exfalso. apply n ; assumption.
    assert (H4: exists A : form, In A l2 /\ In A l3 /\ (In A l1 -> False)).
    exists x. auto. apply IHl3 in H4. 2 : assumption. unfold lt.
    destruct (In_dec l2 a).
    + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
      { rewrite remove_list_delete_head_In. 2: assumption. apply H4. }
      { rewrite keep_list_delete_head_not_In. 2: assumption. apply le_n_S.
        unfold lt in H4. apply Le.le_Sn_le. assumption. }
    + rewrite keep_list_delete_head_not_In. 2: assumption. rewrite keep_list_delete_head_not_In.
      unfold lt in H4. apply le_n_S. assumption. intro. apply f. apply H0. assumption.
Qed.

Lemma remove_list_incr_decr2 : forall (l4 l3 l1 : list form),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              length (remove_list l1 l4) <= length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. apply le_0_n.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (H2: In a l3). apply H1.
    apply in_eq. pose (in_split a l3 H2). repeat destruct e. destruct H3. rewrite H3.
    rewrite keep_list_delete_head_not_origin. 2: assumption. apply le_n_S. apply IHl4.
    inversion H. assumption. subst. apply NoDup_destr_split with (A:=a). assumption.
    inversion H. unfold incl. intros. subst. assert (H9 : In a0 (a :: l4)). apply in_cons.
    assumption. pose (H1 a0 H9). apply in_app_or in i. destruct i. apply in_or_app. left.
    assumption. inversion H3. subst. exfalso. apply H6. assumption. apply in_or_app. right.
    assumption.
Qed.

Lemma remove_list_incr_decr4 : forall (l4 l3 l1: list form),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              ((incl l3 l4) -> False) ->
              (exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False)) ->
              length (remove_list l1 l4) < length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. destruct H3. destruct H3. destruct H4. pose (In_split x l3 H3).
  destruct e. destruct H6. subst. rewrite keep_list_delete_head_not_origin. 2: assumption.
  apply Nat.lt_0_succ.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
    intro. apply H2. unfold incl. intros. apply in_cons. apply H4. assumption. destruct H3.
    destruct H3. destruct H4. exists x. repeat split ; try assumption. intro. apply H5.
    apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (In a l3). apply H1.
    apply in_eq. pose (In_split a l3 H4). destruct e. destruct H5. subst.
    rewrite keep_list_delete_head_not_origin. 2 : assumption. apply Lt.lt_n_S.
    apply IHl4. inversion H. assumption. apply NoDup_destr_split with (A:=a). assumption.
    unfold incl. intros. pose (H1 a0). assert (In a0 (a :: l4)). apply in_cons. assumption.
    apply i in H6. apply in_app_or in H6. destruct H6. apply in_or_app. left. assumption.
    inversion H6. subst. inversion H. exfalso. apply H9. assumption. apply in_or_app. right.
    assumption. intro. apply H2. unfold incl. intros. apply in_app_or in H6. destruct H6.
    apply in_cons. apply H5. apply in_or_app. left. assumption. inversion H6. subst. apply in_eq.
    apply in_cons. apply H5. apply in_or_app. right. assumption.
    destruct H3. destruct H3. destruct H5. exists x1. repeat split ; try assumption.
    apply in_app_or in H3. destruct H3. apply in_or_app. left. assumption. inversion H3.
    subst. exfalso. apply H6. apply in_eq. apply in_or_app. right. assumption.
    intro. apply H6. apply in_cons. assumption.
Qed.

Lemma remove_list_incr_decr : forall (l1 l2 l3 l4 : list form),
              (NoDup l4) ->
              (NoDup l3) ->
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              (incl l4 l3) ->
              length (remove_list l2 l4) < length (remove_list l1 l3).
Proof.
intros. unfold lt.
pose (remove_list_incr_decr2 _ _ l1 H H0 H3).
repeat destruct H1. destruct H4. destruct (In_dec l4 x).
- assert (H6: (exists A, In A l2 /\ In A l4 /\ (In A l1 -> False))).
  exists x. repeat split ; assumption. pose (@remove_list_incr_decr1 l4 l1 l2 H6 H2).
  unfold lt in l0. apply Nat.le_trans with (m:=length (remove_list l1 l4)) ; assumption.
- assert ((incl l3 l4) -> False). intros. apply f. apply H6. assumption.
  assert ((exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False))). exists x. auto.
  pose (@remove_list_incr_decr3 l4 l2 l1 H2). pose (@remove_list_incr_decr4 l4 l3 l1 H H0 H3 H6 H7).
  unfold lt in l5. apply le_n_S in l0.
  apply Nat.le_trans with (m:=S (length (remove_list l1 l4))) ; assumption.
Qed.

Lemma In_remove_list_remove_redund : forall l1 l2 a, In a l1 ->
                remove eq_dec_form a (remove_list l1 l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. rewrite double_remove. reflexivity.
  * pose (IHl1 l2 a0 H0). rewrite permut_remove. rewrite e. reflexivity.
Qed.

Lemma In_matters_remove_list : forall l1 l2, (incl l1 l2 /\ incl l2 l1) -> (forall l0,
                                    remove_list l1 l0 = remove_list l2 l0).
Proof.
induction l1.
- intros. destruct H. destruct l2. auto. unfold incl in H0. pose (H0 f). assert (In f (f :: l2)).
  apply in_eq. apply i in H1. inversion H1.
- intros. destruct H. simpl. pose (H a). assert (In a (a :: l1)). apply in_eq. apply i in H1.
  apply in_split in H1. destruct H1. destruct H1. subst. destruct (In_dec l1 a).
  * rewrite In_remove_list_remove_redund. 2: assumption. apply IHl1. split. intro. intro.
    apply H. apply in_cons. assumption. intro. intro. apply H0 in H1. inversion H1. subst.
    assumption. assumption.
  * rewrite swap_remove_list. simpl. rewrite <- redund_remove_remove_list with (l1:=(x0 ++ x)).
    pose (IHl1 (remove eq_dec_form a (x0 ++ x))). rewrite e.
    auto. split. intro. intro. apply in_not_touched_remove. assert (In a0 (a :: l1)). apply in_cons.
    assumption. apply H in H2. apply in_app_or in H2. destruct H2. apply in_or_app. right. assumption.
    inversion H2. subst. exfalso. apply f. assumption. apply in_or_app. left. assumption.
    intro. subst. apply f. assumption. intro. intro. pose (In_remove_diff (x0 ++ x) _ _ H1).
    pose (In_remove_In_list a0 a (x0 ++ x) H1). assert (In a0 (x ++ a :: x0)). apply in_app_or in i0.
    destruct i0. apply in_or_app. right. apply in_cons. assumption. apply in_or_app. left. assumption.
    apply H0 in H2. inversion H2. exfalso. apply n. symmetry. assumption. assumption.
Qed.

End Remove.


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

(*i $Id: auxiliary.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Export Arith_base.
Require Import BinInt.
Require Import Zorder.
Require Import Decidable.
Require Import Peano_dec.
Require Export Compare_dec.

Open Local Scope Z_scope.

(***************************************************************)
(** * Moving terms from one side to the other of an inequality *)

Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0.
Proof.
  intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1;
    apply Zplus_reg_l with (- y); rewrite Zplus_opp_l;
      rewrite Zplus_comm; trivial with arith.
Qed.

Theorem Zegal_left : forall n m:Z, n = m -> n + - m = 0.
Proof.
  intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute;
    rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption.
Qed.

Theorem Zle_left : forall n m:Z, n <= m -> 0 <= m + - n.
Proof.
  intros x y H; replace 0 with (x + - x).
  apply Zplus_le_compat_r; trivial.
  apply Zplus_opp_r.
Qed.

Theorem Zle_left_rev : forall n m:Z, 0 <= m + - n -> n <= m.
Proof.
  intros x y H; apply Zplus_le_reg_r with (- x).
  rewrite Zplus_opp_r; trivial.
Qed.

Theorem Zlt_left_rev : forall n m:Z, 0 < m + - n -> n < m.
Proof.
  intros x y H; apply Zplus_lt_reg_r with (- x).
  rewrite Zplus_opp_r; trivial.
Qed.

Theorem Zlt_left : forall n m:Z, n < m -> 0 <= m + -1 + - n.
Proof.
  intros x y H; apply Zle_left; apply Zsucc_le_reg;
    change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred;
      apply Zlt_le_succ; assumption.
Qed.

Theorem Zlt_left_lt : forall n m:Z, n < m -> 0 < m + - n.
Proof.
  intros x y H; replace 0 with (x + - x).
  apply Zplus_lt_compat_r; trivial.
  apply Zplus_opp_r.
Qed.

Theorem Zge_left : forall n m:Z, n >= m -> 0 <= n + - m.
Proof.
  intros x y H; apply Zle_left; apply Zge_le; assumption.
Qed.

Theorem Zgt_left : forall n m:Z, n > m -> 0 <= n + -1 + - m.
Proof.
  intros x y H; apply Zlt_left; apply Zgt_lt; assumption.
Qed.

Theorem Zgt_left_gt : forall n m:Z, n > m -> n + - m > 0.
Proof.
  intros x y H; replace 0 with (y + - y).
  apply Zplus_gt_compat_r; trivial.
  apply Zplus_opp_r.
Qed.

Theorem Zgt_left_rev : forall n m:Z, n + - m > 0 -> n > m.
Proof.
  intros x y H; apply Zplus_gt_reg_r with (- y).
  rewrite Zplus_opp_r; trivial.
Qed.

Theorem Zle_mult_approx :
  forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
Proof.
  intros x y z H1 H2 H3; apply Zle_trans with (m := y * x);
    [ apply Zmult_gt_0_le_0_compat; assumption
      | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r;
	apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt;
	  assumption ].
Qed.

Theorem Zmult_le_approx :
  forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
Proof.
  intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x;
    [ assumption
      | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse;
	apply Zplus_lt_compat_l; apply Zgt_lt; assumption ].
Qed.


Set Implicit Arguments.
Require Import List.
From Undecidability.HOU Require Import std.std.
Import ListNotations.

(* * PCP and MPCP *)
Notation symbol := bool.
Notation word   := (list symbol).
Notation card   := (word * word)%type.
Notation stack  := (list card).

Notation hd := fst.
Notation tl := snd.
Notation heads S := (map hd S).
Notation tails S := (map tl S).

Definition PCP (S: list card) :=
  exists (I: list nat),  I ⊆ nats (|S|) /\ I <> nil /\
                  concat (select I (heads S)) = concat (select I (tails S)).

Definition MPCP '(c, C) :=
  exists (I: list nat), I ⊆ nats (1 + |C|)
                 /\ hd c ++ @concat symbol (select I (heads (c :: C))) = tl c ++ concat (select I (tails (c :: C))).

Definition PCPsimp (C: list card) :=
  exists (C': stack),  C' ⊆ C /\ C' <> nil /\ concat (heads C') = concat (tails C').

Definition MPCPsimp '(c, C) :=
  exists (C': stack), C' ⊆ c :: C  /\ hd c ++ concat (heads C') = tl c ++ concat (tails C').

(* ** Equivalences *)
Section PCPEquivalence.

  Hint Resolve nth_error_Some_lt nth_error_lt_Some nats_lt lt_nats : core.

  Lemma incl_select_iff X (A B: list X):
    A ⊆ B <-> exists I, I ⊆ nats (length B) /\ select I B = A.
  Proof.
    split.
    - now intros ? % incl_select.
    - intros [I [? <-]]; eapply select_incl.
  Qed.

  Lemma PCPsimp_PCP C:
    PCPsimp C <-> PCP C.
  Proof.
    split.
    + intros [C' H]. rewrite incl_select_iff in H.
      destruct H as ((I & ? & ?) & ? & ?); subst.
      exists I. rewrite <-!select_map; intuition.
      subst; cbn in *; intuition.
    + intros (I & H).  exists (select I C). rewrite incl_select_iff.
      intuition eauto.
      destruct I; intuition. cbn in H1. specialize (H0 n); mp H0; lauto.
      eapply nats_lt, nth_error_lt_Some in H0 as [? ?].
      rewrite H0 in H1; discriminate.
      rewrite !select_map; intuition.
  Qed.

  Lemma MPCPsimp_MPCP c C:
    MPCPsimp (c,C) <-> MPCP (c,C).
  Proof.
    split.
    + intros [C' H]. rewrite incl_select_iff in H.
      destruct H as ((I & ? & ?) & ?); subst.
      exists I. rewrite <-!select_map; intuition.
    + intros (I & H).  exists (select I (c :: C)). rewrite incl_select_iff.
      intuition eauto. rewrite !select_map; intuition.
  Qed.

End PCPEquivalence.


Set Implicit Arguments.
Require Import List.
Import ListNotations.

Definition rsub U V f g := forall (u : U) (v : V), f u v -> g u v.

Lemma rsub_def: forall U V (f g : U -> V -> Type),
  @rsub U V f g = forall (u : U) (v : V), f u v -> g u v.
Proof.  intros.  unfold rsub.  reflexivity. Qed.

Lemma rsub_trans U V (f g h : U -> V -> Type) :
  rsub f g -> rsub g h -> rsub f h.
Proof. unfold rsub. firstorder. Qed.

Lemma rsub_id U V (f : U -> V -> Type) : rsub f f.
Proof. unfold rsub. firstorder. Qed.

Definition req U V f g := prod (@rsub U V f g) (rsub g f).

Lemma req_refl U V f : @req U V f f.
Proof. unfold req. split ; apply rsub_id. Qed.

Lemma req_sym U V f g : @req U V f g -> @req U V g f.
Proof. unfold req. tauto. Qed.

Lemma req_trans U V f g h : @req U V f g -> @req U V g h -> @req U V f h.
Proof. unfold req. intros F B. destruct F. destruct B.
split ; eapply rsub_trans ; eassumption.  Qed.

Definition rls W := list W -> W -> Prop.

(* lemmas which shouldn't be necessary at all! *)

Lemma or_false: forall P : Prop, iff (or P False) P. Proof. tauto. Qed.
Lemma false_or: forall P : Prop, iff (or False P) P. Proof. tauto. Qed.
Lemma and_true: forall P : Prop, iff (and P True) P. Proof. tauto. Qed.
Lemma true_and: forall P : Prop, iff (and True P) P. Proof. tauto. Qed.

Lemma rappl: forall (A B : Prop), A -> (A -> B) -> B.
Proof.  tauto.  Qed.

Lemma appl: forall (A B : Prop), (A -> B) -> A -> B.
Proof.  tauto.  Qed.

Lemma gen_cong: forall T U f g, f = g ->
  forall x y, x = y -> (f (x : U) : T) = g y.
Proof. intros. subst. reflexivity. Qed.

Lemma fun_cong: forall T U f g, f = g ->
  forall x, (f (x : U) : T) = g x.
Proof. intros. subst. reflexivity. Qed.

(* similar to Coq.Init.Logic.f_equal *)
Lemma arg_cong: forall T U f x y, x = y -> (f (x : U) : T) = f y.
Proof. intros. subst. reflexivity. Qed.

Lemma arg_cong_imp: forall U f x y, x = y -> f (x : U) -> f y.
Proof. intros. subst. assumption. Qed.

(* similar to Coq.Init.Logic.eq_rect *)
Lemma arg_cong_imp': forall U f x y, f (x : U) -> x = y -> f y.
Proof. intros. subst. assumption. Qed.

Lemma arg1_cong_imp: forall U V f x y z, x = y -> f (x : U) (z : V) -> f y z.
Proof. intros. subst. assumption. Qed.

Lemma arg1_cong_imp': forall U V f x y z, f (x : U) (z : V) -> x = y -> f y z.
Proof. intros. subst. assumption. Qed.

(* iffD1, iffD2 for Type *)
Lemma iffD1: forall x y, (x = y) -> x -> y.
Proof. intros.  subst.  assumption. Qed.

Lemma iffD2: forall x y, (x = y) -> y -> x.
Proof. intros.  subst.  assumption. Qed.

(* PiffD1, PiffD2 for Prop *)
Lemma PiffD1: forall x y, (x <-> y) -> x -> y.
Proof. intros.  rewrite -> H in H0.  assumption. Qed.

Lemma PiffD2: forall x y, (x <-> y) -> y -> x.
Proof. intros.  rewrite <- H in H0.  assumption. Qed.

Lemma eq_TrueI: forall (P : Prop), (P -> (P <-> True)).
intros. unfold iff. apply conj ; intro.  apply I. assumption.
Qed.

Definition rsub_imp U V (f g : U -> V -> Type) := iffD1 (@rsub_def U V f g).
Definition rsubI U V f g := iffD2 (@rsub_def U V f g).
Definition rsubD U V f g := iffD1 (@rsub_def U V f g).

(* and do req_def, reqI, reqD as for rsub *)

(* see also eq_refl, eq_trans, eq_sym, eq_ind, eq_ind_r *)

Ltac refl_ni :=
  match goal with
    | [ |- ?P = ?P ] => reflexivity
    end.

Lemma pair_eqI: forall T U (u v : T) (x y : U),
  u = v -> x = y -> (u,x) = (v,y).
Proof. intros. subst. reflexivity. Qed.

Ltac rename_last name :=
  match goal with
    | [ K : _ |- _ ] => rename K into name
    end.

Ltac clear_one :=
  match goal with
    | [ K : _ |- _ ] => clear K
    end.

Ltac cE :=
  repeat match goal with
    | [ H : _ /\ _ |- _ ] => inversion_clear H
    | [ H : ex _ |- _ ] => inversion_clear H
    | [ H : False |- _ ] => contradiction H
    end.

(* one step of cDv *)
Ltac cD' :=
  match goal with
    | [ H : _ /\ _ |- _ ] => destruct H as [?H ?H]
    | [ H : prod _ _ |- _ ] => destruct H as [?H ?H]
    | [ H : ex _ |- _ ] => destruct H as [?H ?H]
    | [ H : sig _ |- _ ] => destruct H as [?H ?H]
    | [ H : sigT _ |- _ ] => destruct H as [?H ?H]
    | [ H : ex2 _ _ |- _ ] => destruct H as [?H ?H ?H]
    | [ H : sig2 _ _ |- _ ] => destruct H as [?H ?H ?H]
    | [ H : sigT2 _ _ |- _ ] => destruct H as [?H ?H ?H]
    | [ H : False |- _ ] => contradiction H
    end.

Ltac cD := repeat cD'.

Ltac sE :=
  repeat match goal with
    | [ H : _ /\ _ |- _ ] => inversion_clear H
    | [ H : _ \/ _ |- _ ] => inversion_clear H
    | [ H : ex _ |- _ ] => inversion_clear H
    | [ H : False |- _ ] => contradiction H
    end.

Ltac sD' :=
  match goal with
    | [ H : _ /\ _ |- _ ] => destruct H as [?H ?H]
    | [ H : prod _ _ |- _ ] => destruct H as [?H ?H]
    | [ H : _ \/ _ |- _ ] => destruct H as [?H | ?H]
    | [ H : sumbool _ _ |- _ ] => destruct H as [?H | ?H]
    | [ H : sum _ _ |- _ ] => destruct H as [?H | ?H]
    | [ H : ex _ |- _ ] => destruct H as [?H ?H]
    | [ H : sig _ |- _ ] => destruct H as [?H ?H]
    | [ H : sigT _ |- _ ] => destruct H as [?H ?H]
    | [ H : False |- _ ] => contradiction H
    end.

(* extra stuff used in sD, not in cD *)
Ltac sDx :=
  match goal with
    | [ H : _ \/ _ |- _ ] => destruct H as [?H | ?H]
    | [ H : sumbool _ _ |- _ ] => destruct H as [?H | ?H]
    | [ H : sum _ _ |- _ ] => destruct H as [?H | ?H]
    end.

Ltac sD := repeat (cD' || sDx).

(* various solutions to dealing with hypothesis forall x, A x -> B x
  see emails 8-9 Jan
evar (z : list (rel (list (PropF V)) * dir)).
specialize (H1 z).
subst z. (* subst. alone doesn't work *)

match type of H1 with
| ?A -> _ =>
  assert (I : A); [| apply H1 in I ]
  end.

apply (fun G2 G1 => G1 (H1 G2)).

eassert _ as I%H1.

or
eassert _ ; [ apply H1 | ].
eassert _ as I ; [ | apply H1 in I ].

all : cycle 1. Show.
Undo. Show.
*)

(* tactics from Lily Chung <ikdc@mit.edu> Tue, 8 Jan 2019
  https://gist.github.com/ichung/032b849da0c3c5e3987c83f835d111ee *)

(* [require], when called on a hypothesis [H : P -> Q],
   asserts that P actually holds,
   and thus that H's type can be replaced with Q *)
Ltac require H :=
  match type of H with
  | forall _  : ?H1, _ =>
    let x := fresh in
    let y := x in
    assert H1 as x; [| specialize (H x); clear y]
  end.

(* [erequire H], when called on a hypothesis [H : forall x, Q x],
   specializes [H] to a new evar to be filled in later *)
Ltac erequire H :=
  match type of H with
  | forall _  : ?H1, _ =>
    let x := fresh in
    evar (x : H1); specialize (H x); subst x
end.

(* solution from  Marko Doko <mdoko@mpi-sws.org> Tue, 8 Jan 2019
  solves question for quantified implication, changed to use Ltac

Tactic Notation "specialize_full" ident(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1;
  [eapply H|try clear H; intro H].
*)

Ltac specialize_full H :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1;
  [eapply H|try clear H; intro H].

Ltac prgt t :=
  match goal with
    | [ |- ?P ] => idtac t P
    end.

Lemma in_single: forall (A : Type) (a x : A), In a [x] <-> a = x.
Proof. intros. unfold iff. split ; intros.
  apply in_inv in H. sD.
  subst. reflexivity.
  apply in_nil in H. contradiction.
  subst.  apply in_eq. Qed.

Lemma Forall_cons_inv: forall A (P : A -> Prop) (x : A) (l : list A),
  Forall P (x :: l) -> P x /\ Forall P l.
Proof. intros. inversion H. tauto. Qed.

Lemma Forall_cons_iff: forall A (P : A -> Prop) (x : A) (l : list A),
  Forall P (x :: l) <-> P x /\ Forall P l.
Proof.  intros. unfold iff. apply conj ; intro.
apply Forall_cons_inv. assumption.
inversion H.  apply Forall_cons ; assumption.
Qed.

Lemma Forall_append: forall X P (xs ys: list X),
  Forall P (xs ++ ys) <-> Forall P xs /\ Forall P ys.
Proof.
intros.  induction xs.  easy.
simpl.  rewrite !Forall_cons_iff.  rewrite IHxs.  tauto.
Qed.

Lemma Forall_single: forall (A : Type) P x, @Forall A P [x] <-> P x.
Proof. intros. unfold iff. rewrite Forall_forall.
  split ; intros.
  apply H. rewrite in_single. reflexivity.
  inversion H0. subst. exact H.
  apply in_nil in H1. contradiction. Qed.

Lemma Forall_map_single: forall (A B : Type) P (f : A -> B) x,
  Forall P (map f [x]) <-> P (f x).
Proof.  simpl. intros. apply Forall_single. Qed.

Lemma Forall_map_2: forall (A B : Type) P (f : A -> B) x y,
  Forall P (map f [x; y]) <-> P (f x) /\ P (f y).
Proof.  intros. rewrite Forall_forall. unfold iff. split.
  intros. split.
  pose (H (f x)). apply p. rewrite in_map_iff. exists x. simpl. tauto.
  pose (H (f y)). apply p. rewrite in_map_iff. exists y. simpl. tauto.
  intros. rewrite -> in_map_iff in H0. cD. simpl in H3.
  sD ; subst ; assumption.  Qed.

Lemma map_cons_ex T U (f : T -> U) ys x : forall ws,
  map f ws = x :: ys -> {u : T & x = f u &
    {vs : list _ & ys = map f vs & ws = u :: vs}}.
Proof. intro. destruct ws ; simpl ; intro.  discriminate.
injection H as . subst. exists t. reflexivity.
exists ws ; reflexivity. Qed.

Lemma map_cons_ex' T U (f : T -> U) ys x : forall ws,
  map f ws = x :: ys -> {u : T & x = f u &
    {vs : list _ & map f vs = ys & ws = u :: vs}}.
Proof. intros ws meq. apply map_cons_ex in meq. cD.
exists meq. assumption.  exists meq1. subst. reflexivity. assumption. Qed.

Lemma map_app_ex T U (f : T -> U) ys xs : forall ws,
  map f ws = xs ++ ys -> {us : _ & map f us = xs &
    {vs : _ & map f vs = ys & ws = us ++ vs}}.
Proof. induction xs ; simpl ; intros.
exists []. simpl. reflexivity.
simpl. exists ws. subst. reflexivity.  reflexivity.
apply map_cons_ex in H. destruct H. destruct s. subst.
apply eq_sym in e0. apply IHxs in e0. destruct e0.  destruct s. subst.
exists (x :: x1). simpl. reflexivity. exists x2. reflexivity.
simpl. reflexivity. Qed.

Lemma map_eq_nil T U (f : T -> U) xs : map f xs = [] -> xs = [].
Proof. intro mx. destruct xs. reflexivity.  simpl in mx. discriminate mx. Qed.

Ltac name_goal name := refine ?[name].


(*A slight rewriting of Eqdep_dec that uses weakly decidable equality (x=y \/
x<>y) instead of strongly decidable equality ({x=y}+{x<>y})*)

Set Implicit Arguments.
(* Set Universe Polymorphism. *)

Section EqdepEm.

  Variable A : Type.

  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
    match eq1 with eq_refl => eq2 end.

  Let trans_sym_eq : forall (x y:A) (u:x = y), comp u u = eq_refl y.
  Proof.
    unfold comp. simple destruct u. reflexivity.
  Qed.

  Variable x : A.

  Variable eqem : forall y:A, x = y \/ x <> y.

  (*Understanding nu: it looks like an identity function - but its purpose is
  to redirect callers that provide an arbitrary instance for u to the specific
  instance captured within eqem.  That way, all nus are the same specific
  instance.*)
  Let nu (y:A) (u:x = y) : x = y :=
    match eqem y with
      | or_introl eqxy => eqxy
      | or_intror neqxy => False_ind _ (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
  Proof.
    intros.
    unfold nu.
    (*Only the proof of false needs help*)
    destruct (eqem y) as [|Hneq].
    - reflexivity.
    - (*All proofs of False are the trivially the same*) case Hneq.
  Qed.

  (*nu_inv isn't an inverse in the sense of actually finding the original u
  for each nu u - it can't be, as that original u is not anywhere to be found.
  Instead, it merely allows u to be cased to eq_refl in both lhs and rhs.*)
  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v.

  Let nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    unfold nu_inv.
    (*This next case is what nu_inv is allowing:*) simple destruct u.
    apply trans_sym_eq.
  Qed.

  Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim nu_left_inv_on with (u := p1).
    elim nu_left_inv_on with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Qed.

  Theorem K_em_on :
    forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim eq_proofs_unicity_on with x (eq_refl x) p.
    assumption.
  Qed.

  (** The corollary *)

  Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
    match exP with
      | ex_intro _ x' prf =>
        match eqem x' with
          | or_introl eqprf => eq_ind x' P prf x (eq_sym eqprf)
          | _ => def
        end
    end.

  Theorem inj_right_pair_on :
    forall (P:A -> Prop) (y y':P x),
      ex_intro P x y = ex_intro P x y' -> y = y'.
  Proof.
    intros.
    cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
    - cbn. destruct (eqem x) as [Heq|Hneq].
      + elim Heq using K_em_on. cbv. tauto.
      + case Hneq. reflexivity.
    - case H. reflexivity.
  Qed.

End EqdepEm.

Theorem eq_proofs_unicity A (eqem : forall x y : A, x = y \/ x <> y) (x : A)
: forall (y:A) (p1 p2:x = y), p1 = p2.
Proof (@eq_proofs_unicity_on A x (eqem x)).

Theorem K_em A (eqem : forall x y : A, x = y \/ x <> y) (x : A)
: forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
Proof (@K_em_on A x (eqem x)).

Theorem inj_right_pair A (eqem : forall x y : A, x = y \/ x <> y) (x : A)
: forall (P:A -> Prop) (y y':P x),
    ex_intro P x y = ex_intro P x y' -> y = y'.
Proof (@inj_right_pair_on A x (eqem x)).

Require Coq.Logic.EqdepFacts.

Theorem K_em_type :
  forall A:Type,
    (forall x y:A, x = y \/ x <> y) ->
    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof. apply K_em. Qed.

Theorem K_em_set :
  forall A:Set,
    (forall x y:A, x = y \/ x <> y) ->
    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof fun A => K_em_type (A:=A).

Theorem eq_rect_eqem :
  forall A:Type,
    (forall x y:A, x = y \/ x <> y) ->
    forall (p:A) (Q:A -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof.
  intros A eqem.
  apply (EqdepFacts.Streicher_K__eq_rect_eq A (K_em_type eqem)).
Qed.

Theorem eq_dep_eqem :
  forall A:Type,
    (forall x y:A, x = y \/ x <> y) ->
     forall (P:A->Type) (p:A) (x y:P p), EqdepFacts.eq_dep A P p x p y -> x = y.
Proof (fun A eqem => EqdepFacts.eq_rect_eq__eq_dep_eq A (eq_rect_eqem eqem)).

Theorem UIP_em :
  forall (A:Type),
    (forall x y:A, x = y \/ x <> y) ->
    forall (x y:A) (p1 p2:x = y), p1 = p2.
Proof. apply eq_proofs_unicity. Qed.

Lemma inj_pair2_eqem : forall A:Type, (forall x y:A, x=y \/ x<>y) ->
   ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ).
Proof.
  intros A eqem.
  apply EqdepFacts.eq_dep_eq__inj_pair2.
  apply EqdepFacts.eq_rect_eq__eq_dep_eq.
  unfold EqdepFacts.Eq_rect_eq, EqdepFacts.Eq_rect_eq_on.
  intros; apply eq_rect_eqem.
  apply eqem.
Qed.

Unset Implicit Arguments.


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

- Frederic Blanqui, 2005-06-17

general results on booleans
*)

Set Implicit Arguments.

From Coq Require Import Arith Lia.
From Coq Require Export Bool.
From Coq Require Setoid.

From CoLoR Require Import LogicUtil.

Arguments orb_false_elim [b1 b2] _.
Arguments orb_true_elim [b1 b2] _.

Hint Rewrite negb_orb negb_andb negb_involutive eqb_negb1 eqb_negb2
  orb_true_r orb_true_l orb_false_r orb_false_l orb_negb_r orb_assoc
  andb_false_r andb_false_l andb_true_r andb_true_l andb_negb_r andb_assoc
  absoption_andb absoption_orb
  xorb_false_r xorb_false_l xorb_nilpotent xorb_assoc_reverse
  : bool.

Ltac bool := autorewrite with bool.

(***********************************************************************)
(** equality *)

Lemma false_not_true : forall b, b = false <-> ~(b = true).

Proof. destruct b; intuition. Qed.

Lemma beq_true : forall b c, b = c <-> (b = true <-> c = true).

Proof.
  split; intro h. subst. tauto. destruct c.
  tauto. rewrite false_not_true. intuition.
Qed.

(***********************************************************************)
(** implication *)

Lemma implb1 : forall b, implb b b = true.

Proof. induction b; refl. Qed.

Lemma implb2 : forall b, implb b true = true.

Proof. induction b; refl. Qed.

(***********************************************************************)
(** conjunction *)

Lemma andb_elim : forall b c, b && c = true -> b = true /\ c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elim [b c] _.

Lemma andb_eliml : forall b c, b && c = true -> b = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_eliml [b c] _.

Lemma andb_elimr : forall b c, b && c = true -> c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elimr [b c] _.

Lemma andb_intro : forall b c, b = true -> c = true -> b && c = true.

Proof. intros. subst b. subst c. refl. Qed.

Lemma andb_eq : forall b c, b && c = true <-> b = true /\ c = true.

Proof. split. intro. apply andb_elim. hyp. intuition. Qed.

Lemma andb_eq_false : forall b c, b && c = false <-> b = false \/ c = false.

Proof. destruct b; destruct c; bool; intuition. Qed.

(***********************************************************************)
(** negation *)

Definition neg (A : Type) (f : A->A->bool) x y := negb (f x y).

Lemma negb_lr : forall b c, negb b = c <-> b = negb c.

Proof. destruct b; destruct c; intuition. Qed.

(***********************************************************************)
(** disjonction *)

Lemma orb_intror : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_introl : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_eq : forall b c, b || c = true <-> b = true \/ c = true.

Proof. intuition. destruct b; auto. Qed.

(***********************************************************************)
(** equality *)

Lemma eqb_equiv : forall b b', b = b' <-> (b = true <-> b' = true).

Proof.
  intros b b'. split; intro H. subst b'. refl.
  destruct b. sym. rewrite <- H. refl.
  destruct b'. rewrite H. refl. refl.
Qed.

(***********************************************************************)
(** decidability *)

Section dec.

  Variables (A : Type) (P : A -> Prop)
    (f : A -> bool) (f_ok : forall x, f x = true <-> P x).

  Lemma ko : forall x, f x = false <-> ~P x.

  Proof. intro x. rewrite <- f_ok. destruct (f x); intuition; discr. Qed.

  Lemma dec : forall x, {P x}+{~P x}.

  Proof.
    intro x. case_eq (f x); intros.
    left. rewrite <- f_ok. hyp. right. rewrite <- ko. hyp.
  Defined.

End dec.

Arguments ko [A P f] _ x.
Arguments dec [A P f] _ x.

(***********************************************************************)
(** correspondance between boolean functions and logical connectors *)

Section bool_ok.

  Variables (A : Type) (P Q : A->Prop) (bP bQ : A-> bool)
    (bP_ok : forall x, bP x = true <-> P x)
    (bQ_ok : forall x, bQ x = true <-> Q x).

  Lemma negb_ok : forall x, negb (bP x) = true <-> ~P x.

  Proof. intro. rewrite <- (ko bP_ok). destruct (bP x); simpl; intuition. Qed.

  Lemma andb_ok : forall x, bP x && bQ x = true <-> P x /\ Q x.

  Proof. intro. rewrite andb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma orb_ok : forall x, bP x || bQ x = true <-> P x \/ Q x.

  Proof. intro. rewrite orb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma implb_ok : forall x, implb (bP x) (bQ x) = true <-> (P x -> Q x).

  Proof.
    intro x. unfold implb. case_eq (bP x).
    rewrite bP_ok, bQ_ok. tauto.
    rewrite (ko bP_ok). tauto.
  Qed.

End bool_ok.

(***********************************************************************)
(** checking a property (P i) for all i<n *)

Set Firstorder Solver debug auto with *.

Section bforall_lt.

  Variables (P : nat->Prop) (bP : nat->bool)
    (bP_ok : forall x, bP x = true <-> P x).

  Definition forall_lt n := forall i, i < n -> P i.

  Fixpoint bforall_lt_aux b n := b &&
    match n with
      | 0 => true
      | S n' => bforall_lt_aux (bP n') n'
    end.

  Lemma bforall_lt_aux_ok : forall n b,
    bforall_lt_aux b n = true <-> b = true /\ forall_lt n.

  Proof.
    unfold forall_lt. induction n; simpl; intros. bool. fo. lia.
    rewrite andb_eq, IHn, bP_ok. intuition.
    destruct (Nat.eq_dec i n). subst. hyp. apply H2. lia.
  Qed.

  Definition bforall_lt := bforall_lt_aux true.

  Lemma bforall_lt_ok : forall n, bforall_lt n = true <-> forall_lt n.

  Proof. intro. unfold bforall_lt. rewrite bforall_lt_aux_ok. tauto. Qed.

End bforall_lt.


Require Import MLTT2F.Overture MLTT2F.Path_eq.

Record IsEquiv {A B} {FibA: Fibrant A} {FibB: Fibrant B} (f: A -> B) :=
  { equiv_inv : B -> A ;
    eisretr : f o equiv_inv == idmap;
    eissect : equiv_inv o f == idmap;
    eisadj :  ∀ x : A, eisretr (f x) = ap f (eissect x) }.

Arguments equiv_inv {_ _ _ _ _} _ _.
Arguments eisretr {_ _ _ _ _} _ _.
Arguments eissect {_ _ _ _ _} _ _.
Arguments eisadj {_ _ _ _ _} _ _.

Definition isequiv_adjointify {A B} {FibA: Fibrant A} {FibB: Fibrant B} {f: A -> B}
           (g: B -> A) : f o g == idmap -> g o f == idmap -> IsEquiv f.
Proof.
  intros isretr issect. use Build_IsEquiv.
  exact g. exact isretr.
  exact (λ x, ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x).
  intro a; cbn.
  apply moveR_M1.
  repeat (rew ap_pp; rew concat_p_pp); rew (ap_compose _ _ _)^.
  rew (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
  repeat rew concat_pp_p; rew ap_V; apply moveL_Vp; rew concat_p1.
  rew concat_p_pp; rew (ap_compose _ _ _)^.
  rew (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
  rew concat_pV; rew concat_1p.
  exact 1.
Defined.
(* Qed. *)

Definition isequiv_compose {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           {f: A -> B} (Hf: IsEquiv f) {g: B -> C} (Hg: IsEquiv g)
  : IsEquiv (compose g f).
Proof.
  use isequiv_adjointify.
  exact ((equiv_inv Hf) o (equiv_inv Hg)).
  exact (fun c => ap g (eisretr _ (equiv_inv Hg c)) @ eisretr _ c).
  exact (fun a => ap _ (eissect _ (f a)) @ eissect _ a).
Defined.

Definition cancelR_isequiv {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           (f : A -> B) {g : B -> C}
           {Hf: IsEquiv f} {Hgf: IsEquiv (g o f)}
  : IsEquiv g.
Proof.
  use isequiv_adjointify.
  exact (f o (equiv_inv Hgf)).
  intro x; cbn. exact (eisretr Hgf x).
  intro x; cbn.
  ref (ap (λ x, f (equiv_inv Hgf (g x))) (eisretr Hf x)^ @ _).
  ref (ap f (eissect Hgf _) @ _).
  apply eisretr.
Defined.

Definition cancelL_isequiv {A B C} {FibA: Fibrant A} {FibB: Fibrant B} {FibC: Fibrant C}
           (g : B -> C) {f : A -> B}
           {Hg: IsEquiv g} {Hgf: IsEquiv (g o f)}
  : IsEquiv f.
Proof.
  use isequiv_adjointify.
  exact ((equiv_inv Hgf) o g).
  intro x; cbn.
  ref ((eissect Hg _)^ @ _).
  ref (ap (equiv_inv Hg) (eisretr Hgf _) @ _).
  apply eissect.
  intro x; cbn. exact (eissect Hgf x).
Defined.


Require Import basic.
Require Import Sublogic.
Require Import Models GenModelSyntax.
Require Import ZF ZFcoc.

(** Set-theoretical model of the Calculus of Constructions in IZF *)

Module ZFsets <: Sets.

  Definition X := set.
Definition inX : X -> X -> Prop := in_set.
Definition eqX : X -> X -> Prop := eq_set.
Definition inclX : X -> X -> Prop := incl_set.
Definition eqX_equiv : Equivalence eqX := eq_set_equiv.
Notation "x ∈ y" := (inX x y).
Notation "x == y" := (eqX x y).

Lemma in_ext: Proper (eqX ==> eqX ==> iff) inX.
Proof in_set_morph.

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

End ZFsets.

(** * Instantiation of the abstract model of CC *)

Module CCM <: CC_Model.

Include ZFsets.

Definition props : X := props.
Definition app : X -> X -> X := cc_app.
Definition lam : X -> (X -> X) -> X := cc_lam.
Definition prod : X -> (X -> X) -> X := cc_prod.

Lemma lam_ext :
  forall x1 x2 f1 f2,
  x1 == x2 ->
  eq_fun x1 f1 f2 ->
  lam x1 f1 == lam x2 f2.
Proof.
intros.
apply cc_lam_ext; intros; trivial.
Qed.

Lemma app_ext:
  forall x1 x2 : X, x1 == x2 ->
  forall x3 x4 : X, x3 == x4 ->
  app x1 x3 == app x2 x4.
Proof cc_app_morph.

Lemma prod_ext :
  forall x1 x2 f1 f2,
  x1 == x2 ->
  eq_fun x1 f1 f2 ->
  prod x1 f1 == prod x2 f2.
Proof.
intros.
apply cc_prod_ext; intros; trivial.
Qed.

Lemma prod_intro : forall dom f F,
  eq_fun dom f f ->
  eq_fun dom F F ->
  (forall x, x ∈ dom -> f x ∈ F x) ->
  lam dom f ∈ prod dom F.
Proof cc_prod_intro.

Lemma prod_elim : forall dom f x F,
  eq_fun dom F F ->
  f ∈ prod dom F ->
  x ∈ dom ->
  app f x ∈ F x.
Proof fun dom f x F _ H H0 => cc_prod_elim dom f x F H H0.

Lemma impredicative_prod : forall dom F,
  eq_fun dom F F ->
  (forall x, x ∈ dom -> F x ∈ props) ->
  prod dom F ∈ props.
Proof fun dom F _ => cc_impredicative_prod dom F.

Lemma beta_eq:
  forall dom F x,
  eq_fun dom F F ->
  x ∈ dom ->
  app (lam dom F) x == F x.
Proof cc_beta_eq.

End CCM.


(* Extensionality Axioms for our type theory *)
Axiom lem : forall P : Prop, P \/ ~P.
Axiom Prop_ext : forall P Q : Prop, (P -> Q) -> (Q -> P) -> P = Q.
Axiom dfun_ext : forall A (P : A -> Type) (f g: forall a : A, P a), (forall x, f x = g x) -> f = g.
Axiom countable_choice : forall A (P : nat -> A -> Prop), (forall n, exists x, P n x) -> exists f : nat -> A , forall n, P n (f n).

Lemma fun_ext : forall A B (f g: A -> B), (forall x, f x = g x) -> f = g.
Proof.
  intros.
  apply dfun_ext.
  exact H.
Defined.

Definition isSubsingleton := fun P : Type => forall x y : P, x = y.
Definition is_hprop (A : Type) := forall x y : A, x = y.
Definition is_mono {A B} (f : A -> B) := forall x y, f x = f y -> x = y.

Lemma fun_to_subsingleton_id : forall {A B} (f g : A -> B), isSubsingleton B -> f = g.
Proof.
  intros.
  apply fun_ext.
  intros.
  apply H.
Defined.

Definition classic : Type -> Prop := fun A => exists x : A, True.

Notation "[ A ]" := (classic A) : type_scope.

(* Proof irrelevence derived from axioms *)
Lemma irrl : forall P : Prop, forall x y : P, x = y.
Proof.
  intros P x.
  assert (P = True).
  apply Prop_ext; intro; auto.

  induction (eq_sym H).
  destruct x.
  intro.
  destruct y.
  apply eq_refl.
Qed.

(* Auxiliary functions *)
Definition lp : forall S T (f : S -> T) (a b : S), a = b -> f a = f b.
Proof.
  intros.
  rewrite H.
  exact (eq_refl _).
Defined.

(* equivalence in extensional type theory *)
Definition id (A : Type) : A -> A := fun x => x.
Definition fc {A B C : Type} (f : B -> C) (g : A -> B) : A -> C := fun x => f (g x).
Definition is_equiv {A B : Type} (f : A -> B) := {g : B -> A | fc g f = id _ /\ fc f g = id _}.

(* transporting path *)
Definition tpp : forall A : Type, forall P : A -> Type, forall x y : A, forall e : x = y, P x -> P y.
Proof.
  intros.
  induction e.
  exact X.
Defined.

(* path of sigma types *)
Lemma sigma_eqT : forall (A : Type) (P : A -> Type) (x y : A) (a : P x) (b : P y), forall e : x = y,
      tpp A P x y e a = b -> existT P x a = existT P y b.
Proof.
  intros.
  induction H.
  unfold tpp.
  unfold eq_rect.

  destruct e.
  exact eq_refl.
Defined.

(* path of sigma types *)
Lemma sigma_eqP : forall (A : Type) (P : A -> Prop) (x y : A) (a : P x) (b : P y), forall e : x = y,
      tpp A P x y e a = b -> exist P x a = exist P y b.
Proof.
  intros.
  induction H.
  unfold tpp.
  unfold eq_rect.

  destruct e.
  exact eq_refl.
Defined.

Definition sigma_eqT_pr1 : forall A P (a c : A) b d, existT P a b = existT P c d -> a = c.
Proof.
  intros.
  auto.
  apply (@lp {x : A & P x} A (@projT1 A P  ) (existT P a b) (existT P c d)) in H.
  simpl in H.
  exact H.
Defined.

Definition projP1 : forall A (P : A -> Prop) (x : {x : A | P x}), A.
Proof.
  intros.
  destruct x.
  exact x.
Defined.

Definition pr1 : forall A (P : A -> Prop) (a : {x | P x}), A.
Proof.
  intros.
  destruct a.
  exact x.
Defined.

Definition sigma_eqP_pr1 : forall A P (a c : A) b d, exist P a b = exist P c d -> a = c.
Proof.
  intros.
  apply (@lp {x : A | P x} A (@projP1 A P  ) (exist P a b) (exist P c d)) in H.
  simpl in H.
  exact H.
Defined.

Lemma sigma_eqP2 : forall (A : Type) (P : A -> Prop) (x y : A) (a : P x) (b : P y),  x = y ->  exist P x a = exist P y b.
Proof.
  intros.
  apply (sigma_eqP A P x y a b H).
  apply irrl.
Defined.


Require Export hexamys.

(* Hexamy implies Desargues *)

Lemma hexamy_desargues_gen_case :
  hexamy ->
  forall O A B C A' B' C' I J K P Q,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  O<>A -> O<>B -> O<>C ->
  O<>A' -> O<>B' -> O<>C' ->
  O<>I -> O<>J -> O<>K ->
  A<>B -> A<>C ->
  A<>A' -> A<>B' -> A<>C' ->
  A<>I -> A<>J -> A<>K ->
  B<>C ->
  B<>A' -> B<>B' -> B<>C' ->
  B<>I -> B<>J -> B<>K ->
  C<>A' -> C<>B' -> C<>C' ->
  C<>I -> C<>J -> C<>K ->
  A'<>B' -> A'<>C' ->
  A'<>I -> A'<>J -> A'<>K ->
  B'<>C' ->
  B'<>I -> B'<>J -> B'<>K ->
  C'<>I -> C'<>J -> C'<>K ->
  I<>J -> I<>K ->
  J<>K ->

  P<>C -> A<>Q ->
  P<>C'-> A'<>Q ->
  Q<>C'-> A'<>P ->

  Col P B C ->
  Col P A' B' ->
  Col Q A B ->
  Col Q B' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' I ->
  Col A C I ->
  Col A B J ->
  Col A' B' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros.

geo_norm.
remove_line_occ.
collapse.
not_eq P Q.
not_eq A P.
not_eq C Q.

hexamy_proof  A A' P C C' Q A Q C' A' P C.
Qed.

Ltac not_eq_4pt A B C D := match goal with
H1: ?Incid A ?l,
H2: ?Incid B ?l,
H3: ?Incid C ?m,
H4: ?Incid D ?m|- _ => not_eq l m
end.

Lemma desargues_cevian_case :
 hexamy ->
 forall O A B C A' B' C' P Q R PI,
  line  A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  A<>B   -> B<>C -> A<>C ->
  A'<>B'  -> B'<>C' -> A'<>C' ->
  A <> A' -> B <> B' -> C<>C' ->
  O <> A -> O<> B -> O<>C ->
  O <> A' -> O<> B' -> O<> C' ->
  PI = inter (line O B) (line P Q) ->
  A' <> inter (line A' C') (line A PI) ->
  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' Q ->
  Col A C Q ->
  Col A B P ->
  Col A' B' P ->
  Col B C R ->
  Col B' C' R ->
  Col A' B C ->
  Col B' A C ->
  Col C' A B ->
  forall II, Col O B II -> Col P Q II -> O<>II ->
  Col P Q R.
Proof.
intro hexa;
intros.
geo_norm.
remove_line_occ.
elim (uniqdec.eq_point_dec P Q);intros.
subst Q;create_line P R lPR;firstorder.

create_inter P Q B C R1.
create_inter P Q B' C' R2.
assert (R1 = R2).

create_inter A' C' A II L.
not_eq L B'.
create_inter A B L B' N.
not_eq A L.
create_inter A L C C' M.
collapse.
remove_line_occ.
assert (Col L N B') by firstorder.

not_eq II A.

not_eq P A'.
not_eq l8 l7.
not_eq A P.
not_eq B' II.

not_eq P II.
not_eq l0 l3.

not_eq Q C.

not_eq II Q.
not_eq A B.

not_eq O Q.
not_eq l2 l3.

not_eq B' Q.
not_eq II L.

not_eq_4pt L B' A P.
not_eq_4pt B' II P A'.
not_eq_4pt II A A' L.

not_eq_4pt P II L A'.
not_eq_4pt II B' A' A.

not_eq A II.
not_eq A' II.
not_eq L P.
not_eq B' P.
not_eq B' A.

not_eq A' L.

assert (Col O N Q) by
 hexamy_proof A' L B' II A P A' A P II B' L.

geo_norm;collapse.

not_eq x l7.
not_eq x l5.
not_eq x x0.
not_eq C II.
not_eq B II.
not_eq B Q.
not_eq A Q.

not_eq_4pt C B O II.
not_eq_4pt B A II Q.
not_eq_4pt A O Q C.

not_eq_4pt C O II A.
not_eq_4pt O Q A B.
not_eq_4pt Q II B C.

assert (Col R1 M N) by
  hexamy_proof C B A O II Q C O Q II A B.

geo_norm.

not_eq C' Q.
not_eq C' II.
not_eq Q L.
not_eq O L.

not_eq_4pt C' B' O II.
not_eq_4pt B' Q II L.
not_eq_4pt Q O L C'.
not_eq_4pt C' O II L.
not_eq_4pt O Q L B'.
not_eq_4pt Q II B' C'.
not_eq L C'.

assert (Col R2 M N) by
  hexamy_proof C' B' Q O II L C' O Q II L B'.

geo_norm.

cases_line x1 x2.
auto.

collapse.
intuition.

subst R2.
geo_norm;collapse;solve_col.
Qed.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.UpwardsSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Sound_Upwards.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        (M: Kmodel)
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {kminSM: KripkeMinimunSemantics L MD M SM}
        {kpSM: KripkePropositionalSemantics L MD M SM}
        {usSM: UpwardsSemantics.SeparatingSemantics L MD M SM}.

Lemma sound_sepcon_comm:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m1 [m2 [? [? ?]]]].
  exists m2, m1.
  split; [| split]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp.
  split; intros.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [mx [myz [? [? ?]]]].
    rewrite sat_sepcon in H2.
    destruct H2 as [my [mz [? [? ?]]]].
    apply join_comm in H0.
    apply join_comm in H2.
    destruct (join_assoc mz my mx myz n H2 H0) as [mxy [? ?]].
    apply join_comm in H5.
    apply join_comm in H6.
    rewrite sat_sepcon.
    exists mxy, mz.
    split; [| split]; auto.
    rewrite sat_sepcon.
    exists mx, my.
    split; [| split]; auto.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [mxy [mz [? [? ?]]]].
    rewrite sat_sepcon in H1.
    destruct H1 as [mx [my [? [? ?]]]].
    destruct (join_assoc mx my mz mxy n H1 H0) as [myz [? ?]].
    rewrite sat_sepcon.
    exists mx, myz.
    split; [| split]; auto.
    rewrite sat_sepcon.
    exists my, mz.
    split; [| split]; auto.
Qed.

Lemma sound_wand_sepcon_adjoint:
  forall x y z: expr,
    (forall m, KRIPKE: M, m |= x * y --> z) <-> (forall m, KRIPKE: M, m |= x --> (y -* z)).
Proof.
  intros.
  split; intro.
  + assert (ASSU: forall m1 m2 m, join m1 m2 m -> KRIPKE: M, m1 |= x -> KRIPKE: M, m2 |= y -> KRIPKE: M, m |= z).
    Focus 1. {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      apply (H m); [reflexivity |].
      rewrite sat_sepcon.
      exists m1, m2; auto.
    } Unfocus.
    clear H.
    intros.
    rewrite sat_impp; intros.
    rewrite sat_wand; intros.
    apply (ASSU m0 m1 m2); auto.
    eapply sat_mono; eauto.
  + assert (ASSU: forall m0 m1 m2 m, m <= m0 -> join m0 m1 m2 -> KRIPKE: M, m |= x -> KRIPKE: M, m1 |= y -> KRIPKE: M, m2 |= z).
    Focus 1. {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      revert m0 m1 m2 H0 H1 H3.
      rewrite <- sat_wand.
      apply (H m); [reflexivity | auto].
    } Unfocus.
    intros.
    rewrite sat_impp; intros.
    rewrite sat_sepcon in H1.
    destruct H1 as [m1 [m2 [? [? ?]]]].
    apply (ASSU m1 m2 n m1); auto.
    reflexivity.
Qed.

Lemma sound_sepcon_mono:
  forall x1 x2 y1 y2: expr,
   (forall m, KRIPKE: M, m |= x1 --> x2) ->
   (forall m, KRIPKE: M, m |= y1 --> y2) ->
   (forall m, KRIPKE: M, m |= x1 * y1 --> x2 * y2).
Proof.
  intros.
  assert (ASSUx: forall m, KRIPKE: M, m |= x1 -> KRIPKE: M, m |= x2).
  Focus 1. {
    intros.
    specialize (H m0).
    rewrite sat_impp in H.
    apply (H m0); [reflexivity | auto].
  } Unfocus.
  assert (ASSUy: forall m, KRIPKE: M, m |= y1 -> KRIPKE: M, m |= y2).
  Focus 1. {
    intros.
    specialize (H0 m0).
    rewrite sat_impp in H0.
    apply (H0 m0); [reflexivity | auto].
  } Unfocus.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H2 |- *.
  destruct H2 as [m1 [m2 [? [? ?]]]].
  exists m1, m2; auto.
Qed.

Lemma sound_sepcon_elim1 {incrSA: IncreasingSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x * y --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [m1 [m2 [? [? ?]]]].
  apply join_comm in H0.
  apply all_increasing in H0.
  eapply sat_mono; eauto.
Qed.

Context {s'L: SeparationEmpLanguage L}
        {ueSM: UpwardsSemantics.EmpSemantics L MD M SM}.

Lemma sound_sepcon_emp {USA': UnitalSeparationAlgebra' (Kworlds M)}:
  forall x: expr,
    forall m, KRIPKE: M, m |= x * emp <--> x.
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp.
  split.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [n' [u [? [? ?]]]].
    rewrite sat_emp in H2.
    apply join_comm in H0.
    unfold increasing in H2.
    specialize (H2 _ ltac:(reflexivity) _ _ H0).
    eapply sat_mono; eauto.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon.
    destruct (incr'_exists n) as [u [? ?]].
    destruct H1 as [n' [H1 H1']].
    exists n', u.
    split; [| split]; auto.
    - apply join_comm; auto.
    - eapply sat_mono; eauto.
    - rewrite sat_emp; eauto.
Qed.

End Sound_Upwards.

(*****************************************)
(* For SL extension                      *)
(*****************************************)

(*
Definition unique_cancel {worlds: Type} {kiM: KripkeIntuitionisticModel worlds} {J: Join worlds} (P: worlds -> Prop): Prop :=
  forall n,
    (exists n1 n2, P n1 /\ join n1 n2 n) ->
    (exists n1 n2, P n1 /\ join n1 n2 n /\
       forall n1' n2', (P n1' /\ join n1' n2' n) -> n2 <= n2').

Lemma sound_precise_sepcon {L: Language} {nL: NormalLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {nSA: SeparationAlgebra (Kworlds M)} {dSA: UpwardsClosedSeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {usSM: UpwardsSemantics.SeparatingSemantics L MD M SM}:
  forall x y,
    unique_cancel (fun m => KRIPKE: M, m |= x) ->
    unique_cancel (fun m => KRIPKE: M, m |= y) ->
    unique_cancel (fun m => KRIPKE: M, m |= x * y).
Proof.
  pose proof Korder_PreOrder as H_PreOrder.
  intros.
  hnf; intros.
  destruct H1 as [nxy [n_res [? ?]]].
  rewrite sat_sepcon in H1.
  destruct H1 as [nx [ny [? [? ?]]]].
  destruct (join_assoc _ _ _ _ _ H1 H2) as [nyr [? ?]].
  destruct (H n (ex_intro _ nx (ex_intro _ nyr (conj H3 H6))))
    as [nx' [nyr' [? [? ?]]]].
  pose proof H9 _ _ (conj H3 H6).
  destruct (join_Korder_up _ _ _ _ H5 H10) as [ny' [n_res' [? [? ?]]]].
  eapply sat_mono in H4; [| exact H12].
  destruct (H0 nyr' (ex_intro _ ny' (ex_intro _ n_res' (conj H4 H11))))
    as [ny'' [n_res'' [? [? ?]]]].

  clear nx ny nxy n_res nyr H1 H2 H3 ny' n_res' H5 H6 H10 H11 H12 H13 H4.
  rename nx' into nx, nyr' into nyr, ny'' into ny, n_res'' into nr.
  destruct (join_assoc _ _ _ _ _ (join_comm _ _ _ H15) (join_comm _ _ _ H8))
    as [nxy [? ?]].
  apply join_comm in H1.
  apply join_comm in H2.

  exists nxy, nr.
  split; [rewrite sat_sepcon; eauto | split; [auto |]].

  clear H7 H8 H14 H15 H1 H2.
  intros nxy' nr' [? ?].
  rewrite sat_sepcon in H1.
  destruct H1 as [nx' [ny' [? [? ?]]]].
  destruct (join_assoc _ _ _ _ _ H1 H2) as [nyr' [? ?]].
  specialize (H9 _ _ (conj H3 H6)).
  destruct (join_Korder_up _ _ _ _ H5 H9) as [ny'' [nr'' [? [? ?]]]].
  eapply sat_mono in H4; [| exact H8].
  specialize (H16 _ _ (conj H4 H7)).
  etransitivity; eassumption.
Qed.
*)
(*
(* This is over generalization, i.e. the soundness of pure_fact_andp needs extra restriction on models. *)

Definition join_inv {worlds: Type} {kiM: KripkeIntuitionisticModel worlds} {J: Join worlds} (P: worlds -> Prop): Prop :=
  (forall n1 n2 n, join n1 n2 n -> P n ->
     exists n1' n2', join n1' n2' n /\ n1' <= n1 /\ n2' <= n2 /\ P n1') /\
  (forall n1 n2 n, join n1 n2 n -> P n1 -> P n).

Lemma sound_andp_sepcon {L: Language} {nL: NormalLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {nSA: SeparationAlgebra (Kworlds M)} {dSA: UpwardsClosedSeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {usSM: UpwardsSemantics.SeparatingSemantics L MD M SM}:
  forall x y z,
    join_inv (fun m => KRIPKE: M, m |= x) ->
    forall m,
      KRIPKE: M, m |= (x && (y * z)) <--> ((x && y) * z).
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp, !sat_impp; split; intros ? _ ?; clear m.
  + rewrite sat_andp in H0; destruct H0.
    rewrite sat_sepcon in H1; destruct H1 as [ny [nz [? [? ?]]]].
    destruct H as [? _].
    specialize (H _ _ _ H1 H0).
    destruct H as [ny' [nz' [? [? [? ?]]]]].
    rewrite sat_sepcon; exists ny', nz'.
    split; [| split]; auto.
    - rewrite sat_andp; split; auto.
      eapply sat_mono; eauto.
    - eapply sat_mono; eauto.
  + rewrite sat_sepcon in H0; destruct H0 as [ny [nz [? [? ?]]]].
    rewrite sat_andp in H1; destruct H1.
    rewrite sat_andp; split.
    - destruct H as [_ ?].
      apply (H _ _ _ H0 H1).
    - rewrite sat_sepcon; exists ny, nz.
      auto.
Qed.

*)


Require Import List.
Require Import Sumbool.

Definition atat {A B:Type} (f: A -> B) x := f x.
Infix "@@" := atat (at level 60).

Definition doll {A B C: Type} (g: B -> C) (f: A -> B) (x: A) := g (f x).
Infix "$" := doll (at level 60).

(* Eliminate element in list if the element is false with f *)
Fixpoint filter_dec {A : Type} {P Q: A -> Prop}
  (f : forall x, {P x} + {Q x}) (l:list A) : list A :=
  match l with
  | nil => nil
  | x :: l => if (f x) then x::(filter_dec f l) else filter_dec f l
  end.

Lemma filter_dec_In : forall {A: Type} {P Q: A -> Prop} (f : forall x, {P x} + {Q x}) (x:A) (l: list A),
  In x (filter_dec f l) -> In x l /\ P x.
Proof.
intros A P Q f.
 induction l; simpl.
  intro H; elim H.

  case (f a); simpl in |- *.
   intros H _H; elim _H; intros.
    split; [ left | rewrite <- H0 in |- * ]; assumption.

    elim (IHl H0); intros.
    split; [ right | idtac ]; assumption.

   intros _ H; elim (IHl H); intros.
   split; [ right | idtac ]; assumption.
Qed.

Lemma filter_dec_length : forall {A: Type} {P Q: A -> Prop} (f : forall x, {P x} + {Q x}) (xs: list A),
  length (filter_dec f xs) <= length xs.
Proof.
intros A P Q f xs; induction xs; simpl.
 apply Le.le_refl.

 case (f a); intro; simpl.
  apply Le.le_n_S; apply IHxs.

  apply le_S; apply IHxs.
Qed.

Lemma filter_dec_In_not1 : forall {A: Type} {P: A -> Prop} (f : forall x, {P x} + {~P x}) (x:A) (xs: list A),
  In x xs -> P x -> In x (filter_dec f xs).
Proof.
intros A P f x xs; induction xs; simpl.
intro H; elim H.
intros.
case (f a).

elim H; intro HH; [rewrite HH; left; reflexivity | right; apply (IHxs HH H0)].
elim H; intro HH; [rewrite HH; intro HH0; elim HH0; apply H0 | intros _; apply (IHxs HH H0)].
Qed.

Lemma filter_dec_In_not2 : forall {A: Type} {P: A -> Prop} (f : forall x, {~P x} + {P x}) (x:A) (xs: list A),
  In x xs -> ~ P x -> In x (filter_dec f xs).
Proof.
intros A P f x xs; induction xs; simpl.
intro H; elim H.
intros.
case (f a).

elim H; intro HH; [rewrite HH; left; reflexivity | right; apply (IHxs HH H0)].
elim H; intro HH; [rewrite HH; intro HH0; elim H0; apply HH0 | intros _; apply (IHxs HH H0)].
Qed.

Section Equiv.
  Variable A : Type.
  Variable R : A -> A -> Prop.

  Variable R_refl : forall x, R x x.

  Section EquivAux.
    Variable neqdec : forall (x y: A), {~R x y} + {R x y}.
    Require Import Recdef.
    Function div_equiv_aux (xs : list A) {measure length xs} : list A :=
      match xs with
      | nil => nil
      | x :: xs => x :: div_equiv_aux (filter_dec (neqdec x) xs)
    end.
    intros.
    simpl.
    apply Lt.le_lt_n_Sm.
    apply filter_dec_length.
    Defined.

    Lemma div_In_aux : forall (x:A) (xs: list A),
      In x xs -> exists x':A, R x' x /\ In x' (div_equiv_aux xs).
    Proof.
    intros x xs; functional induction (div_equiv_aux xs).

     intro H; elim H.

     intro H0; elim H0; intro H.
     rewrite H; exists x.
     split; [apply R_refl | left; reflexivity].

     case (neqdec x0 x); intro HH.

      elim (IHl (filter_dec_In_not2 (neqdec x0) _ _ H HH)).
      intros x' _H; inversion _H; exists x'.
      split; [apply H1 | right; apply H2].

     exists x0; split; [apply HH | left; reflexivity].
    Qed.

    Lemma div_In_incl_aux : forall (x:A) (xs: list A),
      In x (div_equiv_aux xs) -> In x xs.
    Proof.
    intros x xs; functional induction (div_equiv_aux xs).
     intro H; elim H.

     simpl; intro _H; elim _H; intro HH; [left; apply HH | right].

     elim (filter_dec_In _ _ _ (IHl HH)).
     intros H1 _; apply H1.
    Qed.
  End EquivAux.

  Variable eqdec : forall (x y: A), {R x y} + {~R x y}.
  Definition div_equiv xs := div_equiv_aux (fun x y => sumbool_not _ _ (eqdec x y)) xs.

  Lemma div_In : forall (x:A) (xs: list A),
    In x xs -> exists x':A, R x' x /\ In x' (div_equiv xs).
  Proof.
  apply div_In_aux.
  Qed.
  Lemma div_In_incl : forall (x:A) (xs: list A),
    In x (div_equiv xs) -> In x xs.
  Proof.
  apply div_In_incl_aux.
  Qed.
End Equiv.
Implicit Arguments div_equiv [A R].