Load "DH_AUTH".

(******dec of encryption is plaintext****)

Axiom dep_enc :  forall(n:nat) (x z :message), (dec (enc x (pk n) z) (sk n)) # x.

(********************************check if (r n) occurs**************************************)
(******************************* return TRUE if (r n) occurs, FALSE otherwise***************)

Eval compute in (r 1).
Fixpoint  rn_occ_bol (n:nat) (t:Bool) : bool :=
 match t with
| Bvar n' =>  false
| FAlse =>  false
| TRue => false
| EQ_B  b1 b2 =>  (orb (rn_occ_bol n b1)  (rn_occ_bol n b2))
| EQ_M t1 t2 => orb (rn_occ_msg n t1) (rn_occ_msg n t2)
|if_then_else_B t1 t2 t3 => orb (rn_occ_bol n t1)(orb (rn_occ_bol n t2)(rn_occ_bol n t3) )
| EQL t1 t2 => orb (rn_occ_msg n t1) (rn_occ_msg n t2)
| ver t1 t2 t3 => (orb  (orb (rn_occ_msg n t1) (rn_occ_msg n t2)) (rn_occ_msg n t3))
 end
with rn_occ_msg (n:nat) (t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => orb (rn_occ_bol n b3) (orb (rn_occ_msg n  t1)(rn_occ_msg n t2))
| (Mvar n') =>  false
| O => false
| acc =>  false
| N n'=> false
|new =>  false
|exp t1 t2 t3 => orb (rn_occ_msg n t1) (orb ( rn_occ_msg  n t2) (rn_occ_msg n t3))
| pair t1 t2 => orb ( rn_occ_msg n t1) ( rn_occ_msg n t2)
| pi1 t1 => ( rn_occ_msg n t1)
| pi2 t1 =>  ( rn_occ_msg n t1)
| ggen t1 => ( rn_occ_msg n t1)
| act t1 => ( rn_occ_msg n t1)
| (rr t1 ) => (rn_occ_msg n t1)
| rs t1 =>  match t1 with
               | (N n') => if (beq_nat n' n) then true else false
               | _ => (rn_occ_msg n t1)
              end
| L t1 => (rn_occ_msg n t1)
| m t1 => (rn_occ_msg n t1)
|enc t1 t2 t3 =>  orb ( rn_occ_msg n t1) (orb ( rn_occ_msg n t2) ( rn_occ_msg n t3))
|dec t1 t2 => orb (rn_occ_msg n t1) (rn_occ_msg n t2)
| k t1 => (rn_occ_msg n t1)
| nonce t1 => (rn_occ_msg n t1)
 | to t1 => (rn_occ_msg n t1)
| reveal t1 => (rn_occ_msg n t1)
| sign t1 t2 => (orb (rn_occ_msg n t1) (rn_occ_msg n t2))
| i n' => false
| f  l => (@existsb message (rn_occ_msg n) l)
end.

Eval compute in rn_occ_msg 1 ((rs (N 2))  ).

(*********In a term os*****************************)

Definition rn_occ_os (n:nat)(t:oursum): bool :=
match t with
|bol b =>rn_occ_bol n b
|msg t =>rn_occ_msg n t
end.
(*
(**** In a message list: ilist message n********)

Fixpoint rn_occ_mlist {m:nat}(x:nat) (ml : ilist message m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (rn_occ_msg x h) (rn_occ_mlist x ml1))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint rn_occ_blist {m:nat}(x:nat) (ml : ilist Bool m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (rn_occ_bol x h) (rn_occ_blist x ml1))
end.
*)
(********In a mylist : mylist n********)

Fixpoint rn_occ_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => false
| h :: ml1 => (orb (rn_occ_os x h) (rn_occ_mylist x ml1))
end.
(****************************************************************************************)
(********************returns TRUE if a term sk(n) occur, FALSE otherwise *********)

(*********************In a term : message and Bool********)
Fixpoint  skn_occ_bol (n:nat) (t:Bool) : bool :=
 match t with
| Bvar n' =>  false
| FAlse =>  false
| TRue => false
| EQ_B  b1 b2 =>  (orb (skn_occ_bol n b1)  (skn_occ_bol n b2))
| EQ_M t1 t2 => orb (skn_occ_msg n t1) (skn_occ_msg n t2)
|if_then_else_B t1 t2 t3 => orb (skn_occ_bol n t1)(orb (skn_occ_bol n t2)(skn_occ_bol n t3) )
| EQL t1 t2 => orb (skn_occ_msg n t1) (skn_occ_msg n t2)
| ver t1 t2 t3 => (orb  (orb (skn_occ_msg n t1) (skn_occ_msg n t2)) (skn_occ_msg n t3))
 end
with skn_occ_msg (n:nat) (t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => orb (skn_occ_bol n b3) (orb (skn_occ_msg n  t1)(skn_occ_msg n t2))
| (Mvar n') =>  false
| O => false
| acc =>  false
| N n'=> false
|new =>  false
|exp t1 t2 t3 => orb (skn_occ_msg n t1) (orb ( skn_occ_msg  n t2) (skn_occ_msg n t3))
| pair t1 t2 => orb ( skn_occ_msg n t1) ( skn_occ_msg n t2)
| pi1 t1 => ( skn_occ_msg n t1)
| pi2 t1 => match t1 with
             | k (N n') => if (beq_nat n' n) then true else false
             | _ => false
               end
| ggen t1 => ( skn_occ_msg n t1)
| act t1 => ( skn_occ_msg n t1)
| rr n' => false
| rs t1 => (skn_occ_msg n t1)
| L t1 => (skn_occ_msg n t1)
| m t1 => (skn_occ_msg n t1)
|enc t1 t2 t3 =>  orb ( skn_occ_msg n t1) (orb ( skn_occ_msg n t2) ( skn_occ_msg n t3))
|dec t1 t2 => orb (skn_occ_msg n t1) (skn_occ_msg n t2)
| k t1 => (skn_occ_msg n t1)
| nonce t1 => (skn_occ_msg n t1)
 | to t1 => (skn_occ_msg n t1)
| reveal t1 => (skn_occ_msg n t1)
| sign t1 t2 => (orb (skn_occ_msg n t1) (skn_occ_msg n t2))
| i n' => false
| f  l => (@existsb message (skn_occ_msg n) l)
end.

Eval compute in skn_occ_msg 1 ((pi2(k (N 1)))  ).

(*********In a term os*****************************)

Definition skn_occ_os (n:nat)(t:oursum): bool :=
match t with
|bol b =>skn_occ_bol n b
|msg t =>skn_occ_msg n t
end.
(*
(**** In a message list: ilist message n********)

Fixpoint skn_occ_mlist {m:nat}(x:nat) (ml : ilist message m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (skn_occ_msg x h) (skn_occ_mlist x ml1))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint skn_occ_blist {m:nat}(x:nat) (ml : ilist Bool m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (skn_occ_bol x h) (skn_occ_blist x ml1))
end.
*)
(********In a mylist : mylist n********)

Fixpoint skn_occ_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (skn_occ_os x h) (skn_occ_mylist x ml1))
end.

(********* returns TRUE if skn occurs only as dec(_, (sk n))  FALSE otherwise *********)

(*********************In a term : message and Bool********)

Fixpoint  skn_in_dec_bol (n : nat )(t:Bool) : bool :=
 match t with
| Bvar n' => true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  (andb ( skn_in_dec_bol n b1)  (skn_in_dec_bol n b2))
| EQ_M t1 t2 => andb (skn_in_dec_msg n t1) ( skn_in_dec_msg n t2)
| if_then_else_B t1 t2 t3 => andb ( skn_in_dec_bol n t1)  (andb (skn_in_dec_bol n t2)(skn_in_dec_bol n t3) )
| EQL t1 t2 => andb (skn_in_dec_msg n t1) ( skn_in_dec_msg n t2)
| ver t1 t2 t3 => (andb  (andb (skn_in_dec_msg n t1) (skn_in_dec_msg n t2)) (skn_in_dec_msg n t3))
 end
with skn_in_dec_msg (n : nat )(t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => andb (skn_in_dec_bol n b3) (andb ( skn_in_dec_msg n  t1)(skn_in_dec_msg n t2))
| (Mvar n') =>  if (beq_nat n' n) then false else true
| O => true
| acc => true
| N n'=> true
|new => true
| exp t1 t2 t3 => andb ( skn_in_dec_msg n t1) (andb (  skn_in_dec_msg  n t2) ( skn_in_dec_msg n t3))
| pair t1 t2 => andb (  skn_in_dec_msg n t1) (  skn_in_dec_msg n t2)
| pi1 t1 => (  skn_in_dec_msg n t1)
| pi2 t1 => match t1 with
             | k t2 => match t2 with
                       | N n' => if (beq_nat n' n) then false else true
                       | _ => true
                         end
             | _ => true

               end

| ggen t1 => (  skn_in_dec_msg n t1)
| act t1 => (  skn_in_dec_msg n t1)
| rr n' =>  true
| rs t1 => ( skn_in_dec_msg n t1)
| L t1 => ( skn_in_dec_msg n t1)
| m t1 => ( skn_in_dec_msg n t1)
|enc t1 t2 t3 =>  andb (  skn_in_dec_msg n t1) (andb (  skn_in_dec_msg n t2) (  skn_in_dec_msg n t3))
|dec t1 t2 => match t2 with
             | (pi2 (k (N n'))) => if (beq_nat n' n) then (andb true (skn_in_dec_msg n t1))  else true
             | t2' => (skn_in_dec_msg n t1)
              end
| k t1 => (skn_in_dec_msg n t1)
| nonce t1 => (skn_in_dec_msg n t1)
| to t1 => (skn_in_dec_msg n t1)
| reveal t1 => ( skn_in_dec_msg n t1)
| sign t1 t2 => (andb ( skn_in_dec_msg n t1) ( skn_in_dec_msg n t2))
| i n' => true
| f  l => (@forallb message (skn_in_dec_msg n) l)
end.

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

Eval compute in skn_in_dec_msg 1 (k(N 1)).
Eval compute in skn_in_dec_msg 1 (dec (pi2(k (N 2))) O ).

Eval compute in skn_in_dec_msg 1 (r  2).
(*********In a term os*****************************)

Definition skn_in_dec_os (n:nat)(t:oursum): bool :=
match t with
|bol b => skn_in_dec_bol n b
|msg t => skn_in_dec_msg n t
end.
(*
(**** In a message list: ilist message n********)

Fixpoint skn_in_dec_mlist {m:nat}(x:nat) (ml : ilist message m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_msg x h) (skn_in_dec_mlist x ml1))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint skn_in_dec_blist {m:nat}(x:nat) (ml : ilist Bool m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_bol x h) (skn_in_dec_blist x ml1))
end.
*)
(********In a mylist : mylist n********)

Fixpoint skn_in_dec_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_os x h) (skn_in_dec_mylist x ml1))
end.

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

(********return TRUE if the term dec(t , sk(n)) occurs, FALSE otherwise *********)

(*********************In a term : message and Bool********)

Fixpoint  dect_skn_bol (n:nat) (t:message)(k:Bool) : bool :=
 match k with
| Bvar n' =>  false
| FAlse => false
| TRue => false
| EQ_B  b1 b2 =>  (orb ( dect_skn_bol n t b1)  (dect_skn_bol n t b2))
| EQ_M t1 t2 => orb (dect_skn_msg n t t1) ( dect_skn_msg n t t2)
| if_then_else_B t1 t2 t3 => orb ( dect_skn_bol n t t1)  (orb (dect_skn_bol n t t2)(dect_skn_bol n t t3) )
| EQL t1 t2 => orb (dect_skn_msg n t t1) ( dect_skn_msg n t t2)
| ver t1 t2 t3 => (orb  (orb (dect_skn_msg n t t1) (dect_skn_msg n t t2)) (dect_skn_msg n t t3))
 end
with dect_skn_msg (n:nat) (t:message) (k:message) : bool :=
 match k with
| if_then_else_M b3 t1 t2 => orb (dect_skn_bol n t b3) (orb ( dect_skn_msg n t  t1)(dect_skn_msg n t t2))
| (Mvar n') =>  false
| O =>  false
| acc =>  false
| N n'=>  false
|new => false
| exp t1 t2 t3 => orb ( dect_skn_msg n t t1) (orb (  dect_skn_msg  n t t2) ( dect_skn_msg n t t3))
| pair t1 t2 => orb (  dect_skn_msg n t t1) (  dect_skn_msg n t t2)
| pi1 t1 => (  dect_skn_msg n t t1)
| pi2 t1 => (dect_skn_msg n t t1)
| ggen t1 => (  dect_skn_msg n t t1)
| act t1 => (  dect_skn_msg n t t1)
| rr n' => false
| rs t1 => ( dect_skn_msg n t t1)
| L t1 => ( dect_skn_msg n t t1)
| m t1 => ( dect_skn_msg n  t t1)
|enc t1 t2 t3 =>  orb (  dect_skn_msg n t t1) (orb (  dect_skn_msg n t t2) (  dect_skn_msg n t t3))
|dec t1 t2 =>  match (check_eq_msg t1 t) , t2  with
              | true , pi2(k (N n')) => if (beq_nat n' n) then true else false
              | _ , _ => false

                   end

| k t1 => (dect_skn_msg n t t1)
| nonce t1 => (dect_skn_msg n t t1)
 | to t1 => (dect_skn_msg n t t1)
| reveal t1 => ( dect_skn_msg n t t1)
| sign t1 t2 => (orb ( dect_skn_msg n t t1) ( dect_skn_msg n t t2))
| i n' => false
| f  l => (@existsb message (dect_skn_msg n t) l)

end.

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

Eval compute in dect_skn_msg 1 O (dec (f [O;O]) (pi2 (k (N 1)))).

(*********In a term os*****************************)

Definition  dect_skn_os (n:nat)(t:message)(k:oursum): bool :=
match k with
|bol b => dect_skn_bol n t b
|msg t1 => dect_skn_msg n t t1
end.

(**** In a message list: ilist message n********)

Fixpoint dect_skn_mlist (x:nat) (t:message) (ml : list message):bool :=
match ml with
| nil  => true
| cons h tl => (orb (dect_skn_msg x t h) (dect_skn_mlist x  t tl ))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint dect_skn_blist (x:nat) (t:message)(ml : list Bool ):bool :=
match ml with
| nil => true
| cons h tl => (orb (dect_skn_bol x t h) (dect_skn_blist x t tl))
end.

(********In a mylist : mylist n********)

Fixpoint dect_skn_mylist {m:nat}(x:nat)(t:message) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (orb (dect_skn_os x t h) (dect_skn_mylist x t ml1))
end.

(********return TRUE if n occur only as (k n) FALSE otherwise *********)

(*********************In a term : message and Bool********)

Fixpoint  n_kn_bol (n:nat) (k:Bool) : bool :=
 match k with
| Bvar n' =>  if (beq_nat n' n) then false else true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  (andb ( n_kn_bol n  b1)  (n_kn_bol n  b2))
| EQ_M t1 t2 => (andb (n_kn_msg n  t1) ( n_kn_msg n  t2))
| if_then_else_B t1 t2 t3 => andb ( n_kn_bol n  t1)  (andb (n_kn_bol n  t2)(n_kn_bol n  t3) )
| EQL t1 t2 => andb (n_kn_msg n  t1) ( n_kn_msg n  t2)
| ver t1 t2 t3 => (andb  (andb (n_kn_msg n  t1) (n_kn_msg n  t2)) (n_kn_msg n  t3))
 end
with n_kn_msg (n:nat)  (k:message) : bool :=
 match k with
| if_then_else_M b3 t1 t2 => andb (n_kn_bol n b3) (andb ( n_kn_msg n  t1)(n_kn_msg n t2))
| (Mvar n') => if (beq_nat n' n) then false else true
| O =>  true
| acc =>  true
| N n'=>  true
|new =>  true
| exp t1 t2 t3 => andb ( n_kn_msg n  t1) (andb (  n_kn_msg  n  t2) ( n_kn_msg n  t3))
| pair t1 t2 => andb (  n_kn_msg n  t1) (  n_kn_msg n  t2)
| pi1 t1 => (  n_kn_msg n  t1)
| pi2 t1 => (n_kn_msg n  t1)
| ggen t1 => (  n_kn_msg n  t1)
| act t1 => (  n_kn_msg n  t1)
| rr t1 => match t1 with
            | N n' =>  if (beq_nat n' n) then false else true
            | _ => (n_kn_msg n t1)
             end
| rs t1 => ( n_kn_msg n  t1)
| L t1 => ( n_kn_msg n  t1)
| m t1 => ( n_kn_msg n   t1)
|enc t1 t2 t3 =>  orb (  n_kn_msg n  t1) (orb (  n_kn_msg n  t2) (  n_kn_msg n  t3))
|dec t1 t2 => (orb (n_kn_msg n t1) (n_kn_msg n t2))
| k t1 => (n_kn_msg n  t1)
| nonce t1 => (n_kn_msg n  t1)
 | to t1 => (n_kn_msg n  t1)
| reveal t1 => ( n_kn_msg n  t1)
| sign t1 t2 => (orb ( n_kn_msg n  t1) ( n_kn_msg n  t2))
| i n' => if (beq_nat n' n) then false else true
| f  l => (@forallb message (n_kn_msg n ) l)

end.

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

Eval compute in n_kn_msg 1  (dec (f [O;O]) (pi2 (k (N 1)))).

(*********In a term os*****************************)

Definition  n_kn_os (n:nat)(k:oursum): bool :=
match k with
|bol b => n_kn_bol n  b
|msg t1 => n_kn_msg n t1
end.
(*
(**** In a message list: ilist message n********)

Fixpoint n_kn_mlist (x:nat) (t:message) (ml : list message):bool :=
match ml with
| nil  => true
| cons h tl => (orb (n_kn_msg x t h) (n_kn_mlist x  t tl ))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint n_kn_blist (x:nat) (t:message)(ml : list Bool ):bool :=
match ml with
| nil => true
| cons h tl => (orb (n_kn_bol x t h) (n_kn_blist x t tl))
end.
*)
(********In a mylist : mylist n********)

Fixpoint n_kn_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (n_kn_os x  h) (n_kn_mylist x  ml1))
end.

(********************ENCCPA*******************************************)
(*********************************************************************)
Eval compute in r.

Axiom ENCCPA: forall (u u' u'': message) (n n1 n2 n3 :nat){m} (l:mylist m), ( (var_free_mylist n l) = true) /\ (clos_listm [u; u'; u''] = true) /\ ((rn_occ_mylist n2 l) = false) /\ ((rn_occ_mylist n3 l) = false)/\ (( skn_in_dec_mylist n1 l) = true) /\  (skn_occ_mylist n1  ((submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n2))) u'') l) ++
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n3))) u'') l)) = false)  -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n2))) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n3))) u'') l).

(********************ENCCCA1*****************************************)
(********************************************************************)

Axiom ENCCCA1 : forall (t u u' u'': message) (n n1 n2 n3 :nat){m} (l :mylist m), (var_free_msg n t = true) /\ (var_free_mylist n l = true) /\ (clos_listm [u; u'; u''] = true) /\ ((rn_occ_mylist n2 l) = false) /\ ((rn_occ_mylist n3 l) = false)/\ (( skn_in_dec_mylist n1 l) = true)  /\ (dect_skn_mlist n1 t  (subtrmls_mylist  l ) = false) -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n2))) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n3))) u'') l).
(**********************ENCCCA2*************************************)
(******************************************************************)
(**((rn_occ_mylist n2 l) = false) /\ ((rn_occ_mylist n3 l) = false)  /\ (( skn_in_dec_mylist n1 l) = true) /\ ((dect_skn_mlist n1 t  (subtrmls_mylist  l ) = true) ->  exists t'', (var_free_msg n t'' = true) /\ (dec t (sk n1)) # (if_then_else_M (EQ_M t (Mvar n)) & (EQ_M (L u) (L u')) t'' (dec t (sk n1))))**)

Eval compute in occmsg_in_msg (dec O (sk 1)) (if_then_else_M (EQ_M O (Mvar 1)) & (EQ_M (L O) (L O)) O (dec O (sk 1))).
Fixpoint sup_trm  (t:message) {n}  (l':mylist n)  : list message :=
match l'  with
| [] => nil
| h :: tl =>
             if (occmsg_in_msg t (ostomsg h)) then (cons (ostomsg h) (sup_trm t  tl )) else (sup_trm t  tl )
end.

Eval compute in sup_trm O   [msg O; msg ( O); msg O ; msg (N 1)].

Fixpoint trm_listm (t:message) (l:list message): bool :=
match l with
| nil => true
| cons h tl => (andb (occmsg_in_msg t h) (trm_listm t tl))
end.

Axiom ENCCCA2 : forall (t t'' t''' u u' u'': message) (n n1 n2 n3 :nat){m} (l :mylist m), (var_free_mylist n ([msg t ; msg t''] ++ l) = true) /\ (clos_listm [u; u'; u''] = true) /\ ( (dect_skn_mlist n1 t  (subtrmls_mylist  l ) = true) -> ((occmsg_in_msg t t''') = true) /\ (trm_listm (if_then_else_M (EQ_M t (Mvar n)) (* (EQ_M (L u) (L u'))*) t'' t''') (sup_trm (dec t (sk n1)) l) = true)) /\ (rn_occ_mylist n2 l = false) /\ (rn_occ_mylist n3 l = false) -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (rs (N n2))) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u' (pk n1) (rs (N n3))) u'') l).
(*
(*********************ENCCA2***************************************)
(******************************************************************)
Abort All.
Section comp.
Variable m n r :nat.
Variable u u' t' t'' :message.
Variable l : list message.
Variable comp: nat-> nat -> message -> message -> message -> message  -> message -> bool.
Fixpoint check_comp (l:list message) : bool :=
match l with
| nil => true
| cons h t => (andb (comp m n u u' t' t'' h) (check_comp t))
end.
End comp.
Check check_comp.

Fixpoint nuu'cca2 (m n:nat) ( u u'  t' t'' t :message) : bool  :=
match (var_free_msg m t)  with
| true =>  match (clos_msg t) with
           | true => (check_eq_msg t (N n))
           | false => match (check_eq_msg t (pk n)) with
                       | true =>  true
                       | false => match (check_eq_msg t (Mvar m)) with
                                  | true => true
                                  | false => match t  with
                                               | f l => match  (@check_comp m n u u' t' t'' nuu'cca2 l) with
                                                                  | true =>  (var_free_msg m t') && (negb (check_eq_msg t (dec t' (pi2 (k (N n))))))

                                                                   | false =>  false
                                                                   end
                                               | _ =>       match (var_free_mylist  m  [msg t'; msg t'']) with
                                                            | true =>

 match t with
| (if_then_else_M b t5 t''') => match b with
                                  | (if_then_else_B b1 b2 FAlse) => match (check_eq_bol b1 (EQ_M t' (Mvar n))) with
                                                                    |  true =>
                                                                        match b2 with
                                                                          | (EQ_M (L u) (L u')) => (check_eq_msg t''' (dec t' (pi2 (k (N n)))))  && (check_eq_msg t5 t'') && (nuu'cca2 m n u u' t' t'' t5)

       | _                         => false
end

| false => false

end

|  _ => false

end

| _  => false
end
| _ => false

end
end
end
end
end
| false => false
end.

(*************check if every element of list is nuu' compliant****************************)

Fixpoint list_nuu'  {s} (m n:nat) (u u'  t' t'' :message) (l: mylist s) : bool :=
match l with
| [] => true
| h :: t => (andb (match h with
             | msg t1 =>  (nuu'cca2 m n u u'  t' t'' t1)
             | _ => true
               end) (list_nuu' m n u u'  t' t'' t))
end.

Axiom ENCCCA2: forall (t' t'' u u' u'': message) (n n1 n2 n3 m :nat) (l:mylist m),  (var_free_mylist m ([msg t'; msg t''] ++ l) = true) /\  ((notocc_dec_mlist n1 t'  (subterm_list_mylist  l ) = false) ->  (dec t' (sk n1)) # (if_then_else_M  ((EQ_M t'  (Mvar 2))& (EQ_M (L u) (L u'))) t'' (dec t' (sk n1)))) -> ((list_nuu' m n u u' t' t'' l) = true) ->
 (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l). *)
(*****nonce and key generation ******)
Variable lnonce : message.
Axiom ln: forall n, lnonce # (L (N n)).
(**Definition lskey {n} := (L (sk n)).**)

(*******length regular********)

Axiom len_regular: forall (x1 x2 y1 y2 :message), (L x1) # (L y1) /\ (L x2) # (L y2) -> (L (pair x1 x2)) # (L (pair y1 y2)).

(******Idempotent L(L(x)) = L(x)**********)

Axiom idemp_L: forall x,  (L (L x)) # (L x).
Variable lskey : message.

Axiom lsk: forall n, lskey # (L (sk n)).

(**************real or random secrecy of n****)

(** ( Fresh [n;n';n1; n2; n3; n4;n5; n6; n7] [] = true)**)

Theorem RRS_n: forall (n n' n1 n2 n3 n4 n5 n6 n7 :nat),  beq_nat n4 n3 = false /\   beq_nat n1 n = false /\
 beq_nat n2 n = false /\   beq_nat n3 n = false /\   beq_nat n4 n = false /\
  beq_nat n5 n = false /\   beq_nat n6 n = false /\ beq_nat n7 n = false /\    beq_nat n1 n' = false /\   beq_nat n2 n' = false /\    beq_nat n3 n' = false /\    beq_nat n4 n' = false /\    beq_nat n5 n' = false /\    beq_nat n6 n' = false /\
  beq_nat n7 n' = false ->
 [ msg (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3)))); msg (enc (pair (pi2 (dec (f [ (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n)] ~
 [ msg (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3)))); msg (enc (pair (pi2 (dec (f [ (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n')].

Proof. intros .
(******************************************************************************************)
assert(tfx: (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) # (if_then_else_M (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))) (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]))).

rewrite IFSAME_M with (b:=  (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3)))))) (x:= (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])).
reflexivity.

assert (tdecfx:  (pi2 (dec (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) # (if_then_else_M  (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))) (N n5)  (pi2 (dec (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))))).

rewrite tfx at 1.

pose proof(Example11_M).
apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (enc (pair (sk n1) ( N n5 )) (pk n2) (rs (N n3))) ) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=3) (x :=  (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.

rewrite H0 .

assert(H3:  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2))) # (if_then_else_M (Bvar 0) (pi2 (dec (Mvar 1) (sk n2))) (pi2 (dec (Mvar 2) (sk n2))))).

rewrite <- IFSAME_M with (b:= (Bvar 0)) (x:=  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2)))).

rewrite IFEVAL_M .
simpl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
reflexivity.
apply Forall_ELM_EVAL_M with (n:=0) (x:= (EQ_M (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (enc (pair (pi2 (k (N n1))) (N n5)) (pi1 (k (N n2))) (rs (N n3))))) in H3.
simpl in H3.
apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (enc (pair (pi2 (k (N n1))) (N n5)) (pi1 (k (N n2))) (rs (N n3)))) in H3. simpl in H3.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (f [enc (pair (sk n1)  (N n5)) (pk n2) (rs (N n3))])) in H3. simpl in H3.

rewrite H3.
pose proof(dep_enc).
rewrite dep_enc with (n:=n2) (x:=  (pair (pi2 (k (N n1))) (N n5 ))) .
rewrite proj2 with (m1:= (pi2 (k (N n1)))) (m2 := (N n5)) .
reflexivity.

(************************************************************************************************)
assert(ufx: (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))]) # (if_then_else_M (EQ_M (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))) (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))]) (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))]))).
pose proof (IFSAME_M).
rewrite IFSAME_M with (b:=  (EQ_M (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3)))))) (x:= (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))])).
reflexivity.

assert (udecfx:  (pi2 (dec (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) # (if_then_else_M  (EQ_M (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))) (N n5)  (pi2 (dec (f [ (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))))).

rewrite ufx at 1.

pose proof(Example11_M).

apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (enc (pair (sk n6) ( N n5 )) (pk n2) (rs (N n3))) ) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=3) (x :=  (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.

rewrite H0 .

assert(Hf3:  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2))) # (if_then_else_M (Bvar 0) (pi2 (dec (Mvar 1) (sk n2))) (pi2 (dec (Mvar 2) (sk n2))))).

rewrite <- IFSAME_M with (b:= (Bvar 0)) (x:=  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2)))).

rewrite IFEVAL_M .
simpl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
reflexivity.
apply Forall_ELM_EVAL_M with (n:=0) (x:= (EQ_M (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (enc (pair (pi2 (k (N n6))) (N n5)) (pi1 (k (N n2))) (rs (N n3))))) in Hf3.
simpl in Hf3.
apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (enc (pair (pi2 (k (N n6))) (N n5)) (pi1 (k (N n2))) (rs (N n3)))) in Hf3. simpl in Hf3.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (f [enc (pair (sk n6)  (N n5)) (pk n2) (rs (N n3))])) in Hf3. simpl in Hf3.

rewrite Hf3.
pose proof(dep_enc).
rewrite dep_enc with (n:=n2) (x:=  (pair (pi2 (k (N n6))) (N n5 ))) .
rewrite proj2 with (m1:= (pi2 (k (N n6)))) (m2 := (N n5)) .
reflexivity.

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

(**************L<sk1 , n5> , L<sk6, n5> *********)

assert(H2: (L (pair (sk n1) (N n5))) # (L (pair (sk n6) (N n5)))).

apply len_regular.  split.
Focus 2.
reflexivity.

assert(H3: lskey # ( L (sk n1))).
rewrite lsk with (n:= n1).

reflexivity.

assert(H4: lskey # ( L (sk  n6))).
rewrite lsk with (n:= n6).

reflexivity.

rewrite <- H3.
rewrite <- H4.
reflexivity.
apply EQmsg in H2.

pose proof (IFTRUE_M  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3)))) O).
rewrite <- H2 in H0.

pose proof (IFTRUE_M  (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3)))) O).
rewrite <- H2 in H1.

simpl.
(*************************************************************************************************)
(*************************************************************************************************)

assert(TT: ( submsg_mylist 1   (if_then_else_M (EQ_M (L (pair (sk n1) (N n5))) (L (pair (sk n6) (N n5))))
          (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))) O) [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n))  (pk n1) (rs (N n4))) ; msg (N n)]) ~ (submsg_mylist 1  (if_then_else_M (EQ_M (L (pair (sk n1) (N n5))) (L (pair (sk n6) (N n5))))
           (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))) O) [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n))  (pk n1) (rs (N n4))) ; msg (N n)])).

apply ENCCCA2 with (n:=1) (t''' := (pi2 (dec (f [Mvar 1]) (sk n2)))) (t'':= (N n5)) (t:=  (f [Mvar 1])) (u:= (pair (sk n1) (N n5))) (u':= (pair (sk n6) (N n5))) (u'':= O) (n1:= n2) (n2:=n3) (n3:= n3)  (l:=   [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n)) (pk n1) (rs (N n4)))  ; msg (N n)]).
unfold rn_occ_mylist.
simpl.
inversion H.
repeat rewrite H3.
repeat rewrite <- beq_nat_refl.

simpl.
 repeat (try split; try reflexivity).  intros.
simpl. repeat rewrite <- beq_nat_refl.  simpl.
reflexivity.

assert(UU: ( submsg_mylist 1   (if_then_else_M (EQ_M (L (pair (sk n1) (N n5))) (L (pair (sk n6) (N n5))))
          (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))) O)   [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n))  (pk n1) (rs (N n4))) ; msg (N n')]) ~ (submsg_mylist 1  (if_then_else_M (EQ_M (L (pair (sk n1) (N n5))) (L (pair (sk n6) (N n5))))
           (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))) O)   [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n))  (pk n1) (rs (N n4)))  ; msg (N n')])).
apply ENCCCA2 with (n:=1) (t''' := (pi2 (dec (f [Mvar 1]) (sk n2)))) (t'':= (N n5)) (t:= f[ Mvar 1]) (u:= (pair (sk n1) (N n5))) (u':= (pair (sk n6) (N n5))) (u'':= O) (n1:= n2) (n2:=n3) (n3:= n3)  (l:=   [msg (Mvar 1); msg (enc (pair (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1)) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (N n))  (pk n1) (rs (N n4))) ; msg (N n')]).
simpl.
repeat rewrite H3.
 repeat rewrite <- beq_nat_refl.

simpl.
 repeat (try split; try reflexivity).   repeat rewrite <- beq_nat_refl.  simpl.
reflexivity. inversion H. repeat rewrite H3. simpl. reflexivity.
inversion H. repeat rewrite H3. simpl. reflexivity.
rewrite H0 in TT.
rewrite H1 in TT.
simpl in TT.
rewrite <- tdecfx in TT.
rewrite <- udecfx  in TT.
(******************Assumption on lengths*********************************)
assert(HT: (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n))) # (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)))).
apply len_regular.
split. reflexivity.

assert(t1 : lnonce # ( L (N n))).
rewrite ln with (n:=n).

reflexivity.
rewrite <- t1.
rewrite ln with (n:= n7).
reflexivity.

rewrite EQmsg in HT.

assert(TTT: ( submsg_mylist 1 (if_then_else_M (EQ_M (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)))  (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)))) (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))) O)   [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n)]) ~ (submsg_mylist 1 (if_then_else_M (EQ_M (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)))  (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)))) (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))) O) [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n)])).

apply ENCCCA2 with (n:=1) (t'':= (Mvar 1)) (t''' := (Mvar 1)) (t:= (Mvar 1)) (u:= (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n))) (u':=  (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7))) (u'':= O) (n1:= n1) (n2:=n4) (n3:= n4)  (l:=  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n)]).
simpl.
inversion H.
 rewrite <- Nat.eqb_sym.
 repeat rewrite H3. simpl.

 repeat (try split; try reflexivity).
rewrite HT in TTT.
repeat rewrite IFTRUE_M in TTT.
simpl in TTT.
assert(t1t6n7: [msg (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n)] ~  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n)]).
apply EQI_trans with (ml2:= [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n)]).
assumption.

assumption.
rewrite H0 in UU.
rewrite H1 in UU.
simpl in UU.
rewrite <- udecfx in UU.
rewrite <- tdecfx in UU.

assert(UUU: ( submsg_mylist 1 (if_then_else_M (EQ_M (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)))  (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)))) (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))) O)   [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n')]) ~ (submsg_mylist 1 (if_then_else_M (EQ_M (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)))  (L (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)))) (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))) O) [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n')])).

apply ENCCCA2 with (n:=1) (t''' := (Mvar 1)) (t'':= (Mvar 1)) (t:= (Mvar 1)) (u:= (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n))) (u':=  (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7))) (u'':= O) (n1:= n1) (n2:=n4) (n3:= n4)  (l:=  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))); msg (Mvar 1) ; msg (N n')]).
simpl.
inversion H.
 rewrite <- Nat.eqb_sym.
 repeat rewrite H3. simpl.

 repeat (try split; try reflexivity).
rewrite HT in UUU.
repeat rewrite IFTRUE_M in UUU.
simpl in UUU.
assert(u1u6n7: [msg (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n')] ~  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n')]).
apply EQI_trans with (ml2:= [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n')]).
assumption.

assumption.
assert(Final :  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n)] ~  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n')]).

pose proof( FRESHIND_rs 2 n n'   [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4)))]  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4)))]).
simpl in H3.
inversion H; clear H.
inversion H5; clear H5.
inversion H6; clear H6.
inversion H7; clear H7.
inversion H8; clear H8.
inversion H9; clear H9.
inversion H10; clear H10.
inversion H11; clear H11.
inversion H12; clear H12.
inversion H13; clear H13.
inversion H14; clear H14.
inversion H15; clear H15.

inversion H16; clear H16.
inversion H17; clear H17.
rewrite H, H5, H6, H7, H8, H9, H10, H11, H12, H13, H14, H15, H16, H18 in H3.
simpl in H3.

assert( true = true /\ true = true /\ true = true /\ [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4)))] ~ [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4)))]).
repeat (try split; try reflexivity).
apply H3 in H17. apply RESTR_swap with (p1:=1) (p2:=2) in H17. unfold swap_mylist in H17. simpl in H17. apply RESTR_swap with (p1:=2) (p2:=3) in H17. unfold swap_mylist in H17. simpl in H17.
assumption.

assert(result :  [msg (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n)] ~  [msg (enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n')]).
apply EQI_trans with (ml2:=  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n)]).
assumption.
apply EQI_trans with (ml2:=  [msg (enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3)));
        msg
         (enc (pair (pi2 (dec (f [enc (pair (sk n6) (N n5)) (pk n2) (rs (N n3))]) (sk n2))) (N n7)) (pk n1) (rs (N n4))); msg (N n')]).
assumption. symmetry in u1u6n7. assumption. assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D G E F : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ B D /\ (wd_ D G /\ (wd_ B G /\ (wd_ A D /\ (wd_ C D /\ (wd_ G E /\ (wd_ E C /\ (wd_ G C /\ (wd_ G F /\ (wd_ F A /\ (wd_ G A /\ (wd_ C F /\ (col_ A B C /\ (col_ B D G /\ (col_ G E C /\ (col_ G F A /\ col_ A C F)))))))))))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ C Aprime Bprimeprime)))))))))))))))))))))))))))))))) -> col_ A B G)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleLift.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w ->  zn2z w.
 Variable w_0W : w ->  zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.
 Variable w_head0 : w -> w.
 Variable w_tail0 : w -> w.
 Variable w_add: w -> w -> zn2z w.
 Variable w_add_mul_div : w -> w -> w -> w.
 Variable ww_sub: zn2z w -> zn2z w -> zn2z w.
 Variable w_digits : positive.
 Variable ww_Digits : positive.
 Variable w_zdigits : w.
 Variable ww_zdigits : zn2z w.
 Variable low: zn2z w -> w.

 Definition ww_head0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xh with
    | Eq => w_add w_zdigits (w_head0 xl)
    | _ => w_0W (w_head0 xh)
    end
  end.

 Definition ww_tail0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xl with
    | Eq => w_add w_zdigits (w_tail0 xh)
    | _ => w_0W (w_tail0 xl)
    end
  end.

  (* 0 < p < ww_digits *)
 Definition ww_add_mul_div p x y :=
  let zdigits := w_0W w_zdigits in
  match x, y with
  | W0, W0 => W0
  | W0, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_0W yh
    | Lt => w_0W (w_add_mul_div (low p) w_0 yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl)
    end
  | WW xh xl, W0 =>
    match ww_compare p zdigits with
    | Eq => w_W0 xl
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_W0 (w_add_mul_div n xl w_0)
    end
  | WW xh xl, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_WW xl yh
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
    end
  end.

 Section DoubleProof.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_to_w_Z  : forall x, 0 <= [[x]] < wwB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_compare : forall x y,
   w_compare x y = Z.compare [|x|] [|y|].
  Variable spec_ww_compare : forall x y,
   ww_compare x y = Z.compare [[x]] [[y]].
  Variable spec_ww_digits : ww_Digits = xO w_digits.
  Variable spec_w_head00  : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits.
  Variable spec_w_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB.
  Variable spec_w_tail00  : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits.
  Variable spec_w_tail0 : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]).
  Variable spec_w_add_mul_div : forall x y p,
       [|p|] <= Zpos w_digits ->
       [| w_add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
 Variable spec_w_add: forall x y,
   [[w_add x y]] = [|x|] + [|y|].
 Variable spec_ww_sub: forall x y,
   [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.

 Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
 Variable spec_low: forall x, [| low x|] = [[x]] mod wB.

 Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits.

  Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift.
  Ltac zarith := auto with zarith lift.

  Lemma spec_ww_head00  : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_head0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
  { Z.le_elim Hy1; auto.
    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
      apply Z.add_le_mono_r; auto with zarith.
    - Z.le_elim Hx1; auto.
      absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith.
      apply Z.mul_pos_pos; auto with zarith. }
  rewrite spec_compare. case Z.compare_spec.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_head00.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Pos2Z.inj_xO; auto with zarith.
  rewrite F1 in Hx; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

  Lemma spec_ww_head0  : forall x,  0 < [[x]] ->
	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
  Proof.
   clear spec_ww_zdigits.
   rewrite wwB_div_2;rewrite Z.mul_comm;rewrite wwB_wBwB.
   assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Z.lt in H;discriminate H.
   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
   rewrite <- H0 in *. simpl Z.add. simpl in H.
   case (spec_to_Z w_zdigits);
     case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4.
   rewrite spec_w_add.
   rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
   case (spec_w_head0 H); intros H1 H2.
   rewrite Z.pow_2_r; fold wB; rewrite <- Z.mul_assoc; split.
     apply Z.mul_le_mono_nonneg_l; auto with zarith.
   apply Z.mul_lt_mono_pos_l; auto with zarith.
   assert (H1 := spec_w_head0 H0).
   rewrite spec_w_0W.
   split.
   rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc.
   apply Z.le_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB).
   rewrite Z.mul_comm; zarith.
   assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith.
   assert (H2:=spec_to_Z xl);apply Z.mul_nonneg_nonneg;zarith.
   case (spec_to_Z (w_head0 xh)); intros H2 _.
   generalize ([|w_head0 xh|]) H1 H2;clear H1 H2;
     intros p H1 H2.
   assert (Eq1 : 2^p < wB).
     rewrite <- (Z.mul_1_r (2^p));apply Z.le_lt_trans with (2^p*[|xh|]);zarith.
   assert (Eq2: p < Zpos w_digits).
    destruct (Z.le_gt_cases (Zpos w_digits) p);trivial;contradict  Eq1.
   apply Z.le_ngt;unfold base;apply Zpower_le_monotone;zarith.
   assert (Zpos w_digits = p + (Zpos w_digits - p)). ring.
   rewrite Z.pow_2_r.
   unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith.
   rewrite <- Z.mul_assoc; apply Z.mul_lt_mono_pos_l; zarith.
   rewrite <- (Z.add_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
   apply Z.mul_lt_mono_pos_r with (2 ^ p); zarith.
   rewrite <- Zpower_exp;zarith.
   rewrite Z.mul_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
   assert (H1 := spec_to_Z xh);zarith.
  Qed.

  Lemma spec_ww_tail00  : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_tail0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
  { Z.le_elim Hy1; auto.
    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
      apply Z.add_le_mono_r; auto with zarith.
    - Z.le_elim Hx1; auto.
      absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith.
      apply Z.mul_pos_pos; auto with zarith. }
  assert (F2: [|xl|] = 0).
    rewrite F1 in Hx; auto with zarith.
  rewrite spec_compare; case Z.compare_spec.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_tail00; auto.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Pos2Z.inj_xO; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

  Lemma spec_ww_tail0  : forall x,  0 < [[x]] ->
	 exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]].
  Proof.
   clear spec_ww_zdigits.
   destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Z.lt in H;discriminate H.
   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
   rewrite <- H0; rewrite Z.add_0_r.
   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   generalize H; rewrite <- H0; rewrite Z.add_0_r; clear H; intros H.
   case (@spec_w_tail0 xh).
     apply Z.mul_lt_mono_pos_r with wB; auto with zarith.
     unfold base; auto with zarith.
   intros z (Hz1, Hz2); exists z; split; auto.
   rewrite spec_w_add; rewrite (fun x => Z.add_comm [|x|]).
   rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
   rewrite Z.mul_assoc; rewrite <- Hz2; auto.

   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   case (spec_w_tail0 H0); intros z (Hz1, Hz2).
   assert (Hp: [|w_tail0 xl|] < Zpos w_digits).
     case (Z.le_gt_cases (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1.
     absurd (2 ^  (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]).
       apply Z.lt_nge.
       case (spec_to_Z xl); intros HH3 HH4.
       apply Z.le_lt_trans with (2 := HH4).
       apply Z.le_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith.
       rewrite Hz2.
       apply Z.mul_le_mono_nonneg_r; auto with zarith.
     apply Zpower_le_monotone; auto with zarith.
   exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split.
     apply Z.add_nonneg_nonneg; auto.
     apply Z.mul_nonneg_nonneg; auto with zarith.
     case (spec_to_Z xh); auto.
   rewrite spec_w_0W.
   rewrite (Z.mul_add_distr_l 2); rewrite <- Z.add_assoc.
   rewrite Z.mul_add_distr_r; rewrite <- Hz2.
   apply f_equal2 with (f := Z.add); auto.
   rewrite (Z.mul_comm 2).
   repeat rewrite <- Z.mul_assoc.
   apply f_equal2 with (f := Z.mul); auto.
   case (spec_to_Z (w_tail0 xl)); intros HH3 HH4.
   pattern 2 at 2; rewrite <- Z.pow_1_r.
   lazy beta; repeat rewrite <- Zpower_exp; auto with zarith.
   unfold base; apply f_equal with (f := Z.pow 2); auto with zarith.

   contradict H0; case (spec_to_Z xl); auto with zarith.
  Qed.

  Hint Rewrite Zdiv_0_l Z.mul_0_l Z.add_0_l Z.mul_0_r Z.add_0_r
    spec_w_W0 spec_w_0W spec_w_WW spec_w_0
    (wB_div w_digits w_to_Z spec_to_Z)
    (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite.
  Ltac w_rewrite := autorewrite with w_rewrite;trivial.

  Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p,
   let zdigits := w_0W w_zdigits in
    [[p]] <= Zpos (xO w_digits) ->
      [[match ww_compare p zdigits with
        | Eq => w_WW xl yh
        | Lt => w_WW (w_add_mul_div (low p) xh xl)
                     (w_add_mul_div (low p) xl yh)
        | Gt =>
              let n := low (ww_sub p zdigits) in
            w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
        end]] =
      ([[WW xh xl]] * (2^[[p]]) +
       [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   clear spec_ww_zdigits.
   intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits).
   case (spec_to_w_Z p); intros Hv1 Hv2.
   replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits).
   2 : rewrite Pos2Z.inj_xO;ring.
   replace (Zpos w_digits + Zpos w_digits - [[p]]) with
     (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring.
   intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl);
   assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
   simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl);
   assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy.
   rewrite spec_ww_compare; case Z.compare_spec; intros H1.
   rewrite H1; unfold zdigits; rewrite spec_w_0W.
   rewrite spec_zdigits; rewrite Z.sub_diag; rewrite Z.add_0_r.
   simpl ww_to_Z; w_rewrite;zarith.
   fold wB.
   rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;rewrite <- Z.add_assoc.
   rewrite <- Z.pow_2_r.
   rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|].
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring.
   simpl ww_to_Z; w_rewrite;zarith.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; intros tmp.
     apply Z.lt_le_trans with (1 := tmp).
     unfold base.
     apply Zpower2_le_lin; auto with zarith.
   2: generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto with zarith.
   generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto; clear H1; intros H1.
   assert (HH: [|low p|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   repeat rewrite spec_w_add_mul_div with (1 := HH).
   rewrite HH0.
   rewrite Z.mul_add_distr_r.
   pattern ([|xl|] * 2 ^ [[p]]) at 2;
   rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith.
   replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc.
   unfold base at 5;rewrite <- Zmod_shift_r;zarith.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   rewrite wwB_wBwB;rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
   unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. apply Z_mod_lt;zarith.
   split;zarith. apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith.
   assert (Hv: [[p]] > Zpos w_digits).
     generalize H1; clear H1.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith.
   clear H1.
   assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits).
     rewrite spec_low.
     rewrite spec_ww_sub.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
   assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   replace (Zpos w_digits + (Zpos w_digits - [[p]])) with
       (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith.
   lazy zeta; simpl ww_to_Z; w_rewrite;zarith.
   repeat rewrite spec_w_add_mul_div;zarith.
   rewrite HH0.
   pattern wB at 5;replace wB with
    (2^(([[p]] - Zpos w_digits)
         + (Zpos w_digits - ([[p]] - Zpos w_digits)))).
   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc.
   rewrite Z_div_plus_l;zarith.
   rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits)
    (n := Zpos w_digits);zarith. fold wB.
   set (u := [[p]] - Zpos w_digits).
   replace [[p]] with (u + Zpos w_digits);zarith.
   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. fold wB.
   repeat rewrite Z.add_assoc. rewrite <- Z.mul_add_distr_r.
   repeat rewrite <- Z.add_assoc.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits)
   (b:= Zpos w_digits);fold wB;fold wwB;zarith.
   rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
   rewrite Z.mul_add_distr_r.
   replace ([|xh|] * wB * 2 ^ u) with
     ([|xh|]*2^u*wB). 2:ring.
   repeat rewrite <- Z.add_assoc.
   rewrite (Z.add_comm ([|xh|] * 2 ^ u * wB)).
   rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   try (unfold u; omega).
   split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold
   wB;zarith. unfold ww_digits;rewrite Pos2Z.inj_xO;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   try (unfold u; omega).
   unfold u; split;zarith.
   apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
   try (unfold u;zarith).
   try (unfold u;zarith).
   set (u := [[p]] - Zpos w_digits).
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
  Qed.

  Lemma spec_ww_add_mul_div : forall x y p,
       [[p]] <= Zpos (xO w_digits) ->
       [[ ww_add_mul_div p x y ]] =
         ([[x]] * (2^[[p]]) +
          [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   clear spec_ww_zdigits.
   intros x y p H.
   destruct x as [ |xh xl];
   [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0)
   |assert (H1 := @spec_ww_add_mul_div_aux xh xl)];
   (destruct y as [ |yh yl];
    [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)];
    clear H1;w_rewrite);simpl ww_add_mul_div.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq; auto.
   rewrite spec_ww_compare. case Z.compare_spec; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     apply Z.lt_le_trans with (1 := H1).
     unfold base; apply Zpower2_le_lin; auto with zarith.
   rewrite HH0; auto with zarith.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq.
   generalize (spec_ww_compare p (w_0W w_zdigits));
     case ww_compare; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   rewrite Pos2Z.inj_xO in H;zarith.
   assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits).
     symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1.
     revert H1.
     rewrite spec_low.
     rewrite spec_ww_sub; w_rewrite; intros H1.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     unfold base; auto with zarith.
     unfold base; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
  case (spec_to_Z xh); auto with zarith.
  Qed.

 End DoubleProof.

End DoubleLift.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D R S I : Universe, ((wd_ D S /\ (wd_ A B /\ (wd_ B C /\ (wd_ C D /\ (wd_ A D /\ (wd_ A C /\ (wd_ B D /\ (wd_ A S /\ (wd_ B R /\ (wd_ S I /\ (wd_ A R /\ (wd_ R I /\ (wd_ R S /\ (wd_ C R /\ (wd_ S C /\ (wd_ S B /\ (wd_ I C /\ (wd_ I B /\ (wd_ R D /\ (wd_ D I /\ (wd_ A I /\ (col_ B C I /\ (col_ S R I /\ (col_ A D S /\ col_ B C R)))))))))))))))))))))))) -> col_ C R S)).
Proof.
  time tac.
Qed.

End FOFProblem.


(******************************************************************************)
(** * Definition of the OCaml memory model [Dolan-al:PLDI18] *)
(******************************************************************************)
From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_s_hb.
Require Import imm_s.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section OCamlMM.

Variable G : execution.

Notation "'E'" := G.(acts_set).
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'rfe'" := G.(rfe).
Notation "'co'" := G.(co).
Notation "'coe'" := G.(coe).
Notation "'rmw'" := G.(rmw).
Notation "'fr'" := G.(fr).
Notation "'fre'" := G.(fre).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

(******************************************************************************)
(** ** Consistency  *)
(******************************************************************************)

Definition hb := (sb ∪ ⦗Sc⦘ ⨾ (co ∪ rf) ⨾ ⦗Sc⦘)⁺. (* see p. 6 *)

Definition ocaml_consistent :=
  ⟪ Comp : complete G ⟫ /\
  ⟪ Cat  : rmw_atomicity G ⟫ /\
  ⟪ CoWW : irreflexive (hb ⨾ co) ⟫ /\ (* see p. 6 *)
  ⟪ CoWR : irreflexive (hb ⨾ fr) ⟫ /\
  ⟪ Caus : acyclic (sb ∪ rfe ∪ ⦗Sc⦘ ⨾ (coe ∪ fre) ⨾ ⦗Sc⦘) ⟫. (* see expanded definition at p. 17 *)

End OCamlMM.


(***************************************************************************
* Safety for STLC with Patterns - Infrastructure                          *
* Arthur Chargueraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN STLC_Pat_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i j  => \{}
  | trm_fvar x    => {{x}
  | trm_abs t1    => (fv t1)
  | trm_let p1 t1 t2 => (fv t1) \u (fv t2)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_pair t1 t2 => (fv t1) \u (fv t2)
  end.

(** Computing free variables of a list of terms. *)

Definition fv_list :=
  List.fold_right (fun t acc => fv t \u acc) \{}.

(** Free variables of the default term. *)

Lemma trm_def_fresh : fv trm_def = \{}.
Proof.
  auto.
Qed.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => trm_bvar i j
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_let p1 t1 t2 => trm_let p1 (subst z u t1) (subst z u t2)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_pair t1 t2 => trm_pair (subst z u t1) (subst z u t2)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(** Iterated substitution *)

Fixpoint substs (zs : list var) (us : list trm) (t : trm)
   {struct zs} : trm :=
  match zs, us with
  | z::zs', u::us' => substs zs' us' ([z ~> u]t)
  | _, _ => t
  end.

(** Iterated typing *)

Inductive typings (E : env) : list trm -> list typ -> Prop :=
  | typings_nil : typings E nil nil
  | typings_cons : forall ts Us t U,
      typings E ts Us ->
      typing E t U ->
      typings E (t::ts) (U::Us).

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  let E := gather_vars_with (fun x : list trm => fv_list x) in
  constr:(A \u B \u C \u D \u E).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Ltac pick_freshes n Y :=
  let L := gather_vars in (pick_freshes_gen L n Y).

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; autos*.

Tactic Notation "apply_fresh" constr(T) "as" ident(X) :=
  apply_fresh_base T gather_vars X.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(X) :=
  apply_fresh T as X; autos*.

Hint Constructors term value red typing typings.

Hint Extern 1 (_ \notin fv trm_def) =>
  rewrite trm_def_fresh.

Hint Extern 1 (terms _ _) => split; auto.

Hint Extern 1 (fresh (dom (_ & _)) _ _) => simpl_env.
(* todo: move *)

(* ********************************************************************** *)
(** ** Properties of iterated operators *)

Lemma fv_list_map : forall ts1 ts2,
  fv_list (ts1 ++ ts2) = fv_list ts1 \u fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma typings_concat : forall E ts1 Us1 ts2 Us2,
  typings E ts1 Us1 ->
  typings E ts2 Us2 ->
  typings E (ts1++ts2) (Us1++Us2).
Proof.
  induction ts1; introv Typ1 Typ2; inversions Typ1; simpls*.
Qed.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh x. forwards~ K: (H0 x).
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::nil))).
  pick_freshes (pat_arity p1) xs. forwards~ K: (H1 xs).
   apply* (@open_rec_term_core t2 0 (trm_fvars xs)).
  unfolds~ opens. (* todo : was not needed *)
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->
  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*.
  case_var*. notin_false.
Qed.

Lemma subst_fresh_list : forall z u ts,
  z \notin fv_list ts ->
  ts = List.map (subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ subst_fresh. auto.
Qed.

Lemma subst_fresh_trm_fvars : forall z u xs,
  fresh ({{z}) (length xs) xs ->
  trm_fvars xs = List.map (subst z u) (trm_fvars xs).
Proof.
  intros. apply subst_fresh_list.
  induction xs; simpls. auto.
    destruct H. notin_solve. auto.
Qed.

Lemma substs_fresh : forall xs us t,
  fresh (fv t) (length xs) xs ->
  substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ (List.map (subst x u) t2).
Proof.
  intros. unfold open, opens. simpl. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. unfold trm_nth.
   apply list_map_nth. apply* subst_fresh.
  case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_vars : forall x ys u t,
  fresh {{x} (length ys) ys ->
  term u ->
  ([x ~> u]t) ^ ys = [x ~> u] (t ^ ys).
Proof.
  introv Fr Tu. rewrite* subst_open.
  unfold trm_fvars. fequals.
  induction ys; simpls. auto.
  destruct Fr. case_var.
    notin_false. fequals~.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma substs_intro_ind : forall t xs us vs,
  fresh (fv t \u fv_list vs \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  terms (length vs) vs ->
  t ^^ (vs ++ us) = substs xs us (t ^^ (vs ++ (trm_fvars xs))).
Proof.
  induction xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct us; tryfalse.
  auto.
  inversions H0. destruct Fr as [Fra Frb]. simpls.
  rewrite app_last.
  forwards K: (IHxs us (vs++t0::nil)); clear IHxs.
    rewrite* fv_list_map.
    auto.
    split~. inversions Tv. apply* Forall_app.
  rewrite K. clear K.
  f_equal. rewrite~ subst_open. rewrite~ subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; tryfalse*.
  rewrite <- app_last.
  fequals. apply~ subst_fresh_list.
  fequals. apply* subst_fresh_trm_fvars.
Qed.

Lemma substs_intro : forall xs t us,
  fresh (fv t \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = substs xs us (t ^ xs).
Proof.
  intros. apply* (@substs_intro_ind t xs us nil).
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simple*.
  case_var*.
  apply_fresh term_abs. rewrite* subst_open_vars.
  apply_fresh* term_let. rewrite* subst_open_vars.
Qed.

Hint Resolve subst_term.

(** Terms are stable by iterated substitution *)

Lemma substs_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (substs xs us t).
Proof.
  induction xs; destruct us; introv TU TT; simpl; auto.
  inversions TU. simpls. inversions H. inversions* H0.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> bodys 1 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H; destruct H.
  destruct xs; simpl in H0; destruct H0. auto.
Qed.

Lemma body_to_term_abs : forall t1,
  bodys 1 t1 -> term (trm_abs t1).
Proof.
  destruct 1. apply_fresh* term_abs.
Qed.
Lemma term_let_to_body : forall p1 t1 t2,
  term (trm_let p1 t1 t2) -> bodys (pat_arity p1) t2.
Proof.
  intros. unfold bodys. inversions* H.
Qed.

Lemma body_to_term_let : forall p1 t1 t2,
  pattern p1 -> term t1 -> bodys (pat_arity p1) t2 ->
  term (trm_let p1 t1 t2).
Proof.
  destruct 3. apply_fresh* term_let.
Qed.

Hint Resolve body_to_term_abs term_abs_to_body
             body_to_term_let.

Hint Extern 1 (bodys (pat_arity ?p1) ?t2) =>
  match goal with H: context [trm_let p1 ?t1 t2] |- _ =>
    apply (@term_let_to_body p1 t1 t2) end.

(** ** Opening a body with a term gives a term *)

Lemma open_terms : forall t us,
  bodys (length us) t ->
  terms (length us) us ->
  term (t ^^ us).
Proof.
  introv [L K] WT. pick_freshes (length us) xs. lets Fr': Fr.
  rewrite (fresh_length _ _ _  Fr) in WT, Fr'.
  rewrite* (@substs_intro xs). apply* substs_terms.
Qed.

Hint Resolve open_terms.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** Pattern typing is regular. *)

Lemma Pat_typing_regular : forall Ts p T,
  Pat_typing Ts p T -> pattern p.
Proof. unfolds* Pat_typing. Qed.

(* The typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split; induction* H.
  pick_fresh x. forwards~ K: (H0 x). inversions* K.
  autos* Pat_typing_regular.
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; autos*.
Qed.

(** Pattern-matching regular. *)

Lemma Pat_match_regular : forall vs p v,
  Pat_match vs p v ->
  pattern p /\ terms (pat_arity p) vs /\ term v.
Proof. unfolds* Pat_match. Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof.
  induction 1; autos* value_regular.
  destruct H1 as [? [[Eq ?] [? ?]]]. split~.
   apply~ open_terms. rewrite~ <- Eq.
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.

Hint Extern 1 (pattern ?p) =>
  match goal with
  | H: Pat_match _ p _ |- _ => apply (proj31 (Pat_match_regular H))
  | H: Pat_typing _ p _ |- _ => apply (Pat_typing_regular H)
  end.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils
     PCUICLiftSubst PCUICTyping PCUICWeakeningConv PCUICWeakeningTyp PCUICCases
     PCUICCumulativity PCUICReduction
     PCUICParallelReduction PCUICEquality PCUICUnivSubstitutionConv
     PCUICParallelReductionConfluence PCUICConfluence
     PCUICContextReduction PCUICOnFreeVars PCUICWellScopedCumulativity
     PCUICGuardCondition PCUICConversion PCUICContextConversion PCUICClosedTyp.

From Coq Require Import CRelationClasses ssreflect ssrbool.
From Equations Require Import Equations.

Arguments red_ctx : clear implicits.

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Lemma lift0_open {cf:checker_flags} {Γ : closed_context} {Γ'' : open_context Γ}
  {M : open_term Γ} {n} :
  n = #|Γ''| -> is_open_term (Γ ,,, Γ'') (lift0 n M).
Proof.
  intro e. rewrite on_free_vars_lift0; eauto. rewrite app_length. rewrite <- shiftnP_add.
  subst. rewrite addnP_shiftnP; intuition.
Defined.

Lemma weakening_cumulSpec0 {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : closed_context} {Γ'' : open_context Γ}
  {M N : open_term Γ} n :
  n = #|Γ''| ->
  Σ ;;; Γ |- M <=s N ->
  Σ ;;; Γ ,,, Γ'' |- lift0 n M <=s lift0 n N.
Proof.
  intros e H.
  eapply (@cumulAlgo_cumulSpec _ _ Cumul).
  eapply into_ws_cumul_pb; try  apply lift0_open; eauto.
  - cbn. eapply weakening_cumul0; eauto. apply cumulSpec_cumulAlgo in H; eauto. exact (ws_cumul_pb_forget H).
  - cbn. rewrite on_free_vars_ctx_app; solve_all; intuition.
Defined.

Lemma split_closed_context {Γ : context} (n : nat) :
  is_closed_context Γ ->
  n <= #|Γ| ->
  ∑ (Δ : closed_context) (Δ' : open_context Δ),
    [× Δ = skipn n Γ :> context, Δ' = firstn n Γ :> context,
       Γ = Δ ,,, Δ' & n = #|Δ'|].
Proof.
  rewrite -{1}(firstn_skipn n Γ).
  rewrite on_free_vars_ctx_app => /andP[] sk fi.
  exists (exist (skipn n Γ) sk).
  exists (exist (firstn n Γ) fi). split; auto.
  cbn. now rewrite firstn_skipn. cbn.
  rewrite List.firstn_length. lia.
Qed.

Lemma nth_error_closed_context {Γ n d} :
  is_closed_context Γ ->
  nth_error Γ n = Some d ->
  ws_decl (skipn (S n) Γ) d.
Proof.
  rewrite -on_free_vars_ctx_on_ctx_free_vars -[shiftnP _ _]addnP0 => hΔ' hnth.
  eapply nth_error_on_free_vars_ctx in hΔ'; tea.
  2:{ rewrite /shiftnP /= orb_false_r. apply Nat.ltb_lt. now apply nth_error_Some_length in hnth. }
  rewrite List.skipn_length.
  eapply on_free_vars_decl_impl; tea.
  intros i.
  rewrite /= /addnP /shiftnP /= !orb_false_r => /Nat.ltb_lt hl.
  apply Nat.ltb_lt. lia.
Qed.

Lemma on_free_vars_decl_lift (p : nat -> bool) n k t :
  on_free_vars_decl (strengthenP k n p) (lift_decl n k t) = on_free_vars_decl p t.
Proof.
  rewrite /on_free_vars_decl /test_decl /=.
  f_equal. destruct (decl_body t) => /= //.
  all:now rewrite on_free_vars_lift.
Qed.

Lemma on_free_vars_decl_lift_impl (p : nat -> bool) n k d :
  on_free_vars_decl (shiftnP k p) d ->
  on_free_vars_decl (shiftnP (n + k) p) (lift_decl n k d).
Proof.
  rewrite /on_free_vars_decl /test_decl /= => /andP[].
  destruct (decl_body d) => /= //.
  move/(on_free_vars_lift_impl _ n) ->.
  move/(on_free_vars_lift_impl _ n) -> => //.
  move=> _.
  move/(on_free_vars_lift_impl _ n) -> => //.
Qed.

Lemma nth_error_Some_add {A} (l : list A) (n : nat) (x : A) :
  (nth_error l n = Some x) <~>
  (n < #|l| × nth_error l n = Some x).
Proof.
  split. intros hnth; split => //.
  now eapply nth_error_Some_length in hnth.
  now intros [].
Qed.

Lemma nth_error_closed_context_lift {Γ n d} :
  is_closed_context Γ ->
  nth_error Γ n = Some d ->
  ws_decl Γ (lift_decl (S n) 0 d).
Proof.
  move=> cl /nth_error_Some_add[] hn /(nth_error_closed_context cl).
  rewrite -(on_free_vars_decl_lift _ (S n) 0 d).
  apply: on_free_vars_decl_impl => i.
  rewrite /strengthenP /= /shiftnP !orb_false_r List.skipn_length.
  repeat PCUICSigmaCalculus.nat_compare_specs => //.
Qed.

Lemma wt_cum_ws_cumul_pb {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {t A B : term} {s} :
  Σ ;;; Γ |- t : A ->
  Σ ;;; Γ |- B : tSort s ->
  Σ ;;; Γ |- A <= B ->
  Σ ;;; Γ ⊢ A ≤ B.
Proof.
  move=> a; move: a (typing_wf_local a).
  move/PCUICClosedTyp.type_closed/(@closedn_on_free_vars xpred0) => clA.
  move/wf_local_closed_context => clΓ.
  move/PCUICClosedTyp.subject_closed/(@closedn_on_free_vars xpred0) => clB cum.
  now apply into_ws_cumul_pb.
Qed.

Lemma wt_cum_ws_cumul_ctx_pb {cf:checker_flags} {Σ:global_env_ext} {wfΣ : wf Σ} {Γ Δ : context} pb :
  wf_local Σ Γ ->
  wf_local Σ Δ ->
  cumul_pb_context cumulAlgo_gen pb Σ Γ Δ ->
  Σ ⊢ Γ ≤[pb] Δ.
Proof.
  move/wf_local_closed_context => wfΓ.
  move/wf_local_closed_context => wfΔ.
  now eapply into_ws_cumul_ctx_pb.
Qed.

Lemma All2_conv_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} :
  All2_fold (All_over (conv_decls cumulAlgo_gen Σ) Γ Γ') Δ Δ.
Proof.
  eapply All2_fold_refl. intros ? ?; reflexivity.
Qed.

Lemma All2_cumul_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} :
  All2_fold (All_over (cumul_decls cumulAlgo_gen Σ) Γ Γ') Δ Δ.
Proof.
  eapply All2_fold_refl. intros ? ?; reflexivity.
Qed.

Lemma cumul_context_Algo_Spec {cf:checker_flags} Σ Γ' Γ :
  Σ ⊢ Γ' ≤ Γ -> PCUICCumulativitySpec.cumul_context cumulSpec0 Σ Γ' Γ.
Proof.
  intros e.
  eapply All2_fold_impl. 1: tea. cbn; intros.
  destruct X.
  - econstructor 1; eauto. eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto.
  - econstructor 2; eauto.
    + eapply (@cumulAlgo_cumulSpec _ _ Conv); eauto.
    + eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto.
Defined.

Lemma context_cumulativity_prop {cf:checker_flags} :
  env_prop
    (fun Σ Γ t T =>
       forall Γ', cumul_context cumulAlgo_gen Σ Γ' Γ -> wf_local Σ Γ' -> Σ ;;; Γ' |- t : T)
    (fun Σ Γ =>
    All_local_env
      (lift_typing (fun Σ (Γ : context) (t T : term) =>
        forall Γ' : context, cumul_context cumulAlgo_gen Σ Γ' Γ -> wf_local Σ Γ' -> Σ;;; Γ' |- t : T) Σ) Γ).
Proof.
  apply typing_ind_env; intros Σ wfΣ Γ wfΓ; intros **; rename_all_hyps;
    try solve [econstructor; eauto].

  - induction X; constructor; auto.
    all: now apply infer_typing_sort_impl with id tu.

  - pose proof heq_nth_error.
    eapply (All2_fold_nth_r X0) in H as [d' [Hnth [Hrel Hconv]]].
    unshelve eapply nth_error_All_local_env in X; tea. 2:eapply nth_error_Some_length in heq_nth_error; lia.
    rewrite heq_nth_error /= in X.
    destruct decl as [na [b|] ty] => /=.
    + red in X. cbn in X. destruct X as [Hb Hty].
      destruct Hty as [s Hty]. specialize (Hty _ Hrel).
      forward Hty by now eapply All_local_env_skipn.
      eapply type_Cumul with _ s.
      * econstructor. auto. eauto.
      * rewrite -(firstn_skipn (S n) Γ').
        change (tSort s) with (lift0 (S n) (tSort s)).
        eapply weakening_length. auto.
        rewrite firstn_length_le. eapply nth_error_Some_length in Hnth. lia. auto.
        now rewrite /app_context firstn_skipn.
        assumption.
      * depelim Hconv; simpl in *.
        destruct (split_closed_context (S n) (wf_local_closed_context X1)) as [Δ [Δ' [eqΔ eqΔ' -> hn]]].
        eapply nth_error_Some_length in Hnth. lia.
        rewrite -eqΔ in Hty, Hrel.
        rewrite -eqΔ in eqb, eqt.
        assert (is_open_term Δ t).
        { eapply nth_error_closed_context in Hnth. 2:eauto with fvs.
          rewrite -eqΔ in Hnth. now move/andP: Hnth => []. }
        eapply PCUICClosedTyp.subject_closed in Hty.
        eapply (@closedn_on_free_vars xpred0) in Hty.
        eapply (weakening_cumulSpec0 (Γ := Δ) (Γ'' := Δ') (M := exist t H) (N := exist ty Hty)); cbn. lia.
        unshelve eapply (@cumulAlgo_cumulSpec _ _ Cumul). apply into_ws_cumul_pb; eauto.
        intuition.
    + cbn in X. destruct X as [s ondecl].
      specialize (ondecl _ Hrel).
      depelim Hconv.
      forward ondecl by now eapply All_local_env_skipn.
      eapply type_Cumul with _ s.
      * econstructor. auto. eauto.
      * rewrite -(firstn_skipn (S n) Γ').
        change (tSort s) with (lift0 (S n) (tSort s)).
        eapply weakening_length. auto.
        rewrite firstn_length_le. eapply nth_error_Some_length in Hnth. lia. auto.
        now rewrite /app_context firstn_skipn.
        assumption.
      * destruct (split_closed_context (S n) (wf_local_closed_context X1)) as [Δ [Δ' [eqΔ eqΔ' -> hn]]].
        eapply nth_error_Some_length in Hnth. lia.
        rewrite -eqΔ in ondecl, Hrel.
        rewrite -eqΔ in eqt.
        assert (is_open_term Δ t).
        { rewrite nth_error_app_lt in Hnth. rewrite -hn. lia.
          destruct Δ' as [Δ' hΔ']. cbn in *.
          move: hΔ'.
          rewrite -on_free_vars_ctx_on_ctx_free_vars -[shiftnP _ _]addnP0 => hΔ'.
          eapply nth_error_on_free_vars_ctx in hΔ'; tea.
          2:{ rewrite shiftnP_add /shiftnP /= orb_false_r. apply Nat.ltb_lt. lia. }
          rewrite /test_decl /= in hΔ'. move: hΔ'.
          now rewrite hn addnP_shiftnP. }
        eapply PCUICClosedTyp.subject_closed in ondecl.
        eapply (@closedn_on_free_vars xpred0) in ondecl.
        eapply (weakening_cumulSpec0 (Γ := Δ) (Γ'' := Δ') (M := exist t H) (N := exist ty ondecl)); cbn. lia.
        unshelve eapply (@cumulAlgo_cumulSpec _ _ Cumul). apply into_ws_cumul_pb; eauto.
        intuition.
  - constructor; pcuic.
    eapply forall_Γ'0. repeat (constructor; pcuic).
    constructor; auto. red. eexists; eapply forall_Γ'; auto.
  - econstructor; pcuic.
    eapply forall_Γ'0; repeat (constructor; pcuic).
  - econstructor; pcuic.
    eapply forall_Γ'1; repeat (constructor; pcuic).
  - econstructor; eauto. 2,3: constructor; eauto.
    * eapply IHp0. rewrite /predctx.
      eapply All2_fold_app => //.
      eapply All2_fold_refl. intros ? ?; reflexivity.
      eapply context_cumulativity_wf_app; tea.
    * eapply context_cumulativity_wf_app; tea.
    * revert X5.
      clear -Γ' X9 X10. induction 1; constructor; eauto. now destruct t0.
    * eapply All2i_impl; tea => i cdecl br. cbv beta.
      set (brctxty := case_branch_type _ _ _ _ _ _ _ _). cbn.
      move=> [] hbctx [] ihbctxty [] [] hbody IHbody [] hbty IHbty.
      intuition eauto; solve_all.
      eapply context_cumulativity_wf_app; tea.
      eapply IHbody. eapply All2_fold_app => //. apply All2_cumul_over_refl.
      eauto using context_cumulativity_app, context_cumulativity_wf_app.
      eapply IHbty.
      eapply All2_fold_app => //. apply All2_cumul_over_refl.
      eapply context_cumulativity_wf_app; tea.
  - econstructor.
    all:pcuic.
    * eapply fix_guard_context_cumulativity; eauto.
      eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto.
      + apply wf_local_closed_context; eauto.
      + apply wf_local_closed_context; eauto.
    * eapply (All_impl X0).
      intros d Ht.
      apply infer_typing_sort_impl with id Ht; now intros [_ IH].
    * eapply (All_impl X1).
      intros d [Hs IH].
      eapply IH.
      now apply cumul_context_app_same.
      eapply (All_mfix_wf); auto.
      apply (All_impl X0); simpl.
      intros d' Ht.
      apply infer_typing_sort_impl with id Ht; now intros [_ IH'].
  - econstructor.
    all:pcuic.
    * eapply cofix_guard_context_cumulativity; eauto.
      eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto.
      + apply wf_local_closed_context; eauto.
      + apply wf_local_closed_context; eauto.
    * eapply (All_impl X0).
      intros d Ht.
      apply infer_typing_sort_impl with id Ht; now intros [_ IH].
    * eapply (All_impl X1).
      intros d [Hs IH].
      eapply IH.
      now apply cumul_context_app_same.
      eapply (All_mfix_wf); auto.
      apply (All_impl X0); simpl.
      intros d' Ht.
      apply infer_typing_sort_impl with id Ht; now intros [_ IH'].

  - econstructor; eauto. pose proof (wf_local_closed_context wfΓ).
    pose proof (type_closed (forall_Γ' _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H0.
    pose proof (subject_closed (forall_Γ'0 _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H1.
    pose proof (type_closed typet). eapply (@closedn_on_free_vars xpred0) in H2.
    pose proof (subject_closed typeB). eapply (@closedn_on_free_vars xpred0) in H3.
    unshelve eapply (@cumulAlgo_cumulSpec  _ _ Cumul); eauto.
    apply into_ws_cumul_pb; eauto.
    * unshelve eapply (cumulSpec_cumulAlgo _ _ (exist Γ _) (exist A _) (exist B _)) in X4; eauto.
      apply ws_cumul_pb_forget in X4. eapply wt_cum_ws_cumul_pb in X4; tea.
      apply (wt_cum_ws_cumul_ctx_pb Cumul) in X5; tea.
      eapply (ws_cumul_pb_ws_cumul_ctx X5) in X4.
      now eapply ws_cumul_pb_forget in X4.
    * eapply wf_local_closed_context; eauto.
Qed.

Lemma closed_context_cumul_cumul {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} :
  Σ ⊢ Γ ≤ Γ' -> cumul_context cumulAlgo_gen Σ Γ Γ'.
Proof.
  now move/ws_cumul_ctx_pb_forget.
Qed.
#[global] Hint Resolve closed_context_cumul_cumul : pcuic.

Lemma closed_context_conv_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} :
  Σ ⊢ Γ = Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'.
Proof.
  now move/ws_cumul_ctx_pb_forget.
Qed.
#[global] Hint Resolve closed_context_conv_conv : pcuic.

Lemma closed_context_cumulativity {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} Γ {pb t T Γ'} :
  Σ ;;; Γ |- t : T ->
  wf_local Σ Γ' ->
  Σ ⊢ Γ' ≤[pb] Γ ->
  Σ ;;; Γ' |- t : T.
Proof.
  intros h hΓ' e.
  pose proof (ws_cumul_ctx_pb_forget e).
  destruct pb; eapply context_cumulativity_prop; eauto.
  eapply conv_cumul_context in e; tea.
  eapply (ws_cumul_ctx_pb_forget e).
Qed.

Lemma context_cumulativity {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} Γ {t T Γ'} :
  Σ ;;; Γ |- t : T ->
  wf_local Σ Γ' ->
  cumul_context cumulAlgo_gen Σ Γ' Γ ->
  Σ ;;; Γ' |- t : T.
Proof.
  intros h hΓ' e.
  eapply context_cumulativity_prop; eauto.
Qed.

#[global] Hint Resolve wf_local_closed_context : fvs.

Lemma wf_conv_context_closed {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} {Γ Γ'} :
  conv_context cumulAlgo_gen Σ Γ Γ' ->
  wf_local Σ Γ ->
  wf_local Σ Γ' ->
  Σ ⊢ Γ = Γ'.
Proof.
  move=> a wf wf'.
  eapply into_ws_cumul_ctx_pb; eauto with fvs.
Qed.

Lemma wf_cumul_context_closed {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} {Γ Γ'} :
  cumul_context cumulAlgo_gen Σ Γ Γ' ->
  wf_local Σ Γ ->
  wf_local Σ Γ' ->
  Σ ⊢ Γ ≤ Γ'.
Proof.
  move=> a wf wf'.
  eapply into_ws_cumul_ctx_pb; eauto with fvs.
Qed.

Lemma context_conversion {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} Γ {t T Γ'} :
  Σ ;;; Γ |- t : T ->
  wf_local Σ Γ' ->
  conv_context cumulAlgo_gen Σ Γ Γ' ->
  Σ ;;; Γ' |- t : T.
Proof.
  intros h hΓ' e.
  eapply wf_conv_context_closed in e; eauto with fvs pcuic.
  symmetry in e.
  now eapply closed_context_cumulativity in e.
Qed.

(* For ease of application, avoiding to add a call to symmetry *)
Lemma closed_context_conversion {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} Γ {t T Γ'} :
  Σ ;;; Γ |- t : T ->
  wf_local Σ Γ' ->
  Σ ⊢ Γ = Γ' ->
  Σ ;;; Γ' |- t : T.
Proof.
  intros h hΓ' e.
  symmetry in e.
  now eapply closed_context_cumulativity in e.
Qed.


(**********************************************************************)
(* This Program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      SF_size.v                                     *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

(*
Add LoadPath ".." as IntensionalLib.
*)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.
Require Import IntensionalLib.SF_calculus.SF_Normal.
Require Import IntensionalLib.SF_calculus.SF_Closed.
Require Import IntensionalLib.SF_calculus.Substitution.
Require Import IntensionalLib.SF_calculus.SF_Eval.
Require Import IntensionalLib.SF_calculus.Star.
Require Import IntensionalLib.SF_calculus.Fixpoints.
Require Import IntensionalLib.SF_calculus.Equal.
Require Import IntensionalLib.SF_calculus.Extensions.

Require Import IntensionalLib.Closure_to_SF.Tagging.
Require Import IntensionalLib.Closure_to_SF.Adding.
Require Import IntensionalLib.Closure_to_SF.Abstraction_to_Combination.

(*
From Bignums Require Import BigN.

Delimit Scope bigN_scope with bigN.
Local Open Scope bigN_scope.
*)

Fixpoint size M :=
match M with
| Ref _ => 2
| Op _ => 1
| App M1 M2 => (size M2) + (size M1)
end .

Lemma var_size: size (var s_op) = 417 .
Proof. cbv. auto.  Qed.

Lemma size_add: size (add i_op) = 17855.
Proof. cbv. auto. Qed.

Require Import IntensionalLib.Closure_calculus.Closure_calculus.

Lemma size_identity_abs:
size (closure_to_SF (Abs Closure_calculus.Iop 0 (Closure_calculus.Ref 0))) = 18290.
Proof. cbv. auto. Qed.


From Hammer Require Import Hammer.

Require Import Arith.
From Lambda Require Import Terms.
From Lambda Require Import Reduction.
From Lambda Require Import Redexes.
From Lambda Require Import Test.
From Lambda Require Import Substitution.
From Lambda Require Import Residuals.

Inductive compat : redexes -> redexes -> redexes -> Prop :=
| Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
| Compat_Fun :
forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
| Compat_Ap1 :
forall U1 V1 W1 : redexes,
compat U1 V1 W1 ->
forall U2 V2 W2 : redexes,
compat U2 V2 W2 ->
forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
| Compat_Ap2 :
forall U1 V1 W1 : redexes,
compat U1 V1 W1 ->
forall U2 V2 W2 : redexes,
compat U2 V2 W2 ->
forall b b' : bool,
compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).

Lemma compat_intro :
forall U W WU : redexes,
residuals W U WU ->
forall (V WV : redexes) (R2 : residuals W V WV) (S : sub V U), compat U V W.
Proof. hammer_hook "Cube" "Cube.compat_intro".

simple induction 1; intros; generalize S; inversion_clear R2; intros;
inversion_clear S.
apply Compat_Var.
apply Compat_Fun.
inversion_clear S0; apply H1 with W1; auto.
inversion_clear S0; apply Compat_Ap1; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
inversion_clear S0.
inversion_clear S0; generalize H4; inversion_clear H8.
intro H11; inversion_clear H11; apply Compat_Ap2; auto.
apply H1 with W4; auto.
apply H3 with W3; auto.
generalize H4; inversion_clear S0.
inversion_clear H8.
intro H11; inversion_clear H11; apply Compat_Ap2; auto.
apply H1 with W4; auto.
apply H3 with W3; auto.
inversion_clear S0; apply Compat_Ap2; inversion_clear H8; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
inversion_clear S0; apply Compat_Ap2; inversion_clear H8; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
Qed.

Lemma prism0 :
forall U V W : redexes,
compat U V W ->
forall (UV : redexes) (R1 : residuals U V UV) (WU WV : redexes)
(R2 : residuals W U WU) (R3 : residuals W V WV),
residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism0".
simple induction 1.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
simple induction b; intros; inversion_clear R1; inversion_clear R2;
inversion_clear R3; auto.
apply commutation; auto.
inversion_clear H4; inversion_clear H8; auto.
Qed.

Lemma prism1 :
forall U V W : redexes,
sub V U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals W U WU -> residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism1".
intros; apply prism0 with U V W; auto.
apply compat_intro with WU WV; trivial.
Qed.

Lemma prism2 :
forall U V W : redexes,
sub V U ->
regular U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals WV UV WU -> residuals W U WU.
Proof. hammer_hook "Cube" "Cube.prism2".
intros.
elim (residuals_intro W U); trivial.
intros WU' R; elim (residuals_function WV UV WU) with WU'; trivial.
apply prism1 with U V W; trivial.
apply comp_trans with V.
apply residuals_comp with WV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
Qed.

Theorem prism :
forall U V W : redexes,
sub V U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals W U WU <-> regular U /\ residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism".
intros; unfold iff in |- *; split.
intro; split.
apply residuals_regular with W WU; trivial.
apply prism1 with U V W; trivial.
simple induction 1; intros; apply prism2 with V UV WV; trivial.
Qed.

Lemma cube :
forall U V UV VU : redexes,
residuals U V UV ->
residuals V U VU ->
forall W WU WV WUV : redexes,
residuals W U WU ->
residuals WU VU WUV -> residuals W V WV -> residuals WV UV WUV.
Proof. hammer_hook "Cube" "Cube.cube".
intros.
cut (comp U V).
2: apply residuals_comp with UV; trivial.
intro C; elim (union_defined U V C); intros T UVT.
apply prism1 with T V W; trivial.
apply union_r with U; trivial.
apply preservation with U; trivial.
apply prism2 with U VU WU; trivial.
apply union_l with V; trivial.
apply union_preserve_regular with U V; trivial.
apply residuals_regular with V VU; trivial.
apply residuals_regular with U UV; trivial.
apply preservation with V; trivial.
apply union_sym; trivial.
Qed.

Lemma paving :
forall U V W WU WV : redexes,
residuals W U WU ->
residuals W V WV ->
exists UV : redexes,
(exists VU : redexes,
(exists WUV : redexes, residuals WU VU WUV /\ residuals WV UV WUV)).
Proof. hammer_hook "Cube" "Cube.paving".
intros; elim (residuals_intro U V).
intros UV R1; exists UV.
elim (residuals_intro V U).
intros VU R2; exists VU.
elim (residuals_intro WU VU).
intros WUV R3; exists WUV.
split; trivial.
apply cube with U V VU W WU; trivial.
apply mutual_residuals_comp with U W V; trivial.
apply residuals_preserve_regular with V U; trivial.
apply residuals_regular with U UV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
apply residuals_regular with W WU; trivial.
apply comp_trans with W.
apply comp_sym; apply residuals_comp with WU; trivial.
apply residuals_comp with WV; trivial.
apply residuals_regular with W WV; trivial.
Qed.