(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex7_9".

(** Derivation of DDH assumption for three parties from two parties. [DDH] assumption for three parties:

[Fresh(G,g,a,b,c,e)-> [[G;g;g^a;g^b;g^c;g^(ab);g^(ac); g^(bc); g^(abc)]] ~ [[G;g;g^a;g^b;g^c;g^(ab);g^(ac); g^(bc); g^e]] ]. *)

Theorem Example19: forall (n n1 n2 n3 n4 n5 :nat), (Fresh [ n ; n1 ; n2 ; n3; n5 ; n4] []  = true )-> ([msg (G n); msg (g n); msg (exp (G n)(g n)(r n1)) ; msg (exp (G n)(g n)(r n2)) ; msg (exp (G n)(g n)(r n3)); msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2)) ; msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3)) ; msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3)); msg (exp (G n)(exp (G n) (exp (G n)(g n)(r n1)) (r n2)) (r n3))])
 ~ [msg (G n); msg (g n); msg (exp (G n)(g n)(r n1)) ; msg (exp (G n)(g n)(r n2)) ; msg (exp (G n)(g n)(r n3)); msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2)) ; msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3)) ; msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3)); msg (exp (G n)(g n)(r n5))] .
Proof.
intros.
assert (D: Fresh [n; n1; n2; n4] [] = true).
(*************proof**********)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.
assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
  Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
(*******************************************************)
rew_all_hyps.
(****************************************************************)
apply DDH in D.
(******step3**************)
assert(Fresh3: Fresh [n3 ] ([msg (G  n); msg (g  n);
      msg (exp (G n)(g n)(r n1));
msg (exp (G n)(g n)(r n2));
     msg (exp (G  n)
        (exp (G n)(g n)(r n1)) (r n2))] ++
     [msg (G n); msg (g n);
    msg  (exp (G n)(g n)(r n1));
   msg  (exp (G n)(g n)(r n2));
     msg (exp (G n)(g n)(r n4))]) = true) .
(********proof***********)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.
assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.
(**********************)
rew_all_hyps.
 rewrite <- Nat.eqb_sym.  rew_all_hyps. rewrite <- Nat.eqb_sym.  rew_all_hyps. rewrite <- Nat.eqb_sym.  rew_all_hyps.
(******************************************************)
assert(s4: (clos_mylist([msg (G n); msg (g n);
 msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n);msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))] )= true) /\ ( Fresh [n3]
       ([ msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
       msg ( exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n); msg ( g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)
/\( Fresh [n3]
       ([ msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
       msg ( exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n); msg ( g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)
/\ ([msg (G n); msg (g n);
      msg (exp (G n)(g n)(r n1));
      msg (exp (G n)(g n)(r n2));
      msg (exp (G n)
        (exp (G n)(g n)(r n1)) (r n2))]) ~
     [msg (G n); msg  (g n);
     msg (exp (G n)(g n)(r n1));
     msg (exp (G n)(g n)(r n2));
     msg (exp (G n)(g n)(r n4))]).

repeat (try split); repeat (try reflexivity);
auto.
apply FRESHIND with (n1:=n3) (n2:=n3) in s4 .
simpl in s4.

(*******construct term from terms in list and append *****************)
funapp_exp_in  2 3 1 s4.
funapp_exp_in 2 4 1 s4.
funapp_exp_in 2 5 1 s4.
funapp_exp_in 2 6 1 s4.
dropone_in s4.
assert(DDH2: Fresh [n;n4;n3;n5] [] = true).
(***********proof**********************)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.
assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.
assert(H16: beq_nat n4 n5 = false).
Fr_pf.
(**********************)
rew_all_hyps. rewrite <- Nat.eqb_sym. rew_all_hyps. rewrite <- Nat.eqb_sym. rew_all_hyps.
rewrite <- Nat.eqb_sym. rew_all_hyps.
(****************************************)
apply DDH in DDH2.
assert(Fresh [n2] ([msg (G n); msg (g n);
 msg   (   exp (G n)(g n)(r n4));
     msg ( exp (G n)(g n)(r n3));
     msg (exp (G n)
        (exp (G n)(g n)(r n4)) (r n3))]++[ msg (G n); msg ( g n);
     msg (exp (G n)(g n)(r n4));
    msg (exp (G n)(g n)(r n3));
     msg (exp (G n)(g n)(r n5))]) = true).
(********proof***********)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.

assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.
(**********************)
rew_all_hyps.
 rewrite <- Nat.eqb_sym. rew_all_hyps.
(*********************************************************)
assert(line7: (clos_mylist ([msg (G n); msg (g n);
      msg (exp (G n)(g n)(r n4));
      msg (exp (G n)(g n)(r n3));
      msg (exp (G n)
        (exp (G n)(g n)(r n4)) (r n3))]++[msg (G n); msg (g n);
     msg (exp (G n)(g n)(r n4));
     msg (exp (G n)(g n)(r n3));
     msg (exp (G n)(g n)(r n5))]) = true) /\
(Fresh [n2] ([msg (G n); msg (g n);
 msg   (   exp (G n)(g n)(r n4));
     msg ( exp (G n)(g n)(r n3));
     msg (exp (G n)
        (exp (G n)(g n)(r n4)) (r n3))] ++ [ msg (G n); msg ( g n);
     msg (exp (G n)(g n)(r n4));
    msg (exp (G n)(g n)(r n3));
     msg (exp (G n)(g n)(r n5))]) = true) /\ (Fresh [n2] ([msg (G n); msg (g n);
 msg   (   exp (G n)(g n)(r n4));
     msg ( exp (G n)(g n)(r n3));
     msg (exp (G n)
        (exp (G n)(g n)(r n4)) (r n3))]++[ msg (G n); msg ( g n);
     msg (exp (G n)(g n)(r n4));
    msg (exp (G n)(g n)(r n3));
     msg (exp (G n)(g n)(r n5))]) = true) /\ [msg (G n); msg (g n);
      msg (exp (G n)(g n)(r n4));
      msg (exp (G n)(g n)(r n3));
      msg (exp (G n)
        (exp (G n)(g n)(r n4)) (r n3))] ~
     [msg (G n); msg (g n);
     msg (exp (G n)(g n)(r n4));
    msg (exp (G n)(g n)(r n3));
     msg (exp (G n)(g n)(r n5))]).
repeat (try split); repeat (try reflexivity); auto.

apply FRESHIND with (n1:=n2) (n2:=n2) in line7 .
simpl in line7. clear H0.

assert(Fresh1 : ( Fresh [n1] ([msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
         msg (exp (G n)(g n)(r n3));
         msg (exp (G n)
           (exp (G n)(g n)(r n4)) (r n3))] ++
        [msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
       msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(g n)(r n5))]) = true)).

(*****proof**********************************************)
(********proof***********)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.

assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.

assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.

assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.

(**********************)
rew_all_hyps. rewrite <- Nat.eqb_sym. rew_all_hyps.
(***************************************************)
(***************************************************)
assert(temp2:(clos_mylist ([msg (r n2); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n4));
         msg (exp (G n)(g n)(r n3));
         msg (exp (G n)
           (exp (G n)(g n)(r n4)) (r n3))] ++
        [msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
        msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(g n)(r n5))]) = true)/\( Fresh [n1] ([msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
         msg (exp (G n)(g n)(r n3));
         msg (exp (G n)
           (exp (G n)(g n)(r n4)) (r n3))] ++
        [msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
       msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(g n)(r n5))]) = true) /\
( Fresh [n1] ([msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
         msg (exp (G n)(g n)(r n3));
         msg (exp (G n)
           (exp (G n)(g n)(r n4)) (r n3))] ++
        [msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
       msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(g n)(r n5))]) = true) /\
[msg (r n2); msg (G n); msg (g n);
       msg (  exp (G n)(g n)(r n4));
       msg ( exp (G n)(g n)(r n3));
        msg (exp (G n)
           (exp (G n)(g n)(r n4)) (r n3))] ~
        [msg (r n2); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n4));
       msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(g n)(r n5))]).

repeat (try split); repeat (try reflexivity); auto.

apply FRESHIND with (n1:= n1) (n2:= n1) in temp2.
simpl in temp2.

(*******construct term from terms in list and append *****************)

funapp_exp_in 3 4 1 temp2.
funapp_exp_in 3 4 2 temp2.
funapp_exp_in 3 6 1 temp2.
funapp_exp_in 3 6 2 temp2.
(*rewrite IFTRUE_M *)
rewrite commexp with (G:= (G n))(g:= g n)(x := (r n3))(y:= (r n1)) in temp2.
rewrite commexp with (G:= (G n))(g:= g n)(x := (r n3))(y:= (r n2)) in temp2.
(*******drop 2 elements***************)
aply_in 2 dropone_in temp2.
(********************RESTR2***********************)
restr_swap_in 5 6 temp2.
restr_swap_in 6 7 temp2.
restr_swap_in 4 5 temp2.
restr_swap_in 3 4 temp2.
restr_swap_in 5 6 temp2.
restr_swap_in 4 5 temp2.
restr_swap_in 7 8 temp2.
restr_swap_in 8 9 temp2.
assert(line10: [msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2));
        msg (exp (G n)(g n)(r n3));
        msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
        msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
        msg
          (exp (G n)
             (exp (G n)(exp (G n)(g n)(r n1)) (r n2))
             (r n3))] ~   [msg (G n); msg (g n);
          msg (exp (G n)(g n)(r n1));
          msg (exp (G n)(g n)(r n2));
          msg (exp (G n)(g n)(r n4));
          msg (exp (G n)(g n)(r n3));
          msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
          msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
          msg (exp (G n)(g n)(r n5))]).

apply EQI_trans with (ml2:= [msg (G n); msg (g n);
       msg (exp (G n)(g n)(r n1));
       msg (exp (G n)(g n)(r n2));
       msg (exp (G n)(g n)(r n4));
       msg (exp (G n)(g n)(r n3));
       msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
       msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
       msg (exp (G n)(exp (G n)(g n)(r n4)) (r n3))] ). apply s4. apply temp2.
assert(Fresh5: ( Fresh [n5] ( [msg (G n); msg (g n);
       msg (exp (G n)(g n)(r n1));
       msg (exp (G n)(g n)(r n2));
       msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))] ++
          [msg (G n); msg (g n);
      msg (exp (G n)(g n)(r n1));
      msg (exp (G n)(g n)(r n2));
      msg (exp (G n)(g n)(r n4))]) = true)).
(*****************************************************)
(*****proof**********************************************)
(***********proof**********************)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.
assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.
assert(H16: beq_nat n4 n5 = false).
Fr_pf.
(**********************)
rew_all_hyps.
 rewrite <- Nat.eqb_sym. rew_all_hyps.
  rewrite <- Nat.eqb_sym.  rew_all_hyps.
rewrite <- Nat.eqb_sym.  rew_all_hyps.
(***************************************************)
(***************************************************)
assert(s11: (clos_mylist([msg (G n); msg (g n);
 msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n);msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))] )= true) /\ ( Fresh [n5]
       ([ msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
       msg ( exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n); msg ( g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)
/\( Fresh [n5]
       ([ msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
       msg ( exp (G n)
          (exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (G n); msg ( g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)
/\ ([msg (G n); msg (g n);
      msg (exp (G n)(g n)(r n1));
      msg (exp (G n)(g n)(r n2));
      msg (exp (G n)
        (exp (G n)(g n)(r n1)) (r n2))]) ~
     [msg (G n); msg  (g n);
     msg (exp (G n)(g n)(r n1));
     msg (exp (G n)(g n)(r n2));
     msg (exp (G n)(g n)(r n4))]).
repeat (try split); repeat (try reflexivity); auto.
apply FRESHIND with (n1:= n5) (n2:= n5) in s11.
simpl in s11.
clear Fresh3.
assert(Fresh3:( Fresh [n3] ( [msg (r n5); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n1));
         msg (exp (G n)(g n)(r n2));
         msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))] ++  [msg (r n5); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)).
(*********************proof************************************)
unfold Fresh in H.
apply andb_prop with (a:=  nodup_ilist [n; n1; n2; n3; n5;n4]) (b:=  notocclist_mylist [n; n1; n2; n3; n5;n4] []) in H.
inversion H.
unfold nodup_ilist in H0.
 unfold count_occur in H0.
 rewrite <- beq_nat_refl in H0.
assert(H2: beq_nat n1 n = false).
Fr_pf.
assert(H3: beq_nat n2 n = false).
Fr_pf.
assert(H4: beq_nat n3 n = false).
Fr_pf.
assert(H5: beq_nat n5 n = false).
Fr_pf.
assert(H6: beq_nat n4 n = false).
Fr_pf.
assert(H7: beq_nat n2 n1 = false).
Fr_pf.
assert(H8: beq_nat n3 n1 = false ).
Fr_pf.
assert(H9: beq_nat n5 n1 = false).
Fr_pf.
assert(H10 : beq_nat n4 n1 = false).
Fr_pf.
assert(H11: beq_nat n3 n2 = false).
Fr_pf.
assert(H12: beq_nat n5 n2 = false).
Fr_pf.
assert(H13: beq_nat n4 n2 = false).
Fr_pf.
assert(H14: beq_nat n5 n3 = false).
Fr_pf.
assert(H15: beq_nat n4 n3 = false).
Fr_pf.
(**********************)
rew_all_hyps.  rewrite <- Nat.eqb_sym. rew_all_hyps. rewrite <- Nat.eqb_sym. rew_all_hyps.  rewrite <- Nat.eqb_sym. rew_all_hyps.
assert(temp3:(clos_mylist ([msg (r n5); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n1));
         msg (exp (G n)(g n)(r n2));
         msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))] ++
        [msg (r n5); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true) /\( Fresh [n3] ( [msg (r n5); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n1));
         msg (exp (G n)(g n)(r n2));
         msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))] ++  [msg (r n5); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true) /\
( Fresh [n3] ( [msg (r n5); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n1));
         msg (exp (G n)(g n)(r n2));
         msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))] ++  [msg (r n5); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]) = true)
       /\ ([msg (r n5); msg (G n); msg (g n);
         msg (exp (G n)(g n)(r n1));
         msg (exp (G n)(g n)(r n2));
         msg (exp (G n)(exp (G n)(g n)(r n1)) (r n2))]) ~
        [msg (r n5); msg (G n); msg (g n);
        msg (exp (G n)(g n)(r n1));
        msg (exp (G n)(g n)(r n2));
        msg (exp (G n)(g n)(r n4))]).
repeat (try split); repeat (try reflexivity); auto.
apply FRESHIND with (n1:= n3) (n2:= n3) in temp3.
simpl in temp3.
(*******construct term from terms in list and append *****************)
funapp_exp_in 3 4 1 temp3.
funapp_exp_in 3 4 2 temp3.
funapp_exp_in 3 5 1 temp3.
funapp_exp_in 3 6 1 temp3.
(**********drop two elts ********************)
aply_in 2 dropone_in temp3.
restr_swap_in 7 8 temp3.
restr_swap_in 8 9 temp3.
assert(Final :[msg (G n); msg (g n);
            msg (exp (G n)(g n)(r n1));
            msg (exp (G n)(g n)(r n2));
            msg
              (exp (G n)(exp (G n)(g n)(r n1)) (r n2));
            msg (exp (G n)(g n)(r n3));
            msg
              (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
            msg
              (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
            msg
              (exp (G n)
                 (exp (G n)(exp (G n)(g n)(r n1))
                    (r n2)) (r n3))] ~ [msg (G n); msg (g n);
           msg (exp (G n)(g n)(r n1));
           msg (exp (G n)(g n)(r n2));
           msg
             (exp (G n)(exp (G n)(g n)(r n1)) (r n2));
           msg (exp (G n)(g n)(r n3));
           msg
             (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
           msg
             (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
           msg (exp (G n)(g n)(r n5))]).
apply EQI_trans with (ml2:=  [msg (G n); msg (g n);
          msg (exp (G n)(g n)(r n1));
          msg (exp (G n)(g n)(r n2));
          msg (exp (G n)(g n)(r n4));
          msg (exp (G n)(g n)(r n3));
          msg (exp (G n)(exp (G n)(g n)(r n1)) (r n3));
          msg (exp (G n)(exp (G n)(g n)(r n2)) (r n3));
          msg (exp (G n)(g n)(r n5))]). apply line10.
symmetry. apply temp3.
restr_swap_in 5 6 Final.
apply Final.
Qed.


Require Import Arith.
Variable A:Type.
Print list.

Notation "x :: l" := (cons x l) (at level 60, right associativity).

Notation "[ ]" := nil.

Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Fixpoint get (l : list A)(n : nat): option A :=
  match l, n with
    | [] , _ => None
    | x::xs, 0 => Some x
    | x::xs, S n0 => get xs n0
  end.

Fixpoint update (l : list A)(n : nat)(a : A):list A :=
  match l, n with
    | x::xs, 0 => a::xs
    | [], _ => []
    | x::xs, S n => x::(update xs n a)
  end.

Variable error : A.

(*Esto siento que esta super chaca pero fue lo único que se me ocurrio para quitar el option*)
Fixpoint chaka (a : option A): A :=
match a with
| Some b => b
| none => error
end.

Lemma mayor_0: forall (n m : nat), n > S m ->  n <> 0.
Proof.
  intros.
  induction n.
  unfold gt in H.
  apply lt_n_0 in H.
  exfalso;trivial.
  discriminate.
Qed.

Lemma ex_n : forall (n : nat), n <> 0 -> exists (m : nat), n = S m.
Proof.
  induction n.
  intro.
  contradict H.
  trivial.
  intro.
  exists n.
  trivial.
Qed.

Theorem uno: forall (l : list A)(i : nat), i > (length l) -> (get l i) = None.
Proof.
  intro.
  induction l.
  trivial.
  intros.
  simpl in H.
  assert (i > S (length l)).
  trivial.
  simpl.
  apply mayor_0 in H.
  apply ex_n in H.
  destruct H.
  rewrite H.
  apply IHl.
  rewrite H in H0.
  apply gt_S_n in H0.
  trivial.
Qed.

Lemma not_in_head: forall (l : list A)(x a : A),~ List.In x (a :: l) -> x <> a.
Admitted.

Lemma not_in_tail: forall (l : list A)(x a : A),~ List.In x (a :: l) -> ~ List.In x l.
Admitted.

(*Los dos lemas de arriba son equivalentes al lema not_in_cons que esta en
Coq.Lists.List pero por alguna razon no lo pude usar, es por eso que no los demostre*)

Theorem dos: forall (x : A)(l : list A), ~(List.In x l) -> forall (i : nat), ~(get l i = Some x).
Proof.
  intros x l.
  induction l.
  intros.
  simpl.
  discriminate.
  intros.
  destruct i.
  simpl.
  apply not_in_head in H.
  admit. (*No sé como demostrar que Some a <> Some x si a <> x pero es claro que es cierto*)
  apply IHl.
  apply not_in_tail in H.
  trivial.
Qed.

Theorem tres: forall (x : A)(l : list A), List.In x l -> exists (i : nat), get l i = Some x.
Proof.
  intros x l.
  induction l; intro.
  simpl in H.
  exfalso.
  trivial.
  apply List.in_inv in H.
  destruct H.
  exists 0.
  simpl.
  rewrite H.
  trivial.
  apply IHl in H.
  destruct H.
  exists (S x0).
  simpl.
  trivial.
Qed.

Theorem cuatro: forall (l : list A)(i : nat), update l i (chaka (get l i)) = l.
Proof.
  intro.
  induction l.
  destruct i.
  simpl.
  trivial.
  reflexivity.
  destruct i.
  simpl.
  trivial.
  simpl.
  rewrite IHl.
  trivial.
Qed.

Theorem cinco: forall (l : list A)(a : A)(n : nat), n > (length l) -> update l n a = l.
Proof.
  intros l a.
  induction l.
  intros.
  reflexivity.
  intros.
  destruct n.
  simpl in H.
  exfalso.
  assert (forall (n : nat), ~(0 > n)).
  admit. (*Es obvio que 0 no es mayor que ningún natural, pero no encontre un lema en la biblioteca que dijera eso*)
  apply H0 in H.
  trivial.
  simpl.
  rewrite IHl.
  trivial.
  simpl in H.
  apply gt_S_n in H.
  trivial.
Qed.


Require Import init.

Require Import order_minmax.

Require Import linear_extend.

Require Export geometric_construct.
Require Import geometric_grade.
Require Import geometric_exterior_isomorphism.
Require Import geometric_decomposition.
Require Import exterior_involutions.
Require Import geometric_involutions_grade.
Require Import exterior_grade.

(* begin hide *)
Section GeometricOuter.

(* end hide *)
Context {F : CRingObj} {V : ModuleObj F}.
(* begin hide *)

Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMC := cring_mult_comm F.

Existing Instances UP UZ UN UPC UPZ UPN UM UO UMC.

Let VP := module_plus V.
Let VS := module_scalar V.

Existing Instances VP VS.

(* end hide *)
Context (B : set_type bilinear_form).

(* begin hide *)
Let GP := geo_plus B.
Let GZ := geo_zero B.
Let GN := geo_neg B.
Let GPA := geo_plus_assoc B.
Let GPC := geo_plus_comm B.
Let GPZ := geo_plus_lid B.
Let GPN := geo_plus_linv B.
Let GM := geo_mult B.
Let GO := geo_one B.
Let GL := geo_ldist B.
Let GR := geo_rdist B.
Let GMA := geo_mult_assoc B.
Let GML := geo_mult_lid B.
Let GMR := geo_mult_rid B.
Let GS := geo_scalar B.
Let GSO := geo_scalar_id B.
Let GSL := geo_scalar_ldist B.
Let GSR := geo_scalar_rdist B.
Let GSC := geo_scalar_comp B.
Let GSML := geo_scalar_lmult B.
Let GSMR := geo_scalar_rmult B.
Let GG := geo_grade B.

Existing Instances GP GZ GN GPA GPC GPZ GPN GM GO GL GR GMA GML GMR GS GSO GSL
    GSR GSC GSML GSMR GG.

Local Notation "'φ'" := (vector_to_geo B).
Local Notation "'σ'" := (scalar_to_geo B).
Local Notation "'E'" := (geo_to_ext B).
Local Notation "'G'" := (ext_to_geo B).

Let EP := ext_plus V.
Let EZ := ext_zero V.
Let EN := ext_neg V.
Let EPA := ext_plus_assoc V.
Let EPC := ext_plus_comm V.
Let EPZ := ext_plus_lid V.
Let EPN := ext_plus_linv V.
Let EM := ext_mult V.
Let EO := ext_one V.
Let EL := ext_ldist V.
Let ER := ext_rdist V.
Let EML := ext_mult_lid V.
Let EMR := ext_mult_rid V.
Let EMA := ext_mult_assoc V.
Let ES := ext_scalar V.
Let ESO := ext_scalar_id V.
Let ESL := ext_scalar_ldist V.
Let ESR := ext_scalar_rdist V.
Let ESML := ext_scalar_lmult V.
Let ESMR := ext_scalar_rmult V.

Existing Instances EP EZ EN EPA EPC EPZ EPN EM EO EL ER EML EMR EMA ES ESO ESL
    ESR ESML ESMR.

Local Open Scope geo_scope.
Local Open Scope nat_scope.

(* end hide *)
Definition geo_outer_base i j (a b : geo B) (ai : of_grade i a) (bj : of_grade j b)
    := grade_project (a * b) (i + j) : geo B.

Lemma geo_outer_ldist_base : bilinear_extend_ldist_base geo_outer_base.
Proof.
    intros u v w i j ui vj wj.
    unfold geo_outer_base.
    rewrite ldist.
    apply grade_project_plus.
Qed.

Lemma geo_outer_rdist_base : bilinear_extend_rdist_base geo_outer_base.
Proof.
    intros u v w i j ui vi wj.
    unfold geo_outer_base.
    rewrite rdist.
    apply grade_project_plus.
Qed.

Lemma geo_outer_lscalar_base : bilinear_extend_lscalar_base geo_outer_base.
Proof.
    intros a u v i j ui vj.
    unfold geo_outer_base.
    rewrite scalar_lmult.
    apply grade_project_scalar.
Qed.

Lemma geo_outer_rscalar_base : bilinear_extend_rscalar_base geo_outer_base.
Proof.
    intros a u v i j ui vj.
    unfold geo_outer_base.
    rewrite scalar_rmult.
    apply grade_project_scalar.
Qed.

Definition geo_outer := bilinear_extend geo_outer_base : geo B → geo B → geo B.

(** Note: Because Coq already uses ∧ for logical and, this symbol is actually
\bigwedge, not \wedge!
*)
(* begin show *)
Local Infix "⋀" := geo_outer (at level 34, left associativity).
(* end show *)

Theorem outer_ldist : ∀ a b c, a ⋀ (b + c) = a ⋀ b + a ⋀ c.
Proof.
    apply bilinear_extend_ldist.
    -   exact geo_outer_ldist_base.
    -   exact geo_outer_rscalar_base.
Qed.

Theorem outer_rdist : ∀ a b c, (a + b) ⋀ c = a ⋀ c + b ⋀ c.
Proof.
    apply bilinear_extend_rdist.
    -   exact geo_outer_rdist_base.
    -   exact geo_outer_lscalar_base.
Qed.

Theorem outer_lscalar : ∀ a u v, (a · u) ⋀ v = a · (u ⋀ v).
Proof.
    apply bilinear_extend_lscalar.
    -   apply geo_outer_rdist_base.
    -   apply geo_outer_lscalar_base.
Qed.

Theorem outer_rscalar : ∀ a u v, u ⋀ (a · v) = a · (u ⋀ v).
Proof.
    apply bilinear_extend_rscalar.
    -   apply geo_outer_ldist_base.
    -   apply geo_outer_rscalar_base.
Qed.

Theorem outer_lanni : ∀ a, 0 ⋀ a = 0.
Proof.
    intros a.
    rewrite <- (scalar_lanni 0) at 1.
    rewrite outer_lscalar.
    apply scalar_lanni.
Qed.

Theorem outer_ranni : ∀ a, a ⋀ 0 = 0.
Proof.
    intros a.
    rewrite <- (scalar_lanni 0) at 1.
    rewrite outer_rscalar.
    apply scalar_lanni.
Qed.

Lemma outer_homo : ∀ i j u v (ui : of_grade i u) (vj : of_grade j v),
    u ⋀ v = geo_outer_base i j u v ui vj.
Proof.
    intros i j u v ui vj.
    unfold geo_outer.
    apply bilinear_extend_homo.
    -   exact geo_outer_ldist_base.
    -   exact geo_outer_rdist_base.
    -   exact geo_outer_lscalar_base.
    -   exact geo_outer_rscalar_base.
Qed.

(* begin hide *)
Let EG := exterior_grade V.
Let EGA := exterior_grade_mult V.

Existing Instances EG EGA.

(* end hide *)
Theorem outer_exterior : ∀ a b, a ⋀ b = G (E a * E b).
Proof.
    intros a' b'.
    rewrite <- (ext_to_geo_to_ext B a') at 1.
    rewrite <- (ext_to_geo_to_ext B b') at 1.
    remember (E a') as a.
    remember (E b') as b.
    clear a' b' Heqa Heqb.
    induction b as [|b b' n bn b'n IHb] using grade_induction.
    {
        rewrite mult_ranni.
        rewrite ext_to_geo_zero.
        apply outer_ranni.
    }
    rewrite ldist.
    do 2 rewrite ext_to_geo_plus.
    rewrite outer_ldist.
    rewrite IHb; clear IHb.
    apply rplus; clear b' b'n.
    pose proof (ext_sum V a) as [l l_eq]; subst a.
    induction l as [|[α al] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite mult_lanni.
        rewrite ext_to_geo_zero.
        apply outer_lanni.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite rdist.
    do 2 rewrite ext_to_geo_plus.
    rewrite outer_rdist.
    rewrite IHl; clear IHl.
    apply rplus; clear l.
    rewrite scalar_lmult.
    do 2 rewrite ext_to_geo_scalar.
    rewrite outer_lscalar.
    apply lscalar; clear α.
    assert (of_grade (H9 := GG) (list_size al)
        (G (list_prod (list_image (vector_to_ext V) al)))) as al_grade.
    {
        exists (list_prod (list_image (vector_to_ext V) al)).
        split; [>|reflexivity].
        apply ext_list_grade.
    }
    assert (of_grade (H9 := GG) n (G b)) as b_grade.
    {
        exists b.
        split; [>exact bn|reflexivity].
    }
    rewrite (outer_homo _ _ _ _ al_grade b_grade).
    unfold geo_outer_base.
    clear al_grade.
    induction al as [|v al].
    {
        cbn.
        rewrite ext_to_geo_one.
        do 2 rewrite mult_lid.
        rewrite plus_lid.
        apply grade_project_of_grade.
        exact b_grade.
    }
    do 2 rewrite list_image_add; cbn.
    do 2 rewrite list_prod_add.
    remember (list_prod (list_image (vector_to_ext V) al)) as a.
    rewrite list_size_add.
    remember (list_size al) as m.
    assert (of_grade m a) as a_grade.
    {
        rewrite Heqa, Heqm.
        apply ext_list_grade.
    }
    clear al Heqa Heqm.
    rewrite ext_to_geo_add.
    rewrite rdist.
    rewrite grade_project_plus.
    assert (of_grade (H9 := GG) m (G a)) as a_grade'.
    {
        exists a.
        split; [>exact a_grade|reflexivity].
    }
    rewrite mult_lneg.
    rewrite grade_project_neg.
    assert (grade_project (geo_mult_inner B v (G a) * G b) (nat_suc m + n) = 0)
        as eq.
    {
        nat_destruct m.
        -   apply ext_grade_zero_scalar in a_grade as [α α_eq]; subst a.
            rewrite ext_to_geo_of_scalar.
            rewrite geo_mult_inner_scalar.
            rewrite mult_lanni.
            apply grade_project_zero.
        -   pose proof (geo_mult_inner_grade B v (G a) _ a_grade') as am.
            apply (geo_mult_project_bigger _ _ _ _ _ am b_grade).
            do 2 rewrite nat_plus_lsuc.
            apply (trans (nat_lt_suc _)).
            apply nat_lt_suc.
    }
    rewrite eq; clear eq.
    rewrite neg_zero, plus_lid.
    rewrite <- mult_assoc.
    rewrite <- (ext_to_geo_to_ext B (φ v * _)).
    rewrite geo_to_ext_add.
    rewrite ext_to_geo_plus.
    rewrite grade_project_plus.
    rewrite ext_to_geo_inner.
    rewrite ext_to_geo_to_ext.
    rewrite mult_inner_grade_add.
    assert (m + n < nat_suc (nat_suc m + n)) as ltq.
    {
        rewrite nat_plus_lsuc.
        apply (trans (nat_lt_suc _)).
        apply nat_lt_suc.
    }
    rewrite (geo_mult_project_bigger _ _ _ _ _ a_grade' b_grade _ ltq).
    rewrite geo_mult_inner_rzero.
    rewrite plus_lid.
    rewrite ext_to_geo_project.
    rewrite nat_plus_lsuc.
    rewrite exterior_grade_add.
    rewrite geo_to_ext_project.
    rewrite IHal.
    rewrite geo_to_ext_to_geo.
    rewrite mult_assoc.
    reflexivity.
Qed.

Theorem outer_assoc : ∀ a b c : geo B, a ⋀ (b ⋀ c) = (a ⋀ b) ⋀ c.
Proof.
    intros a b c.
    do 4 rewrite outer_exterior.
    do 2 rewrite geo_to_ext_to_geo.
    rewrite mult_assoc.
    reflexivity.
Qed.

Theorem outer_lid : ∀ a : geo B, 1 ⋀ a = a.
Proof.
    intros a.
    rewrite outer_exterior.
    rewrite geo_to_ext_one.
    rewrite mult_lid.
    apply ext_to_geo_to_ext.
Qed.

Theorem outer_rid : ∀ a : geo B, a ⋀ 1 = a.
Proof.
    intros a.
    rewrite outer_exterior.
    rewrite geo_to_ext_one.
    rewrite mult_rid.
    apply ext_to_geo_to_ext.
Qed.

Theorem outer_alternating : ∀ v, φ v ⋀ φ v = 0.
Proof.
    intros v.
    rewrite outer_exterior.
    rewrite geo_to_ext_vector.
    rewrite <- ext_alternating.
    apply ext_to_geo_zero.
Qed.

Theorem outer_anticomm : ∀ u v, φ u ⋀ φ v = -(φ v ⋀ φ u).
Proof.
    intros u v.
    do 2 rewrite outer_exterior.
    do 2 rewrite geo_to_ext_vector.
    rewrite ext_anticomm.
    apply ext_to_geo_neg.
Qed.

Theorem outer_reverse : ∀ a b, (a ⋀ b)† = b† ⋀ a†.
Proof.
    intros a b.
    do 2 rewrite outer_exterior.
    rewrite ext_to_geo_reverse.
    rewrite ext_reverse_mult.
    do 2 rewrite geo_to_ext_reverse.
    reflexivity.
Qed.

Theorem outer_involute : ∀ a b, (a ⋀ b)∗ = a∗ ⋀ b∗.
Proof.
    intros a b.
    do 2 rewrite outer_exterior.
    rewrite ext_to_geo_involute.
    rewrite ext_involute_mult.
    do 2 rewrite geo_to_ext_involute.
    reflexivity.
Qed.

Theorem outer_involute_swap : ∀ a X, φ a ⋀ X = X∗ ⋀ φ a.
Proof.
    intros a X.
    do 2 rewrite outer_exterior.
    rewrite geo_to_ext_vector.
    rewrite ext_involute_swap.
    rewrite geo_to_ext_involute.
    reflexivity.
Qed.

(* begin hide *)
End GeometricOuter.

(* end hide *)
Infix "⋀" := (geo_outer _) (at level 34, left associativity) : geo_scope.


(*
 * ANY equivalence can be expressed by a configuration. Here is a proof!
 *)
Require Import Ornamental.Ornaments.

Set DEVOID lift type.

(*
 * Assume two arbitrary equivalent types A and B:
 *)
Parameter A : Type.
Parameter B : Type.

(*
 * And assume an arbitrary equivalence between them:
 *)
Parameter f : A -> B.
Parameter g : B -> A.

Parameter section : forall (a : A), g (f a) = a.
Parameter retraction : forall (b : B), f (g b) = b.

(* --- Defining a configuration for the arbitrary equivalence --- *)

(*
 * The trick is to view each a : A as g (f a). So DepConstr:
 *)
Definition dep_constr_A_0 (b : B) : A := g b.
Definition dep_constr_B_0 (b : B) : B := b.

(*
 * Eta:
 *)
Definition eta_A (a : A) := a.
Definition eta_B (b : B) := b.

Lemma eta_OK_A : forall (a : A), eta_A a = a.
Proof.
  reflexivity.
Defined.
Lemma eta_OK_B : forall (b : B), eta_B b = b.
Proof.
  reflexivity.
Defined.

(*
 * DepElim:
 *)
Program Definition dep_elim_A (P : A -> Type) (f0 : forall (b : B), P (dep_constr_A_0 b)) (a : A) : P (eta_A a).
Proof.
  rewrite <- section. apply f0.
Defined.

Program Definition dep_elim_B (P : B -> Type) (f0 : forall (b : B), P (dep_constr_B_0 b)) (b : B) : P (eta_B b).
Proof.
  apply f0.
Defined.

(*
 * We use a modified version of Gaëtan Gilbert's proof,
 * using the adjunction machinery that Jasper Hugunin proved for us a
 * while ago. Without Gaëtan's help, I wouldn't have understood how to
 * use this.
 *)
Definition retraction_adjoint := Adjoint.fg_id' f g section retraction.

Lemma is_adjoint (b : B) : section (g b) = f_equal g (retraction_adjoint b).
Proof.
  apply Adjoint.g_adjoint.
Defined.

Lemma iota_A_aux_gen :
  forall (P : A -> Type) (b : B) (f0 : forall (b : B), P (dep_constr_A_0 b)),
    dep_elim_A
      P
      (fun b0 : B => f0 b0)
      (dep_constr_A_0 b)
    =
    eq_rect (dep_constr_A_0 b) (fun H : A => P H) (f0 b) (eta_A (dep_constr_A_0 b)) (eq_sym (eta_OK_A (dep_constr_A_0 b))).
Proof.
  intros P b f0. unfold dep_elim_A.
  unfold dep_constr_A_0. rewrite eta_OK_A.
  rewrite is_adjoint.
  destruct retraction_adjoint.
  reflexivity.
Defined.

(*
 * This nasty eq_rect ... here reduces to just (f0 b), it is just included for clarity in the general case
 * where eta is not identity.
 *)
Lemma iota_A_0:
  forall (P : A -> Type) (f0 : forall b : B, P (dep_constr_A_0 b))  (b : B) (Q : P (eta_A (dep_constr_A_0 b)) -> Type),
    Q (dep_elim_A P f0 (dep_constr_A_0 b)) ->
    Q (eq_rect (dep_constr_A_0 b) (fun H : A => P H) (f0 b) (eta_A (dep_constr_A_0 b)) (eq_sym (eta_OK_A (dep_constr_A_0 b)))).
Proof.
  intros. rewrite <- iota_A_aux_gen. apply X.
Defined.

(*
 * This follows by reflexivity, but I abstract to show the type signatures and so on:
 *)
Lemma iota_B_aux_gen :
  forall (P : B -> Type) (b : B) (f0 : forall (b : B), P (dep_constr_B_0 b)),
    dep_elim_B
      P
      (fun b0 : B => f0 b0)
      (dep_constr_B_0 b)
    =
    eq_rect (dep_constr_B_0 b) (fun H : B => P H) (f0 b) (eta_B (dep_constr_B_0 b)) (eq_sym (eta_OK_B (dep_constr_B_0 b))).
Proof.
  intros P b f0. unfold dep_elim_B.
  unfold dep_constr_B_0. destruct eta_OK_B.
  reflexivity.
Defined.

(*
 * Likewise, this nasty eq_rect ... here reduces to just (f0 b).
 *)
Lemma iota_B_0 :
  forall (P : B -> Type) (f0 : forall (b : B), P (dep_constr_B_0 b)) (b : B) (Q : P (eta_B (dep_constr_B_0 b)) -> Type),
    Q (dep_elim_B P f0 (dep_constr_B_0 b)) ->
    Q (eq_rect (dep_constr_B_0 b) (fun H : B => P H) (f0 b) (eta_B (dep_constr_B_0 b)) (eq_sym (eta_OK_B (dep_constr_B_0 b)))).
Proof.
  intros. rewrite <- iota_B_aux_gen. apply X.
Defined.

(* --- Proof that this configuration is OK --- *)

(*
 * Here we prove the correctness criteria from Figure 12.
 *)

(*
 * First we define f, g, section, and retraction:
 *)
Definition f' (a : A) : B :=
  dep_elim_A (fun _ => B) (fun b => dep_constr_B_0 b) a.

Definition g' (b : B) : A :=
  dep_elim_B (fun _ => A) (fun b => dep_constr_A_0 b) b.

Lemma section' (a : A) : g' (f' a) = a.
Proof.
  replace a with (eta_A a) by (apply eta_OK_A).
  apply dep_elim_A.
  intros b0. unfold dep_constr_A_0 at 1.
  replace (dep_constr_A_0 b0) with (eq_rect (dep_constr_B_0 b0) (fun _ : B => A) (dep_constr_A_0 b0) (eta_B (dep_constr_B_0 b0)) (eq_sym (eta_OK_B (dep_constr_B_0 b0)))).
  - apply (iota_B_0 (fun _ => A) (fun b0 : B => dep_constr_A_0 b0) b0 (fun a => (g' (f' (dep_constr_A_0 b0))) = a)).
    replace (dep_constr_B_0 b0) with (eq_rect (dep_constr_A_0 b0) (fun _ : A => B) (dep_constr_B_0 b0) (eta_A (dep_constr_A_0 b0)) (eq_sym (eta_OK_A (dep_constr_A_0 b0)))).
    + apply (iota_A_0 (fun _ => B) (fun b0 : B => dep_constr_B_0 b0) b0 (fun b => (g' (f' (dep_constr_A_0 b0))) = g' b)).
      reflexivity.
    + destruct (eta_OK_A (dep_constr_A_0 b0)). reflexivity.
  - destruct (eta_OK_B (dep_constr_B_0 b0)). reflexivity.
Defined.

Print section'.

Lemma retraction' (b : B) : f' (g' b) = b.
Proof.
  replace b with (eta_B b) by (apply eta_OK_B).
  apply dep_elim_B.
  intros b0. unfold dep_constr_B_0 at 1.
  replace (dep_constr_B_0 b0) with (eq_rect (dep_constr_A_0 b0) (fun _ : A => B) (dep_constr_B_0 b0) (eta_A (dep_constr_A_0 b0)) (eq_sym (eta_OK_A (dep_constr_A_0 b0)))).
  - apply (iota_A_0 (fun _ => B) (fun b0 : B => dep_constr_B_0 b0) b0 (fun b => (f' (g' (dep_constr_B_0 b0))) = b)).
    replace (dep_constr_A_0 b0) with (eq_rect (dep_constr_B_0 b0) (fun _ : B => A) (dep_constr_A_0 b0) (eta_B (dep_constr_B_0 b0)) (eq_sym (eta_OK_B (dep_constr_B_0 b0)))).
    + apply (iota_B_0 (fun _ => A) (fun b0 : B => dep_constr_A_0 b0) b0 (fun b => (f' (g' (dep_constr_B_0 b0))) = f' b)).
      reflexivity.
    + destruct (eta_OK_B (dep_constr_B_0 b0)). reflexivity.
  - destruct (eta_OK_A (dep_constr_A_0 b0)). reflexivity.
Defined.

(*
 * To avoid dependencies, we unfold the definition of transport here.
 *)
Lemma dep_constr_OK :
  forall (b : B), dep_constr_A_0 b = g (dep_constr_B_0 b).
Proof.
  reflexivity.
Defined.

Definition section_adjoint := Adjoint.fg_id' g f retraction section.

Lemma is_adjoint' (a : A) : retraction (f a) = f_equal f (section_adjoint a).
Proof.
  apply Adjoint.g_adjoint.
Defined.

(*
 * Same here:
 *)
Lemma dep_elim_OK :
  forall P f0 b,
    dep_elim_B P f0 b =
    eq_rect
      (f (eta_A (g b)))
      (fun (H : B) => P H)
      (dep_elim_A (fun (a : A) => P (f a)) (fun b => f0 (f (dep_constr_A_0 b))) (g b))
      (eta_B b)
      (retraction b).
Proof.
  intros P f0 b. unfold dep_elim_B. destruct (eta_OK_B b).
  unfold dep_elim_A. unfold eta_A. unfold eta_B.
  rewrite is_adjoint.
  destruct retraction_adjoint.
  rewrite is_adjoint'.
  destruct section_adjoint.
  reflexivity.
Defined.

Definition elim_eta_A := dep_elim_A.
Definition elim_eta_B := dep_elim_B.

Definition iota_OK_0_A := iota_A_0.
Definition iota_OK_0_B := iota_B_0.

(*
 * eta_OK is up top of the file.
 *)

(* --- Using the configuration --- *)

(*
 * We can transform functions and proofs using this equivalence.
 *
 * First we save the equivalence:
 *)
Save equivalence A B { promote = f'; forget = g' }.
Configure Lift A B {
  constrs_a = dep_constr_A_0;
  constrs_b = dep_constr_B_0;
  elim_a = dep_elim_A;
  elim_b = dep_elim_B;
  eta_a = eta_A;
  eta_b = eta_B;
  iota_a = iota_A_0;
  iota_b = iota_B_0
}.

(*
 * Same note from flip.v: Note that since we don't have unification
 * heuristics for custom equivalences, for now we'll need to represent the configuration
 * terms explicitly everywhere. And also because the transformation tries to transform
 * _everything_ that matches, but our dependent constructors take B and A respectively as
 * inputs, we need to baby the transformation into understanding when _not_ to lift a B.
 *
 * So the answer here is: we can handle any equivalence, but when
 * it comes to the details of handling it usefully, the usability barriers come up a lot here.
 * In particular all of our notes in the paper about the current lack of:
 * 1) custom unification heuristics, and
 * 2) type-directed search
 * become extremely relevant.
 *)
Module Over_A.
  (*
   * These are fine:
   *)
  Definition from_x (X : Type) (from_x : X -> A) (x : X) : A := from_x x.
  Definition to_x (X : Type) (to_x : A -> X) (a : A) : X := to_x a.

  (*
   * The catch is whenever you can _only_ create a B from an A,
   * you will not be able to remove references to A. Obviously, I guess.
   *)
   Definition ignore_A := A.
   Definition from_A (a : ignore_A) : A := dep_constr_A_0 (f a).

End Over_A.

Lift Module A B in Over_A as Over_B { opaque Over_A.ignore_A }.
Print Over_B.from_x.
Print Over_B.to_x.
Print Over_B.from_A.

(*
 * So, as we see above, this way, we get something OK. It's just not the most
 * useful configuration. It is always OK: given any (a : A), we can always choose
 * some b such that (g b = a), since a and b are equivalent:
 *)
Lemma this_is_fine_gif:
  forall (a : A), { b : B | g b = a}.
Proof.
  intros a. exists (f a). apply section.
Defined.

(*
 * But writing all of our functions and proofs this way would be silly.
 * So with concrete instances of A, like when A is inductive,
 * we can split up into cases.
 *
 * For example, let A be list T and let B be sigT (vector T), using the standard equivalence.
 * Since (g (existT _ 0 (nilV T))) reduces to (nil T), and similarly for the cons case,
 * and nil and cons are the only two ways to construct a list, we split g into
 * two cases: nil and cons, and let those be dep_constr_A_0 and dep_constr_A_1.
 * This gives us the standard configuration.
 *)


Require Import TLC.LibLN Definitions.
Set Implicit Arguments.
Implicit Types E F G : ctx.

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

(** * Mutual Induction principles *)

(** We define some mutual induction principles to make simultaneus proofs about types,
    formulas and logical values *)

Scheme typ_mut := Induction for typ Sort Prop
with formula_mut := Induction for formula Sort Prop
with logic_val_mut := Induction for logic_val Sort Prop.

(** The Scheme command doesn't generate a mutual indution hypothesis for logic_val so
    we must combine it ourself *)

Combined Scheme typ_combined_aux from typ_mut, formula_mut.

Theorem typ_combined
     : forall (P : typ -> Prop) (P0 : formula -> Prop) (P1 : logic_val -> Prop),
       (forall B p, P0 p -> P { v : B | p}%typ) ->
       (forall T, P T -> forall S, P S -> P (T) --> S%typ) ->
       (forall p, P0 p -> forall q, P0 q -> P0 (p \/ q)%logic) ->
       (forall p, P0 p -> forall q, P0 q -> P0 (p /\ q)%logic) ->
       (forall p, P0 p -> P0 (~ p)%logic) ->
       P0 formula_true ->
       (forall v, P1 v -> forall u, P1 u -> P0 (v = u)%logic) ->
       (forall n, P1 (logical_nat n)) ->
       P1 logical_true ->
       P1 logical_false ->
       (forall n, P1 (logical_bvar n)) ->
       (forall x, P1 (logical_fvar x)) ->
       (forall x, P1 (logical_abs_var x)) ->
       (forall T, P T) /\ (forall p : formula, P0 p) /\ (forall v, P1 v).
Proof. intros. rewrite <- and_assoc. split. eapply typ_combined_aux; eauto.
       apply logic_val_ind; auto. Qed.

Scheme type_mut := Minimality for type Sort Prop
with closed_formula_mut := Minimality for closed_formula Sort Prop
with closed_logic_val_mut := Minimality for closed_logic_val Sort Prop.

Combined Scheme type_combined_aux from type_mut, closed_formula_mut.

Theorem type_combined
     : forall (P : typ -> Prop) (P0 : formula -> Prop) (P1 : logic_val -> Prop),
       (forall L B p,
        (forall x, x \notin L -> closed_formula (p ^ x)) ->
        (forall x, x \notin L -> P0 (p ^ x)%logic) ->
        P { v : B | p}%typ) ->
       (forall L T1 T2,
        type T1 ->
        P T1 ->
        (forall x, x \notin L -> type (T2 ^^ logical_fvar x)) ->
        (forall x, x \notin L -> P (T2 ^^ logical_fvar x)%typ) ->
        P (T1) --> T2%typ) ->
       (forall p1 p2,
        closed_formula p1 ->
        P0 p1 -> closed_formula p2 -> P0 p2 -> P0 (p1 \/ p2)%logic) ->
       (forall p1 p2,
        closed_formula p1 ->
        P0 p1 -> closed_formula p2 -> P0 p2 -> P0 (p1 /\ p2)%logic) ->
       (forall p, closed_formula p -> P0 p -> P0 (~ p)%logic) ->
       P0 formula_true ->
       (forall v1 v2,
        closed_logic_val v1 ->
        P1 v1 -> closed_logic_val v2 -> P1 v2 -> P0 (v1 = v2)%logic) ->
       (forall n, P1 (logical_nat n)) ->
       P1 logical_true ->
       P1 logical_false ->
       (forall x, P1 (logical_fvar x)) ->
       (forall x, P1 (logical_abs_var x)) ->
       (forall T, type T -> P T) /\
       (forall p, closed_formula p -> P0 p) /\
       (forall v, closed_logic_val v -> P1 v).
Proof. intros. rewrite <- and_assoc. split. eapply type_combined_aux; eauto.
       apply closed_logic_val_ind; auto. Qed.

(** * Body of abstraction and types *)

Definition trm_body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

Definition typ_body T :=
  exists L, forall x, x \notin L -> type (T ^ x).

(** * Tactics *)

(** The library LibLN define some generic tactics to deal with cofinite quantification. To
    use them we must provide a way to ghater non fresh variables in the context of a proof. *)

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 : ctx => dom x) in
  let D := gather_vars_with (fun x : trm => trm_fv x) in
  let E := gather_vars_with (fun x : typ => typ_fv x) in
  let F := gather_vars_with (fun x : formula => formula_fv x) in
  let G := gather_vars_with (fun x : logic_val => logic_val_fv x) in
  constr:(A \u B \u C \u D \u E \u F \u G).

(** The tactic [pick_fresh] pick a fresh variable in the context *)
Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in (pick_fresh_gen L x).

(** The tactic [apply_fresh T as y] takes a lemma T of the form
    [forall L ..., (forall x, x \notin L, P x) -> ... -> Q.]
    and applies it by instantiating L as the set of variables occuring in the context
    Moreover, for each subgoal of the form [forall x, x \notin L, P x] being generated, the
    tactic automatically introduces the name [x] as well as the hypothesis [x \notin L].
*)
Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.

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

(** * Automation *)

(** ** Solve in *)
Ltac in_simpl :=
  match goal with
  | |- context[_ \in (_ \u _)] =>  rewrite in_union; in_simpl
  | |- _ => first [progress cbn; in_simpl | idtac]
  end.
Ltac in_simpl_context :=
  match goal with
  | H: context[_ \in (_ \u _)] |-  _ =>  rewrite in_union in H; in_simpl_context
  | |- _ => first[ progress cbn; in_simpl_context | idtac]
  end.

Ltac in_solve_context_case:=
  match goal with
  | H: (?E \/ ?F)%type |- _ =>
    match E with
    | context[_ \in _] => destruct H; in_solve_context_case
    | _ => match F with
          | context[_ \in _] => destruct H; in_solve_context_case
          | _ => fail 20
          end
    end
  | _ => idtac
  end.

Ltac in_solve_base :=
  match goal with
  | |- (?E \/ ?F)%type  => first [left; in_solve_base | right; in_solve_base]
  | |- ?x \in \{?x} => rewrite in_singleton; reflexivity
  | H: ?x \in ?E |- ?x \in ?E => apply H
  end.
Tactic Notation "in_simpls" := in_simpl; in_simpl_context.
Tactic Notation "in_solve" :=
  in_simpls; in_solve_context_case; try solve [in_solve_base].
Hint Extern 1 (_ \in _) => in_solve.
Hint Extern 1 (_ \in (_ \u _)) => in_solve.

(** ** Some basic automation to solve subset *)

Ltac subset_solve_one :=
  match goal with
  | |- \{} \c _ => apply subset_empty_l
  | |- _  => idtac
  end.

Ltac simpl_set :=
  repeat rewrite union_empty_l; repeat rewrite union_empty_r.

Hint Extern 1 (_ \c _) => simpl_set; subset_solve_one.

(** * Lemma about finite sets *)

Lemma subset_transitive : forall A (E F G : fset A), E \c F -> F \c G -> E \c G.
Proof. red. intros. apply H in H1. apply H0 in H1. assumption. Qed.

Lemma subset_empty_inv : forall {A} {E : fset A}, E \c \{} -> E = \{}.
Proof. introv Subset. apply fset_extens; auto. Qed.

Lemma subset_weaken : forall A (E F G H : fset A),
    E \c (F \u H) -> E \c (F \u G \u H).
Proof. unfolds subset. intros. rewrite union_comm with (E:=G).
       rewrite union_assoc. in_simpl. left. rewrite <- in_union. eauto. Qed.

Lemma singleton_subset : forall (x:var) A, x \in A -> \{x} \c A.
Proof. intros_all.  rewrite in_singleton in *. subst*. Qed.

Lemma union_subset : forall A (E F G : fset A), E \c G -> F \c G -> E \u F \c G.
Proof. unfolds subset. intros. in_simpls. destruct H1; auto. Qed.

Lemma union_subset_inv : forall A (E F G : fset A), E \u F \c G -> E \c G /\ F \c G.
Proof.
  unfolds subset; intros; split; intros. apply H. in_simpl. left*.
  apply H. in_simpl. right*.
Qed.
Lemma subset_union_l : forall A (E F G : fset A), E \c F -> E \c (F \u G).
Proof. unfolds subset. intros. auto. Qed.
Lemma subset_union_r : forall A (E F G : fset A), E \c G -> E \c (F \u G).
Proof. unfolds subset. intros. auto. Qed.

Lemma union_empty : forall {A} (E F : fset A), E \u F = \{} -> E = \{} /\ F = \{} .
Proof.
  intros. split.
  * apply fset_extens. rewrite <- H. apply subset_union_weak_l.
    apply subset_empty_l.
  * apply fset_extens. rewrite <- H. apply subset_union_weak_r.
    apply subset_empty_l.
Qed.

(** * Properties of fv *)
Lemma open_var_rec_in_typ_fv : forall x A,
    x \in A ->
    (forall T k, typ_fv T \c A ->
            typ_fv ({k ~> logical_fvar x} T) \c A) /\
    (forall p k, formula_fv p \c A ->
            formula_fv ({k ~> logical_fvar x} p) \c A) /\
    (forall v k, logic_val_fv v \c A ->
            logic_val_fv ({k ~> logical_fvar x} v) \c A).
Proof.
  introv In. apply typ_combined; unfolds subset; intros; simpl in *;
             in_solve; eauto.
  case_if; auto. simpl in *. rewrite in_singleton in H0; subst*.
Qed.

Lemma open_var_rec_notin_typ_fv : forall y A,
    (forall T k, y \notin typ_fv T ->
                typ_fv ({k ~> logical_fvar y} T) \c A \u \{y} ->
                typ_fv T \c A) /\
    (forall p k, y \notin formula_fv p ->
                formula_fv ({k ~> logical_fvar y} p) \c A \u \{y} ->
                formula_fv p \c A) /\
    (forall v k, y \notin logic_val_fv v ->
                logic_val_fv ({k~>logical_fvar y} v) \c A \u \{y} ->
                logic_val_fv v \c A).
Proof.
  intros. apply typ_combined; unfolds subset; intros; simpl in *;
          in_solve; eauto.
  * exfalso. rewrite in_empty in H1. auto.
  * exfalso. rewrite in_empty in H1. auto.
  * exfalso. rewrite in_empty in H1. auto.
  * exfalso. rewrite in_empty in H1. auto.
  * exfalso. rewrite in_empty in H1. auto.
  * rewrite in_singleton in H1. red in H. subst. forwards*: (H0 x). in_simpls.
    destruct* H1. rewrite in_singleton in H1. subst. exfalso. auto.
  * exfalso. rewrite in_empty in H1. auto.
Qed.

(** * Properties of terms *)
Open Scope trm_scope.
Lemma open_rec_term_core :forall t j v i s,
    i <> j ->
    {j ~> v}t = {i ~> s}({j ~> v}t) -> t = {i ~> s}t.
Proof.
  induction t; intros; simpl; inversion H0; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t s,
    term t -> forall k,
    t = {k ~> s} t.
Proof.
  intros t s H.
  induction H; intros; simpl; f_equal*.
  unfolds open_trm. pick_fresh_gen L x.
  apply* (@open_rec_term_core t 0 (trm_fvar x)).
  unfolds open_trm. pick_fresh_gen L x.
  apply* (@open_rec_term_core t2 0 (trm_fvar x)).
Qed.

Lemma subst_fresh : forall x t s,
    x \notin (trm_fv t) ->
    [x ~> s] t = t.
Proof. intros. induction t; simpl in *; f_equal*. case_var*. Qed.

Lemma subst_open : forall x s (t1 t2 : trm),
    term s ->
    [x ~> s] (t1 ^^ t2) = ([x ~> s]t1) ^^ ([x ~> s]t2).
Proof.
  intros. unfold open_trm. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

Lemma subst_open_var : forall x y s t,
    y <> x -> term s ->
    ([x ~> s]t) ^ y = [x ~> s] (t ^ y).
Proof.
  introv Neq H.
  rewrite* subst_open. simpl. case_var*.
Qed.

Lemma subst_intro : forall x t s,
    x \notin (trm_fv t) -> term s ->
    t ^^ s = [x ~> s] (t ^ x) .
Proof.
  intros.
  rewrite* subst_open. simpl. case_var. rewrite* subst_fresh.
Qed.
Close Scope trm_scope.

Lemma term_abs_to_body : forall lbl t, term (trm_abs lbl t) -> trm_body t.
Proof. introv H. inversion H. exists L; assumption. Qed.
Hint Resolve term_abs_to_body.

Lemma term_let_to_body : forall t1 t2, term (trm_let t1 t2) -> trm_body t2.
Proof. introv H. inversion H. exists L; assumption. Qed.
Hint Resolve term_let_to_body.

Lemma body_to_term_abs : forall lbl t, trm_body t -> term (trm_abs lbl t).
Proof. destruct 1. econstructor. eassumption. Qed.
Hint Resolve body_to_term_abs.

Lemma body_to_term_let : forall t1 t2, term t1 -> trm_body t2 -> term (trm_let t1 t2).
Proof. destruct 2. econstructor; eauto. Qed.
Hint Resolve body_to_term_let.

Lemma subst_term : forall x t s,
    term t -> term s ->
    term ([x ~> s] t).
Proof.
  intros. induction H; simpls; auto.
  case_var*.
  apply_fresh* term_abs. intros. rewrite* subst_open_var.
  apply_fresh* term_let. intros. rewrite* subst_open_var.
Qed.

Lemma open_term : forall t s, trm_body t -> term s -> term (t ^^ s).
Proof.
  intros t s H H0.
  destruct H as [L]. pick_fresh x.
  rewrite* (@subst_intro x).
  apply* subst_term.
Qed.

(** * Properties of types *)

Lemma open_rec_type_core : forall v u,
    (forall T j i, i <> j -> {j ~> v} T = {i ~> u}({j ~> v} T) ->
              T = {i ~> u} T)%typ /\
    (forall p j i, i <> j -> {j ~> v} p = {i ~> u}({j ~> v} p) ->
              p = {i ~> u} p)%logic /\
    (forall v' j i, i <> j -> {j ~> v} v' = {i ~> u}({j ~> v} v') ->
               v' = {i ~> u} v')%logic_val.
Proof.
  intros. apply typ_combined; intros; simpl in *;
          try solve [auto; inversion H1; f_equal* | inversion H2; f_equal*].
  case_nat*. case_nat*.
Qed.

Lemma open_rec_type : forall v,
    (forall T, type T -> forall k, T = {k ~> v} T)%typ /\
    (forall p, closed_formula p -> forall k, p = {k ~> v} p)%logic /\
    (forall u, closed_logic_val u -> forall k, u = {k ~> v} u)%logic_val.
Proof.
  introv. apply type_combined; intros; simpl; f_equal*.
  * pick_fresh x. eapply open_rec_type_core. unify ?j 0. auto. unify ?v (logical_fvar x).
    apply* H0.
  * pick_fresh_gen L x. eapply open_rec_type_core. unify ?j 0. auto.
    unify ?v (logical_fvar x). apply* H2.
Qed.

Lemma subst_open_logic_val : forall x k (b u v : logic_val),
    closed_logic_val v ->
    ([x ~> v] ({k ~> u} b) = {k ~> [x ~> v]u } ([x ~> v] b))%logic_val.
Proof. intros. destruct b; simpl; f_equal*. case_nat*. case_var*.
       destruct u; simpl; destruct* H. Qed.

Open Scope logic.
Lemma subst_open_formula : forall x p k (u v : logic_val),
    closed_logic_val v ->
    ([x ~> v] ({k ~> u} p) = {k ~> [x ~> v] u} ([x ~> v] p)).
Proof.
  intros. unfold open_formula. generalize 0.
  induction p; intros; simpl; f_equal; auto using subst_open_logic_val.
Qed.
Close Scope logic.

Lemma subst_open_typ : forall x T (u v : logic_val),
    closed_logic_val v ->
    ([x ~> v] (T ^^ u) = ([x ~> v] T) ^^ ([x ~> v]u))%typ.
Proof.
  intros. unfold open_typ. generalize 0.
  induction T; intros; simpl; f_equal; auto using subst_open_formula.
Qed.

Lemma open_closed_type : forall v T,
    type T -> T = (T ^^ v)%typ.
Proof. intros. apply* open_rec_type. Qed.

Lemma subst_fresh_mut : forall x v,
    (forall T, x \notin (typ_fv T) -> [x ~> v] T = T)%typ /\
    (forall p, x \notin (formula_fv p) -> [x ~> v] p = p)%logic /\
    (forall u, x \notin (logic_val_fv u) -> [x ~> v] u = u)%logic_val.
Proof.
  intros. apply typ_combined; intros; simpl in *; f_equal*.
  case_var*.
Qed.
Lemma subst_fresh_typ : forall x v T,
    x \notin (typ_fv T) -> ([x ~> v] T = T)%typ.
Proof. apply* subst_fresh_mut. Qed.

Lemma subst_fresh_formula : forall x v p,
    x \notin (formula_fv p) -> (([x ~> v] p)%logic = p).
Proof. apply* subst_fresh_mut. Qed.

Lemma subst_open_rec : forall x u v,
    closed_logic_val u ->
    (forall T k, [x ~> u] {k ~> v} T = {k ~> [x ~> u] v} ([x ~> u] T))%typ /\
    (forall p k, [x ~> u] {k ~> v} p = {k ~> [x ~> u] v} ([x ~> u] p))%logic /\
    (forall v' k, [x ~> u] {k ~> v} v' = {k ~> [x ~> u] v} ([x ~> u] v'))%logic_val.
Proof.
  introv H. apply typ_combined; intros; cbn; f_equal*.
  * case_nat*.
  * case_var*. inversion H; subst; auto.
Qed.
Lemma subst_open_rec_typ : forall x u v T k,
    closed_logic_val u ->
    [x ~> u] {k ~> v} T %typ= {k ~> [x ~> u] v} ([x ~> u] T)%typ.
Proof. intros; apply* subst_open_rec. Qed.
Lemma subst_open_rec_formula : forall x u v p k,
    closed_logic_val u ->
    [x ~> u] {k ~> v} p %logic= {k ~> [x ~> u] v} ([x ~> u] p)%logic.
Proof. intros; apply* subst_open_rec. Qed.

Lemma subst_open_typ_var : forall x y u,
    x <> y -> closed_logic_val u ->
    (forall T, [x ~>u] T ^ y = [x ~> u] (T ^ y))%typ /\
    (forall p, [x ~>u] p ^ y = [x ~> u] (p ^ y))%logic /\
    (forall v, [x ~>u] v ^ y = [x ~> u] (v ^ y))%logic_val.
Proof.
  intros. unfold open_typ, open_formula, open_logic_val.
  apply typ_combined; intros; simpl; f_equal*.
  rewrite subst_open_rec_formula; simpl; auto. case_var*.
  rewrite subst_open_rec_typ; simpl; auto. case_var*.
  case_nat*. simpl. case_var*.
  case_var*. inversion* H0.
Qed.
Lemma subst_open_var_typ : forall T x y u,
    x <> y -> closed_logic_val u ->
    ([x ~>u] T ^ y = [x ~> u] (T ^ y))%typ.
Proof. intros. apply* subst_open_typ_var. Qed.
Lemma subst_open_var_formula : forall p x y u,
    x <> y -> closed_logic_val u ->
    ([x ~>u] p ^ y)%logic = [x ~> u] (p ^ y)%logic.
Proof. intros. apply* subst_open_typ_var. Qed.

Lemma subst_type : forall x u,
    closed_logic_val u ->
    (forall T, type T -> type ([x ~> u] T)) /\
    (forall p, closed_formula p -> closed_formula ([x ~> u] p)) /\
    (forall v, closed_logic_val v -> closed_logic_val ([x ~> u] v)).
Proof.
  intros. apply type_combined; intros; simpl; auto.
  apply_fresh type_refinement. rewrite* subst_open_var_formula.
  apply_fresh* type_arrow. rewrite* subst_open_var_typ.
  case_var*.
Qed.

Lemma subst_intro_typ : forall x T u,
    x \notin (typ_fv T) ->  closed_logic_val u ->
    (T ^^ u)%typ = [x ~> u] (T ^ x)%typ.
Proof.
  intros. unfold open_typ. rewrite subst_open_rec_typ; simpl; auto.
  case_var. rewrite* subst_fresh_typ.
Qed.

Lemma subst_intro_formula : forall x p u,
    x \notin (formula_fv p) -> closed_logic_val u ->
    (p ^^ u)%logic = [x ~> u] (p ^ x)%logic.
Proof.
  intros. unfold open_formula. rewrite subst_open_rec_formula; simpl; auto.
  case_var. rewrite* subst_fresh_formula.
Qed.

Lemma open_type : forall T u, typ_body T -> closed_logic_val u -> type (T ^^ u).
Proof. intros. destruct H as [L]. pick_fresh x.
       rewrite* (@subst_intro_typ x). apply* subst_type.
Qed.

(** * Properties of environments *)

Lemma extract_concat : forall {E F}, extract (E & F) = extract E \u extract F.
Proof.
  induction F.
  * cbn. rewrite union_empty_r. reflexivity.
  * destruct t; cbn; rewrite IHF.
    + rewrite union_assoc. reflexivity.
    + reflexivity.
  * cbn. rewrite IHF. rewrite union_assoc. reflexivity.
Qed.

Lemma subst_env_concat : forall E F x u,
    [x~>u] (E & F) = [x~>u] E & [x~>u] F.
Proof. intros. induction F; simpl; auto; rewrite* IHF. Qed.
Lemma binds_in_dom : forall x E T, binds x T E -> x \in (dom E).
Proof.
  intros. induction E.
  * inversion H.
  * unfolds binds. simpl. unfolds get. case_var*.
  * simpl. auto.
Qed.

Lemma dom_env_subst : forall E x u, dom ([x ~> u] E) = dom E.
Proof. intros. induction E; auto. simpl. rewrite* IHE. Qed.

Lemma subst_env_notin_dom : forall E x u,
    |~ E ->
    x \notin dom E ->
    [x~>u] E = E.
Proof.
  introv Wf Nin. induction E; simpl; auto.
  * rewrite IHE; simpls; auto. inversion Wf. rewrite notin_union in Nin.
    rewrite* subst_fresh_typ. intros_all. forwards* : (H4 x H6). inversion* Wf.
  * rewrite IHE; simpls; auto. inversion Wf.
    rewrite* subst_fresh_formula. intros_all. forwards* : (H2 x H4). inversion* Wf.
Qed.

Hint Extern 1 (_ \notin dom _) => repeat (rewrite dom_concat in *).
Hint Extern 1 (_ \in dom _) => repeat (rewrite dom_concat in *).
Hint Extern 1 (?x \in dom ?E) =>
match goal with
| H: binds x ?T E |- _ => apply binds_in_dom in H
end.

(** * Properties of substitution of sets *)

(* Substitution is well defined *)
Lemma subst_set_unique : forall x v A B C, subst_set x v A B -> subst_set x v A C -> B = C.
Proof.
  introv Subst1 Subst2. unfolds subst_set. apply fset_extens.
  * intros_all. destruct Subst1 as [_ Subst1]. apply Subst1 in H. destruct H as [p [In Eq]].
    destruct Subst2 as [Subst2 _]. apply Subst2 in In. subst. assumption.
  * intros_all. destruct Subst2 as [_ Subst2]. apply Subst2 in H. destruct H as [p [In Eq]].
    destruct Subst1 as [Subst1 _]. apply Subst1 in In. subst. assumption.
Qed.

Lemma subst_set_singleton : forall x v p, subst_set x v \{p} \{[x~>v]p}%logic.
Proof. unfold subst_set. intros. split.
   * introv In. repeat rewrite in_singleton in *. subst. reflexivity.
   * introv In. rewrite in_singleton in *. exists p. subst. split.
     + rewrite in_singleton. reflexivity.
     + reflexivity.
Qed.

Lemma subst_set_empty : forall x v, subst_set x v \{} \{}.
Proof.
  unfold subst_set. intros. split; introv In; rewrite in_empty in In; exfalso; assumption.
Qed.

Lemma subst_set_union : forall x v A B C D,
    subst_set x v A C ->
    subst_set x v B D ->
    subst_set x v (A \u B) (C \u D).
Proof.
  introv Subst1 Subst2.
  unfold subst_set. split.
  * introv In. destruct Subst1 as [Subst1 _]. destruct Subst2 as [Subst2 _]. auto.
  * introv In. rewrite in_union in In. destruct In as [In | In].
    + destruct Subst1 as [_ Subst1]. apply Subst1 in In as [p [In Eq]].
      exists p. split; auto.
    + destruct Subst2 as [_ Subst2]. apply Subst2 in In as [p [In Eq]].
      exists p. split; auto.
Qed.

Lemma subst_set_extract : forall E x v,
    closed_logic_val v ->
    x \notin dom E ->
    subst_set x v (extract E) (extract [x ~> v] E).
Proof.
  introv Closed Notin. induction E.
  * cbn. apply subst_set_empty.
  * cbn in Notin. destruct t; cbn; auto. apply subst_set_union; auto.
    assert (([x ~> v] f ^ v0)%logic = ([x~>v] (f ^ v0))%logic).
    unfold open_formula; rewrite subst_open_rec_formula; auto; cbn; case_var; reflexivity.
    rewrite H. apply subst_set_singleton.
  * cbn. apply subst_set_union; auto. apply subst_set_singleton.
Qed.

(** * Properties of well-formedness *)

(** ** Well formed environments *)

Lemma wf_ok : forall {E}, |~ E -> ok E.
Proof. introv Wf. induction E; inversion Wf; constructor; auto. Qed.

Hint Extern 1 (ok ?E) =>
match goal with  H : |~ ?F |- _ => match F with context[E] => apply wf_ok end end.

Lemma wf_middle_inv : forall E x T F,
    |~ (E « x : T & F) ->
    x \notin dom E /\ x \notin dom F.
Proof. introv Wf. eapply ok_middle_inv. apply wf_ok. eassumption. Qed.

Lemma wf_concat_inv : forall {E F}, |~ (E & F) -> |~ E.
Proof. introv Wf. gen E. induction F; intros; inversion Wf; auto. Qed.

Lemma wf_env_strengthen : forall {E F} p, |~ (E « p & F) -> |~ (E & F).
Proof.
  introv wf. induction F; simpl in *; inversion* wf; subst.
  * constructor*. rewrite dom_middle_formula in H4. auto.
  * constructor*. rewrite dom_middle_formula in H2. auto.
Qed.

Hint Extern 1 (|~ ?E) =>
  match goal with
  | H: |~ (?F « ?p) |- _ => match F with context[E] => inversion H end
  | H: |~ (?F « _ : _ ) |- _ => match F with context[E] => inversion H end
  | H: |~ (?F & ?G) |- _ => match F with context[E] => apply wf_concat_inv in H end
  | H: |~ (?F « ?p  & ?G) |- _ => match F with context[E] => apply (wf_env_strengthen H) end
  end.

Hint Extern 1 (|~ (?E & ?F)) =>
  match goal with
  | H: |~ (?E « ?p  & ?F) |- _ => apply (wf_env_strengthen p H)
  end.

(** ** Well formed Types *)

Lemma type_wf_strengthen : forall {E F T} p, E « p & F |~ T -> E & F |~ T.
Proof.
  introv Typ. destructs Typ. splits 3; auto.
  rewrite dom_middle_formula in H1. auto.
Qed.

Lemma type_wf_strengthen_r : forall {E T} p, E « p |~ T -> E |~ T.
Proof.
  intros. rewrite (empty_concat_r E).
  rewrite (empty_concat_r (E « p)) in H.
  apply (type_wf_strengthen p); assumption.
Qed.

(** * Properties of entailment *)

Lemma entails_valid : forall A p, valid p -> A |= p.
Proof.
   introv Valid. apply (entails_monotone A) in Valid. rewrite union_empty_l in Valid. assumption.
Qed.

Lemma entails_trans : forall {A p1 p3} p2, A \u \{p1} |= p2 -> A \u \{p2} |= p3 -> A \u \{p1} |= p3.
Proof.
  introv Ent1 Ent2.
  apply (entails_monotone \{p1}) in Ent2.
  rewrite <- union_assoc in Ent2. rewrite (union_comm \{p2}) in Ent2.
  rewrite union_assoc in Ent2. apply entails_cut in Ent2; assumption.
Qed.

Lemma entails_eq : forall {A v}, A |= (v = v).
Proof. intros. rewrite <- (union_empty_l A). apply (entails_monotone A). apply valid_eq. Qed.

(** * Typing Judgment *)

Lemma typing_var_inv : forall E x T,
    E |~ (trm_fvar x) : T ->
    exists S, binds x S E.
Proof. introv Typ. inductions Typ; eauto. Qed.

Lemma typing_nat_inv : forall {E n T},
    E |~ (trm_nat n) : T -> exists p, T = {v : typ_nat | p}%typ.
Proof.
  introv Typ. inductions Typ.
  + exists (logical_bvar 0 = logical_nat n)%logic. eauto.
  + destruct IHTyp. subst. inversion H. subst. exists q. auto.
Qed.

Lemma typing_bool_inv : forall {E t T},
    t = trm_true \/ t = trm_false ->
    E |~ t : T ->
    exists p, T = {v : typ_bool | p}%typ.
Proof.
  introv Eq Typ. destruct Eq; subst.
  + inductions Typ.
    - eexists; eauto.
    - destruct IHTyp. subst. inversion H. subst. exists q. auto.
  + inductions Typ.
    - eexists; eauto.
    - destruct IHTyp. subst. inversion H. subst. exists q. auto.
Qed.

Lemma typing_abs_inv : forall {E lbl t T},
    value (trm_abs lbl t) ->
    E |~ (trm_abs lbl t) : T ->
    exists U S, T = (U --> S)%typ.
Proof. introv Val Typ.
   + inductions Typ.
     - exists* T1 T2.
     - lets : (IHTyp Val). destruct H0. destruct H0; subst. inversion H; subst. exists* T21 T22.
Qed.

Lemma open_typ_term : forall E t T,
    value t -> E |~ t : T ->
    (forall S k, typ_fv S \c dom E -> typ_fv ({k ~> !t} S) \c dom E) /\
    (forall p k, formula_fv p \c dom E -> formula_fv ({k~>!t} p) \c dom E) /\
    (forall v k, logic_val_fv v \c dom E -> logic_val_fv ({k~>!t} v) \c dom E).
Proof.
  introv Atom Typ. apply typ_combined; unfolds subset;
                   intros; simpl in *; in_solve; eauto.
  * inversion Atom; subst; case_if*. simpl in H0.
    rewrite in_singleton in H0; subst. apply typing_var_inv in Typ. destruct Typ.
    auto.
Qed.

(** * Regularity *)

(** The subtyping relation is restricted to well-formed objects. *)
Lemma sub_regular : forall {E T S}, E |~ T <: S -> |~ E /\ E |~ T /\  E |~ S.
Proof.
  introv sub. induction sub.
  * lets : H. destructs H2. splits*.
  * destructs IHsub. destructs H2. destructs H3. splits*.
    + splits*.
      - apply_fresh* type_arrow. forwards*: (H0 y). destructs H8. destructs* H9.
      - pick_fresh y. forwards *: (H0 y). destructs H8. destructs H9.
        simpl in *. apply* union_subset. eapply open_var_rec_notin_typ_fv; eauto.
    + splits*.
      - apply_fresh* type_arrow. forwards*: (H0 y). destructs H8. destructs* H10.
      - pick_fresh y. forwards *: (H0 y). destructs H8. destructs H10.
        simpl in *. apply* union_subset. eapply open_var_rec_notin_typ_fv; eauto.
Qed.

(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall {E t T}, E |~ t : T -> |~ E /\ term t /\ E |~ T.
Proof.
  intros. induction H; auto.
  * splits*. splits 3; cbn; auto. apply_fresh type_refinement. cbn. case_if*.
  * splits*. splits 3; cbn; auto. apply_fresh type_refinement. cbn. case_if*.
  * splits*. splits 3; cbn; auto. apply_fresh type_refinement. cbn. case_if*.
  * splits*. splits 3; cbn; auto. apply_fresh type_refinement. cbn. case_if*.
    simpl_set. apply* singleton_subset.
  * splits*.
    + pick_fresh y. forwards* : (H1 y).
    + apply_fresh term_abs. forwards* : (H1 y).
    + destructs H. splits 3; auto. apply_fresh* type_arrow.
      forwards* : (H1 y). destructs H4. destructs* H6.
      pick_fresh y. forwards* : (H1 y). destructs H4. destructs* H6.
      cbn. apply* union_subset. cbn in H8. eapply open_var_rec_notin_typ_fv; eauto.
  * splits*. destructs IHtyping2. apply type_wf_strengthen_r in H5. auto.
  * splits*.
    destructs IHtyping1. splits 3; auto.
    - destructs H5. inversion H5. apply open_type. red. exists L. auto.
      inversion H0; simpl; constructor.
    - destructs H5. simpls. apply union_subset_inv in H7. destruct H7.
      eapply open_typ_term; eauto.
  * splits*. destructs IHtyping. apply_fresh* term_let. forwards* :(H1 y).
  * splits*. eapply sub_regular. eauto.
Qed.

Lemma value_regular : forall t, value t -> term t.
Proof. induction 1; auto. Qed.
Hint Resolve value_regular.

Lemma atom_regular : forall t, atom t -> value t.
Proof. induction 1; auto. Qed.

Lemma red_regular : forall {t s}, t ---> s -> term t /\ term s.
Proof. induction 1; split*.
   * apply* open_term.
   * inversion H0. apply* open_term.
Qed.

(** Automation *)

(** Extract wf env from other judgments *)
Hint Extern 1 (|~ ?E) =>
  match goal with
  | H: (?F |~ _ <: _) |- _ => match F with context[E] => apply (sub_regular H) end
  | H: (?F |~ _ : _) |- _ => match F with context[E] => apply (typing_regular H) end
  | H: (?F |~ _ ) |- _ => match F with context[E] => inversion H as [_ [? _]] end
  end.

Hint Extern 1 (?E |~ ?T) =>
  match goal with
  | H: (E |~ T <: _) |- _ => apply (sub_regular  H)
  | H: (E |~ _ <: T) |- _ => apply (sub_regular  H)
  | H: (E |~ _ : T) |- _ => apply (typing_regular H)
  | H: (E « ?p |~ T) |- _ => apply (type_wf_strengthen_r p H)
  end.

Hint Extern 1 ((?E & ?F) |~ ?T) =>
  match goal with
  | H: (E « ?p & F |~ T) |- _ => apply (type_wf_strengthen p H)
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: (_ |~ t : _) |- _ => apply (typing_regular H)
  | H: (t ---> _)  |- _ => apply (red_regular H)
  | H: (_ ---> t)  |- _ => apply (red_regular H)
  end.

Hint Extern 1 (type ?T) =>
  match goal with
  | H: (_ |~ _ : T) |- _ => apply (typing_regular H)
  | H: (_ |~ T <: _) |- _=> apply (sub_regular H)
  | H: (_ |~ _ <: T) |- _ => apply (sub_regular H)
  | H: (_ |~ T) |- _ => destruct H as [? _]
  end.

Hint Extern 1 (closed_logic_val (!?u)) =>
  match goal with
  | H : (value u) |- _ => inversion H; simpl; auto
  end.


From Hammer Require Import Hammer.

Require Import ZArithRing.
Require Import ZArith_base.
Require Export Omega.
Require Import Wf_nat.
Local Open Scope Z_scope.

Notation two_or_two_plus_one := Z_modulo_2 (only parsing).

Fixpoint floor_pos (a:positive) : positive :=
match a with
| xH => 1%positive
| xO a' => xO (floor_pos a')
| xI b' => xO (floor_pos b')
end.

Definition floor (a:positive) := Zpos (floor_pos a).

Lemma floor_gt0 : forall p:positive, floor p > 0.
Proof. hammer_hook "Zcomplements" "Zcomplements.floor_gt0".   reflexivity. Qed.

Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p.
Proof. hammer_hook "Zcomplements" "Zcomplements.floor_ok".
unfold floor. induction p; simpl.
- rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega.
- rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. omega.
- omega.
Qed.

Theorem Z_lt_abs_rec :
forall P:Z -> Set,
(forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
forall n:Z, P n.
Proof. hammer_hook "Zcomplements" "Zcomplements.Z_lt_abs_rec".
intros P HP p.
set (Q := fun z => 0 <= z -> P z * P (- z)).
enough (H:Q (Z.abs p)) by
(destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
apply (Z_lt_rec Q); auto with zarith.
subst Q; intros x H.
split; apply HP.
- rewrite Z.abs_eq; auto; intros.
destruct (H (Z.abs m)); auto with zarith.
destruct (Zabs_dec m) as [-> | ->]; trivial.
- rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
destruct (H (Z.abs m)); auto with zarith.
destruct (Zabs_dec m) as [-> | ->]; trivial.
Qed.

Theorem Z_lt_abs_induction :
forall P:Z -> Prop,
(forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
forall n:Z, P n.
Proof. hammer_hook "Zcomplements" "Zcomplements.Z_lt_abs_induction".
intros P HP p.
set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
enough (Q (Z.abs p)) by
(destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
apply (Z_lt_induction Q); auto with zarith.
subst Q; intros.
split; apply HP.
- rewrite Z.abs_eq; auto; intros.
elim (H (Z.abs m)); intros; auto with zarith.
elim (Zabs_dec m); intro eq; rewrite eq; trivial.
- rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
destruct (H (Z.abs m)); auto with zarith.
destruct (Zabs_dec m) as [-> | ->]; trivial.
Qed.

Lemma Zcase_sign :
forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
Proof. hammer_hook "Zcomplements" "Zcomplements.Zcase_sign".
intros x P Hzero Hpos Hneg.
destruct x; [apply Hzero|apply Hpos|apply Hneg]; easy.
Qed.

Lemma sqr_pos n : n * n >= 0.
Proof. hammer_hook "Zcomplements" "Zcomplements.sqr_pos".
Z.swap_greater. apply Z.square_nonneg.
Qed.

Require Import List.

Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
match l with
| nil => acc
| _ :: l => Zlength_aux (Z.succ acc) A l
end.

Definition Zlength := Zlength_aux 0.
Arguments Zlength [A] l.

Section Zlength_properties.

Variable A : Type.

Implicit Type l : list A.

Lemma Zlength_correct l : Zlength l = Z.of_nat (length l).
Proof. hammer_hook "Zcomplements" "Zcomplements.Zlength_correct".
assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)).
clear l. induction l.
auto with zarith.
intros. simpl length; simpl Zlength_aux.
rewrite IHl, Nat2Z.inj_succ; auto with zarith.
unfold Zlength. now rewrite H.
Qed.

Lemma Zlength_nil : Zlength (A:=A) nil = 0.
Proof. hammer_hook "Zcomplements" "Zcomplements.Zlength_nil".   reflexivity. Qed.

Lemma Zlength_cons (x:A) l : Zlength (x :: l) = Z.succ (Zlength l).
Proof. hammer_hook "Zcomplements" "Zcomplements.Zlength_cons".
intros. now rewrite !Zlength_correct, <- Nat2Z.inj_succ.
Qed.

Lemma Zlength_nil_inv l : Zlength l = 0 -> l = nil.
Proof. hammer_hook "Zcomplements" "Zcomplements.Zlength_nil_inv".
rewrite Zlength_correct.
destruct l as [|x l]; auto.
now rewrite <- Nat2Z.inj_0, Nat2Z.inj_iff.
Qed.

End Zlength_properties.

Arguments Zlength_correct [A] l.
Arguments Zlength_cons [A] x l.
Arguments Zlength_nil_inv [A] l _.