(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)
 Require Export cpacca.
 Set Nested Proofs Allowed.
(** [Voting Phase] *)

(** STEP:3 *)

 Definition x3tt (n n':nat) := f (toListm (phi0 ++ [msg (tr 0 n 3  5 9), msg (tr 1 n' 4 6 10)])).

 Definition x3ftt (n n':nat) := f (toListm (phi0 ++ [msg (tr 1 n' 4 6 10), msg (tr 0 n 3 5 9)])).

 Definition acpt (n k r:nat) (x:message)  := (acc (c n k) pk (rb (nonce r)) x).
 Definition bk n := (rb (nonce n)).
 Definition se n := (re (nonce n)).

 Definition e n1 k n2 x ph n3 := (enc ((c n1 k), ((ub (c n1 k) pk (bk n2) x), ph)) (pke 2) (se n3)).

 Definition Avote x (n n':nat) k r ph n3 := (If ((to (x n n')) #? A) then (If (acpt n k r (x n n')) then (e n k r (x n n') ph n3) else O) else O).

 Definition Bvote x (n n':nat) k r ph n3 := (If ((to (x n n')) #? B) then (If (acpt n' k r (x n n')) then (e n' k r (x n n') ph n3) else O) else O).

 Definition t3 n n'   := If (theta x1 A) then (If (theta (x2t n) B) then (Avote x3tt n n' 3 5 TWO 11) else O) else (If (theta x1 B) then (If (theta (x2ft n') A) then (Bvote x3ftt n n' 4 6 TWO 11) else O) else O).

Definition phi3 n n' := (phi2 n n') ++ [msg (t3 n n')].

(** STEP:4 *)

Definition x4ttt (n n':nat) := f (toListm (phi0 ++ [msg (tr 0 n 3  5 9), msg (tr 1 n' 4 6 10), msg (e n 3 5 (x3tt n n') TWO 11) ])).
Definition x4fttt (n n': nat) := f (toListm (phi0 ++ [msg (tr 1 n' 4 6 10), msg (tr 0 n 3 5 9), msg (e n' 4 6 (x3tt n n') TWO 11) ])).

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

Definition t4 n n' := If (theta x1 A) then
                         (If (theta (x2t n) B) then
                            (If ((to (x3tt n n')) #? A) then
                               (If (acpt n 3 5 (x3tt n n')) then
                                  (If ((to (x4ttt n n')) #? B) then
                                     (If (acpt n' 4 6 (x3tt n n')) then (e n' 4 6 (x3tt n n') TWO  12) else O) else O) else O) else O) else O) else (If (theta x1 B) then (If (theta (x2ft n') A) then (If ((to (x3ftt n n'))#?B) then (If (acpt n' 4 6 (x3ftt n n')) then (If ((to (x4fttt n n'))#? A) then (If (acpt n 3 5 (x3ftt n n')) then (e n 3 5 (x3ftt n n') TWO 12) else O) else O) else O) else O) else O) else O).

Definition phi4 n n' := (phi3 n n') ++ [msg (t4 n n')].

(** STEP:5 *)
Definition x5t (n n':nat) := f (toListm (phi0 ++ [msg (tr 0 n 3  5 9), msg (tr 1 n' 4 6 10), msg (e n 3 5 (x3tt n n') TWO 11), msg (e n' 4 6 (x3tt n n') TWO  12) ])).
Definition x5ft (n n':nat) := f (toListm (phi0 ++ [msg (tr 1 n' 4 6 10), msg (tr 0 n 3 5 9), msg (e n' 4 6 (x3ftt n n') TWO 11), msg (e n 3 5 (x3ftt n n') TWO 12) ])).

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

Definition tau n (m:message) := match n, m with
                                | 1, m => (pi1 m)
                                | 2, m => (pi1 (pi2 m))
                                | 3, m => (pi2 (pi2 m))
                                | _, _ => O
                                end.

Definition d n x := (dec (tau n x) (ske 2)).
Definition pchecks x ph := ((tau 3 (d 1 x)) #? ph) & ((tau 3 (d 2 x)) #? ph) & ((tau 3 (d 3 x)) #? ph).
Definition dist x y z := !(x #? y) & !(x#?z)& ! (y #? z).
Definition isin (x y:message):Bool := (x #? (tau 1 y)) or (x #? (tau 2 y)) or (x #? (tau 3 y)).
Definition bcheck (x y:message):Bool := (isin x ((pi2 (tau 1 y)), ((pi2 (tau 2 y)), (pi2 (tau 3 y))))).

Definition label x y := If (x #? (pi2 (tau 1 y))) then (pi1 (tau 1 y))
                           else  (If (x#?(pi2 (tau 2 y))) then (pi1 (tau 2 y))
                                                       else (If (x #? (pi2 (tau 3 y))) then (pi1 (tau 3 y))
                                                            else O)).

Definition mchecks x (n n':nat) ph := (dist (d 1 (x n n')) (d 2 (x n n')) (d 3 (x n n'))) & (pchecks (x n n') ph).

Definition p n x := ( (tau 1 (d n x)), (tau 2 (d n x))).

Definition strm x := (shufl (p 1 x) (p 2 x) (p 3 x)).

Definition t5 x n n' := (If ((to (x n n'))#? M) then (If (mchecks x n n' TWO) then (strm (x n n')) else O) else O).

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

Definition t4s n n' := If (theta x1 A) then
                         (If (theta (x2t n) B) then
                            (If ((to (x3tt n n')) #? A) then
                               (If (acpt n 3 5 (x3tt n n')) then
                                  (If ((to (x4ttt n n')) #? B) then
                                     (If (acpt n' 4 6 (x3tt n n')) then (t5 x5t n n')
                                      else O)
                                   else O) else O) else O) else O)
                      else (If (theta x1 B) then
                              (If (theta (x2ft n') A) then
                                 (If ((to (x3ftt n n'))#?B) then
                                    (If (acpt n' 4 6 (x3ftt n n')) then
                                       (If ((to (x4fttt n n'))#? A) then
                                          (If (acpt n 3 5 (x3ftt n n')) then (t5 x5ft n n') else O) else O) else O) else O) else O) else O).

(****************************)
Definition phi5 n n' := (phi4 n n') ++ [msg (t4s n n')].

Axiom gen_prop1:  forall {n m} (n1 n2 n3 n4:nat) (t t0 t1: message) (z: mylist n) (z1:mylist m), let v0 := (V0 (f (toListm z))) in
                                                                                let v1 := (V1 (f (toListm z))) in
                                                                                (|v0|#?|v1|) ## TRue ->  (Fresh [n1; n2; n3; n4] (z++ z1++[msg t, msg t0, msg t1])  = true) ->  closMylist (z++[msg t]) = true -> ((length (distMvars [msg t0, msg t1]))=?  2)%nat = true -> bVarMylist [msg t0, msg t1] = nil  ->
    let mvl:= [5; 6] in  (mVarMsg t0) = mvl /\ (mVarMsg t1) = mvl ->
                 let r0 := (r n1) in
                 let r1 := (r n2) in
                 let k0 := (kc (nonce n3)) in
                 let k1 := (kc (nonce n4)) in
                 let c00 := (comm v0 k0) in
                 let c01 := (comm v0 k1) in
                 let c10 := (comm v1 k0) in
                 let c11 := (comm v1 k1) in
                 let t2 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t0)) in
                 let t3 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t1)) in
                 let t4 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t0)) in
                 let t5 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t1)) in
                 let lt1 := (((ub c00 t r0 t2), (c00, k0)), ((ub c11 t r1 t2), (c11, k1)) ) in
                 let lt2 := ((ub c00 t r0 t2), (c00, |_)) in
                 let lt3 := (|_, ((ub c11 t r1 t3), c11)) in
                 let rt1 := (((ub c10 t r1 t5), (c10, k0)), ((ub c01 t r0 t4), (c01, k1))) in
                 let rt2 := ((ub c10 t r0 t4), (c10, |_)) in
                 let rt3 := (|_, ((ub c01 t r1 t5), c01)) in

                 (z++z1++[msg (bl c00 t r0), msg (bl c11 t r1),
                        msg (If (acc c00 t r0 t2)& (acc c11 t r1 t3) then lt1 else (If (acc c00 t r0 t2) then lt2 else (If (acc c11 t r1 t3) then lt3  else (|_, |_))))])
                    ~

                    (z++z1++[msg (bl c10 t r0), msg (bl c01 t r1),
                             msg (If (acc c10 t r0 t4)& (acc c01 t r1 t5) then rt1 else (If (acc c10 t r0 t4)  then rt2 else (If (acc c01 t r1 t5) then rt3 else (|_, |_))))]).

Axiom gen_prop3:  forall {n m} (n1 n2 n3 n4:nat) (t t0 t1: message) (z: mylist n) (z1:mylist m), let v0 := (V0 (f (toListm z))) in
                                                                                let v1 := (V1 (f (toListm z))) in
                                                                                (|v0|#?|v1|) ## TRue ->  (Fresh [n1; n2; n3; n4] (z++ z1++[msg t, msg t0, msg t1])  = true) ->  closMylist (z++[msg t]) = true -> ((length (distMvars [msg t0, msg t1]))=?  2)%nat = true -> bVarMylist [msg t0, msg t1] = nil  ->
    let mvl:= [5; 6] in  (distMvars [msg t0]) = mvl /\ (distMvars [msg t1]) = mvl ->
                 let r0 := (r n1) in
                 let r1 := (r n2) in
                 let k0 := (kc (nonce n3)) in
                 let k1 := (kc (nonce n4)) in
                 let c00 := (comm v0 k0) in
                 let c01 := (comm v0 k1) in
                 let c10 := (comm v1 k0) in
                 let c11 := (comm v1 k1) in
                 let t2 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t0)) in
                 let t3 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t1)) in
                 let t4 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t0)) in
                 let t5 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t1)) in
                 let lt1 := (((ub c00 t r0 t2), (c00, k0)), ((ub c11 t r1 t2), (c11, k1)) ) in
                 let lt2 := ((ub c00 t r0 t2), (c00, |_)) in
                 let lt3 := (|_, ((ub c11 t r1 t3), c11)) in
                 let rt1 := (((ub c10 t r1 t5), (c10, k0)), ((ub c01 t r0 t4), (c01, k1))) in
                 let rt2 := ((ub c10 t r0 t4), (c10, |_)) in
                 let rt3 := (|_, ((ub c01 t r1 t5), c01)) in

                 (z++z1++[msg (bl c00 t r0), msg (bl c11 t r1), bol (acc c00 t r0 t2)& (acc c11 t r1 t3), bol (acc c00 t r0 t2), bol (acc c11 t r1 t3), msg lt3])

                    ~

                    (z++z1++[msg (bl c10 t r0), msg (bl c01 t r1), bol (acc c10 t r0 t4)& (acc c01 t r1 t5), bol (acc c10 t r0 t4), bol (acc c01 t r1 t5), msg rt3]).
(** This is actually, Ex 7.4 in the other paper *)
Axiom symEql: forall x y, (|x|#?|y|) ## (|y|#?|x|).
Axiom refEql: forall x, (|x|#?|x|) ## TRue.
Axiom zeroEql1: forall x y, (|x|#?|y|) ## TRue -> (|x| #? |(z y)|) ## TRue.
Axiom len_reg: forall x1 y1 x2 y2, (|x1|#?|y1|) ## TRue -> (|x2|#?|y2|) ## TRue -> (|(x1, x2)| #? |(y1, y2)|) ## TRue.
Axiom len_prev_comp: forall (x:nat -> nat -> message) n n', (|(x n n')| #? |(x n' n)|) ## TRue.

Axiom ubEql: forall x1 y1 x2 y2 x3 y3 x4 y4, (|x1|#?|y1|) ## TRue -> (|x2|#?|y2|) ## TRue -> (|x3|#?|y3|) ## TRue -> (|x4|#?|y4|) ## TRue ->  (| (ub x1 x2 x3 x4)| #? | (ub y1 y2 y3 y4)|) ## TRue.
Axiom voteEql: forall {x}, (^? x) = true -> (|(V0 x)| #? |(V1 x)|)## TRue.

Axiom tempax: forall  t n n' n'' u v, (dec t (ske n)) # (If (t#? {u}_n^^n') then u else (If (t#?{v}_n^^n'') then v else (dec t (ske n)))).

(** morphism for tau *)
Axiom tau_cong: forall n1 n2 m1 m2, n1 = n2 -> m1 # m2 -> tau n1 m1 # tau n2 m2.
Add Parametric Morphism: (@tau) with
signature eq ==> EQm ==> EQm as tau_mor.
Proof. intros.
apply tau_cong;try auto.
Qed.
(*
Theorem frame5ind: (phi5 0 1) ~ (phi5 1 0).
Proof.
unfold phi5, phi4, phi3, phi2, phi1.
unfold t1, t2, t3, t4, t4s.
unfold t5, mchecks, strm, p, d.
unfold pchecks. simpl.
apply IFBRANCH_M5 with (ml1:= phi0) (ml2:= phi0).
simpl. unfold Avote.
apply IFBRANCH_M4 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9)]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9)])).
apply IFBRANCH_M3 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10)]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10)])).

apply IFBRANCH_M3 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A])).

apply IFBRANCH_M2 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11)]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11)])).

apply IFBRANCH_M2 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11), bol (to (x4ttt 0 1)) #? B]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11), bol (to (x4ttt 1 0)) #? B])).

apply IFBRANCH_M1 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11), bol (to (x4ttt 0 1)) #? B, bol (acpt 1 4 6 (x3tt 0 1)), msg (e 1 4 6 (x3tt 0 1) TWO 12)]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11), bol (to (x4ttt 1 0)) #? B, bol (acpt 0 4 6 (x3tt 1 0)), msg (e 0 4 6 (x3tt 1 0) TWO 12)])).

simpl. unfold d. unfold dist.

pose proof(tempax (tau 1 (x5t 0 1)) 2 11 12 (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO))).
pose proof(tempax  (tau 2 (x5t 0 1)) 2 11 12 (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO))).
pose proof(tempax  (tau 3 (x5t 0 1)) 2 11 12 (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO))).

pose proof(tempax  (tau 1 (x5t 1 0)) 2 11 12 (c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO))).
pose proof(tempax  (tau 2 (x5t 1 0)) 2 11 12 (c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO))).
pose proof(tempax  (tau 3 (x5t 1 0)) 2 11 12 (c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO))).
rewrite H, H0, H1, H2, H3, H4.
clear. simpl.

rewrite tempax.
apply IFBRANCH_M1 with (ml1:= (phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11), bol (to (x4ttt 0 1)) #? B, bol (acpt 1 4 6 (x3tt 0 1)), msg (e 1 4 6 (x3tt 0 1) TWO 12), bol (to (x5t 0 1)) #? M]))(ml2:= (phi0 ++ [bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11), bol (to (x4ttt 1 0)) #? B, bol (acpt 0 4 6 (x3tt 1 0)), msg (e 0 4 6 (x3tt 1 0) TWO 12), bol (to (x5t 1 0)) #? M])).

simpl.

unfold theta, tr, e.
rewrite tempax. *)

Theorem frame4goal1: [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2),
   bol (theta x1 A), msg (tr 0 0 3 5 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A,
   bol (acpt 0 3 5 (x3tt 0 1)), msg {(c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) }_ 2 ^^ 11,
   bol (to (x4ttt 0 1)) #? B, bol (acpt 1 4 6 (x3tt 0 1)), msg {(c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 12] ~
  [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2),
  bol (theta x1 A), msg (tr 0 1 3 5 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A,
  bol (acpt 1 3 5 (x3tt 1 0)), msg {(c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) }_ 2 ^^ 11,
  bol (to (x4ttt 1 0)) #? B, bol (acpt 0 4 6 (x3tt 1 0)), msg {(c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO)) }_ 2 ^^  12].
   Proof.

(** l1 ++ [e1] ++ [e2] ~ l2 ++ [e1'] ++ [e2'] *)

(** Now, using ENCCCA2, we prove that, l1 ++ [e1] ++ [e2] ~ l1 ++ [z(e1)] ++ [z(e2)]  **)

pose proof(EXTENCCCA2 (tau 1 (x5t 0 1)) (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) (z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO))) O (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) (z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO))) O 0 1 2 11 12 13 14 ([msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2),
   msg (tr 0 0 3 5 9), msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), bol (acpt 1 4 6 (x3tt 0 1)), msg (Mvar 0), msg (Mvar 1)])).
 simpl in H.
do 2  rewrite zeroEql1 in H; try rewrite refEql.
simpl.  do 4 rewrite IFTRUE_M in H. simpl.

(** Assuming the proposition1 with z= sublist(l1) ++ [z(e1)] ++ [z(e2)] and again using ENCCCA2, we get that
 l1 ++ [z(e1)] ++ [z(e2)] ~ l2 ++ [e1'] ++ [e2'] *)
(** 3nd Branch *)

(*Eval compute in (x3tt 0 1).  *)
Definition x3ttx := f (toListm (phi0 ++ [msg ((vk 0), (Mvar 5, (sign (Mvar 5) (ssk 0) (rs (nonce 9)))))] ++ [msg ((vk 1), (Mvar 6, (sign (Mvar 6) (ssk 1) (rs (nonce 10)))))])).

Definition sr (n:nat) := (rs (nonce n)).

pose proof (gen_prop3 5 6 3 4 (pubkey x1) (x3ttx) (x3ttx) phi0 [msg {(z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)))}_ 2 ^^ 13,  msg {z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 14, msg (ssk 0), msg (ssk 1), msg (sr 9), msg (sr 10) ]). unfold distMvars in H0.
 simpl in H0.
 unfold Fresh in H0. simpl in H0.
 rewrite voteEql in H0.
restr_proj_in 21 H0; simpl; try split; try reflexivity.
Ltac dropLast_in H1 :=
  match goal with
  | [H: ?L1~?L2 |- _] => match H with
                           | H1 =>  restr_proj_in (length (toListm L1)) H
                         end
                           end.
dropLast_in H0.

Ltac signTerm n n' k r a r' H := funapptrmhypbl (msg (s n k r a r')) (msg (s n' k r a r')) H;
                                 funapptrmhypbl (msg (tr a n k r r')) (msg (tr a n' k r r')) H; simpl; try reflexivity.

 signTerm 0 1 3 5 0 9 H0.
 signTerm 1 0 4 6 1 10 H0.

Ltac toTerm x n n' a H := funapptrmhypbl (msg (x n n')) (msg (x n' n)) H;
                          funapptrmhypbl (msg (to (x n n'))) (msg (to (x n' n))) H;
                          funapptrmhypbl (bol ((to (x n n')) #? a))  (bol ((to (x n' n)) #? a)) H; simpl; try reflexivity.

funapptrmhypbl (msg (x3tt 0 1)) (msg (x3tt 1 0)) H0; simpl; try reflexivity.
funapptrmhypbl (msg (to (x3tt 0 1))) (msg (to (x3tt 1 0))) H0; simpl; try reflexivity.
funapptrmhypbl (bol ((to (x3tt 0 1)) #? A))  (bol ((to (x3tt 1 0)) #? A)) H0; simpl; try reflexivity.

do 6 (restr_proj_in 15 H0).
restr_proj_in 17 H0 . restr_proj_in 18 H0. do 2 restr_proj_in 19 H0.
(*Eval compute in (x3tt 0 1).  *)
 repeat unfold tr, acpt, vk, b, c, s.
restr_swap_in 13 17 H0.
restr_swap_in 14 18 H0.
restr_swap_in 15 19 H0.
restr_swap_in 18 19 H0.
restr_swap_in 17 18 H0.
restr_swap_in 16 17 H0.

assert ( [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (pi1 (ks (nonce 0))), msg (pi1 (ks (nonce 1))), msg (pi1 (ke (nonce 2))),
       msg
         (pi1 (ks (nonce 0)),
         (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
            (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5)),
         sign
           (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
              (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5))) (pi2 (ks (nonce 0)))
           (rs (nonce 9)))),
       msg
         (pi1 (ks (nonce 1)),
         (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
            (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6)),
         sign
           (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
              (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6))) (pi2 (ks (nonce 1)))
           (rs (nonce 10)))),
       bol
         (to
            (f
               [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
               (pi1 (ks (nonce 0)),
               (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                  (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5)),
               sign
                 (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5))) (pi2 (ks (nonce 0)))
                 (rs (nonce 9))));
               (pi1 (ks (nonce 1)),
               (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                  (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6)),
               sign
                 (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6))) (pi2 (ks (nonce 1)))
                 (rs (nonce 10))))])) #? A, bol (acpt 0 3 5 (x3tt 0 1)), bol (acpt 1 4 6 (x3tt 0 1)),
       msg
         {(comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)),
          (ub (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
             (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5))
             (f
                [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
                (pi1 (ks (nonce 0)),
                (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5)),
                sign
                  (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                     (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 5))) (pi2 (ks (nonce 0)))
                  (rs (nonce 9))));
                (pi1 (ks (nonce 1)),
                (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6)),
                sign
                  (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                     (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (rb (nonce 6))) (pi2 (ks (nonce 1)))
                  (rs (nonce 10))))]), TWO)) }_ 2 ^^ 11, msg {(c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 12] ~ [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2), msg (tr 0 1 3 5 9),
       msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), bol (acpt 0 4 6 (x3tt 1 0)),
       msg {z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) }_ 2 ^^ 13, msg {z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 14]).

apply EQI_trans with (ml2:= [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2), msg (tr 0 0 3 5 9),
        msg (tr 1 1 4 6 10), bol (to (x3tt 0 1)) #? A, bol (acpt 0 3 5 (x3tt 0 1)), bol (acpt 1 4 6 (x3tt 0 1)),
        msg {z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) }_ 2 ^^ 13, msg {z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 14]).
apply H; repeat try split; try reflexivity.
assumption. clear H H0.

(** inorder to apply ENCCCA2 axiom, I do need utilize the axioms such as [CommEql], |V0x| = |V1x| and so on *)

pose proof(EXTENCCCA2 (tau 1 (x5t 0 1)) (z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO))) (c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO)) O (z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO))) (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO)) O 0 1 2 13 14 11 12 [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2), msg (tr 0 1 3 5 9),
       msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)), bol (acpt 0 4 6 (x3tt 1 0)),
       msg (Mvar 0), msg (Mvar 1)]).
simpl in H.

(** I will come back to here later *)

(** This is not true in general, I'll come back it later *)

Check x3tt.

assert( (| z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) |) #? (| (c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO)) |) ## TRue).
rewrite symEql.
apply zeroEql1. apply len_reg.

pose proof (commEql 4 4 (V1 x1) (V0 x1)).
rewrite symEql in H0. rewrite voteEql in H0. rewrite IFTRUE_B in H0.
rewrite symEql.
apply H0.

try split; try reflexivity. unfold Fresh. simpl. reflexivity.
simpl.
reflexivity.
apply len_reg.

apply ubEql.

pose proof (commEql 4 4 (V1 x1) (V0 x1)).
rewrite symEql in H0. rewrite voteEql in H0. rewrite IFTRUE_B in H0.
rewrite symEql.
apply H0.

try split; try reflexivity. unfold Fresh. simpl. reflexivity.
simpl.
reflexivity.
 apply refEql.
apply refEql.
apply len_prev_comp.
apply refEql.
rewrite H0 in H.

assert ( (|z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO))|#? |(c 1 3, (ub (c 1 3) pk (bk 5) (x3tt 1 0), TWO))|) ## TRue).

rewrite symEql.
apply zeroEql1. apply len_reg.

pose proof (commEql 3 3 (V1 x1) (V0 x1)).
rewrite symEql in H2. rewrite voteEql in H2. rewrite IFTRUE_B in H2.
apply H2.

try split; try reflexivity. unfold Fresh. simpl. reflexivity.
simpl.
reflexivity.
apply len_reg.
apply ubEql.

pose proof (commEql 3 3 (V1 x1) (V0 x1)).
rewrite symEql in H2. rewrite voteEql in H2. rewrite IFTRUE_B in H2.
apply H2.

try split; try reflexivity. unfold Fresh. simpl. reflexivity.
simpl.
reflexivity.
apply refEql. apply refEql.
apply len_prev_comp.
apply refEql.
rewrite H2 in H.
clear H0 H2.

repeat rewrite IFTRUE_M in H.

(** transitivity *)

assert ( [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (pi1 (ks (nonce 0))),
        msg (pi1 (ks (nonce 1))), msg (pi1 (ke (nonce 2))),
        msg
          (pi1 (ks (nonce 0)),
          (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
             (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
             (rb (nonce 5)),
          sign
            (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
               (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
               (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9)))),
        msg
          (pi1 (ks (nonce 1)),
          (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
             (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
             (rb (nonce 6)),
          sign
            (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
               (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
               (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10)))),
        bol
          (to
             (f
                [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
                (pi1 (ks (nonce 0)),
                (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 5)),
                sign
                  (bl
                     (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                     (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                     (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
                (pi1 (ks (nonce 1)),
                (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 6)),
                sign
                  (bl
                     (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                     (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                     (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))])) #? A, bol (acpt 0 3 5 (x3tt 0 1)), bol (acpt 1 4 6 (x3tt 0 1)),
        msg
          {(comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)),
           (ub (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
              (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
              (rb (nonce 5))
              (f
                 [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
                 (pi1 (ks (nonce 0)),
                 (bl
                    (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                    (rb (nonce 5)),
                 sign
                   (bl
                      (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                         (kc (nonce 3)))
                      (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                      (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
                 (pi1 (ks (nonce 1)),
                 (bl
                    (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                    (rb (nonce 6)),
                 sign
                   (bl
                      (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                         (kc (nonce 4)))
                      (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                      (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))]), TWO)) }_ 2 ^^ 11,
        msg {(c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 12] ~  [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (pi1 (ks (nonce 0))), msg (pi1 (ks (nonce 1))),
      msg (pi1 (ke (nonce 2))),
      msg
        (pi1 (ks (nonce 0)),
        (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
           (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
           (rb (nonce 5)),
        sign
          (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
             (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
             (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9)))),
      msg
        (pi1 (ks (nonce 1)),
        (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
           (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
           (rb (nonce 6)),
        sign
          (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
             (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
             (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10)))),
      bol
        (to
           (f
              [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
              (pi1 (ks (nonce 0)),
              (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 5)),
              sign
                (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
              (pi1 (ks (nonce 1)),
              (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 6)),
              sign
                (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))])) #? A,
      bol
        (acc (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
           (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
           (rb (nonce 5))
           (f
              [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
              (pi1 (ks (nonce 0)),
              (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 5)),
              sign
                (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
              (pi1 (ks (nonce 1)),
              (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 6)),
              sign
                (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))])),
      bol
        (acc (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
           (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
           (rb (nonce 6))
           (f
              [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
              (pi1 (ks (nonce 0)),
              (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 5)),
              sign
                (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
              (pi1 (ks (nonce 1)),
              (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                 (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                 (rb (nonce 6)),
              sign
                (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                   (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                   (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))])),
      msg
        {(comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)),
         (ub (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
            (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
            (rb (nonce 5))
            (f
               [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2));
               (pi1 (ks (nonce 0)),
               (bl (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                  (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                  (rb (nonce 5)),
               sign
                 (bl
                    (comm (V1 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 3)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                    (rb (nonce 5))) (pi2 (ks (nonce 0))) (rs (nonce 9))));
               (pi1 (ks (nonce 1)),
               (bl (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                  (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                  (rb (nonce 6)),
               sign
                 (bl
                    (comm (V0 (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))])) (kc (nonce 4)))
                    (pubkey (f [A; B; M; C1; C2; C3; ONE; TWO; THREE; pi1 (ks (nonce 0)); pi1 (ks (nonce 1)); pi1 (ke (nonce 2))]))
                    (rb (nonce 6))) (pi2 (ks (nonce 1))) (rs (nonce 10))))]), TWO)) }_2^^11,
      msg {(c 0 4, (ub (c 0 4) pk (bk 6) (x3tt 1 0), TWO)) }_ 2 ^^ 12]).
apply EQI_trans with (ml2:= [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1),
       msg (pke 2), msg (tr 0 1 3 5 9), msg (tr 1 0 4 6 10), bol (to (x3tt 1 0)) #? A, bol (acpt 1 3 5 (x3tt 1 0)),
       bol (acpt 0 4 6 (x3tt 1 0)), msg {z (c 0 3, (ub (c 0 3) pk (bk 5) (x3tt 0 1), TWO)) }_ 2 ^^ 13,
       msg {z (c 1 4, (ub (c 1 4) pk (bk 6) (x3tt 0 1), TWO)) }_ 2 ^^ 14]).
assumption. apply H.
repeat (split; try reflexivity).
clear - H0. unfold theta.
funapptrmhypbl (msg x1) (msg x1) H0; simpl; try reflexivity.
funapptrmhypbl (msg (to x1)) (msg (to x1)) H0; simpl; try reflexivity.
funapptrmhypbl (bol ((to x1) #? A)) (bol ((to x1) #? A)) H0; simpl; try reflexivity.

funapptrmhypbl (msg (v 0)) (msg (v 0)) H0;simpl; try reflexivity.
funapptrmhypbl (bol (vcheck (v 0))) (bol (vcheck (v 0))) H0;simpl; try reflexivity.
funapptrmhypbl (msg (v 1)) (msg (v 1)) H0;simpl; try reflexivity.
funapptrmhypbl (bol (vcheck (v 1))) (bol (vcheck (v 1))) H0;simpl; try reflexivity.
funapptrmhypbl (bol (vcheck (v 0))& (vcheck (v 1))) (bol (vcheck (v 0))& (vcheck (v 1))) H0; simpl; try reflexivity.
simpl.

funapptrmhypbl (msg (x2t 0)) (msg (x2t 1)) H0; simpl; try reflexivity.
funapptrmhypbl (msg (to (x2t 0))) (msg (to (x2t 1))) H0; simpl; try reflexivity.
funapptrmhypbl (bol ((to (x2t 0)) #? B)) (bol ((to (x2t 1)) #? B)) H0; simpl; try reflexivity.
funapp_andB_in 22 27 H0. simpl.
funapp_andB_in 31 28 H0.

funapptrmhypbl (msg (x4ttt 0 1)) (msg (x4ttt 1 0)) H0; simpl; try reflexivity.
 funapptrmhypbl (msg (to (x4ttt 0 1))) (msg (to (x4ttt 1 0))) H0; simpl; try reflexivity.
funapptrmhypbl (bol (to (x4ttt 0 1)) #? B) (bol (to (x4ttt 1 0)) #?B) H0; simpl; try reflexivity.

restrsublis H0; simpl; try auto.
simpl; repeat try auto. reflexivity.  reflexivity. reflexivity.
Qed.


Require Import Kami.AllNotations.
Require Import List.

Section Ifc.
  Record Client (outResK : Kind)
    := { clientTagSz : nat;
         clientResK := STRUCT_TYPE {
                           "tag" :: Bit clientTagSz;
                           "res" :: outResK
                         };
       }.

  Record Clients := { outResK: Kind;
                      clientList: list (Client outResK) }.

  Class Params :=
    {
      name : string;
      inReqK : Kind;
      immResK : Kind;
      isError : forall {ty}, immResK @# ty -> Bool @# ty;
    }.

  Context {params: Params}.
  Context (clients : Clients).

  Definition numClients := length (clientList clients).

  Definition clientIdSz := Nat.log2_up numClients.
  Definition ClientId := Bit clientIdSz.

  Definition maxClientTagSz
    := fold_left Nat.max
         (map
           (fun client : Client _
             => clientTagSz client)
           (clientList clients))
         0.

  Definition MaxClientTag := Bit maxClientTagSz.

  Definition Tag
    := STRUCT_TYPE {
         "id"  :: ClientId;
         "tag" :: MaxClientTag
       }.

  Definition ClientReq clientTagSz := STRUCT_TYPE {
                                          "tag" :: Bit clientTagSz;
                                          "req" :: inReqK
                                        }.

  Definition OutReq := STRUCT_TYPE {
                           "tag" :: Tag;
                           "req" :: inReqK
                         }.

  Definition InRes := STRUCT_TYPE {
                          "tag" :: Tag;
                          "res" :: (outResK clients)
                        }.

  Record Ifc
    := {
         regs : list RegInitT;
         regFiles : list RegFileBase;

         sendReq (send : forall {ty}, ty OutReq -> ActionT ty (Maybe immResK))
         : forall (clientId : Fin.t numClients) {ty},
             ty (ClientReq (clientTagSz (nth_Fin (clientList clients) clientId))) -> ActionT ty (Maybe immResK);

         hasResps (first: forall {ty}, ActionT ty (Maybe InRes))
         : forall (clientId: Fin.t numClients) {ty},
             ActionT ty Bool;

         getResps (first: forall {ty}, ActionT ty (Maybe InRes))
                  (deq: forall {ty}, ActionT ty Bool)
         : forall (clientId: Fin.t numClients) {ty},
             ActionT ty (Maybe (clientResK (nth_Fin (clientList clients) clientId)));

         resetRule : forall {ty}, ActionT ty Void;
       }.
End Ifc.


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

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

Set Implicit Arguments.

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

Local Open Scope Z_scope.

Section GENDIVN1.

 Variable w             : Type.
 Variable w_digits      : positive.
 Variable w_zdigits     : w.
 Variable w_0           : w.
 Variable w_WW          : w -> w -> zn2z w.
 Variable w_head0       : w -> w.
 Variable w_add_mul_div : w -> w -> w -> w.
 Variable w_div21       : w -> w -> w -> w * w.
 Variable w_compare     : w -> w -> comparison.
 Variable w_sub         : w -> w -> w.

 (* ** For proofs ** *)
 Variable w_to_Z        : w -> Z.

 Notation wB := (base w_digits).

 Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
 Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x)
                                      (at level 0, x at level 99).
 Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x)  (at level 0, x at level 99).

 Variable spec_to_Z   : forall x, 0 <= [| x |] < wB.
 Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits.
 Variable spec_0   : [|w_0|] = 0.
 Variable spec_WW  : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
 Variable spec_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB.
 Variable spec_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_div21 : forall a1 a2 b,
     wB/2 <= [|b|] ->
     [|a1|] < [|b|] ->
     let (q,r) := w_div21 a1 a2 b in
     [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
     0 <= [|r|] < [|b|].
 Variable spec_compare :
     forall x y,
       match w_compare x y with
       | Eq => [|x|] = [|y|]
       | Lt => [|x|] < [|y|]
       | Gt => [|x|] > [|y|]
       end.
 Variable spec_sub: forall x y,
   [|w_sub x y|] = ([|x|] - [|y|]) mod wB.

 Section DIVAUX.
  Variable b2p : w.
  Variable b2p_le : wB/2 <= [|b2p|].

  Definition double_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h :=
   let (hh,hl) := double_split w_0 n h in
   let (qh,rh) := divn1 r hh in
   let (ql,rl) := divn1 rh hl in
   (double_WW w_WW n qh ql, rl).

  Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w :=
   match n return w -> word w n -> word w n * w with
   | O => fun r x => w_div21 r x b2p
   | S n => double_divn1_0_aux n (double_divn1_0 n)
   end.

  Lemma spec_split : forall (n : nat) (x : zn2z (word w n)),
       let (h, l) := double_split w_0 n x in
       [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!].
  Proof (spec_double_split w_0 w_digits w_to_Z spec_0).

  Lemma spec_double_divn1_0 : forall n r a,
    [|r|] < [|b2p|] ->
    let (q,r') := double_divn1_0 n r a in
    [|r|] * double_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\
    0 <= [|r'|] < [|b2p|].
  Proof.
   induction n;intros.
   exact (spec_div21 a b2p_le H).
   simpl (double_divn1_0 (S n) r a); unfold double_divn1_0_aux.
   assert (H1 := spec_split n a);destruct (double_split w_0 n a) as (hh,hl).
   rewrite H1.
   assert (H2 := IHn r hh H);destruct (double_divn1_0 n r hh) as (qh,rh).
   destruct H2.
   assert ([|rh|] < [|b2p|]). omega.
   assert (H4 := IHn rh hl H3);destruct (double_divn1_0 n rh hl) as (ql,rl).
   destruct H4;split;trivial.
   rewrite spec_double_WW;trivial.
   rewrite <- double_wB_wwB.
   rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   rewrite H0;rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc.
   rewrite H4;ring.
  Qed.

  Definition double_modn1_0_aux n (modn1:w -> word w n -> w) r h :=
   let (hh,hl) := double_split w_0 n h in modn1 (modn1 r hh) hl.

  Fixpoint double_modn1_0 (n:nat) : w -> word w n -> w :=
   match n return w -> word w n -> w with
   | O => fun r x => snd (w_div21 r x b2p)
   | S n => double_modn1_0_aux n (double_modn1_0 n)
   end.

  Lemma spec_double_modn1_0 : forall n r x,
     double_modn1_0 n r x = snd (double_divn1_0 n r x).
  Proof.
   induction n;simpl;intros;trivial.
   unfold double_modn1_0_aux, double_divn1_0_aux.
   destruct (double_split w_0 n x) as (hh,hl).
   rewrite (IHn r hh).
   destruct (double_divn1_0 n r hh) as (qh,rh);simpl.
   rewrite IHn. destruct (double_divn1_0 n rh hl);trivial.
  Qed.

  Variable p : w.
  Variable p_bounded : [|p|] <= Zpos w_digits.

  Lemma spec_add_mul_divp : forall x y,
    [| w_add_mul_div p x y |] =
       ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
  Proof.
   intros;apply spec_add_mul_div;auto.
  Qed.

  Definition double_divn1_p_aux n
   (divn1 : w -> word w n -> word w n -> word w n * w) r h l :=
   let (hh,hl) := double_split w_0 n h in
   let (lh,ll) := double_split w_0 n l in
   let (qh,rh) := divn1 r hh hl in
   let (ql,rl) := divn1 rh hl lh in
   (double_WW w_WW n qh ql, rl).

  Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w :=
   match n return w -> word w n -> word w n ->  word w n * w with
   | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p
   | S n => double_divn1_p_aux n (double_divn1_p n)
   end.

  Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (double_digits w_digits n).
  Proof.
(*
   induction n;simpl. destruct p_bounded;trivial.
   case (spec_to_Z p); rewrite Zpos_xO;auto with zarith.
*)
   induction n;simpl. trivial.
   case (spec_to_Z p); rewrite Zpos_xO;auto with zarith.
  Qed.

  Lemma spec_double_divn1_p : forall n r h l,
    [|r|] < [|b2p|] ->
    let (q,r') := double_divn1_p n r h l in
    [|r|] * double_wB w_digits n +
      ([!n|h!]*2^[|p|] +
        [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|])))
        mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\
    0 <= [|r'|] < [|b2p|].
  Proof.
   case (spec_to_Z p); intros HH0 HH1.
   induction n;intros.
   simpl (double_divn1_p 0 r h l).
   unfold double_to_Z, double_wB, double_digits.
   rewrite <- spec_add_mul_divp.
   exact (spec_div21 (w_add_mul_div p h l) b2p_le H).
   simpl (double_divn1_p (S n) r h l).
   unfold double_divn1_p_aux.
   assert (H1 := spec_split n h);destruct (double_split w_0 n h) as (hh,hl).
   rewrite H1. rewrite <- double_wB_wwB.
   assert (H2 := spec_split n l);destruct (double_split w_0 n l) as (lh,ll).
   rewrite H2.
   replace ([|r|] * (double_wB w_digits n * double_wB w_digits n) +
    (([!n|hh!] * double_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] +
    ([!n|lh!] * double_wB w_digits n + [!n|ll!]) /
     2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod
      (double_wB w_digits n * double_wB w_digits n)) with
    (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] +
      [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod
                      double_wB w_digits n) * double_wB w_digits n +
     ([!n|hl!] * 2^[|p|] +
      [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod
              double_wB w_digits n).
   generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh);
   intros (H3,H4);rewrite H3.
   assert ([|rh|] < [|b2p|]). omega.
   replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n +
     ([!n|hl!] * 2 ^ [|p|] +
      [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod
      double_wB w_digits n)  with
    ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n +
      ([!n|hl!] * 2 ^ [|p|] +
       [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod
      double_wB w_digits n)). 2:ring.
   generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl);
   intros (H5,H6);rewrite H5.
   split;[rewrite spec_double_WW;trivial;ring|trivial].
   assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh);
    unfold double_wB,base in Uhh.
   assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl);
    unfold double_wB,base in Uhl.
   assert (Ulh := spec_double_to_Z w_digits w_to_Z spec_to_Z n lh);
    unfold double_wB,base in Ulh.
   assert (Ull := spec_double_to_Z w_digits w_to_Z spec_to_Z n ll);
    unfold double_wB,base in Ull.
   unfold double_wB,base.
   assert (UU:=p_lt_double_digits n).
   rewrite Zdiv_shift_r;auto with zarith.
   2:change (Zpos (double_digits w_digits (S n)))
     with (2*Zpos (double_digits w_digits n));auto with zarith.
   replace (2 ^ (Zpos (double_digits w_digits (S n)) - [|p|])) with
    (2^(Zpos (double_digits w_digits n) - [|p|])*2^Zpos (double_digits w_digits n)).
   rewrite Zdiv_mult_cancel_r;auto with zarith.
   rewrite Zmult_plus_distr_l with (p:=  2^[|p|]).
   pattern  ([!n|hl!] * 2^[|p|]) at 2;
   rewrite (shift_unshift_mod (Zpos(double_digits w_digits n))([|p|])([!n|hl!]));
    auto with zarith.
   rewrite Zplus_assoc.
   replace
    ([!n|hh!] * 2^Zpos (double_digits w_digits n)* 2^[|p|] +
      ([!n|hl!] / 2^(Zpos (double_digits w_digits n)-[|p|])*
       2^Zpos(double_digits w_digits n)))
   with
    (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl /
       2^(Zpos (double_digits w_digits n)-[|p|]))
      * 2^Zpos(double_digits w_digits n));try (ring;fail).
   rewrite <- Zplus_assoc.
   rewrite <- (Zmod_shift_r ([|p|]));auto with zarith.
   replace
     (2 ^ Zpos (double_digits w_digits n) * 2 ^ Zpos (double_digits w_digits n)) with
     (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))).
   rewrite (Zmod_shift_r (Zpos (double_digits w_digits n)));auto with zarith.
   replace (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n)))
   with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)).
   rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] +
      [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))).
   rewrite  Zmult_mod_distr_l;auto with zarith.
   ring.
   rewrite Zpower_exp;auto with zarith.
   assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity.
   auto with zarith.
   apply Z_mod_lt;auto with zarith.
   rewrite Zpower_exp;auto with zarith.
   split;auto with zarith.
   apply Zdiv_lt_upper_bound;auto with zarith.
   rewrite <- Zpower_exp;auto with zarith.
   replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with
     (Zpos(double_digits w_digits n));auto with zarith.
   rewrite <- Zpower_exp;auto with zarith.
   replace (Zpos (double_digits w_digits (S n)) - [|p|]) with
       (Zpos (double_digits w_digits n) - [|p|] +
         Zpos (double_digits w_digits n));trivial.
   change (Zpos (double_digits w_digits (S n))) with
    (2*Zpos (double_digits w_digits n)). ring.
  Qed.

  Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:=
   let (hh,hl) := double_split w_0 n h in
   let (lh,ll) := double_split w_0 n l in
   modn1 (modn1 r hh hl) hl lh.

  Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w :=
   match n return w -> word w n -> word w n -> w with
   | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p)
   | S n => double_modn1_p_aux n (double_modn1_p n)
   end.

  Lemma spec_double_modn1_p : forall n r h l ,
    double_modn1_p n r h l = snd (double_divn1_p n r h l).
  Proof.
   induction n;simpl;intros;trivial.
   unfold double_modn1_p_aux, double_divn1_p_aux.
   destruct(double_split w_0 n h)as(hh,hl);destruct(double_split w_0 n l) as (lh,ll).
   rewrite (IHn r hh hl);destruct (double_divn1_p n r hh hl) as (qh,rh).
   rewrite IHn;simpl;destruct (double_divn1_p n rh hl lh);trivial.
  Qed.

 End DIVAUX.

 Fixpoint high (n:nat) : word w n -> w :=
  match n return word w n -> w with
  | O => fun a => a
  | S n =>
    fun (a:zn2z (word w n)) =>
     match a with
     | W0 => w_0
     | WW h l => high n h
     end
  end.

 Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n).
 Proof.
  induction n;simpl;auto with zarith.
  change (Zpos (xO (double_digits w_digits n))) with
    (2*Zpos (double_digits w_digits n)).
  assert (0 < Zpos w_digits);auto with zarith.
  exact (refl_equal Lt).
 Qed.

 Lemma spec_high : forall n (x:word w n),
   [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits).
 Proof.
  induction n;intros.
  unfold high,double_digits,double_to_Z.
  replace (Zpos w_digits - Zpos w_digits) with 0;try ring.
  simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith.
  assert (U2 := spec_double_digits n).
  assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt).
  destruct x;unfold high;fold high.
  unfold double_to_Z,zn2z_to_Z;rewrite spec_0.
  rewrite Zdiv_0_l;trivial.
  assert (U0 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w0);
   assert (U1 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w1).
  simpl [!S n|WW w0 w1!].
  unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith.
  replace (2 ^ (Zpos (double_digits w_digits (S n)) - Zpos w_digits)) with
   (2^(Zpos (double_digits w_digits n) - Zpos w_digits) *
        2^Zpos (double_digits w_digits n)).
  rewrite Zdiv_mult_cancel_r;auto with zarith.
  rewrite <- Zpower_exp;auto with zarith.
  replace (Zpos (double_digits w_digits n) - Zpos w_digits +
    Zpos (double_digits w_digits n)) with
   (Zpos (double_digits w_digits (S n)) - Zpos w_digits);trivial.
  change (Zpos (double_digits w_digits (S n))) with
     (2*Zpos (double_digits w_digits n));ring.
  change (Zpos (double_digits w_digits (S n))) with
  (2*Zpos (double_digits w_digits n)); auto with zarith.
 Qed.

 Definition double_divn1 (n:nat) (a:word w n) (b:w) :=
  let p := w_head0 b in
  match w_compare p w_0 with
  | Gt =>
    let b2p := w_add_mul_div p b w_0 in
    let ha := high n a in
    let k := w_sub w_zdigits p in
    let lsr_n := w_add_mul_div k w_0 in
    let r0 := w_add_mul_div p w_0 ha in
    let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in
    (q, lsr_n r)
  | _ => double_divn1_0 b n w_0 a
  end.

 Lemma spec_double_divn1 : forall n a b,
    0 < [|b|] ->
    let (q,r) := double_divn1 n a b in
    [!n|a!] = [!n|q!] * [|b|] + [|r|] /\
    0 <= [|r|] < [|b|].
  Proof.
   intros n a b H. unfold double_divn1.
   case (spec_head0 H); intros H0 H1.
   case (spec_to_Z (w_head0 b)); intros HH1 HH2.
   generalize (spec_compare (w_head0 b) w_0); case w_compare;
     rewrite spec_0; intros H2; auto with zarith.
   assert (Hv1: wB/2 <= [|b|]).
     generalize H0; rewrite H2; rewrite Zpower_0_r;
       rewrite Zmult_1_l; auto.
   assert (Hv2: [|w_0|] < [|b|]).
     rewrite spec_0; auto.
   generalize (spec_double_divn1_0 Hv1 n a Hv2).
   rewrite spec_0;rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
   contradict H2; auto with zarith.
   assert (HHHH : 0 < [|w_head0 b|]); auto with zarith.
   assert ([|w_head0 b|] < Zpos w_digits).
    case (Zle_or_lt (Zpos w_digits) [|w_head0 b|]); auto; intros HH.
    assert (2 ^ [|w_head0 b|] < wB).
     apply Zle_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith.
     replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail).
     apply Zmult_le_compat;auto with zarith.
     assert (wB <= 2^[|w_head0 b|]).
     unfold base;apply Zpower_le_monotone;auto with zarith. omega.
   assert ([|w_add_mul_div (w_head0 b) b w_0|] =
               2 ^ [|w_head0 b|] * [|b|]).
    rewrite (spec_add_mul_div b w_0); auto with zarith.
    rewrite spec_0;rewrite Zdiv_0_l; try omega.
    rewrite Zplus_0_r; rewrite Zmult_comm.
    rewrite Zmod_small; auto with zarith.
   assert (H5 := spec_to_Z (high n a)).
   assert
    ([|w_add_mul_div (w_head0 b) w_0 (high n a)|]
          <[|w_add_mul_div (w_head0 b) b w_0|]).
    rewrite H4.
    rewrite spec_add_mul_div;auto with zarith.
    rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
    assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB).
     apply Zdiv_lt_upper_bound;auto with zarith.
     apply Zlt_le_trans with wB;auto with zarith.
     pattern wB at 1;replace wB with (wB*1);try ring.
     apply Zmult_le_compat;auto with zarith.
     assert (H6 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));
       auto with zarith.
    rewrite Zmod_small;auto with zarith.
    apply Zdiv_lt_upper_bound;auto with zarith.
    apply Zlt_le_trans with wB;auto with zarith.
    apply Zle_trans with (2 ^ [|w_head0 b|] * [|b|] * 2).
    rewrite <- wB_div_2; try omega.
    apply Zmult_le_compat;auto with zarith.
    pattern 2 at 1;rewrite <- Zpower_1_r.
    apply Zpower_le_monotone;split;auto with zarith.
   rewrite <- H4 in H0.
   assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith.
   assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6).
   destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n
             (w_add_mul_div (w_head0 b) w_0 (high n a)) a
             (double_0 w_0 n)) as (q,r).
   assert (U:= spec_double_digits n).
   rewrite spec_double_0 in H7;trivial;rewrite Zdiv_0_l in H7.
   rewrite Zplus_0_r in H7.
   rewrite spec_add_mul_div in H7;auto with zarith.
   rewrite spec_0 in H7;rewrite Zmult_0_l in H7;rewrite Zplus_0_l in H7.
   assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB
     = [!n|a!] / 2^(Zpos (double_digits w_digits n) - [|w_head0 b|])).
   rewrite Zmod_small;auto with zarith.
   rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith.
   rewrite <- Zpower_exp;auto with zarith.
   replace (Zpos (double_digits w_digits n) - Zpos w_digits +
                       (Zpos w_digits - [|w_head0 b|]))
    with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring.
   assert (H8 := Zpower_gt_0 2  (Zpos w_digits - [|w_head0 b|]));auto with zarith.
   split;auto with zarith.
   apply Zle_lt_trans with ([|high n a|]);auto with zarith.
   apply Zdiv_le_upper_bound;auto with zarith.
   pattern ([|high n a|]) at 1;rewrite <- Zmult_1_r.
   apply Zmult_le_compat;auto with zarith.
   rewrite H8 in H7;unfold double_wB,base in H7.
   rewrite <- shift_unshift_mod in H7;auto with zarith.
   rewrite H4 in H7.
   assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|]
               = [|r|]/2^[|w_head0 b|]).
   rewrite spec_add_mul_div.
   rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
   replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|])
      with ([|w_head0 b|]).
   rewrite Zmod_small;auto with zarith.
   assert (H9 := spec_to_Z r).
   split;auto with zarith.
   apply Zle_lt_trans with ([|r|]);auto with zarith.
   apply Zdiv_le_upper_bound;auto with zarith.
   pattern ([|r|]) at 1;rewrite <- Zmult_1_r.
   apply Zmult_le_compat;auto with zarith.
   assert (H10 := Zpower_gt_0 2  ([|w_head0 b|]));auto with zarith.
   rewrite spec_sub.
   rewrite Zmod_small; auto with zarith.
   split; auto with zarith.
   case (spec_to_Z w_zdigits); auto with zarith.
   rewrite spec_sub.
   rewrite Zmod_small; auto with zarith.
   split; auto with zarith.
   case (spec_to_Z w_zdigits); auto with zarith.
  case H7; intros H71 H72.
   split.
   rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith.
   rewrite H71;rewrite H9.
   replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|]))
      with ([!n|q!] *[|b|] * 2^[|w_head0 b|]);
     try (ring;fail).
   rewrite Z_div_plus_l;auto with zarith.
   assert (H10 := spec_to_Z
       (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split;
    auto with zarith.
   rewrite H9.
   apply Zdiv_lt_upper_bound;auto with zarith.
   rewrite Zmult_comm;auto with zarith.
   exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a).
 Qed.

 Definition double_modn1 (n:nat) (a:word w n) (b:w) :=
  let p := w_head0 b in
  match w_compare p w_0 with
  | Gt =>
    let b2p := w_add_mul_div p b w_0 in
    let ha := high n a in
    let k := w_sub w_zdigits p in
    let lsr_n := w_add_mul_div k w_0 in
    let r0 := w_add_mul_div p w_0 ha in
    let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in
    lsr_n r
  | _ => double_modn1_0 b n w_0 a
  end.

 Lemma spec_double_modn1_aux : forall n a b,
    double_modn1 n a b = snd (double_divn1 n a b).
 Proof.
  intros n a b;unfold double_divn1,double_modn1.
  generalize (spec_compare (w_head0 b) w_0); case w_compare;
     rewrite spec_0; intros H2; auto with zarith.
  apply spec_double_modn1_0.
  apply spec_double_modn1_0.
  rewrite spec_double_modn1_p.
  destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n
            (w_add_mul_div (w_head0 b) w_0 (high n a)) a (double_0 w_0 n));simpl;trivial.
 Qed.

 Lemma spec_double_modn1 : forall n a b, 0 < [|b|] ->
  [|double_modn1 n a b|] = [!n|a!] mod [|b|].
 Proof.
  intros n a b H;assert (H1 := spec_double_divn1 n a H).
  assert (H2 := spec_double_modn1_aux n a b).
  rewrite H2;destruct (double_divn1 n a b) as (q,r).
  simpl;apply Zmod_unique with (double_to_Z w_digits w_to_Z n q);auto with zarith.
  destruct H1 as (h1,h2);rewrite h1;ring.
 Qed.

End GENDIVN1.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA        LRI-CNRS        ENS-CNRS                *)
(*              Rocquencourt         Orsay          Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.3                                 *)
(*                               May 1st 1998                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 Manna.v                                  *)
(****************************************************************************)
    (*******************************************************************)
    (* f : nat->nat is an increasing and unbounded function            *)
    (* lambo(f)(n) = inf {m:nat| f(m)>n}                               *)
    (* is computed using the following algorithm :                     *)
    (* lambo f n = if f(0) > n the 0 else limbo(1)                     *)
    (*        where limbo(i) = if f(i) > n then 0                      *)
    (*                         else let j = limbo(2i) in               *)
    (*                  if f(j+i) > n then j else j+i                  *)
    (*******************************************************************)

Require Import Relation_Definitions.

Definition one : nat := 1.

(* Addition and multiplication by 2 *)
Fixpoint add (n m : nat) {struct n} : nat :=
  match n with
  | O => m
  | S p => S (add p m)
  end.

Definition twice (n : nat) : nat := add n n.

Definition peano :
  forall P : nat -> Prop,
  P 0 -> (forall u : nat, P u -> P (S u)) -> forall n : nat, P n := nat_ind.

(* Operator for pattern-matching *)
 Definition nat_match (n : nat) (P : nat -> Prop) (h1 : P 0)
   (h2 : forall m : nat, P (S m)) : P n :=
   peano P h1 (fun (m : nat) (ind : P m) => h2 m) n.

(* Properties of addition                         *)
Theorem add_nO : forall n : nat, add n 0 = n.
intro; symmetry  in |- *; apply plus_n_O.
Qed.

Theorem add_ass : forall u v w : nat, add (add u v) w = add u (add v w).
intros.
elim u; auto.
intros; simpl in |- *.
elim H; auto.
Qed.

(* Induction de contenu positif                        *)
Definition peano_set :
  forall P : nat -> Set,
  P 0 -> (forall u : nat, P u -> P (S u)) -> forall n : nat, P n := nat_rec.

(* Absurdity *)

 Theorem abs : forall A : Prop, False -> A.
 intros; elim H; auto.
 Qed.

(* An axiomatized order relation on natural numbers *)

 Parameter inf : nat -> nat -> Prop.

 Axiom tran_inf : transitive nat inf.
 Axiom infOO : inf 0 0.
 Axiom infS_inf : forall n m : nat, inf (S n) (S m) -> inf n m.
 Axiom inf_infS : forall n m : nat, inf n m -> inf (S n) (S m).
 Axiom infS : forall n : nat, inf n (S n).
 Axiom absO : inf one 0 -> False.

 Definition sup (n m : nat) : Prop := inf (S m) n.

(* Properties of this order *)

 Lemma re_inf : forall n : nat, inf n n.
 intro; elim n.
 apply infOO.
 intros; apply inf_infS; auto.
 Qed.

 Lemma infO : forall n : nat, inf 0 n.
 intro; elim n.
 apply infOO.
 intros; apply (tran_inf 0 n0 (S n0)); auto.
 apply infS.
 Qed.

 Lemma infS_O : forall n : nat, inf (S n) 0 -> False.
 intro; elim n; intros.
 apply absO; auto.
 elim H.
 apply (tran_inf (S n0) (S (S n0)) 0); auto.
 apply infS.
 Qed.

 Lemma infSn_n : forall n : nat, inf (S n) n -> False.
 intro; elim n; intros.
 apply absO; auto.
 elim H.
 apply infS_inf; auto.
 Qed.

 Lemma inf_sup_abs : forall n m : nat, inf n m -> sup n m -> False.
 intros; apply (infSn_n n).
 apply (tran_inf (S n) (S m) n); auto.
 apply inf_infS; auto.
 Qed.

(* A lemma : (sup n m)->(sup (twice n) (S m)) *)

 Lemma inf_add : forall n m : nat, inf m (add n m).
 intros; elim n.
 apply re_inf.
 intros; apply (tran_inf m (add n0 m) (add (S n0) m)); auto.
 simpl in |- *; apply infS.
 Qed.

 Lemma sup_twice : forall n m : nat, sup n m -> sup (twice n) (S m).
 intros n m; elim n; intros.
 apply abs.
 apply (infS_O m H).
 apply (inf_infS (S m) (add n0 (S n0))).
 apply (tran_inf (S m) (S n0) (add n0 (S n0))); auto.
 apply inf_add.
 Qed.

(* Program Lambo *)

(* Hypotheses *)
Variable f : nat -> nat.

(* f is unbounded *)
Hypothesis Unbound : forall n : nat, {y : nat | sup (f y) n}.

(* f is increasing *)
Hypothesis Increas : forall n m : nat, inf n m -> inf (f n) (f m).

(* There is a procedure to decide if inf or sup hold *)

Axiom inf_sup : forall x y : nat, {inf x y} + {sup x y}.
Axiom inf_sup0 : forall x y : nat, inf x y \/ sup x y.

(* We give n : nat and try to compute lambo(n) *)
Variable n : nat.

 Definition Inf (m : nat) : Prop := inf (f m) n.
 Definition Sup (m : nat) : Prop := sup (f m) n.

(* We only use the following properties of Inf and Sup *)

 Definition bound : {y : nat | sup (f y) n} := Unbound n.

 Definition Inf_Sup (u : nat) : {Inf u} + {Sup u} := inf_sup (f u) n.

 Definition Inf_Sup_abs (u : nat) : Inf u -> Sup u -> False :=
   inf_sup_abs (f u) n.

(* F is increasing is used this way *)

 Lemma infInf : forall u v : nat, inf u v -> Inf v -> Inf u.
 intros; apply (tran_inf (f u) (f v) n); auto.
 apply Increas; auto.
 Qed.

(* Setifications *)
 Definition Small (m : nat) : Prop := forall i : nat, inf (S i) m -> Inf i.

 Lemma SmallO : Small 0.
 red in |- *; intros; apply abs; apply (infS_O i H).
 Qed.

(* The initial specification *)
 Definition Lambo : Set := {m : nat | Sup m &  Small m}.

 Fact Lem1 : forall m : nat, Inf m -> Small (S m).
 red in |- *; intros; apply (infInf i m); auto.
 apply infS_inf; auto.
 Qed.

(* Transformation of the specification *)
 Definition Lambo1 : Set := {m : nat | Inf m &  Sup (S m)} + {Sup 0}.

 Lemma Reduct1 : Lambo1 -> Lambo.
 intro h; elim h.
 intro h1; elim h1; intros m f1 f2.
 red in |- *; exists (S m); auto.
 apply Lem1; auto.
 intro; red in |- *; exists 0; auto.
 exact SmallO.
 Qed.

(* Intermediate function *)
 Definition Limbo (i : nat) : Set :=
   sup i 0 -> {m : nat | Inf m &  Sup (add i m)} + {Sup 0}.

(* (add one m)=(S m) by Beta reduction *)

 Lemma Reduct2 : Limbo one -> Lambo1.
 intro; apply H.
 apply (re_inf one).
 Qed.

(* Termination *)

(* A parametrized order *)
 Definition bd (y u v : nat) : Prop := sup u v /\ inf v y.

(* Property to be well-formed *)
 Definition wf_bd (y i : nat) : Set :=
   forall P : nat -> Set,
   (forall v : nat, (forall u : nat, bd y u v -> P u) -> P v) -> P i.

(* Some property of bd *)

 Fact Lem2 : forall y1 y2 u v : nat, bd y1 u v -> inf v y2 -> bd y2 u v.
 intros; elim H; intros.
 red in |- *; auto.
 Qed.

 Fact Lem3 : forall y u v w : nat, bd y u v -> bd y v w -> sup y w.
 intros; apply (tran_inf (S w) v y); auto.
 elim H0; auto.
 elim H; auto.
 Qed.

 Lemma Term : forall i y : nat, sup i y -> wf_bd y i.
 red in |- *; intros i y h P q.
 apply q.
 intros.
 apply except.
 apply (inf_sup_abs i y); auto.
 elim H; auto.
 Qed.

(* Proof of (wf_bd y) by induction on y *)

 Lemma cas_base : forall i : nat, sup i 0 -> wf_bd 0 i.
 red in |- *; intros i h P q.
 apply q.
 intros; apply except.
 apply (inf_sup_abs i 0); auto.
 elim H; auto.
 Qed.

 Lemma cas_ind : forall i y : nat, wf_bd y i -> wf_bd (S y) i.
 red in |- *; intros.
 apply H; intros.
 apply H0; intros.
 elim (inf_sup v y); intros.
 apply H1.
 apply (Lem2 (S y) y u v); auto.
 apply H0; intros.
 apply except.
 apply (infSn_n v).
 apply (tran_inf (S v) (S y) v); auto.
 apply (Lem3 (S y) u0 u v); auto.
 Qed.

Theorem Wf1 : forall y i : nat, sup i 0 -> wf_bd y i.
intros; elim y.
apply cas_base; auto.
intros; apply cas_ind; auto.
Qed.

(* Actually we will use a simpler induction scheme *)

 Definition Induct (y i : nat) (P : nat -> Set) : Set :=
   (forall k : nat, (inf k y -> P (twice k)) -> P k) -> P i.

(* Proof of the induction scheme *)
Theorem wf_Ind :
 forall y i : nat, sup i 0 -> forall P : nat -> Set, Induct y i P.
intros.
elim y; red in |- *; intros.
apply H0; intros.
apply except.
apply (inf_sup_abs i 0); auto.
apply H0; intros.
apply H1; intros.
elim (inf_sup k n0); intros.
apply H2; auto.
apply H1; intros.
apply except.
apply (inf_sup_abs (twice k) (S n0)); auto.
apply sup_twice; auto.
Qed.

(* Proof of the Limbo's program  *)

 Fact Lem4 : forall u v : nat, Sup u -> Inf v -> inf v u.
 intros.
 elim (inf_sup0 v u); intros.
 apply H1.
 apply abs.
 apply (Inf_Sup_abs u); auto.
 apply (infInf u v); auto.
 apply (tran_inf u (S u) v); auto.
 apply infS.
 Qed.

 Definition LimboSig (i : nat) : Set := {m : nat | Inf m &  Sup (add i m)}.

 Lemma LimboLem : forall i : nat, sup i 0 -> Inf 0 -> LimboSig i.
 intros; elim bound.
 intros.
 apply (wf_Ind x i H LimboSig); intros.
 elim (Inf_Sup (add k 0)); intros.
 elim H1; intros.
 elim (Inf_Sup (add k x0)); intros.
 red in |- *; exists (add k x0); auto.
 unfold twice in q.
 elim add_ass; auto.
 red in |- *; exists x0; auto.
 apply Lem4; auto.
 elim (add_nO k); auto.
 red in |- *; exists 0; auto.
 Qed.

 Lemma Prog : forall i : nat, Limbo i.
 red in |- *; intros.
 elim (Inf_Sup 0); intros.
 left; apply (LimboLem i H a).
 right; auto.
 Qed.

(* Final proof *)
Theorem LamboProg : Lambo.
exact (Reduct1 (Reduct2 (Prog one))).
Qed.

(* $Id$ *)