Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e165m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e129m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e166m5_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)
Require Export auth.

Definition Phi1 (n:nat) := phi0 ++ [msg (b n 3 5)].
Definition Phi2 (n n':nat):= (Phi1 n) ++ [msg (b n' 4 6)].
(** abbreviations *)

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 pvchecks x := ((pi2 (d 1 x)) #? TWO) & ((pi2 (d 2 x)) #? TWO) & ((pi2 (d 3 x)) #? TWO).
Definition pochecks x := ((tau 3 (d 1 x)) #? THREE) & ((tau 3 (d 2 x)) #? THREE) & ((tau 3 (d 3 x)) #? THREE).

Definition dist x := !((d 1 x) #? (d 2 x)) & !((d 1 x) #? (d 3 x))& ! ((d 2 x) #? (d 3 x)).
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 ((tau 1 (pi2 (tau 1 y))), ((tau 1 (pi2 (tau 2 y))), (tau 1 (pi2 (tau 3 y)))))).
Definition ncheck (x y:message):Bool := (isin x ((tau 3 (pi2 (tau 1 y))), ((tau 3 (pi2 (tau 2 y))), (tau 3 (pi2 (tau 3 y)))))).

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

Definition bnlcheck( x y z:message):Bool:= (bcheck x z) & (|(label x z)| #? lbl) & (ncheck y z).

Definition mvchecks x (n n':nat) := (dist (x n n')) & (pvchecks (x n n')).

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

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

Theorem lemma14:  forall (t t0 t1 : message),   let v0 := (V0 (nonce 0)) in
                                                                                let v1 := (V1 (nonce 0)) in
                                                                                (|v0|#?|v1|) ## TRue ->  (Fresh [1; 2; 3; 4] ([msg t, msg v0, msg v1, msg t0, msg t1])  = true) ->  closMylist ([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 1) in
                 let r1 := (r 2) in
                 let k0 := (kc (nonce 3)) in
                 let k1 := (kc (nonce 4)) 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 e00 := (enc (c00, ((ub c00 t r0 t2), (nonce 0))) (pke 11) (er 7)) in
                 let e11 := (enc (c11, ((ub c11 t r1 t3), (nonce 1))) (pke 11) (er 8)) in
                 let e10 := (enc (c10, ((ub c10 t r0 t4), (nonce 0))) (pke 11) (er 7)) in
                 let e01 := (enc (c01, ((ub c01 t r1 t5), (nonce 1))) (pke 11) (er 8)) in
                 let mvtrm0 n n' x := let y := f (toListm ((Phi2 n n') ++ [msg e00, msg e11])) in (If (dist y) & (pvchecks y) then x else |_) in
                 let mvtrm1 n n' x := let y := f (toListm ((Phi2 n n') ++ [msg e10, msg e01])) in (If (dist y) & (pvchecks y) then x else |_) in
                 let f3ph30 n n' x := f (toListm ((Phi2 n n') ++ [msg e00, msg e11, msg (mvtrm0 n n' x)])) in
                 let f3ph31 n n' x := f (toListm ((Phi2 n n') ++ [msg e10, msg e01, msg (mvtrm1 n n' x)])) in
                 let l00 n n' x := (If (bnlcheck c00 (nonce 0) (f3ph30 n n' x)) then (enc ((label c00 (f3ph30 n n' x)), (k0, THREE))(pke 11) (er 9)) else O) in
                 let l11 n n' x := (If (bnlcheck c11 (nonce 1) (f3ph30 n n' x)) then (enc ((label c11 (f3ph30 n n' x)), (k1, THREE))(pke 11) (er 10)) else O) in
                 let l10 n n' x := (If (bnlcheck c10 (nonce 0) (f3ph31 n n' x)) then (enc ((label c10 (f3ph31 n n' x)), (k0, THREE))(pke 11) (er 9)) else O) in
                 let l01 n n' x := (If (bnlcheck c01 (nonce 1) (f3ph31 n n' x)) then (enc ((label c01 (f3ph31 n n' x)), (k1, THREE))(pke 11) (er 10)) else O) in
                 let f5ph50 n n' x := f (toListm ((Phi2 n n') ++ [msg e00, msg e11, msg (mvtrm0 n n' x), msg (l00 n n' x), msg (l11 n n' x)])) in
                 let f5ph51 n n' x := f (toListm ((Phi2 n n') ++ [msg e10, msg e01, msg (mvtrm1 n n' x), msg (l10 n n' x), msg (l01 n n' x)])) in
                 let motrm0 n n' x := let z := (f5ph50 n n' x) in
                                      let Isin0 := (isin k0 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      let Isin1 := (isin k1 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      (If (dist z) & (pochecks z)& ((Isin0&Isin1) or (! (Isin0 or Isin1))) then (sotrm z) else O) in
                 let motrm1 n n' x := let z := (f5ph51 n n' x) in
                                      let Isin0 := (isin k0 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      let Isin1 := (isin k1 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      (If (dist z) & (pochecks z)& ((Isin0&Isin1) or (! (Isin0 or Isin1))) then (sotrm z) else O) in
                 let pv00 := (c00, ((ub c00 t r0 t2), (nonce 0))) in
                 let pv10 := (c10, ((ub c10 t r0 t4), (nonce 0))) in
                 let s0 n n' := let y := f (toListm ((Phi2 n n') ++ [msg e00, msg e11])) in  (If !(isin pv00 ((pi1 (d 1 y)), ((pi1 (d 2 y)), (pi1 (d 3 y))))) then (shufl (pi1 (d 1 y)) (pi1 (d 2 y)) (pi1 (d 3 y))) else O) in
                 let s1 n n' := let y := f (toListm ((Phi2 n n') ++ [msg e10, msg e01])) in  (If !(isin pv10 ((pi1 (d 1 y)), ((pi1 (d 2 y)), (pi1 (d 3 y))))) then (shufl (pi1 (d 1 y)) (pi1 (d 2 y)) (pi1 (d 3 y))) else O) in
                 let lt1 n n' x := (e00, (e11, (mvtrm0 n n' x))) in
                 let lt2 n n' x := ((l00 n n' x), ((l11 n n' x), (motrm0 n n' x))) in
                 let rt1 n n' x := (e10, (e01, (mvtrm1 n n' x))) in
                 let rt2 n n' x := ((l10 n n' x), ((l01 n n' x), (motrm1 n n' x))) in
                 [ msg (bl c00 t r0), msg (bl c11 t r1), msg (If (acc c00 t r0 t2)& (acc c11 t r1 t3) then ((lt1 0 1 (s0 0 1)), (lt2 0 1 (s0 0 1))) else |_)] ~ [msg (bl c10 t r0), msg (bl c01 t r1), msg (If  (acc c10 t r0 t4)& (acc c01 t r1 t5) then ((rt1 1 0 (s1 1 0)), (rt2 1 0 (s1 1 0))) else |_)].

Proof.
intros.
unfold lt1, rt1.
unfold mvtrm0, mvtrm1.
simpl.
unfold lt2, rt2, l00, l11, l10, l01.
unfold f3ph30.
unfold mvtrm0. unfold motrm0. unfold f5ph50.
unfold l00.
pose proof(ENCCCA2). unfold e00.
pose proof(ENCCCA2 O O (c00, (ub c00 t r0 t2, nonce 0)) (c00, (ub c00 t r0 t2, nonce 100)) O 0 11 7 7

                  (   let s0x n n':= (If ! (isin pv00
                                (pi1 (d 1 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))),
                                (pi1 (d 2 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))),
                                pi1 (d 3 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))))))
                           then shufl
                                  (pi1 (d 1 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))))
                                  (pi1 (d 2 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))))
                                  (pi1 (d 3 (f (toListm (Phi2 n n' ++ [msg (Mvar 0), msg e11])))))
                else O) in
 let mvtrm0x n n' x := let y := f (toListm ((Phi2 n n') ++ [msg (Mvar 0), msg e11])) in (If (dist y) & (pvchecks y) then x else |_) in
let f3ph30x n n' x := (f
                       (toListm
                          (Phi2 0 1 ++
                           [msg (Mvar 0), msg e11, msg (mvtrm0x n n' x)]))) in

 let l00x n n' x := (If (bnlcheck c00 (nonce 0) (f3ph30x n n' x)) then (enc ((label c00 (f3ph30x n n' x)), (k0, THREE))(pke 11) (er 9)) else O) in
 let l11x n n' x := (If (bnlcheck c11 (nonce 1) (f3ph30x n n' x)) then (enc ((label c11 (f3ph30x n n' x)), (k1, THREE))(pke 11) (er 10)) else O) in
 let f5ph50x n n' x := f (toListm ((Phi2 n n') ++ [msg (Mvar 0), msg e11, msg (mvtrm0x n n' x), msg (l00x n n' x), msg (l11x n n' x)])) in
     let motrm0x n n' x := let z := (f5ph50x n n' x) in
                                      let Isin0 := (isin k0 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      let Isin1 := (isin k1 ((tau 2 (d 1 z)), ((tau 2 (d 2 z)), (tau 2 (d 3 z))))) in
                                      (If (dist z) & (pochecks z)& ((Isin0&Isin1) or (! (Isin0 or Isin1))) then (sotrm z) else O) in

     [msg (bl c00 t r0), msg (bl c11 t r1),
   msg
     (If (acc c00 t r0 t2) & (acc c11 t r1 t3)
         then (((Mvar 0),
              (e11, (mvtrm0x 0 1 (s0x 0 1)))),
              (If bnlcheck c00 (nonce 0) (f3ph30x 0 1 (s0x 0 1))
                  then (enc (label c00 (f3ph30x 0 1 (s0x 0 1)), (k0, THREE)) (pke 11) (er 9))
                  else O,
              (If bnlcheck c11 (nonce 1) (f3ph30x 0 1 (s0x 0 1))
                  then (enc (label c11 (f3ph30x 0 1 (s0x 0 1)), (k1, THREE)) (pke 11) (er 10))
                  else O, motrm0x 0 1 (s0x 0 1))))
         else |_)])).
simpl in H6.
Definition s0x := (If ! (isin pv00
                                (pi1 (d 1 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))),
                                (pi1 (d 2 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))),
                                pi1 (d 3 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))))))
                           then shufl
                                  (pi1 (d 1 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))))
                                  (pi1 (d 2 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))))
                                  (pi1 (d 3 (f (toListm (Phi2 0 1 ++ [msg (Mvar 0), msg e11])))))
                           else O).
unfold
unfold f3ph30.
unfold mvtrm0.
unfold s0.

(** STEP:1 *)
Definition vcheck (v:message) :=  (v #? C1) or (v#?C2) or (v#?C3).
Definition x1:= f (toListm phi0).
Definition pk:= (pubkey x1).
Axiom vote_len_reg : forall t, (|V0 t| #? |V1 t|) ## TRue.
(** * Phase 1:Authentication *)
(** nA = 0, nB = 1, nM = 2 *)
(*Eval compute in ssk. *)
Definition v (n:nat) := match n with
                        | 0 => V0 (x1)
                        | 1 => V1 (x1)
                        | _ => O
                        end.

(*Eval compute in kc. *)

Definition ssk (n:nat) := pi2 (ks (nonce n)).
Definition k0 := (kc (nonce 3)) .
Definition k1 := (kc (nonce 4)).
Definition rb0 := (rb (nonce 5)).
Definition rb1 := (rb (nonce 6)).
Definition ssk0 := (ssk 0).
Definition ssk1 := (ssk 1).
Definition rs0 := (rs (nonce 9)).
Definition rs1 := (rs (nonce 10)).

Definition c (n k: nat) := (comm (v n) (kc (nonce k))).
Definition b (n k r : nat) := (bl (c n k) pk (rb (nonce r))).
Definition s (n k r n' r' : nat) := (sign (b n k r) (ssk n') (rs (nonce r'))).
Definition tr (a n k r r':nat) := ( (vk a), ((b n k r), (s n k r a r'))).

Definition theta (x a: message) :=  ((to x) #? a) & (vcheck (v 0))&(vcheck (v  1)).

Definition t1 (n n':nat)  := If (theta x1 A) then (tr 0 n 3 5 9) else (If (theta x1 B) then (tr 1 n' 4 6 10) else O).

Definition phi1 (n n':nat) := phi0 ++ [msg (t1 n n')].

(** Indistinguishability proof of frame phi1 *)

(** Actually, we dont need this lengthy proof as we can always prove the indistinguishability of longer frames and use [RESTR] to get the indistinguishability of the smaller ones *)
(*
Theorem frame1_ind : (phi1 0 1) ~ (phi1 1 0).
Proof. intros.
unfold phi1.
simpl. unfold t1. simpl.
 simpl. apply IFBRANCH_M1 with (ml1:= phi0) (ml2:= phi0).
simpl. repeat unfold theta, tr, s, b, c.
simpl.

pose proof (let x1:= f (toListm phi0) in
            let v0 := V0(x1) in
            let v1 := V1(x1) in
            let k0 := (kc (nonce 3)) in
            let k1 := (kc (nonce 4)) in
            let rb0 := (rb (nonce 5)) in
            let rb1 := (rb (nonce 6)) in
            let rs0 := (rs (nonce 7)) in
            let rs1 := (rs (nonce 8)) in
            let ssk0 := pi2 (ks (nonce 9)) in
            let ssk1 := pi2 (ks (nonce 10)) in
            compHid 3 4 O (V0(f (toListm phi0)))  (V1(f (toListm phi0))) (phi0++[msg x1, bol ((to x1) #? A) & (vcheck v0)&(vcheck v1),  msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1])).
simpl in H.
assert ( (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. simpl in H0.
repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.
funappf1 pi1 21 H.
funappf1 pi2 22 H.
repeat rewrite proj1, proj2 in H.
funappf1 pubkey 15 H.
fold x1.
funapptrmhyp (msg (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))) (msg (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))) H;simpl; try reflexivity.

funapptrmhyp (msg (sign (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))
       (pi2 (ks (nonce 9))) (rs (nonce 7)))) (msg (sign (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5))) (pi2 (ks (nonce 9))) (rs (nonce 7)))) H;simpl; try reflexivity.
funapptrmhyp (msg (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)),
     sign (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))
       (pi2 (ks (nonce 9))) (rs (nonce 7)))) (msg (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)),
    sign (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))
      (pi2 (ks (nonce 9))) (rs (nonce 7)))) H; simpl; try reflexivity.
funapptrmhyp (msg (vk 0,
     (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)),
     sign (bl (comm (V0 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))
       (pi2 (ks (nonce 9))) (rs (nonce 7))))) (msg (vk 0,
    (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)),
    sign (bl (comm (V1 x1) (kc (nonce 3))) (pubkey x1) (rb (nonce 5)))
      (pi2 (ks (nonce 9))) (rs (nonce 7))))) H; simpl; try reflexivity.

restrsublis H.  auto. simpl; try reflexivity.  simpl. reflexivity. try split.
reflexivity. split. reflexivity. reflexivity.
(** branch 2 *)

simpl.
repeat unfold theta, tr, s, b, c.
apply IFBRANCH_M1 with (ml1:= [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 ((to x1) #? A) & (vcheck (v 0)) & (vcheck (v 1))]) (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),
   bol ((to x1) #? A) & (vcheck (v 0)) & (vcheck (v 1))]). simpl.

pose proof (let x1:= f (toListm phi0) in
            let v0 := V0(x1) in
            let v1 := V1(x1) in
            let k0 := (kc (nonce 3)) in
            let k1 := (kc (nonce 4)) in
            let rb0 := (rb (nonce 5)) in
            let rb1 := (rb (nonce 6)) in
            let rs0 := (rs (nonce 7)) in
            let rs1 := (rs (nonce 8)) in
            let ssk0 := pi2 (ks (nonce 9)) in
            let ssk1 := pi2 (ks (nonce 10)) in
            compHid 3 4 O (V0(f (toListm phi0)))  (V1(f (toListm phi0))) (phi0++[msg x1,bol ((to x1) #? A) & (vcheck (V1 x1)) & (vcheck (V0 x1)),
   bol ((to x1) #? B) & (vcheck (V1 x1)) & (vcheck (V0 x1)),msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1])).
simpl in H.
assert ( let x1:= f (toListm phi0) in (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.

 funappf1 pi1 22 H.
funappf1 pi2 23 H.
repeat rewrite proj1, proj2 in H.
 funapptrmhyp (msg (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))) (msg (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))) H;simpl; try reflexivity.

funapptrmhyp (msg (sign (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))
       (pi2 (ks (nonce 10))) (rs (nonce 8)))) (msg (sign (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6))) (pi2 (ks (nonce 10))) (rs (nonce 8)))) H;simpl; try reflexivity.
funapptrmhyp (msg (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)),
     sign (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))
       (pi2 (ks (nonce 10))) (rs (nonce 8)))) (msg (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)),
    sign (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))
      (pi2 (ks (nonce 10))) (rs (nonce 8)))) H; simpl; try reflexivity.
funapptrmhyp (msg (vk 1,
     (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)),
     sign (bl (comm (V1 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))
       (pi2 (ks (nonce 10))) (rs (nonce 8))))) (msg (vk 1,
    (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)),
    sign (bl (comm (V0 x1) (kc (nonce 4))) (pubkey x1) (rb (nonce 6)))
      (pi2 (ks (nonce 10))) (rs (nonce 8))))) H; simpl; try reflexivity.

 restrsublis H; try assumption;  simpl; try reflexivity. repeat (simpl; try split; try reflexivity).  reflexivity.
Qed.

*)

(** STEP: 2 *)

Definition x2t (n:nat) := f (toListm (phi0 ++ [msg (tr 0 n 3  5 9)])).

(*Eval compute in x2t 0. *)
Definition x2ft (n':nat) := f (toListm (phi0 ++ [msg (tr 1 n' 4 6 10)])).

Definition t2 (n n': nat) := If (theta x1 A) then (If (theta (x2t n) B) then (tr 1 n' 4 6 10) else O) else (If (theta x1 B) then (If (theta (x2ft n') A) then (tr 0 n 3 5 9) else O) else O).

Definition phi2 (n n':nat) := (phi1 n n') ++ [msg (t2 n n') ].
Print IFEVAL_B'.
Axiom ext_ifeval: forall b1 b2 b3 x y, (IF b1 & (!b2)&(!b3) then x else y) ## (IF b1 & (!b2)&(!b3) then (subbol_bol' b1 TRue (subbol_bol' b2 FAlse (subbol_bol' b3 FAlse x))) else  (subbol_bol' b1 FAlse (subbol_bol' b2 TRue (subbol_bol' b3 TRue y)))).
Axiom eqbrmsg_msg'' :forall ( m m1 m2:message) (b1 b2: Bool) ,  (IF (m1 #? m2) then (submsg_bol' m m1 b1) else b2) ##  (IF (eqm m1 m2) then (submsg_bol' m m2 b1) else b2).

Ltac aply_eqbr :=
match goal with
| [|-  context [IF (?X #? ?Y) then ?B1 else ?B2] ] => pose proof (eqbrmsg_msg'' X X Y B1 B2)
end.
(** Using ext_comp_hid **)
(*Eval compute in (v 0). *)
Theorem vote_len_eql: (IF (vcheck (v 0)) & (vcheck (v 1)) then |(v 0)|#? |(v 1)| else TRue) ## TRue.
Proof. unfold vcheck.

       rewrite <- IFSAME_B with (b:= ((v 0) #? C1)).
rewrite IFEVAL_B'.
simpl.
repeat redg.
aply_eqbr.
simpl in H.
rewrite H.
clear H.
rewrite <- IFSAME_B with (b:= ((v 1) #? C1)).
rewrite IFEVAL_B'.
simpl.
repeat redg.
aply_eqbr.
simpl in H.
repeat red_in H.
rewrite eqmeql in H. repeat red_in H.
rewrite H; clear H.
rewrite <- IFSAME_B with (b:= ((v 0) #? C2)).
rewrite IFEVAL_B' ; repeat redg.
simpl.
repeat redg.
aply_eqbr.
simpl in H.
pose proof(candEql1).
Axiom Example14_M': forall m1 m2, (m1 #? m2) ## (m2 #? m1).

rewrite Example14_M' in H0.
rewrite H0 in H.
repeat red_in H. rewrite H.
rewrite <- IFSAME_B with (b:= ((v 1) #? C2)).
rewrite IFEVAL_B'.
simpl.
repeat redg.
aply_eqbr.
simpl in H1.
repeat rewrite eqmeql in H1.
repeat red_in H1.
rewrite Example14_M' in H0.
rewrite H0 in H1; repeat red_in H1.
rewrite H1. clear H1. clear H.
rewrite <- IFSAME_B with (b:= ((v 0) #? C3)).
rewrite IFEVAL_B'.
simpl.
repeat redg.
aply_eqbr.
simpl in H.
repeat red_in H.
pose proof (candEql2).
pose proof (candEql3).
rewrite Example14_M' in H1.

repeat rewrite H1 in H.
rewrite Example14_M' in H2.
rewrite H2 in H. repeat red_in H.
rewrite H.
clear H.
rewrite <- IFSAME_B with (b:= ((v 1) #? C3)).
rewrite IFEVAL_B'.
simpl.
repeat redg.
aply_eqbr.
simpl in H.
rewrite Example14_M' in H2.
repeat rewrite H2 in H.
rewrite Example14_M' in H0.
repeat rewrite H0 in H.
rewrite Example14_M' in H1.
repeat rewrite H1 in H.
repeat rewrite eqmeql in H.
repeat red_in H. rewrite H.
reflexivity.
Qed.
(** Go back apply ext_comphid in this way in prop1 and voting_prop*)
Axiom compHid_ext': forall (n2 n3 n4 n5:nat) (t2 t3 : message) {n} {m} (z: mylist n) (l:mylist m), closMylist [msg t2, msg t3] = true /\ closMylist z = true /\ Fresh [n2; n3] (z++[msg t2, msg t3]) = true  ->
                                                                                ((length (distMvars l))=? 2)%nat = true ->
                                                                                let mvl:= [n4; n5] in ((distMvars l) = mvl \/ (distMvars l) = [n5; n4])  ->

                                                                                let m0 := (comm t2 (k n2)) in
                                                                                let m1 := (comm t3 (k n3)) in
                                                                                let m0':= (comm t3 (k n2)) in
                                                                                let m1':= (comm t2 (k n3)) in

(z ++ ([n4 <- (If |t2|#?|t3| then m0 else O)]([n5 <- (If |t2|#?|t3| then m1 else O)]l))) ~ (z ++ ([n4 <- (If |t2|#?|t3| then m0' else O)]([n5 <- (If |t2|#?|t3| then m1' else O)]l))).

Axiom ifmr_gen1_msg: forall f b t1 t2, (f (If b then t1 else t2)) # (If b then (f t1) else (f t2)).
Axiom ifmr_gen21_msg: forall (f:message->message->message) t b t1 t2, (f (If b then t1 else t2) t) # (If b then (f t1 t) else (f t2 t)).
Axiom ifmr_gen22_msg: forall (f:message->message->message) t b t1 t2, (f t (If b then t1 else t2)) # (If b then (f t t1) else (f t t2)).
Axiom ifmr_gen31_msg: forall (f:message->message->message->message) s t b t1 t2, (f (If b then t1 else t2) s t) # (If b then (f t1 s t) else (f t2 s t)).
Axiom ifmr_gen32_msg: forall (f:message->message->message->message) s t b t1 t2, (f s  (If b then t1 else t2) t) # (If b then (f s t1 t) else (f s t2 t)).
Axiom ifmr_gen33_msg: forall (f:message->message->message->message) s t b t1 t2, (f s t (If b then t1 else t2)) # (If b then (f s t t1) else (f s t t2)).
Axiom ifmr_gen33b_msg: forall (f:Bool->message->message->message) s t b t1 t2, (f s t (If b then t1 else t2)) # (If b then (f s t t1) else (f s t t2)).
Axiom ifmr_gen31b_msg: forall (f:Bool->message->message->message) s t b t1 t2, (f (IF b then t1 else t2) s t) # (If b then (f t1 s t) else (f t2 s t)).
Axiom ifmr_gen32b_msg: forall (f:Bool->message->message->message) s t b t1 t2, (f s  (If b then t1 else t2) t) # (If b then (f s t1 t) else (f s t2 t)).

Axiom ifmr_gen1_bol: forall f b t1 t2, (f (IF b then t1 else t2)) ## (IF b then (f t1) else (f t2)).
Axiom ifmr_gen21_bol: forall (f:Bool-> Bool->Bool) t b t1 t2, (f t (IF b then t1 else t2)) ## (IF b then (f t t1) else (f t t2)).
Axiom ifmr_gen22_bol: forall (f:Bool->Bool->Bool) t b t1 t2, (f (IF b then t1 else t2) t) ## (IF b then (f t1 t) else (f t2 t)).
Axiom ifmr_gen21m_bol: forall (f:message->message->Bool) t b t1 t2, (f t (If b then t1 else t2)) ## (IF b then (f t t1) else (f t t2)).
Axiom ifmr_gen22m_bol: forall (f:message->message->Bool) t b t1 t2, (f (If b then t1 else t2) t) ## (IF b then (f t1 t) else (f t2 t)).

Axiom ifmr_gen31_bol: forall (f:Bool->Bool->Bool->Bool) s t b t1 t2, (f (IF b then t1 else t2) s t) ## (IF b then (f t1 s t) else (f t2 s t)).
Axiom ifmr_gen32_bol: forall (f:Bool->Bool->Bool->Bool) s t b t1 t2, (f s  (IF b then t1 else t2) t) ## (IF b then (f s t1 t) else (f s t2 t)).
Axiom ifmr_gen33_bol: forall (f:Bool->Bool->Bool->Bool) s t b t1 t2, (f s t (IF b then t1 else t2)) ## (IF b then (f s t t1) else (f s t t2)).

  Theorem frame2_ind: (|v 0| #? |v 1|) ## TRue -> (phi2 0 1) ~ (phi2 1 0).
Proof. intros. unfold phi2, phi1. unfold t1, t2. simpl.
       unfold x2t, x2ft, tr, theta. repeat unfold b, s.
       unfold andB.
       pose proof(compHid_ext).
pose proof(compHid_ext 3 4 0 1 (v 0) (v 1) [] (phi0++
[msg
     (If IF (to x1) #? A then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
         then (vk 0, (bl (Mvar 0) pk (rb (nonce 5)), sign (bl (Mvar 0) pk (rb (nonce 5))) (ssk 0) (rs (nonce 9))))
         else If IF (to x1) #? B then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
                 then (vk 1, (bl (Mvar 1) pk (rb (nonce 6)), sign (bl (Mvar 1) pk (rb (nonce 6))) (ssk 1) (rs (nonce 10))))
                 else O),
   msg
     (If IF (to x1) #? A then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
         then If IF (to
                       (f
                          (toListm
                             (phi0 ++
                              [msg (vk 0, (bl (Mvar 0) pk (rb (nonce 5)), sign (bl (Mvar 0) pk (rb (nonce 5))) (ssk 0) (rs (nonce 9))))])))) #?
                    B then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
                 then (vk 1, (bl (Mvar 1) pk (rb (nonce 6)), sign (bl (Mvar 1) pk (rb (nonce 6))) (ssk 1) (rs (nonce 10))))
                 else O
         else If IF (to x1) #? B then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
                 then If IF (to
                               (f
                                  (toListm
                                     (phi0 ++
                                      [msg
                                         (vk 1, (bl (Mvar 1) pk (rb (nonce 6)), sign (bl (Mvar 1) pk (rb (nonce 6))) (ssk 1) (rs (nonce 10))))]))))
                            #? A then IF vcheck (v 0) then vcheck (v 1) else FAlse else FAlse
                         then (vk 0, (bl (Mvar 0) pk (rb (nonce 5)), sign (bl (Mvar 0) pk (rb (nonce 5))) (ssk 0) (rs (nonce 9))))
                         else O
                 else O)])).
simpl in H1.
apply H1.
repeat (try split; auto).
reflexivity. unfold distMvars.
simpl; right. trivial.

Qed.
(** Using FUNCApp and Comphid **)
(*
Theorem frame2_ind: (phi2 0 1) ~ (phi2 1 0).
Proof. repeat unfold phi2, phi1, theta, tr, s, b, c, t1, t2. simpl.
apply IFBRANCH_M2 with (ml1:= phi0) (ml2:=phi0). simpl.

apply IFBRANCH_M1 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)]).
repeat unfold phi2, phi1, theta, tr, s, b, c, t1, t2. simpl.
pose proof (compHid 3 4 O (V0 x1) (V1 x1) (phi0++[msg x1,  bol (vcheck (v 0)), bol (vcheck (v 1)), bol ((to x1) #? A) & (vcheck (v 0))&(vcheck (v 1)),  msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1, bol FAlse, bol TRue])).
simpl in H.
assert ( (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. simpl in H0.
repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.
funappf1 pi1 25 H.
funappf1 pi2 26 H.
repeat rewrite proj1, proj2 in H.
funappf1 pubkey 15 H.
clear H0.
(** construct bool condition *)
 unfold rb0, rb1, rs0, rs1, ssk0, ssk1 in H.
 funapptrmhyp (msg (b 0 3 5)) (msg (b 1 3 5)) H; simpl; try reflexivity.

funapptrmhyp (msg (s 0 3 5 0 9)) (msg (s 1 3 5 0 9)) H; simpl; try reflexivity.
funapptrmhyp (msg (tr 0 0 3 5 9)) (msg (tr 0 1 3 5 9)) H; simpl; try reflexivity.
funapptrmhyp (msg (x2t 0)) (msg (x2t 1)) H; simpl; try reflexivity.
funapptrmhyp (msg (to (x2t 0))) (msg (to (x2t 1))) H; simpl; try reflexivity.
funapptrmhyp  (bol ((to (x2t 0)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) ( bol ((to (x2t 1)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) H; simpl; try reflexivity.
funapptrmhyp (msg (bl (comm (V1 x1) (kc (nonce 4))) pk (rb (nonce 6)))) (msg (bl (comm (V0 x1) (kc (nonce 4))) pk (rb (nonce 6)))) H; simpl; try reflexivity.
funapptrmhyp (msg (s 1 4 6 1 10)) (msg (s 0 4 6 1 10)) H; simpl; try reflexivity.

funapptrmhyp (msg (tr 1 1 4 6 10)) (msg (tr 1 0 4 6 10)) H; simpl; try reflexivity.

(** reduce the goal *)
restrsublis H. auto.
repeat (simpl; try reflexivity).
simpl.
reflexivity.
repeat ( simpl; try split; try reflexivity).

(** goal-2 *)

pose proof (compHid 3 4 O (V0 x1) (V1 x1) (phi0++[msg x1,  bol (vcheck (v 0)), bol (vcheck (v 1)), bol ((to x1) #? A) & (vcheck (v 0))&(vcheck (v 1)),  msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1, bol FAlse, bol TRue])).
simpl in H.
assert ( (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. simpl in H0.
repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.
funappf1 pi1 25 H.
funappf1 pi2 26 H.
repeat rewrite proj1, proj2 in H.
funappf1 pubkey 15 H.
clear H0.

(** construct bool condition *)
funapptrmhyp (msg (b 0 3 5)) (msg (b 1 3 5)) H; simpl; try reflexivity.
funapptrmhyp (msg (s 0 3 5 0 9)) (msg (s 1 3 5 0 9)) H; simpl; try reflexivity.
funapptrmhyp (msg (tr 0 0 3 5 9)) (msg (tr 0 1 3 5 9)) H; simpl; try reflexivity.
funapptrmhyp (msg (x2t 0)) (msg (x2t 1)) H; simpl; try reflexivity.
funapptrmhyp (msg (to (x2t 0))) (msg (to (x2t 1))) H; simpl; try reflexivity.
funapptrmhyp  (bol ((to (x2t 0)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) ( bol ((to (x2t 1)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) H; simpl; try reflexivity.  repeat unfold rb0, rb1, rs0, rs1, ssk0, ssk1 in H.
repeat unfold tr.
(** reduce the goal *)
restrsublis H. auto.
repeat (simpl; try reflexivity).
simpl.
reflexivity.
repeat ( simpl; try split; try reflexivity).
simpl.

(** goal 3 *)

apply IFBRANCH_M2 with (ml1:= phi0 ++[ bol ((to x1) #? A) & (vcheck (V0 x1)) & (vcheck (V1 x1))] )  (ml2:=phi0 ++ [ bol ((to x1) #? A) & (vcheck (V0 x1)) & (vcheck (V1 x1))]). simpl.

apply IFBRANCH_M1 with (ml1:= phi0 ++ [bol (theta x1 A), bol (theta x1 B), msg (tr 1 1 4 6 10)]) (ml2:= phi0 ++ [bol (theta x1 A), bol (theta x1 B), msg (tr 1 0 4 6 10)]).

repeat unfold phi2, phi1, theta, tr, s, b, c, t1, t2. simpl.
pose proof (compHid 4 3 O (V1 x1) (V0 x1) (phi0++[msg x1,  bol (vcheck (v 0)), bol (vcheck (v 1)),  bol ((to x1) #? A), bol ((to x1) #? B), msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1, bol FAlse, bol TRue])).
simpl in H.
Axiom eqm_refl: forall m1 m2, (m1 #? m2) ## TRue -> (m2 #? m1) ## TRue.
assert ( (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. simpl in H.
apply eqm_refl in H0.
repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.
funappf1 pi1 26 H.
funappf1 pi2 27 H.
repeat rewrite proj1, proj2 in H.
funappf1 pubkey 15 H.
clear H0.
(** construct bool condition *)
(*Eval compute in (x2ft 1). *)
funapptrmhyp (msg (b 1 4 6)) (msg (b 0 4 6)) H; simpl; try reflexivity.
funapptrmhyp (msg (s 1 4 6 1 10)) (msg (s 0 4 6 1 10)) H; simpl; try reflexivity.
funapptrmhyp (msg (tr 1 1 4 6 10)) (msg (tr 1 0 4 6 10)) H; simpl; try reflexivity.

funapptrmhyp (msg (x2ft 1)) (msg (x2ft 0)) H; simpl; try reflexivity.
funapptrmhyp (msg (to (x2ft 1))) (msg (to (x2ft 0))) H; simpl; try reflexivity.
 funapptrmhyp (bol ((to (x2ft 1)) #? B)) (bol ((to (x2ft 0)) #? B)) H; simpl; try reflexivity.
funapptrmhyp (bol (vcheck (V0 x1))& (vcheck (V1 x1))) (bol (vcheck (V0 x1))& (vcheck (V1 x1))) H; simpl; try reflexivity.
 funapptrmhyp  (bol ((to (x2ft 1)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) ( bol ((to (x2ft 0)) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) H; simpl; try reflexivity.

funapptrmhyp (bol ((to x1) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) (bol ((to x1) #? B) & (vcheck (V0 x1)) & (vcheck (V1 x1))) H; simpl; try reflexivity.

funapptrmhyp (msg (b 0 3 5)) (msg (b 1 3 5)) H; simpl; try reflexivity.
funapptrmhyp (msg (s 0 3 5 0 9)) (msg (s 1 3 5 0 9)) H; simpl; try reflexivity.
funapptrmhyp (msg (tr 0 0 3 5 9)) (msg (tr 0 1 3 5 9)) H; simpl; try reflexivity.

(** reduce the goal *)
restrsublis H. auto.
repeat (simpl; try reflexivity).
simpl.
reflexivity.
repeat ( simpl; try split; try reflexivity).
simpl.

(** goal-2 *)

pose proof (compHid 4 3 O (V1 x1) (V0 x1) (phi0++[msg x1,  bol (vcheck (v 0)), bol (vcheck (v 1)),  bol ((to x1) #? A), bol ((to x1) #? B), msg rb0, msg rb1, msg rs0, msg rs1, msg ssk0, msg ssk1, bol FAlse, bol TRue])).
simpl in H.

assert ( (| V0 x1 | #? |V1 x1|) ## TRue).
apply vote_len_reg. simpl in H0. apply eqm_refl in H0.
repeat rewrite H0 in H. repeat rewrite IFTRUE_M in H.
funappf1 pi1 26 H.
funappf1 pi2 27 H.
repeat rewrite proj1, proj2 in H.
funappf1 pubkey 15 H.
clear H0.

(** construct bool condition *)
funapptrmhyp (msg (b 1 4 6)) (msg (b 0 4 6)) H; simpl; try reflexivity.
funapptrmhyp (msg (s 1 4 6 1 10)) (msg (s 0 4 6 1 10)) H; simpl; try reflexivity.
funapptrmhyp (msg (tr 1 1 4 6 10)) (msg (tr 1 0 4 6 10))  H; simpl; try reflexivity.
funapptrmhyp (msg (x2ft 1)) (msg (x2ft 0)) H; simpl; try reflexivity.
funapptrmhyp (msg (to (x2ft 1))) (msg (to (x2ft 0))) H; simpl; try reflexivity.
funapptrmhyp  (bol ((to (x2ft 1)) #? A) & (vcheck (V0 x1)) & (vcheck (V1 x1))) ( bol ((to (x2ft 0)) #? A) & (vcheck (V0 x1)) & (vcheck (V1 x1))) H; simpl; try reflexivity.  repeat unfold rb0, rb1, rs0, rs1, ssk0, ssk1 in H.
repeat unfold tr.

(** reduce the goal *)
restrsublis H. auto.
repeat (simpl; try reflexivity).
simpl.
reflexivity.
repeat ( simpl; try split; try reflexivity).
simpl. reflexivity.
Qed. *)

Theorem frame1ind: (| V0 x1 |) #? (| V1 x1 |) ## TRue -> (phi1 0 1) ~ (phi1 1 0).
Proof. intros. unfold phi1.
simpl. pose proof (frame2_ind).
unfold phi2, phi1 in H.
simpl in H.
apply H0 in H.
dropLast_in H; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e129m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e198m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e140m27_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import HoTT.Basics HoTT.Types.Bool.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.tactics.ring_quote
  HoTT.Classes.theory.rings.

Generalizable Variables Vlt.

Import Quoting.
Local Set Universe Minimization ToSet.

Section content.
Local Existing Instance almost_ring_semiring.
Local Existing Instance almostring_mor_sr_mor.

Universe UC.
Context {C : Type@{UC} } {V : Type0 }.

Inductive Pol : Type@{UC} :=
  | Pconst (c : C)
  | PX (P : Pol) (v : V) (Q : Pol).

(* [C] is the scalar semiring: Z when working on rings,
   N on semirings, other sometimes. *)
Context `{AlmostRing C} `{DecidablePaths C}.

(* [V] is the type of variables, ie we are defining polynomials [C[V]].
   It has a computable compare so we can normalise polynomials. *)
Context `{Trichotomy@{Set Set Set} V Vlt}.

(* Polynomials are supposed (at the meta level) to be in normal form:
   PX P v Q verifies
     + P <> 0
     + forall w in P, w <= v
     + forall w in Q, w <  v *)

Fixpoint Peqb P Q : Bool :=
  match P, Q with
  | Pconst c, Pconst d => c =? d
  | PX P1 v P2, PX Q1 w Q2 =>
    andb (v =? w) (andb (Peqb P1 Q1) (Peqb P2 Q2))
  | _, _ => false
  end.

Global Instance Peqb_instance : Eqb Pol := Peqb.
Arguments Peqb_instance _ _ /.

Global Instance P0 : canonical_names.Zero Pol := Pconst 0.
Global Instance P1 : canonical_names.One Pol := Pconst 1.

Universe UR.
Context {R : Type@{UR} } `{AlmostRing R}
  (phi : C -> R) `{!AlmostRingPreserving phi}.

Notation Vars V := (V -> R).

Fixpoint eval (vs : Vars V) (P : Pol) : R :=
  match P with
  | Pconst c => phi c
  | PX P v Q =>
    (eval vs P) * (vs v) + (eval vs Q)
  end.

Lemma andb_true : forall a b : Bool, andb a b = true -> a = true /\ b = true.
Proof.
intros [|] [|];simpl;auto.
Qed.

Lemma eval_eqb' : forall P Q : Pol, P =? Q = true ->
  forall vs : Vars V, eval vs P = eval vs Q.
Proof.
induction P as [c|P1 IHP1 v P2 IHP2];destruct Q as [d|Q1 w Q2];intros E vs;
change eqb with Peqb in E;simpl in E.
- simpl. apply ap. apply decide_eqb_ok;trivial.
- destruct (false_ne_true E).
- destruct (false_ne_true E).
- apply andb_true in E. destruct E as [E1 E2].
  apply andb_true in E2. destruct E2 as [E2 E3].
  simpl.
  apply compare_eqb_eq,tricho_compare_eq in E1.
  apply ap011;auto. apply ap011;auto.
Qed.

Definition eval_eqb@{} := ltac:(first [exact eval_eqb'@{Ularge}|
                                       exact eval_eqb']).

Lemma eval_0' : forall P, P =? 0 = true -> forall vs, eval vs P = 0.
Proof.
induction P;simpl;intros E vs.
- change eqb with Peqb in E;simpl in E.
  apply decide_eqb_ok in E. rewrite E.
  apply preserves_0.
- change eqb with Peqb in E;simpl in E.
  destruct (false_ne_true E).
Qed.

Definition eval_0@{} := ltac:(first [exact eval_0'@{Ularge}|
                                     exact eval_0']).

Fixpoint addC c P :=
  match P with
  | Pconst d => Pconst (c + d)
  | PX P v Q =>
    PX P v (addC c Q)
  end.

Lemma eval_addC vs : forall c P, eval vs (addC c P) = (phi c) + eval vs P.
Proof.
induction P;simpl.
- apply preserves_plus.
- rewrite IHP2.
  rewrite 2!plus_assoc. rewrite (plus_comm (phi c)).
  reflexivity.
Qed.

(* c * v + Q *)
Fixpoint addX' c v Q :=
  match Q with
  | Pconst d => PX (Pconst c) v Q
  | PX Q1 w Q2 =>
    match v ?= w with
    | LT =>
      PX Q1 w (addX' c v Q2)
    | EQ =>
      PX (addC c Q1) v Q2
    | GT => PX (Pconst c) v Q
    end
  end.

Definition addX c v Q := if c =? 0 then Q else addX' c v Q.

Lemma eval_addX'@{} vs : forall c (v:V) Q,
  eval vs (addX' c v Q) = phi c * vs v + eval vs Q.
Proof.
induction Q as [d|Q1 IH1 w Q2 IH2].
- simpl.
  reflexivity.
- simpl.
  pose proof (tricho_compare_eq v w) as E.
  destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E].
  + simpl. rewrite IH2.
    rewrite 2!plus_assoc. apply ap011;trivial.
    apply plus_comm.
  + simpl. rewrite eval_addC.
    rewrite plus_mult_distr_r.
    symmetry;apply plus_assoc.
  + simpl. reflexivity.
Qed.

Lemma eval_addX vs : forall c (v:V) Q,
  eval vs (addX c v Q) = phi c * vs v + eval vs Q.
Proof.
intros. unfold addX.
pose proof (decide_eqb_ok c 0) as E.
destruct (c =? 0).
- rewrite (fst E) by split. rewrite (preserves_0 (f:=phi)).
  rewrite mult_0_l,plus_0_l. split.
- apply eval_addX'.
Qed.

Definition PXguard@{} P v Q := if eqb P 0 then Q else PX P v Q.

Lemma eval_PXguard vs : forall P (v:V) Q,
  eval vs (PXguard P v Q) = eval vs P * vs v + eval vs Q.
Proof.
intros. unfold PXguard.
pose proof (eval_0 P) as E.
destruct (P =? 0).
- rewrite E by split.
  rewrite mult_0_l,plus_0_l. split.
- reflexivity.
Qed.

Fixpoint mulC c P :=
  match P with
  | Pconst d => Pconst (c * d)
  | PX P v Q =>
    (* in some semirings we can have zero divisors, so P' might be zero *)
    PXguard (mulC c P) v (mulC c Q)
  end.

Lemma eval_mulC vs : forall c P, eval vs (mulC c P) = (phi c) * eval vs P.
Proof.
induction P as [d | P1 IH1 v P2 IH2];simpl.
- apply preserves_mult.
- rewrite eval_PXguard.
  rewrite IH1,IH2,plus_mult_distr_l,mult_assoc. reflexivity.
Qed.

(* if P <= v, P <> 0, and addP Q = P + Q then P * v + Q *)
Fixpoint add_aux addP P v Q :=
  match Q with
  | Pconst _ => PX P v Q
  | PX Q1 w Q2 =>
    match v ?= w with
    | LT =>
      PX Q1 w (add_aux addP P v Q2)
    | EQ => PXguard (addP Q1) v Q2
    | GT =>
      PX P v Q
    end
  end.

Fixpoint add P Q :=
  match P with
  | Pconst c => addC c Q
  | PX P1 v P2 => add_aux (add P1) P1 v (add P2 Q)
  end.

Lemma eval_add_aux vs P addP
  (Eadd : forall Q, eval vs (addP Q) = eval vs P + eval vs Q)
  : forall (v:V) Q, eval vs (add_aux addP P v Q) = eval vs P * vs v + eval vs Q.
Proof.
induction Q as [d|Q1 IH1 w Q2 IH2].
- simpl. reflexivity.
- simpl.
  pose proof (tricho_compare_eq v w) as E.
  destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E].
  + simpl.
    rewrite IH2.
    rewrite 2!plus_assoc. rewrite (plus_comm (eval vs Q1 * vs w)).
    reflexivity.
  + rewrite eval_PXguard. rewrite Eadd.
    rewrite plus_mult_distr_r.
    symmetry;apply plus_assoc.
  + simpl. reflexivity.
Qed.

Lemma eval_add' vs : forall P Q, eval vs (add P Q) = eval vs P + eval vs Q.
Proof.
induction P as [c|P1 IH1 v P2 IH2];intros Q.
- simpl. apply eval_addC.
- simpl. rewrite eval_add_aux;auto.
  rewrite IH2. apply plus_assoc.
Qed.

Definition eval_add@{} := ltac:(first [exact eval_add'@{Ularge}|
                                       exact eval_add'@{}]).

Fixpoint mulX v P :=
  match P with
  | Pconst c => addX c v 0
  | PX P1 w P2 =>
    match v ?= w with
    | LT =>
      PX (mulX v P1) w (mulX v P2)
    | _ => PX P v 0
    end
  end.

Lemma eval_mulX@{} vs : forall (v:V) (P:Pol), eval vs (mulX v P) = eval vs P * vs v.
Proof.
induction P as [c|P1 IH1 w P2 IH2].
- simpl. rewrite eval_addX.
  simpl. rewrite (preserves_0 (f:=phi)),plus_0_r.
  split.
- simpl.
  pose proof (tricho_compare_eq v w) as E.
  destruct (v ?= w);[clear E|rewrite <-E by split;clear E w|clear E].
  + simpl.
    rewrite plus_mult_distr_r,IH1,IH2.
    apply ap011;trivial.
    rewrite <-2!mult_assoc;apply ap,mult_comm.
  + simpl. rewrite (preserves_0 (f:=phi)),plus_0_r.
    reflexivity.
  + simpl. rewrite (preserves_0 (f:=phi)),plus_0_r.
    reflexivity.
Qed.

Definition mkPX P v Q := add (mulX v P) Q.

Lemma eval_mkPX vs : forall P v Q,
  eval vs (mkPX P v Q) = (eval vs P) * (vs v) + eval vs Q.
Proof.
intros. unfold mkPX.
rewrite eval_add,eval_mulX. reflexivity.
Qed.

Fixpoint mul P Q :=
  match P, Q with
  | Pconst c, _ => mulC c Q
  | _, Pconst d => mulC d P
  | PX P1 v P2, PX Q1 w Q2 =>
    (* P1 Q1 v w + P1 Q2 v + P2 Q1 w + P2 Q2 *)
    add (mulX v (add (mulX w (mul P1 Q1)) (mul P1 Q2)))
        (add (mulX w (mul P2 Q1)) (mul P2 Q2))
  end.

Lemma eval_mul' vs : forall P Q, eval vs (mul P Q) = eval vs P * eval vs Q.
Proof.
induction P as [c | P1 IHP1 v P2 IHP2];[apply eval_mulC|].
destruct Q as [d | Q1 w Q2].
- change (mul (PX P1 v P2) (Pconst d)) with (mulC d (PX P1 v P2)).
  rewrite eval_mulC. apply mult_comm.
- simpl.
  rewrite plus_mult_distr_r,!plus_mult_distr_l.
  repeat (rewrite eval_add || rewrite eval_mulX).
  rewrite plus_mult_distr_r,(plus_mult_distr_l (eval vs P2)).
  rewrite IHP1,IHP2.
  apply ap011;apply ap011.
  + rewrite <-!mult_assoc.
    apply ap.
    rewrite (mult_comm (vs v)). apply mult_assoc.
  + rewrite <-mult_assoc,(mult_comm (vs v)),mult_assoc.
    rewrite IHP1;reflexivity.
  + symmetry;apply mult_assoc.
  + auto.
Qed.

Definition eval_mul@{} := ltac:(first [exact eval_mul'@{Ularge}|exact eval_mul'@{}]).

Fixpoint toPol (e: Expr V) :=
  match e with
  | Var v => PX 1 v 0
  | Zero => 0
  | One => 1
  | Plus a b => add (toPol a) (toPol b)
  | Mult a b => mul (toPol a) (toPol b)
  | Neg a => mulC (almost_negate 1) (toPol a)
  end.

Lemma eval_toPol@{} vs : forall e : Expr V,
  eval vs (toPol e) = Quoting.eval _ vs e.
Proof.
induction e as [v| | |a IHa b IHb|a IHa b IHb|a IHa];simpl.
- rewrite (preserves_1 (f:=phi)),(preserves_0 (f:=phi)),plus_0_r,mult_1_l.
  reflexivity.
- apply preserves_0.
- apply preserves_1.
- rewrite eval_add,IHa,IHb. reflexivity.
- rewrite eval_mul,IHa,IHb. reflexivity.
- rewrite eval_mulC. rewrite (almostring_mor_neg (f:=phi)),preserves_1.
  rewrite <-almost_ring_neg_pr. apply ap,IHa.
Qed.

End content.


Require Import Setoid Morphisms RelationClasses Program.Basics Omega.
Require Import CSetoid.

Set Implicit Arguments.
Unset Strict Implicit.

Section FunEq.
  Context A `{eT: type A}.

  Global Instance FunEquiv {T} : Equiv (T -> A) := {
    equiv P Q := forall a, P a === Q a
  }.

  Global Instance FunType T : type (T -> A).
  Proof. firstorder. Qed.
End FunEq.

(* Separation algebras *)
Section SepAlgSect.
  Class SepAlgOps T `{eT : type T}:= {
    sa_unit : T;
    (* sa_mul s1 s2 s if s = s1*s2 *)
    sa_mul : T -> T -> T -> Prop
  }.

  Class SepAlg T `{SAOps: SepAlgOps T} : Type := {
    sa_mul_eqL a b c d : sa_mul a b c -> c === d -> sa_mul a b d;
    sa_mul_eqR a b c d : sa_mul a b c -> sa_mul a b d -> c === d;
    sa_mon a b c   : a === b -> sa_mul a c === sa_mul b c;
    sa_mulC a b        : sa_mul a b === sa_mul b a;
    sa_mulA a b c      : forall bc abc, sa_mul a bc abc -> sa_mul b c bc ->
                                        exists ac, sa_mul b ac abc /\ sa_mul a c ac;
    sa_unitI a         : sa_mul a sa_unit a
  }.

End SepAlgSect.

Implicit Arguments SepAlgOps [[e] [eT]].
Implicit Arguments SepAlg [[e] [eT] [SAOps]].

Section SepAlgCompat.
  Context A `{SA: SepAlg A}.

  Definition compat (a b : A) := exists s, sa_mul a b s.
  Definition subheap (a b : A) := exists c, sa_mul a c b.

  Lemma sa_mulC2 a b c : sa_mul a b c <-> sa_mul b a c.
  Proof.
    apply sa_mulC.
  Qed.

End SepAlgCompat.

Module SepAlgNotations.
Notation "a '·' b" := (sa_mul a b) (at level 50, left associativity) : sa_scope.
Notation "a '·' b |-> c" := (sa_mul a b c) (at level 52, no associativity) : sa_scope.
Notation "^" := sa_unit : sa_scope.
Notation "a # b" := (compat a b) (at level 70, no associativity) : sa_scope.
Notation "a <= b" := (subheap a b) (at level 70, no associativity) : sa_scope.
End SepAlgNotations.

Instance sa_mul_equiv_proper T `{SAP : SepAlg T} :
  Proper (equiv ==> equiv ==> equiv ==> equiv) sa_mul.
Proof.
  intros x y Heqxy t u Heqtu s v Heqsv.
  transitivity (sa_mul y t s); [apply sa_mon; assumption|].
  etransitivity; [apply sa_mulC| etransitivity; [|apply sa_mulC]].
  etransitivity; [apply sa_mon; eassumption|].
  split; intros; (eapply sa_mul_eqL; [eassumption|firstorder]).
Qed.

Import SepAlgNotations.

Delimit Scope sa_scope with sa.

Instance subheap_preo A `{sa : SepAlg A} : PreOrder (@subheap A e eT SAOps).
Proof.
  split.
  + intros s; eexists; apply sa_unitI.
  + intros s0 s1 s2 [s10 HEq1] [s21 HEq2].
    pose proof (sa_mulA).
    apply sa_mulC in HEq2.
    specialize (H _ _ _ _ _ HEq2 HEq1).
    destruct H as [s3 [HEqs2 HEqs3]].
    exists s3; assumption.
Qed.

Instance compat_symm Σ `{sa : SepAlg Σ} : Symmetric (compat (A := Σ)).
Proof.
  intros s s0 [s1 Hs]; exists s1; apply sa_mulC; assumption.
Qed.

Section Properties.
  Context Σ `{sa : SepAlg Σ}.
  Open Scope sa_scope.

  Global Instance sa_subheap_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (subheap (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; [intros [s Heqxst] | intros [s Heqysu]]; exists s.
    + rewrite <- Heqxy, <- Heqtu; assumption.
    + rewrite Heqxy, Heqtu; assumption.
  Qed.

  Global Instance sa_compat_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (compat (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; [intros [s Heqxst] | intros [s Heqysu]]; exists s.
    + rewrite <- Heqxy, <- Heqtu; assumption.
    + rewrite Heqxy, Heqtu; assumption.
  Qed.

  Lemma compat_subheap {r t : Σ} (s : Σ) (Hsr: r <= s) (Hst: s # t) : r # t.
  Proof.
    destruct Hsr as [sr Hsr]; destruct Hst as [st Hst].
    apply sa_mulC in Hst.
    apply sa_mulC in Hsr.
    pose proof sa_mulA.
    specialize (H _ _ _ _ _ Hst Hsr).
    destruct H as [u [Hst2 Hu]].
    exists u. apply sa_mulC; assumption.
  Qed.

  Close Scope sa_scope.

End Properties.

Implicit Arguments compat_subheap [[Σ] [e] [eT] [sa] [r] [t] [SAOps]].


Require Export implicativesyntax universalsyntax termsyntax.

Section form.
  Context {Sigma : Signature}.
Inductive form  : Type :=
  | In_form_implicative : ( form_implicative form  ) -> form
  | In_form_universal : ( form_universal form  ) -> form .

Lemma congr_In_form_implicative  { s0 : form_implicative form  } { t0 : form_implicative form  } (H1 : s0 = t0) : In_form_implicative  s0 = In_form_implicative  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_universal  { s0 : form_universal form  } { t0 : form_universal form  } (H1 : s0 = t0) : In_form_universal  s0 = In_form_universal  t0 .
Proof. congruence. Qed.

Global Instance retract_form_universal_form  : retract (form_universal form) form := Build_retract In_form_universal (fun x => match x with
| In_form_universal s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_universal t'  => fun H => congr_In_form_universal ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_implicative_form  : retract (form_implicative form) form := Build_retract In_form_implicative (fun x => match x with
| In_form_implicative s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_implicative t'  => fun H => congr_In_form_implicative ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Fixpoint subst_form   (sigmaterm : ( fin ) -> term ) (s : form ) : form  :=
    match s return form  with
    | In_form_implicative  s0 =>   subst_form_implicative form subst_form  _ sigmaterm s0
    | In_form_universal  s0 =>   subst_form_universal form subst_form _ sigmaterm s0
    end.

Fixpoint idSubst_form  (sigmaterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : form ) : subst_form sigmaterm s = s.
Proof. destruct s;
  [ eapply idSubst_form_implicative
  | eapply idSubst_form_universal
  ]; eauto.
Defined.

Fixpoint ext_form   (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : form ) : subst_form sigmaterm s = subst_form tauterm s.
Proof. destruct s;
  [ eapply ext_form_implicative
  | eapply ext_form_universal
  ]; eauto.
Defined.

Fixpoint compSubstSubst_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (thetaterm : ( fin ) -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form thetaterm s.
Proof. destruct s;
  [ eapply compSubstSubst_form_implicative
  | eapply compSubstSubst_form_universal
  ]; eauto.
Defined.

Lemma instId_form  : subst_form (var_term ) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_form (var_term ) (fun n => eq_refl) ((id) x))). Qed.

Lemma compComp_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_form sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) : (funcomp) (subst_form tauterm) (subst_form sigmaterm) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_form sigmaterm tauterm n)). Qed.

(*
Global Instance Subst_term   : Subst1 (( fin ) -> term ) (term ) (term ) := @subst_term   .

Global Instance Subst_form   : Subst1 (( fin ) -> term ) (form ) (form ) := @subst_form   .

Global Instance VarInstance_term  : Var (fin) (term ) := @var_term  .

Notation "x '__term'" := (var_term x) (at level 5, format "x __term") : subst_scope.

Notation "x '__term'" := (@ids (_) (_) VarInstance_term x) (at level 5, only printing, format "x __term") : subst_scope.

Notation "'var'" := (var_term) (only printing, at level 1) : subst_scope.

Class Up_term X Y := up_term : ( X ) -> Y.

Notation "↑__term" := (up_term) (only printing) : subst_scope.

Notation "↑__term" := (up_term_term) (only printing) : subst_scope.

Global Instance Up_term_term   : Up_term (_) (_) := @up_term_term   .

Notation "s [ sigmaterm ]" := (subst_term sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_term sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_universal sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_universal sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_implicative sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_implicative sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form sigmaterm) (at level 1, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_term,  Subst_form,  VarInstance_term.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_term,  Subst_form,  VarInstance_term in *.

*)

(* Ltac asimpl' := repeat first [progress rewrite ?instId_term| progress rewrite ?compComp_term| progress rewrite ?compComp'_term| progress rewrite ?instId_form_universal| progress rewrite ?compComp_form_universal| progress rewrite ?compComp'_form_universal| progress rewrite ?instId_form_implicative| progress rewrite ?compComp_form_implicative| progress rewrite ?compComp'_form_implicative| progress rewrite ?instId_form_existential| progress rewrite ?compComp_form_existential| progress rewrite ?compComp'_form_existential| progress rewrite ?instId_form_disjunctive| progress rewrite ?compComp_form_disjunctive| progress rewrite ?compComp'_form_disjunctive| progress rewrite ?instId_form_conjunctive| progress rewrite ?compComp_form_conjunctive| progress rewrite ?compComp'_form_conjunctive| progress rewrite ?instId_form_atomic| progress rewrite ?compComp_form_atomic| progress rewrite ?compComp'_form_atomic| progress rewrite ?instId_form| progress rewrite ?compComp_form| progress rewrite ?compComp'_form| progress rewrite ?varL_term| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form_universal subst_form_implicative subst_form_existential subst_form_disjunctive subst_form_conjunctive subst_form_atomic subst_form])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_term in *| progress rewrite ?compComp_term in *| progress rewrite ?compComp'_term in *| progress rewrite ?instId_form_universal in *| progress rewrite ?compComp_form_universal in *| progress rewrite ?compComp'_form_universal in *| progress rewrite ?instId_form_implicative in *| progress rewrite ?compComp_form_implicative in *| progress rewrite ?compComp'_form_implicative in *| progress rewrite ?instId_form_existential in *| progress rewrite ?compComp_form_existential in *| progress rewrite ?compComp'_form_existential in *| progress rewrite ?instId_form_disjunctive in *| progress rewrite ?compComp_form_disjunctive in *| progress rewrite ?compComp'_form_disjunctive in *| progress rewrite ?instId_form_conjunctive in *| progress rewrite ?compComp_form_conjunctive in *| progress rewrite ?compComp'_form_conjunctive in *| progress rewrite ?instId_form_atomic in *| progress rewrite ?compComp_form_atomic in *| progress rewrite ?compComp'_form_atomic in *| progress rewrite ?instId_form in *| progress rewrite ?compComp_form in *| progress rewrite ?compComp'_form in *| progress rewrite ?varL_term in *| progress (unfold up_ren, up_term_term in * )| progress (cbn [subst_term subst_form_universal subst_form_implicative subst_form_existential subst_form_disjunctive subst_form_conjunctive subst_form_atomic subst_form] in * )| fsimpl in *].
 *)

Ltac substify := auto_unfold.

Ltac renamify := auto_unfold.
End form.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import MetaCoq.Template.All.

Import MonadNotation.
Import ListNotations.

Open Scope string_scope.

Definition rname (s:string) := {| binder_name := nNamed s; binder_relevance := Relevant |}.

Fixpoint mkSwitchCases
         (type_name: kername)
         (A_t: term)
         (P_t: term)
         (choices_t: list term)
         (n: nat) : term :=
  let ind_0 n := {| inductive_mind := n; inductive_ind := 0 |} in
  let T_i := ind_0 type_name in

  let bool_i := ind_0 (MPfile ["Datatypes"; "Init"; "Coq"], "bool") in
  let opt_i := ind_0 (MPfile ["Datatypes"; "Init"; "Coq"], "option") in
  match choices_t with
  | [] => tApp (tConstruct opt_i 1 []) [tInd T_i []]
  | (x::xs) => tCase
               (* # of parameters *)
               ((bool_i, 0), Relevant)

               (* type info *)
               (tLambda (rname "b") (tInd bool_i []) (tApp (tInd opt_i []) [tInd T_i []]))

               (* discriminee *)
               (tApp P_t [tRel 0; x])

               (* branches *)
               [
                 (0, tApp (tConstruct opt_i 0 []) [tInd T_i []; tConstruct T_i n []]) ;
               (0, mkSwitchCases type_name A_t P_t xs (S n))
               ]
  end.

Definition mkSwitch
           (A: Type)
           (P: A -> A -> bool)
           (choices: list (A*string))
           (type_name: string)
           (def_name: string): TemplateMonad unit
  :=
    let one_i : one_inductive_entry :=
        {|
          mind_entry_typename := type_name ;
          mind_entry_arity := tSort Universe.type0 ;
          mind_entry_consnames := map snd choices ;
          mind_entry_lc := map (fun _ => tRel 0) choices;
        |} in
    let ind:mutual_inductive_entry := {|
          mind_entry_record    := None ;
          mind_entry_finite    := Finite ;
          mind_entry_params    := [] ;
          mind_entry_inds      := [one_i] ;
          mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty);
          mind_entry_template := false ;
          mind_entry_variance := None ;
          mind_entry_private   := None (* or (Some false)? *)
        |} in
    mp <- tmCurrentModPath tt ;;
    ind_t <- tmMkInductive ind ;;
    T <- tmUnquoteTyped Type (tInd {| inductive_mind := (mp, type_name); inductive_ind := 0 |} []) ;;
    A_t <- tmQuote A ;;
    P_t <- tmQuote P ;;
    choices_t <- monad_map (fun x => tmQuote (fst x)) choices ;;
    let body_t := tLambda (rname "x") A_t (mkSwitchCases (mp, type_name) A_t P_t choices_t 0) in
    body <- tmUnquoteTyped (A -> option T) body_t ;;
    def_t <- tmDefinition def_name body ;;
    tmReturn tt.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Orders.
Require Export OrdersEx.
Require Export OrdersAlt.
Require Export Equalities.
Require Export MSetInterface.
Require Export MSetFacts.
Require Export MSetDecide.
Require Export MSetProperties.
Require Export MSetEqProperties.
Require Export MSetWeakList.
Require Export MSetList.
Require Export MSetPositive.
Require Export MSetAVL.


Require Import List.
Require OrderedType.
Require FMapInterface.
Require BoolExt.
Require Import Setoid.
Require Sorted.

Module MakeOverlay (M : FMapInterface.S).

Section A.

Hypothesis A : Type.

Lemma key_eq_dec : forall (k k':M.key), {M.E.eq k k'}+{~M.E.eq k k'}.
intros. destruct (M.E.compare k k').
 right. apply M.E.lt_not_eq. assumption.
 left. assumption.
 right. unfold not. intro. refine (M.E.lt_not_eq l _). apply M.E.eq_sym. assumption.
Save.

Definition overlay : M.t A -> M.t A -> M.t A :=
 fun specs' specs =>
  M.fold (fun mdesc spec specs' => if M.mem mdesc specs' then specs' else M.add mdesc spec specs') specs specs'.

Lemma mem_3 : forall x y (m : M.t A),
 M.E.eq x y -> M.In x m -> M.In y m.
intros x y m x_eq_y [e m_x_e]. exists e. eauto using M.MapsTo_1.
Save.
Implicit Arguments mem_3 [x y m].

Lemma add_4 : forall k1 k2 e e' (m:M.t A),
 M.E.eq k1 k2 -> M.MapsTo k1 e (M.add k2 e' m) -> e = e'.
intros.
assert (M.find k1 (M.add k2 e' m) = Some e) by auto using M.find_1.
assert (M.find k1 (M.add k2 e' m) = Some e') by auto using M.find_1, M.add_1, M.E.eq_sym.
congruence.
Save.

Lemma overlay_law1 : forall md sp specs' specs,
 M.MapsTo md sp (overlay specs' specs) ->
 M.MapsTo md sp specs' \/ (~M.In md specs' /\ M.MapsTo md sp specs).
intros md sp specs' specs.
unfold overlay. rewrite M.fold_1.
setoid_replace (M.MapsTo md sp specs) with (SetoidList.InA (M.eq_key_elt (elt:=A)) (md,sp) (M.elements specs)).
set (l:=M.elements specs).
generalize l specs'. clear specs' l. induction l as [|[key elt] l]; intros; simpl in *.
 left. assumption.
 destruct (BoolExt.bool_informative (M.mem key specs')) as [mem_res | mem_res]; rewrite mem_res in H.
  destruct (IHl _ H); intuition.
  destruct (IHl _ H) as [in_specs' | [not_in_specs' in_l]].
   destruct (key_eq_dec key md).
    right. split.
     unfold not. intros.  rewrite (M.mem_1 (mem_3 (M.E.eq_sym e) H0)) in mem_res. discriminate.
     assert (sp=elt). eapply add_4. apply M.E.eq_sym. apply e. apply in_specs'. subst. constructor. unfold M.eq_key_elt. simpl. intuition.
    left. eapply M.add_3. apply n. apply in_specs'.
   destruct (key_eq_dec key md).
    subst. elimtype False. apply not_in_specs'. exists elt. apply M.add_1. assumption.
    right. split.
     unfold not. intro. apply not_in_specs'. destruct H0. exists x. apply M.add_2. apply n. apply H0.
     apply SetoidList.InA_cons_tl. apply in_l.
split. apply M.elements_1. apply M.elements_2.
Save.

Lemma lt_lelist : forall l k k',
  Sorted.lelistA (M.lt_key (elt:=A)) k l ->
  M.lt_key k' k ->
  Sorted.lelistA (M.lt_key (elt:=A)) k' l.
intros. inversion H.
 constructor.
 constructor. destruct k. destruct b. destruct k'. unfold M.lt_key in *. simpl in *. eauto using M.E.lt_trans.
Save.

Lemma in_sorted_contr : forall key elt1 elt2 l,
 Sorted.sort (@M.lt_key A) l ->
 Sorted.lelistA (@M.lt_key A) (key,elt2) l ->
 SetoidList.InA (@M.eq_key_elt A) (key,elt1) l -> False.
intros key elt1 elt2.
induction l as [|[key' elt'] l]; intros.
 inversion H1.
 inversion H1; subst.
  inversion H3. simpl in *. subst. clear H1 H3.
   inversion H0. unfold M.lt_key in H3. simpl in H3.
   refine (M.E.lt_not_eq H3 _). assumption.
  inversion H. apply IHl.
   assumption.
   eapply lt_lelist. apply H6. inversion H0. assumption.
   assumption.
Save.

Lemma InA_eq : forall x y l e,
 M.E.eq x y ->
 SetoidList.InA (@M.eq_key_elt A) (x,e) l ->
 SetoidList.InA (@M.eq_key_elt A) (y,e) l.
intros. induction H0.
 constructor. inversion H0. destruct y0. simpl in *. split; eauto using M.E.eq_trans.
 auto using SetoidList.InA_cons_tl.
Save.

Lemma elements_functional : forall l x y e e',
 M.E.eq x y ->
 Sorted.sort (@M.lt_key A) l ->
 SetoidList.InA (@M.eq_key_elt A) (x,e) l ->
 SetoidList.InA (@M.eq_key_elt A) (y,e') l ->
 e = e'.
induction l as [|[key elt] l]; intros.
 inversion H1.
 inversion H1; subst.
  inversion H2; subst.
   inversion H4. inversion H5. simpl in *. subst. reflexivity.
   inversion H4. simpl in *. subst. inversion H0.
    elimtype False. eapply in_sorted_contr. apply H8. apply H9. eapply InA_eq.
     eapply M.E.eq_trans. apply M.E.eq_sym. apply H. apply H3. apply H5.
  inversion H1; subst.
   inversion H5. simpl in *. subst. inversion H0. elimtype False. eapply in_sorted_contr; eauto.
    eapply InA_eq; eassumption.
   inversion H0. inversion H2. subst. elimtype False. eapply in_sorted_contr; eauto.
    eapply InA_eq. inversion H10. simpl in *. eapply M.E.eq_trans. apply H. apply H3. apply H4.
    eauto.
Save.

Lemma overlay_law2 : forall md sp specs' specs,
 M.MapsTo md sp specs' \/ (~M.In md specs' /\ M.MapsTo md sp specs) ->
 M.MapsTo md sp (overlay specs' specs).
intros md sp specs' specs.
unfold overlay. rewrite M.fold_1.
setoid_replace (M.MapsTo md sp specs) with (SetoidList.InA (M.eq_key_elt (elt:=A)) (md,sp) (M.elements specs)).
set (l:=M.elements specs).
assert (X:Sorted.sort (@M.lt_key A) l). unfold l. apply M.elements_3.
generalize l specs' X. clear specs' l X. induction l as [|[key elt] l]; intros; simpl in *.
 destruct H as [in_specs' | [_ in_nil]]. assumption. inversion in_nil.
 apply IHl.
  inversion X. assumption.
  destruct (BoolExt.bool_informative (M.mem key specs')) as [mem_res | mem_res]; rewrite mem_res.
   destruct H as [in_specs' | [not_in_specs in_ke_l]].
    left. assumption.
    destruct (key_eq_dec md key).
     elimtype False. apply not_in_specs. eapply mem_3. apply M.E.eq_sym. apply e. apply M.mem_2. apply mem_res.
     right. split.
      assumption.
      inversion in_ke_l.
       destruct H0. simpl in H0. contradiction.
       assumption.
  destruct H as [in_specs' | [not_in_specs in_ke_l]].
    left. destruct (key_eq_dec key md).
     assert (M.In key specs'). eapply mem_3. apply M.E.eq_sym. apply e. exists sp. apply in_specs'.
      rewrite (M.mem_1 H) in mem_res. discriminate.
     eapply M.add_2. apply n. apply in_specs'.
   destruct (key_eq_dec md key).
    left.
     assert (SetoidList.InA (M.eq_key_elt (elt:=A)) (md,elt) ((md,elt)::l)). constructor. split; simpl; auto; apply M.E.eq_refl.
     rewrite (elements_functional ((key,elt)::l) key md sp elt); try assumption.
      apply M.add_1. apply M.E.eq_sym. assumption.
      apply M.E.eq_sym. assumption.
      eapply InA_eq. apply e. assumption.
      constructor. split; eauto.
    right. split.
     unfold not. intro. apply not_in_specs. destruct H. exists x. eapply M.add_3. unfold not. intro. apply n. apply M.E.eq_sym. apply H0. apply H.
     inversion in_ke_l.
      inversion H0. simpl in H2. contradiction.
      assumption.
split. apply M.elements_1. apply M.elements_2.
Save.

Lemma overlay_law : forall md sp specs' specs,
 M.MapsTo md sp (overlay specs' specs) <->
  M.MapsTo md sp specs' \/ (~M.In md specs' /\ M.MapsTo md sp specs).
intros. split.
 apply overlay_law1.
 apply overlay_law2.
Save.

End A.

End MakeOverlay.

(*
   Local Variables:
   coq-prog-args: ("-emacs-U" "-I" ".." "-R" "../ill" "ILL" "-R" "." "Verifier")
   End:
   *)


(** This module defines heaps based on finite maps of the coq-std++
library. *)

From stdpp Require Import gmap fin_maps fin_sets.
From Coq Require Import Lia.

From Rattus Require Import RawSyntax.

Definition heap : Set := gmap loc term.

Definition heap_dom_set (h : heap) : (gset loc) := dom _ h.

Definition heap_empty : heap := empty.
Definition heap_cons (h : heap) (l : loc) (t: term) : heap := insert l t h.

Definition heap_delete (h : heap) (l : loc) : heap := delete l h.

Definition heap_mapsto (l : loc) (t : term) (h : heap) : Prop :=
  h !! l = Some t.

Definition alloc_fresh (h : heap) : loc :=
  S(set_fold (fun k k' => max k k') 0 (heap_dom_set h)).

Definition heap_dom (l : loc) (h : heap) : Prop := exists t, heap_mapsto l t h.
Definition heap_fresh (l : loc) (h : heap) : Prop := not (exists t, heap_mapsto l t h).

Lemma heap_empty_fresh l : heap_fresh l heap_empty.
Proof.
  apply lookup_empty_is_Some.
Qed.

Lemma alloc_fresh_max h l : l ∈ heap_dom_set h -> alloc_fresh h > l.
Proof.
  remember (fun f (s : gset loc) => l ∈ s -> S f > l) as P.

  assert (forall s, P (set_fold (fun k k' => max k k') 0 s) s) as IP.
  apply set_fold_ind;subst;simpl;intros.
  - intros n n' En s s' Es. split.
    + intros I E. subst. apply I. apply Es. auto.
    + intros I E. subst. apply I. apply Es. auto.
  - apply not_elem_of_empty in H. contradiction.
  - rewrite elem_of_union in H1. destruct H1.
    + apply elem_of_singleton_1 in H1. subst. zify;lia.
    + apply H0 in H1. zify;lia.
  - subst. eauto.
Qed.

Lemma heap_fresh_alloc h : heap_fresh (alloc_fresh h) h.
Proof.
  intros F. unfold heap_mapsto in *. destruct F.

  assert (alloc_fresh h ∈ heap_dom_set h).
  eapply elem_of_dom_2. eassumption.
  apply alloc_fresh_max in H0. lia.
Qed.

Lemma heap_mapsto_determ l t t' h : heap_mapsto l t h -> heap_mapsto l t' h -> t = t'.
Proof.
  unfold heap_mapsto. intros M1 M2. rewrite M1 in M2. inversion M2. auto.
Qed.

Lemma max_proper : Proper (equiv ==> eq)
                          (set_fold (fun (k k' : nat) => k `max` k') 0 : gset loc -> nat).
Proof.
  apply set_fold_proper.
  - apply Eqsth.
  - intros n n' En m m' Em. subst. auto.
  - intros. do 2 rewrite Nat.max_assoc.
    f_equal. apply Nat.max_comm.
Qed.

Lemma alloc_dom  l h t : heap_dom l h -> alloc_fresh (heap_cons h l t) = alloc_fresh h.
Proof.
  intros D. unfold alloc_fresh, heap_cons.
  f_equal. apply max_proper.
  assert (heap_dom_set (<[l:=t]> h) ≡ {[l]} ∪ heap_dom_set h) as R.
  apply dom_insert.
  rewrite R. clear R.
  assert (l ∈ heap_dom_set h). unfold heap_dom in D.
  destruct D as (u & D). eapply elem_of_dom_2. apply D.
  set_solver.
Qed.

Lemma heap_cons_mapsto_neq  l l' t u h :
  l <> l' -> heap_mapsto l t (heap_cons h l' u) <-> heap_mapsto l t h.
Proof.
  unfold heap_mapsto, heap_cons. intros LNeq. split.
  - intros M. rewrite <- M. symmetry. apply lookup_insert_ne. auto.
  - intros L. rewrite <- L. apply lookup_insert_ne. auto.
Qed.

Lemma heap_cons_comm l l' t u h :
  l <> l' -> heap_cons (heap_cons h l u) l' t = heap_cons (heap_cons h l' t) l u.
Proof.
  intros LNeq. unfold heap_cons. apply insert_commute. auto.
Qed.

Lemma heap_cons_eq l t u h : heap_cons (heap_cons h l u) l t = heap_cons h l t.
Proof.
  apply insert_insert.
Qed.

Lemma heap_cons_mapsto_eq l t u h : heap_mapsto l t (heap_cons h l u) <-> t = u.
Proof.
  unfold heap_mapsto, heap_cons. split.
  - intros M. assert (<[l:=u]> h !! l = Some u) as E by apply lookup_insert.
    rewrite E in M. inversion M. reflexivity.
  - intros E. subst. apply lookup_insert.
Qed.

Lemma heap_overwrite h1 h2 l t u :
  heap_mapsto l t h2 ->  heap_cons h1 l u = heap_cons h2 l u -> heap_cons h1 l t = h2.
Proof.
  unfold heap_mapsto, heap_cons. intros L C.
  apply map_eq. intros.
  destruct (Nat.eq_decidable l i).
  - subst. assert (<[i:=t]> h1 !! i = Some t) as E by apply lookup_insert.
    rewrite <- L in E. auto.
  - assert (<[l:=t]> h1 !! i = h1 !! i) as E by (apply lookup_insert_ne; auto).
    assert (<[l:=u]> h1 !! i = h1 !! i) as E1 by (apply lookup_insert_ne; auto).
    assert (<[l:=u]> h2 !! i = h2 !! i) as E2 by (apply lookup_insert_ne; auto).
    unfold lookup, insert in *. rewrite E.
    rewrite C in E1. rewrite E1 in E2. auto.
Qed.

Lemma heap_overwrite' h l t :
  heap_mapsto l t h -> heap_cons h l t = h.
Proof.
  unfold heap_mapsto, heap_cons. intros L.
  apply map_eq. intros.
  destruct (Nat.eq_decidable l i).
  - subst. assert (<[i:=t]> h !! i = Some t) as E by apply lookup_insert.
    rewrite <- L in E. auto.
  - assert (<[l:=t]> h !! i = h !! i) as E by (apply lookup_insert_ne; auto).
    unfold lookup, insert in *. assumption.
Qed.

Lemma heap_cons_delete h l t : heap_delete (heap_cons h l t) l = heap_delete h l.
Proof.
  unfold heap_delete, heap_cons. apply delete_insert_delete.
Qed.

Lemma heap_cons_delete' h l t : heap_cons (heap_delete h l) l t = heap_cons h l t.
Proof.
  unfold heap_delete, heap_cons. apply insert_delete_insert.
Qed.


Require Import Setoid Coq.Program.Basics.
Global Open Scope program_scope.
Axiom foo : forall A (f : A -> A), f ∘ f = f.
Require Import Coq.Program.Combinators.
Hint Rewrite foo.
Theorem t {A B C D} (f : A -> A) (g : B -> C) (h : C -> D)
: f ∘ f = f.
Proof.
  rewrite_strat topdown (hints core).


Require Import Common.Definitions.
Require Import Common.Util.

From mathcomp Require Import ssreflect ssrfun ssrbool.

(* an imported procedure is either open (the interface is missing)
   or exported by the right component *)
Definition sound_interface (interface : Program.interface) : Prop :=
  forall C C' P, imported_procedure interface C C' P ->
  forall CI',
    Program.has_component interface C' CI' ->
    Component.is_exporting CI' P.

Definition linkable (i1 i2 : Program.interface) : Prop :=
  sound_interface (unionm i1 i2) /\ fdisjoint (domm i1) (domm i2).

Theorem linkable_sym:
  forall {i1 i2},
    linkable i1 i2 -> linkable i2 i1.
Proof.
  intros i1 i2 Hlinkable.
  inversion Hlinkable; subst.
  constructor;
    try assumption.
  - rewrite unionmC; auto.
    unfold fdisjoint. rewrite fsetIC. auto.
  - unfold fdisjoint. rewrite fsetIC. auto.
Qed.

Theorem linkable_emptym:
  forall i,
    sound_interface i ->
    linkable i emptym.
Proof.
  intros i Hsound. constructor.
  - now rewrite unionm0.
  - rewrite domm0. apply fdisjoints0.
Qed.

(* an imported procedure is always exported by the right component *)
Definition closed_interface (interface : Program.interface) : Prop :=
  forall C C' P, imported_procedure interface C C' P ->
                 exported_procedure interface C' P.

Lemma closed_interface_is_sound:
  forall iface,
    closed_interface iface -> sound_interface iface.
Proof.
  unfold closed_interface, sound_interface.
  intros iface Hiface_closed C C' P Himported CI' HCI'.
  specialize (Hiface_closed C C' P Himported).
  destruct Hiface_closed as [CI'' [HCI'' Hexporting]].
  unfold Program.has_component in HCI', HCI''.
  enough (HsameCI: CI' = CI'').
  - subst. auto.
  - rewrite HCI'' in HCI'. inversion HCI'. reflexivity.
Qed.

Definition mergeable_interfaces (i1 i2: Program.interface) : Prop :=
  linkable i1 i2 /\
  closed_interface (unionm i1 i2).

Lemma mergeable_interfaces_sym i1 i2 :
  mergeable_interfaces i1 i2 ->
  mergeable_interfaces i2 i1.
Proof.
  case=> [[Hsound Hdis] Hclosed].
  by do 2?split; rewrite -1?unionmC // fdisjointC.
Qed.

Lemma domm_partition_notin :
  forall ctx1 ctx2,
    mergeable_interfaces ctx1 ctx2 ->
  forall C,
    C \in domm ctx2 ->
    C \notin domm ctx1.
Proof.
by move=> ctx1 ctx2 [[_]]; rewrite fdisjointC=> /fdisjointP.
Qed.

Lemma domm_partition_notin_r :
  forall ctx1 ctx2,
    mergeable_interfaces ctx1 ctx2 ->
  forall C,
    C \in domm ctx1 ->
    C \notin domm ctx2.
Proof.
  intros.
  eapply domm_partition_notin; [apply mergeable_interfaces_sym |]; eassumption.
Qed.


Require Import Crypto.Compilers.Syntax.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {var1 var2 : base_type_code -> Type}
          (fvar12 : forall t, var1 t -> var2 t)
          (fvar21 : forall t, var2 t -> var1 t).
  Local Notation exprf := (@exprf base_type_code op).
  Fixpoint mapf_interp_flat_type {t} (e : interp_flat_type var2 t) {struct t}
    : interp_flat_type var1 t
    := match t return interp_flat_type _ t -> interp_flat_type _ t with
       | Tbase _ => fvar21 _
       | Unit => fun v : unit => v
       | Prod x y => fun xy => (@mapf_interp_flat_type _ (fst xy),
                                @mapf_interp_flat_type _ (snd xy))
       end e.

  Fixpoint mapf {t} (e : @exprf var1 t) : @exprf var2 t
    := match e in Syntax.exprf _ _ t return exprf t with
       | TT => TT
       | Var _ x => Var (fvar12 _ x)
       | Op _ _ op args => Op op (@mapf _ args)
       | LetIn _ ex _ eC => LetIn (@mapf _ ex) (fun x => @mapf _ (eC (mapf_interp_flat_type x)))
       | Pair _ ex _ ey => Pair (@mapf _ ex) (@mapf _ ey)
       end.
End language.

Global Arguments mapf_interp_flat_type {_ _ _} _ {t} _.
Global Arguments mapf {_ _ _ _} _ _ {t} _.


From SSL_Iris Require Import core.
From iris.heap_lang Require Import lang notation proofmode.
From iris_string_ident Require Import ltac2_string_ident.
Section common.
Context `{!heapG Σ}.
Inductive dll_card : Set :=
    | dll_card_0 : dll_card
    | dll_card_1 : dll_card -> dll_card.

Fixpoint dll (x: loc) (z: loc) (s: (list Z)) (self_card: dll_card) { struct self_card } : iProp Σ := match self_card with
    | dll_card_0  => ⌜(x = null_loc) ∧ (s = [])⌝
    | dll_card_1 _alpha_533 => ∃ (v : Z) (s1 : (list Z)) (w : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #w ∗ (x +ₗ 2) ↦ #z ∗ (dll w x s1 _alpha_533)
end.

Global Opaque dll.

Lemma dll_card_0_learn (x: loc) (z: loc) (s: (list Z)) self_card:
dll x z s self_card  ⊢ dll x z s self_card ∗ ⌜(x = null_loc) -> self_card = dll_card_0⌝.
Proof.
Transparent dll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 w) "((% & %) & (? & ? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, w. iFrame. eauto.
   eauto.
Global Opaque dll.
Qed.

Lemma dll_card_1_learn (x: loc) (z: loc) (s: (list Z)) self_card:
dll x z s self_card  ⊢ dll x z s self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_533, self_card = (dll_card_1 _alpha_533)⌝.
Proof.
Transparent dll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 w) "((% & %) & (? & ? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, w. iFrame. eauto.
   eauto.
Global Opaque dll.
Qed.

Lemma dll_card_0_open  (x: loc) (z: loc) (s: (list Z)) :
dll x z s (dll_card_0 ) = (⌜(x = null_loc) ∧ (s = [])⌝)%I.
Proof. auto. Qed.

Lemma dll_card_1_open (_alpha_533 : dll_card) (x: loc) (z: loc) (s: (list Z)) :
dll x z s (dll_card_1 _alpha_533) = (∃ (v : Z) (s1 : (list Z)) (w : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #w ∗ (x +ₗ 2) ↦ #z ∗ (dll w x s1 _alpha_533))%I.
Proof. auto. Qed.

End common.


(* This has been a bug reported by Y. Bertot *)
Inductive expr : Set :=
  | b : expr -> expr -> expr
  | u : expr -> expr
  | a : expr
  | var : nat -> expr.

Fixpoint f (t : expr) : expr :=
  match t with
  | b t1 t2 => b (f t1) (f t2)
  | a => a
  | x => b t a
  end.

Fixpoint f2 (t : expr) : expr :=
  match t with
  | b t1 t2 => b (f2 t1) (f2 t2)
  | a => a
  | x => b x a
  end.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo120:
  prime  86472197895793->
  prime  73501368737533661.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      73501368737533661
      850
      ((86472197895793,1)::nil)
      27563013276575124
      0
      36750684368766832
      55126026553150248)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj21eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) lv2) (plus lv2 (mult (Succ lv0) lv1))).
Admitted.
QuickChick conj21eqsynthconj5.