Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun fintype.
From mathcomp Require Import choice path bigop.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Lib.Dist Ipdl.Tacs Pars Lib.Set.
Require Import OTIdeal.

Require Import Setoid Relation_Definitions Morphisms.
Require Import Permutation Typ Lib.SeqOps.
Close Scope bool_scope.

  Lemma samp_pair {chan} {t'} {t : finType} `{unif t} `{Inhabited t'} `{Inhabited t} (x : chan t') (c d : chan t) :
    pars [::
            Out c (_ <-- Read x ;; Samp (Unif));
         Out d (_ <-- Read x ;; Samp Unif)] =p
    e <- new (t * t) ;;
    pars [::
            Out e (_ <-- Read x ;; Samp Unif) ;
            Out c (_ <-- Read x ;; x <-- Read e ;; Ret (x.1));
            Out d (_ <-- Read x ;; x <-- Read e ;; Ret (x.2))].
    symmetry.
    simpl.
    etransitivity.
    Intro => e.
    edit_tac 0.
    rewrite /Unif_pair.
    setoid_rewrite EqSampBind.
    setoid_rewrite EqSampBind.
    instantiate (1 :=
                   x0 <-- (_ <-- Read x ;; Samp Unif) ;;
                   y <-- (_ <-- Read x ;; Samp Unif) ;;
                   Ret (x0, y)).
         symmetry; simp_rxn.
         r_swap 1 2.
         rewrite EqReadSame.
         setoid_rewrite EqSampRet.
         done.
    rewrite -pars_fold.
    Intro => c'.
    swap_at 0 0 1.
    rewrite -pars_fold.
    Intro => d'.
    do_inline; simp_all.
    do_inline; simp_all.

    simpl.
    swap_tac 0 3.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_tac 0 4.
    swap_at 0 0 1.
    swap_tac 1 2.
    rewrite -pars_mkdep //=; last by firstorder.
    apply EqRefl.
    rewrite EqNewExch.
    setoid_rewrite EqNewExch at 2.
    swap_tac 0 3.
    setoid_rewrite new_pars_remove.
    swap_tac 0 2.
    setoid_rewrite pars_fold.
    swap_tac 0 2.
    rewrite pars_fold.
    align.
    apply EqCongReact; simp_rxn; r_swap 1 2; rewrite EqReadSame; setoid_rewrite EqBindRet; done.
    apply EqCongReact; simp_rxn; r_swap 1 2; rewrite EqReadSame; setoid_rewrite EqBindRet; done.
Qed.

  Lemma rerandomP {chan : Type -> Type} {L : nat} b (i : chan (bool * bool)%type) (c1 c2 : chan L.-bv) :
    pars [::
            Out c1 (_ <-- Read i ;; Samp Unif);
            Out c2 (_ <-- Read i ;; Samp Unif)
         ]
    =p
       c1' <- new L.-bv ;;
       c2' <- new L.-bv ;;
       pars [::
               Out c1' (Samp Unif);
               Out c2' (Samp Unif);
               Out c1 (i <-- Read i ;; x <-- Read c1' ;; y <-- Read c2' ;; Ret (if  (if b then i.1 else i.2) then x else y));
               Out c2 (i <-- Read i ;; x <-- Read c1' ;; y <-- Read c2' ;; Ret (if (if b then i.1 else i.2) then y else x))
                   ].
    rewrite samp_pair.
    etransitivity.
    Intro => e.
    edit_tac 0.
    instantiate (1 :=
                   (i <-- Read i ;; x <-- Samp Unif ;; y <-- Samp Unif ;;
                    Ret (if (if b then i.1 else i.2) then (x, y) else (y, x )))).
         apply EqBind_r => x.
         destruct x as [x0 x1]; simpl.
         destruct b.
         destruct x0.
         rewrite /Unif_pair EqSampBind; setoid_rewrite EqSampBind; setoid_rewrite EqSampRet; done.
         rewrite /Unif_pair EqSampBind; setoid_rewrite EqSampBind; setoid_rewrite EqSampRet.
         r_swap 0 1.
         done.
         destruct x1.
         rewrite /Unif_pair EqSampBind; setoid_rewrite EqSampBind; setoid_rewrite EqSampRet; done.
         rewrite /Unif_pair EqSampBind; setoid_rewrite EqSampBind; setoid_rewrite EqSampRet.
         r_swap 0 1.
         done.
    swap_at 0 0 1.
    rewrite -pars_fold.
    Intro => c1'.
    swap_at 0 0 2.
    rewrite -pars_fold.
    Intro => c2'.
    do_inline; simp_all.
    do_inline; simp_all.
    apply EqRefl.
    setoid_rewrite EqNewExch at 1.
    setoid_rewrite EqNewExch at 2.
    setoid_rewrite new_pars_remove.
    Intro => c1'.
    Intro => c2'.
    align.
        apply EqCongReact.
        r_swap 0 2.
        r_swap 1 3.
        rewrite EqReadSame.
        r_swap 1 2.
        apply EqBind_r => x.
        apply EqBind_r => y.
        apply EqBind_r => z.
        destruct x as [x0 x1]; destruct b; [ destruct x0 | destruct x1]; rewrite //=.

        apply EqCongReact.
        r_swap 0 2.
        r_swap 1 3.
        rewrite EqReadSame.
        r_swap 1 2.
        apply EqBind_r => x.
        apply EqBind_r => y.
        apply EqBind_r => z.
        destruct x as [x0 x1]; destruct b; [ destruct x0 | destruct x1]; rewrite //=.
Qed.

  Lemma rerandomP_rs {chan : Type -> Type} {L : nat} b (i : chan (bool * bool)%type) (c1 c2 : chan L.-bv) rs :
    pars [::
            Out c1 (_ <-- Read i ;; Samp Unif),
            Out c2 (_ <-- Read i ;; Samp Unif) & rs
         ]
    =p
       c1' <- new L.-bv ;;
       c2' <- new L.-bv ;;
       pars [::
               Out c1' (Samp Unif),
               Out c2' (Samp Unif),
               Out c1 (i <-- Read i ;; x <-- Read c1' ;; y <-- Read c2' ;; Ret (if  (if b then i.1 else i.2) then x else y)),
               Out c2 (i <-- Read i ;; x <-- Read c1' ;; y <-- Read c2' ;; Ret (if (if b then i.1 else i.2) then y else x)) & rs
                   ].
    rewrite (pars_split 2); simpl; rewrite take0 drop0.
    rewrite rerandomP.
    rewrite newComp.
    Intro => c.
    rewrite newComp.
    Intro => c'.
    rewrite -pars_cat //=.
Qed.

Lemma ot14_xort_subproof {t} (a b c : t.-tuple bool) :
    ((((a +t b) +t c) +t a) +t b)
              =
              (c +t (a +t a) +t (b +t b)).
  rewrite (xortC _ c).
  rewrite !xortA.
  congr (_ _).
  congr (_ _).
  rewrite (xortC b).
  rewrite xortA //=.
Qed.

Ltac rxn_intros_combine_reads :=
  lazymatch goal with
  | [ |- @EqRxn _ _ ?r1 _ ] =>
    lazymatch r1 with
    | @Bind _ _ _ ?c ?k =>
      lazymatch c with
      | Read ?ch =>
        find_read_in_rxn (k witness) ch
                         ltac:(fun p =>
                            lazymatch p with
                            | Some ?j => r_swap 1 (j.+1); rewrite EqReadSame; apply EqBind_r; intro; rxn_intros_combine_reads
                            | None => apply EqBind_r; intro; rxn_intros_combine_reads
                                                               end
                         )
      | _ => apply EqBind_r; intro; rxn_intros_combine_reads
      end
    | _ => idtac
 end end.

Section OneOutOf4.
  Context (L : nat).
  Context {chan : Type -> Type}.
  Context (ot_i1 ot_i2 ot_i3 : chan bool).
  Context (ot_o1 ot_o2 ot_o3 : chan L.-bv).

  Context (ot14_m : chan ((L.-bv * L.-bv) * (L.-bv * L.-bv))).
  Context (ot14_i : chan (bool * bool)).
  Context (ot14_o : chan L.-bv).

  (* Leakage channels for bob *)
  Context (leak_ot_o1 leak_ot_o2 leak_ot_o3 : chan L.-bv).
  Context (leak_send : chan ((L.-bv * L.-bv) * (L.-bv * L.-bv))).

  Definition One4_sender (ot_m1 ot_m2 ot_m3 : chan (L.-bv * L.-bv)) (ready : chan unit) (send : chan ((L.-bv * L.-bv) * (L.-bv * L.-bv)))  :=
    s0 <- new L.-bv ;;
    s1 <- new L.-bv;;
    s2 <- new L.-bv;;
    s3 <- new L.-bv;;
    s4 <- new L.-bv;;
    s5 <- new L.-bv;;
    pars [::
            Out s0 (_ <-- Read ready;; Samp Unif);
            Out s1 (_ <-- Read ready;; Samp Unif);
            Out s2 (_ <-- Read ready;; Samp Unif);
            Out s3 (_ <-- Read ready;; Samp Unif);
            Out s4 (_ <-- Read ready;; Samp Unif);
            Out s5 (_ <-- Read ready;; Samp Unif);

            Out send (
                  m <-- Read ot14_m ;;
                  s0 <-- Read s0 ;;
                  s1 <-- Read s1 ;;
                  s2 <-- Read s2 ;;
                  s3 <-- Read s3 ;;
                  s4 <-- Read s4 ;;
                  s5 <-- Read s5 ;;
                  Ret (
                  let '((m0, m1), (m2, m3)) := m in
                  ( (s0 +t s2 +t m0,
                     s0 +t s3 +t m1),
                    (s1 +t s4 +t m2, s1 +t s5 +t m3))));
         Out ot_m1 (
               a <-- Read s0 ;;
               b <-- Read s1 ;;
               Ret (a, b) );
         Out ot_m2 (
               a <-- Read s2 ;;
               b <-- Read s3 ;;
               Ret (a, b) );
         Out ot_m3 (
               a <-- Read s4 ;;
               b <-- Read s5 ;;
               Ret (a, b) ) ].

  Definition One4_recv (ready : chan unit) (ot_i1 ot_i2 ot_i3 : chan bool) (ot_o1 ot_o2 ot_o3 : chan L.-bv) (send : chan ((L.-bv * L.-bv) * (L.-bv * L.-bv))) :=
    pars [::
            Out ready (_ <-- Read ot14_i ;; Ret tt);
            Out ot_i1 (
                  i <-- Read ot14_i ;; Ret (i.1));
            Out ot_i2 (
                  i <-- Read ot14_i ;; Ret (i.2));
            Out ot_i3 (
                  i <-- Read ot14_i ;; Ret (i.2));
            Out leak_send (copy send);
            Out leak_ot_o1 (copy ot_o1);
            Out leak_ot_o2 (copy ot_o2);
            Out leak_ot_o3 (copy ot_o3);
            Out ot14_o (
                  t <-- Read ot14_i ;;
                  a <-- Read send ;;
                  T0 <-- Read ot_o1 ;;
                  T1 <-- Read ot_o2 ;;
                  T2 <-- Read ot_o3 ;;
                  Ret (
                      let '((a0, a1), (a2, a3)) := a in
                      match t.1, t.2 with
                        | false, false => a0 +t T0 +t T1
                        | false, true => a1 +t T0 +t T1
                        | true, false => a2 +t T0 +t T2
                        | true, true => a3 +t T0 +t T2
                                                    end))].

  Definition OT14_real_simpl :=
    c <- new L.-bv ;;
    c0 <- new L.-bv ;;
    c1 <- new L.-bv ;;
    c2 <- new L.-bv ;;
    c3 <- new L.-bv ;;
    c4 <- new L.-bv ;;
    [pars [:: Out ot14_o
              (x <-- Read ot14_i;; x_m <-- Read ot14_m;; Ret ((x_m # x.1) # x.2 : L.-bv));
            Out c2 (_ <-- Read ot14_i;; Samp Unif);
            Out c3 (_ <-- Read ot14_i;; Samp Unif);
            Out leak_send
              (x <-- Read ot14_m;;
               x0 <-- Read c;;
               x1 <-- Read c0;;
               x2 <-- Read c1;;
               x3 <-- Read c2;;
               x4 <-- Read c3;;
               x5 <-- Read c4;;
               Ret
                 (let
                  '(m0, m1, (m2, m3)) := x in
                   ( ( (x0 +t x2) +t m0, (x0 +t x3) +t m1),
                     ( (x1 +t x4) +t m2, (x1 +t x5) +t m3))));
            Out leak_ot_o3
              (x <-- Read c3;;
               x0 <-- Read c4;;
               x1 <-- Read ot14_i;; Ret (if x1 .2 then x0 else x));
            Out leak_ot_o2
              (x <-- Read c1;;
               x0 <-- Read c2;;
               x1 <-- Read ot14_i;; Ret (if x1 .2 then x0 else x));
            Out leak_ot_o1
              (x <-- Read c;;
               x0 <-- Read c0;;
               x1 <-- Read ot14_i;; Ret (if x1 .1 then x0 else x));
            Out c1 (_ <-- Read ot14_i;; Samp Unif);
            Out c4 (_ <-- Read ot14_i;; Samp Unif);
            Out c (_ <-- Read ot14_i;; Samp Unif);
            Out c0 (_ <-- Read ot14_i;; Samp Unif) ]].

  Definition OT14_real :=
    ot_i1 <- new bool ;;
    ot_i2 <- new bool ;;
    ot_i3 <- new bool ;;
    ot_m1 <- new (L.-bv * L.-bv) ;;
    ot_m2 <- new (L.-bv * L.-bv) ;;
    ot_m3 <- new (L.-bv * L.-bv) ;;
    ot_o1 <- new L.-bv ;;
    ot_o2 <- new L.-bv ;;
    ot_o3 <- new L.-bv ;;
    send <- new ((L.-bv * L.-bv) * (L.-bv * L.-bv)) ;;
    ready <- new unit ;;
    pars [::
            OTIdeal _ ot_i1 ot_m1 ot_o1;
            OTIdeal _ ot_i2 ot_m2 ot_o2;
            OTIdeal _ ot_i3 ot_m3 ot_o3;
            One4_sender ot_m1 ot_m2 ot_m3 ready send;
            One4_recv ready ot_i1 ot_i2 ot_i3 ot_o1 ot_o2 ot_o3 send ].

  Lemma ot14_simp : OT14_real =p OT14_real_simpl.
    etransitivity.
    repeat ltac:(apply EqCongNew; intro).
    rewrite /OTIdeal.
    rewrite /One4_sender.
    swap_tac 0 3.
    setoid_rewrite New_in_pars at 1.
    setoid_rewrite New_in_pars at 1.
    setoid_rewrite New_in_pars at 1.
    setoid_rewrite New_in_pars at 1.
    setoid_rewrite New_in_pars at 1.
    setoid_rewrite New_in_pars at 1.
    apply EqCongNew => s0.
    apply EqCongNew => s1.
    apply EqCongNew => s2.
    apply EqCongNew => s3.
    apply EqCongNew => s4.
    apply EqCongNew => s5.
    rewrite pars_pars; simpl.
    swap_tac 0 13.
    rewrite pars_pars; simpl.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    do_inline; simp_all.
    progress ltac:(do_inline; simp_all).
    progress ltac:(do_inline; simp_all).
    progress ltac:(do_inline; simp_all).
    progress ltac:(do_inline; simp_all).
    progress ltac:(do_inline; simp_all).
    progress ltac:(do_inline; simp_all).
    apply EqRefl.
    (* now we elim all the useless channels *)
    simpl.
    repeat setoid_rewrite (EqNewExch unit).
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch ((L.-bv * L.-bv) * (L.-bv * L.-bv))).
    swap_tac 0 13.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch bool) at 3.
    swap_tac 0 1.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    repeat setoid_rewrite (EqNewExch bool) at 2.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch bool) at 1.
    swap_tac 0 10.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch (L.-bv * L.-bv)) at 3.
    swap_tac 0 12.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch (L.-bv * L.-bv)) at 2.
    swap_tac 0 10.
    under_new rewrite new_pars_remove; last first; apply EqRefl.
    simpl.
    repeat setoid_rewrite (EqNewExch (L.-bv * L.-bv)).
    swap_tac 0 8.
    under_new rewrite new_pars_remove; last first; apply EqRefl.

    simpl.
    swap_tac 0 10.
    setoid_rewrite (EqNewExch L.-bv) at 2.
    setoid_rewrite (EqNewExch L.-bv) at 3.
    setoid_rewrite (EqNewExch L.-bv) at 4.
    setoid_rewrite (EqNewExch L.-bv) at 5.
    setoid_rewrite (EqNewExch L.-bv) at 6.
    setoid_rewrite (EqNewExch L.-bv) at 7.
    setoid_rewrite (EqNewExch L.-bv) at 8.
    under_new rewrite new_pars_remove; last first; apply EqRefl.

    simpl.
    swap_tac 0 11.
    setoid_rewrite (EqNewExch L.-bv) at 1.
    setoid_rewrite (EqNewExch L.-bv) at 2.
    setoid_rewrite (EqNewExch L.-bv) at 3.
    setoid_rewrite (EqNewExch L.-bv) at 4.
    setoid_rewrite (EqNewExch L.-bv) at 5.
    setoid_rewrite (EqNewExch L.-bv) at 6.
    setoid_rewrite (EqNewExch L.-bv) at 7.
    under_new rewrite new_pars_remove; last first; apply EqRefl.

    simpl.
    swap_tac 0 9.
    setoid_rewrite (EqNewExch L.-bv) at 1.
    setoid_rewrite (EqNewExch L.-bv) at 2.
    setoid_rewrite (EqNewExch L.-bv) at 3.
    setoid_rewrite (EqNewExch L.-bv) at 4.
    setoid_rewrite (EqNewExch L.-bv) at 5.
    setoid_rewrite (EqNewExch L.-bv) at 6.
    under_new rewrite new_pars_remove; last first; apply EqRefl.

    (* Now do some final simpl *)
    etransitivity.
    repeat ltac:(apply EqCongNew; intro).
    edit_tac 7.
    etransitivity.
    rxn_intros_combine_reads.
    apply EqRxnRefl.
    etransitivity.
    rxn_intros_combine_reads.
    apply EqRxnRefl.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intros x_i.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intros x_m.
    instantiate (1 :=
                   fun x_m => _).
    simpl.
    instantiate (1 := Ret ((x_m # x_i.1) # x_i.2)).
    destruct x_m as [[m0 m1] [m2 m3]].
    simpl.
    destruct x_i as [i1 i2]; simpl.
    destruct i1, i2; simpl.

    rewrite ot14_xort_subproof !xortK !xort0 //=.
    rewrite ot14_xort_subproof !xortK !xort0 //=.
    rewrite ot14_xort_subproof !xortK !xort0 //=.
    rewrite ot14_xort_subproof !xortK !xort0 //=.

    swap_tac 0 7.
    swap_tac 1 10.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_tac 1 9.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_at 0 0 1.
    swap_tac 1 10.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_at 0 0 1.
    swap_tac 1 2.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_at 0 0 1.
    swap_tac 1 8.
    rewrite -pars_mkdep //=; last by firstorder.
    swap_at 0 0 1.
    swap_tac 1 7.
    rewrite -pars_mkdep //=; last by firstorder.
    apply EqRefl.
    apply EqRefl.
Qed.

  Definition mkpair4 {t} (f : bool -> bool -> t) : (t * t) * (t * t) :=
    ((f false false, f false true), (f true false, f true true)).

  Definition cflip {t} (p : t * t) (b : bool) : t * t :=
    if b then p else (p.2, p.1).

  Lemma bind_samp_xor {n : nat} {t} (a : n.-tuple bool) (k : n.-bv -> @rxn chan t) :
    EqRxn _ (x <-- Samp (Unif) ;; k x) (x <-- Samp Unif ;; k (x +t a)).
    apply EqBind_r_samp_bijection.
    apply is_unif.
    apply xort_inj_r.
  Qed.

  Definition OT14_real_rerandomize :=
    c <- new L.-bv;;
  c0 <- new L.-bv;;
  c1 <- new L.-bv;;
  [pars [:: Out leak_send
              (x <-- Read ot14_i;;
               x0 <-- Read c1;;
               x1 <-- Read c0;;
               x2 <-- Read c;;
               x3 <-- Read ot14_m;;
               x4 <-- Samp Unif;;
               x5 <-- Samp Unif;;
               x6 <-- Samp Unif;;
               Ret
                 (let o := (x3 # x .1) # x .2 in
                  let o0 := if x .2 && x .1 then o else tzero _ in
                  let o1 := if ~~ x .2 && x .1 then o else tzero _ in
                  let o2 := if x .2 && ~~ x .1 then o else tzero _ in
                  let o3 := if ~~ x .2 && ~~ x .1 then o else tzero _ in
                  ( ( ((x2, x4) # x .1 +t (x0, x6) # x .2) +t o3 : L.-bv,
                    ((x2, x4) # x .1 +t (x6, x0) # x .2) +t o2 : L.-bv),
                  (((x4, x2) # x .1 +t (x1, x5) # x .2) +t o1 : L.-bv,
                  ((x4, x2) # x .1 +t (x5, x1) # x .2) +t o0 : L.-bv))));
            Out leak_ot_o1 (_ <-- Read ot14_i;; Read c);
            Out leak_ot_o3 (_ <-- Read ot14_i;; Read c0);
            Out leak_ot_o2 (_ <-- Read ot14_i;; y <-- Read c1;; Ret y);
            Out c1 (Samp Unif); Out c (Samp Unif);             Out ot14_o
              (x <-- Read ot14_i;; x0 <-- Read ot14_m;; Ret ((x0 # x.1) # x.2 : L.-bv));
            Out c0 (Samp Unif) ] ].

Lemma ot_simpl_rerandomize : OT14_real_simpl =p OT14_real_rerandomize.
    etransitivity.
    repeat ltac:(apply EqCongNew; intro).
    swap_tac 0 9.
    swap_tac 1 10.
    etransitivity.
    rewrite (rerandomP_rs true).
    repeat ltac:(apply EqCongNew; intro).
    repeat ltac:(do_inline; simp_all).
    edit_tac 8.
        r_swap 1 3.
        rewrite EqReadSame.
        r_swap 1 5.
        rewrite EqReadSame.
        apply EqBind_r => i.
        r_swap 1 2.
        rewrite !EqReadSame.
        apply EqBind_r => x.
        rewrite !EqReadSame.
        apply EqBind_r => y.
        instantiate (1 := fun y => Ret y).
        destruct i; simpl.
        destruct b; done.
   swap_tac 0 4.
   swap_tac 1 10.
    rewrite (rerandomP_rs false).
    repeat ltac:(apply EqCongNew; intro).
    repeat ltac:(do_inline; simp_all).
    edit_tac 8.
        r_swap 1 3.
        rewrite EqReadSame.
        r_swap 1 5.
        rewrite EqReadSame.
        apply EqBind_r => i.
        r_swap 1 2.
        rewrite !EqReadSame.
        apply EqBind_r => x.
        rewrite !EqReadSame.
        apply EqBind_r => y.
        instantiate (1 := fun y => Ret y).
        destruct i; simpl.
        destruct b0; done.
  swap_tac 0 11.
  swap_tac 1 14.
    rewrite (rerandomP_rs false).
    repeat ltac:(apply EqCongNew; intro).
    repeat ltac:(do_inline; simp_all).
    edit_tac 11.
        r_swap 1 3.
        rewrite EqReadSame.
        r_swap 1 5.
        rewrite EqReadSame.
        apply EqBind_r => i.
        r_swap 1 2.
        rewrite !EqReadSame.
        apply EqBind_r => x.
        rewrite !EqReadSame.
        apply EqBind_r => y.
        instantiate (1 := fun y => Ret y).
        destruct i; simpl.
        destruct b0; done.
  apply EqRefl.
  apply EqRefl.
  (* Now elim useless channels *)
  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  setoid_rewrite (EqNewExch L.-bv) at 7.
  setoid_rewrite (EqNewExch L.-bv) at 8.
  setoid_rewrite (EqNewExch L.-bv) at 9.
  setoid_rewrite (EqNewExch L.-bv) at 10.
  setoid_rewrite (EqNewExch L.-bv) at 11.
  swap_tac 0 6.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  setoid_rewrite (EqNewExch L.-bv) at 7.
  setoid_rewrite (EqNewExch L.-bv) at 8.
  setoid_rewrite (EqNewExch L.-bv) at 9.
  setoid_rewrite (EqNewExch L.-bv) at 10.
  swap_tac 0 6.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  setoid_rewrite (EqNewExch L.-bv) at 7.
  setoid_rewrite (EqNewExch L.-bv) at 8.
  setoid_rewrite (EqNewExch L.-bv) at 9.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  setoid_rewrite (EqNewExch L.-bv) at 7.
  setoid_rewrite (EqNewExch L.-bv) at 8.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  setoid_rewrite (EqNewExch L.-bv) at 7.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  setoid_rewrite (EqNewExch L.-bv) at 6.
  under_new rewrite new_pars_remove; last first.
  apply EqRefl.

  (* Now undep the leaks *)
  etransitivity.
  repeat ltac:(apply EqCongNew; intro).
  swap_at 4 0 1.
  (* leak_ok_o3 *)
  swap_tac 0 4.
  swap_tac 1 7.
  rewrite -pars_mkdep //=.

  (* leak_ok_o2 *)
  swap_tac 0 5.
  swap_at 0 0 1.
  swap_tac 1 4.
  rewrite -pars_mkdep //=.

  (* leak_ot_o1 *)
  swap_tac 0 6.
  swap_at 0 0 1.
  swap_tac 1 2.
  rewrite -pars_mkdep //=.
  edit_tac 3.

    r_swap 1 3.
    r_swap 2 6.
    r_swap 3 9.
    r_swap 4 12.
    r_swap 5 15.
    rewrite !EqReadSame.
    apply EqBind_r => i.
    r_swap 1 2.
    rewrite !EqReadSame.
    apply EqBind_r => x.
    rewrite !EqReadSame.
    apply EqBind_r => y.
    r_swap 1 2.
    rewrite !EqReadSame.
    apply EqBind_r => z.
    rewrite !EqReadSame.
    apply EqBind_r => w.
    r_swap 1 2.
    rewrite !EqReadSame.
    apply EqBind_r => a.
    rewrite !EqReadSame.
    apply EqRxnRefl.
  apply EqRefl.

  (* Now fold in the samps *)
  simpl.
  setoid_rewrite (EqNewExch L.-bv) at 5.
  swap_tac 0 3.
  under_new swap_at 0 0 1.
  simpl.
  swap_tac 1 2.
  under_new rewrite pars_fold; [ apply EqRefl ].

  simpl.
  under_new swap_at 0 0 3.
  simpl.
  swap_tac 1 3.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  setoid_rewrite (EqNewExch L.-bv) at 4.
  under_new rewrite pars_fold; [ apply EqRefl ].

  simpl.
  under_new swap_at 0 0 5.
  simpl.
  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  swap_tac 1 2.
  under_new rewrite pars_fold; [ apply EqRefl ].

  (* Now simplify leak_send *)
  simpl.
  etransitivity.
  apply EqCongNew; intro.
  apply EqCongNew; intro.
  apply EqCongNew; intro.
  edit_tac 0.
    r_swap 0 3.
    r_swap 1 4.
    r_swap 2 5.
    r_swap 3 6.
    r_swap 4 7.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    instantiate (1 := fun x3 =>
                   x4 <-- Samp Unif ;;
                   x5 <-- Samp Unif ;;
                   x6 <-- Samp Unif ;;
                   Ret (
                       let o := (x3 # x.1) # x.2 in
                       let o0 := if x.2 && x.1 then o else tzero _ in
                       let o1 := if (~~ x.2) && x.1 then o else tzero _ in
                       let o2 := if (x.2) && (~~ x.1) then o else tzero _ in
                       let o3 := if (~~ x.2) && (~~ x.1) then o else tzero _ in
                       ( (
                              (x2, x4) # x.1 +t (x0, x6) # x.2 +t o3,
                              (x2, x4) # x.1 +t (x6, x0) # x.2 +t o2 ),
                         (
                              (x4, x2) # x.1 +t (x1, x5) # x.2 +t o1,
                              (x4, x2) # x.1 +t (x5, x1) # x.2 +t o0 )
                            ))).
    simpl.
    destruct x3 as [[m0 m1] [m2 m3]]; simpl.
    destruct x as [ [ | ] [ | ]]; simpl.

    rewrite (bind_samp_xor m1).
    apply EqBind_r => x.
    rewrite (bind_samp_xor m2).
    apply EqBind_r => y.
    rewrite (bind_samp_xor (m1 +t m0)).
    apply EqBind_r => z.
    rewrite (xortC _ x0).
    rewrite !xortA !xortK !xort0.
    rewrite (xortC m1) xortA xortK xort0.
    rewrite (xortC x0) //=.

    rewrite (bind_samp_xor m0).
    apply EqBind_r => x.
    rewrite (bind_samp_xor m3).
    apply EqBind_r => y.
    rewrite (bind_samp_xor (m0 +t m1)).
    apply EqBind_r => z.
    rewrite (xortC _ x0).
    rewrite !xortA !xortK !xort0.
    rewrite (xortC m0) xortA xortK xort0.
    rewrite (xortC x0) //=.

    rewrite (bind_samp_xor m3).
    apply EqBind_r => x.
    rewrite (bind_samp_xor (m3 +t m2)).
    apply EqBind_r => y.
    rewrite (bind_samp_xor m0).
    apply EqBind_r => z.
    rewrite !xortA !xortK !xort0.
    rewrite (xortC m3) xortA xortK xort0.
    rewrite (xortC m3) xortA xortK xort0 //=.

    rewrite (bind_samp_xor m2).
    apply EqBind_r => x.
    rewrite (bind_samp_xor (m3 +t m2)).
    apply EqBind_r => y.
    rewrite (bind_samp_xor m1).
    apply EqBind_r => z.
    rewrite !xortA !xortK !xort0.
    rewrite (xortC m3) xortA xortK xort0.
    rewrite (xortC m2) xortA xortK xort0 //=.
    rewrite (xortC m2) xortA xortK xort0 //=.
    apply EqRefl.

    rewrite /OT14_real_rerandomize.
    apply EqCongNew => c.
    apply EqCongNew => c1.
    apply EqCongNew => c2.
    align.
    apply EqCongReact; apply EqBind_r; intro; rewrite EqBindRet //=.
    apply EqCongReact; apply EqBind_r; intro; rewrite EqBindRet //=.
 Qed.

Definition OT14_sim (out : chan L.-bv) :=
c <- new L.-bv;;
c0 <- new L.-bv;;
c1 <- new L.-bv;;
[pars [:: Out leak_send
          (
            o <-- Read out ;;
            x <-- Read ot14_i;;
             x0 <-- Read c1;;
             x1 <-- Read c0;;
             x2 <-- Read c;;
             x4 <-- Samp Unif;;
             x5 <-- Samp Unif;;
             x6 <-- Samp Unif;;
             Ret
               (
                let o0 := if x .2 && x .1 then o else tzero L in
                let o1 := if ~~ x .2 && x .1 then o else tzero L in
                let o2 := if x .2 && ~~ x .1 then o else tzero L in
                let o3 := if ~~ x .2 && ~~ x .1 then o else tzero L in
                ((((x2, x4) # x .1 +t (x0, x6) # x .2) +t o3,
                  ((x2, x4) # x .1 +t (x6, x0) # x .2) +t o2),
                (((x4, x2) # x .1 +t (x1, x5) # x .2) +t o1,
                ((x4, x2) # x .1 +t (x5, x1) # x .2) +t o0))));
          Out leak_ot_o1 (_ <-- Read ot14_i;; Read c);
          Out leak_ot_o3 (_ <-- Read ot14_i;; Read c0);
          Out leak_ot_o2 (_ <-- Read ot14_i;; y <-- Read c1;; Ret y);
          Out c1 (Samp Unif); Out c (Samp Unif);
          Out c0 (Samp Unif) ] ].

Lemma OT14_real_simE :
  OT14_real_rerandomize =p
                           o <- new L.-bv ;;
                           pars [::
                                   OT14Ideal _ ot14_i ot14_m ot14_o;
                                   OT14Ideal _ ot14_i ot14_m o;
                                   OT14_sim o ].
  symmetry.
  rewrite /OT14Ideal.
  rewrite /OT14_sim.
  swap_tac 0 2.
  repeat setoid_rewrite newPars.
  repeat setoid_rewrite pars_pars; simpl.
  etransitivity.
  repeat ltac:(apply EqCongNew; intro).
  do_inline; simp_all.
  apply EqRefl.
  setoid_rewrite (EqNewExch L.-bv) at 1.
  setoid_rewrite (EqNewExch L.-bv) at 2.
  setoid_rewrite (EqNewExch L.-bv) at 3.
  swap_tac 0 7.
  under_new rewrite new_pars_remove. apply EqRefl.
  rewrite /OT14_real_rerandomize.
  apply EqCongNew => c.
  apply EqCongNew => c0.
  apply EqCongNew => c1.
  swap_tac 0 6.
  apply pars_cons_cong.
  apply EqCongReact.
  r_swap 1 2.
  rewrite EqReadSame.
  apply EqBind_r; intro.
  r_swap 0 1.
  apply EqBind_r; intro.
  r_swap 0 1.
  apply EqBind_r; intro.
  r_swap 0 1.
  apply EqBind_r; intro.
  apply EqBind_r; intro.
  apply EqBind_r; intro.
  apply EqBind_r; intro.
  apply EqBind_r; intro.
  destruct x as [ [|] [|] ]; done.
  align.
  apply _.
  apply _.
  apply _.
Qed.

Definition OT14_sim_ideal :=
                           o <- new L.-bv ;;
                           pars [::
                                   OT14Ideal _ ot14_i ot14_m ot14_o;
                                   OT14Ideal _ ot14_i ot14_m o;
                                   OT14_sim o ].

Theorem OT14_security :
  OT14_real =p OT14_sim_ideal.
  rewrite ot14_simp.
  rewrite ot_simpl_rerandomize.
  rewrite OT14_real_simE.
  done.
Qed.

Definition ot14_chans :=
[:: tag ot14_o; tag leak_ot_o1; tag leak_ot_o2; tag leak_ot_o3; tag leak_send].

Lemma OT14_t : ipdl_t ot14_chans OT14_real.
  rewrite /OT14_real /OTIdeal.
  rewrite /One4_sender /One4_recv.
  repeat type_tac.
  perm_match_step; rewrite insert_0.
  perm_match_step.
  perm_match_step.
  simpl in *.
  perm_match.
Qed.

Lemma OT14_sim_t o : ipdl_t [:: tag leak_send; tag leak_ot_o1; tag leak_ot_o3; tag leak_ot_o2] (OT14_sim o).
  rewrite /OT14_sim.
  repeat type_tac.
  perm_match.
Qed.

Lemma OT14_sim_ideal_t : ipdl_t ot14_chans OT14_sim_ideal.
  rewrite /OT14_sim_ideal.
  rewrite /OT14Ideal.
  repeat type_tac.
  apply OT14_sim_t.
  rewrite /ot14_chans.
  perm_match.
Qed.

End OneOutOf4.


Require Import GraphBasics.Graphs.
Require Import Coq.Logic.Classical_Prop.
Require Import Verdi.Verdi.

Require Export StructTact.Fin.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.

Require Import Verdi.ExtrOcamlBasicExt.
Require Import Verdi.ExtrOcamlList.

Load PO_III.

(* helping functions*)

Fixpoint remove (x : Component) (l : list Component) : list Component :=
    match l with
      | [] => []
      | y::tl => if ((Component_index x) == (Component_index y)) then tl else y::(remove x tl)
    end.

Definition empty (l : list Component) : bool :=
  match l with
  | nil => true
  | a :: m => false
  end.

(***)

Inductive Name := Checker : Component  -> Name.

(* get component from name*)
Definition name_component (n: Name): Component :=
match n with
  | Checker x => x
end.

Definition Nodes : list Name := (map Checker (CV_list v a g)) .

Axiom all_Names_Nodes : forall n, In n Nodes.

Axiom NoDup_Nodes : NoDup Nodes.

Definition Name_eq_dec : forall x y : Name, {x = y} + {x <> y}.
  decide equality.
  destruct c. destruct c0.
  case (eq_nat_dec n n0); intros H.
  left; rewrite H; trivial.
  right; injection; trivial.
Qed.

Inductive Msg := Checkermessage : list Fact -> Msg.

Definition Msg_eq_dec : forall x y : Msg, {x = y} + {x <> y}.
decide equality.
apply list_eq_dec.
apply fact_eq_dec.
Qed.

Record Checkerknowledge: Set := mk_Checkerknowledge {
  Inp : list inp;
  Sub_predicates: list Predicate;
  facts: list Key
}.

Record Checkerinput  := mk_Checkerinput {
output : list outp;
certificate : list Fact
}.

Inductive Input : Type :=
  | ci : Checkerinput -> Input
  | li : Checkerknowledge -> Input.

Definition Output := Msg.

Record Data := mkData{
 queue : list Component ;
 messages_received : list Component;
 consistent : bool ;
 checkerresult: bool;
 checkerinput : Checkerinput ;
 localinput : Checkerknowledge;
 initialized_localinput: bool;
 initialized_checkerinput: bool;
 control_neighbourlist: list Component
 }.

Definition init_Data (n: Name) := mkData
(neighbors g (name_component n)) [] true false (mk_Checkerinput [] [(fact_cons keynull valuenull)] ) (mk_Checkerknowledge []  []  []) false false (neighbors g (name_component n)).

Definition set_queue a v := mkData v  (messages_received a) (consistent a) (checkerresult a) (checkerinput a) (localinput a) (initialized_localinput a) (initialized_checkerinput a)(control_neighbourlist a) .
Definition set_consistent a v:= mkData (queue a) (messages_received a)  v (checkerresult a) (checkerinput a) (localinput a)(initialized_localinput a)(initialized_checkerinput a)(control_neighbourlist a).
Definition set_queue_consistent a q r c:= mkData q r  c (checkerresult a)(checkerinput a) (localinput a)(initialized_localinput a)(initialized_checkerinput a)(control_neighbourlist a).
Definition set_checkeroutput_queue a q r v:= mkData q r (consistent a)  v (checkerinput a) (localinput a)(initialized_localinput a)(initialized_checkerinput a)(control_neighbourlist a).

(* Send messages to all entries of a list (neighbours)*)
Fixpoint sendlist (neighbours: list Component) (me : Component)(cert: list Fact): list (Name * Msg)  :=
         match neighbours with
              | nil => [(Checker me, Checkermessage cert)]
              | n::m => (Checker n, Checkermessage cert) :: (sendlist m me cert)
         end.

(**** 2 Inputs -> 1. Input Checkerknowledge  2. Input Checkerinput (from component) **)
Definition InputHandler (me : Name) (c : Input) (state: Data) :
            (list Output) * Data * list (Name * Msg) :=
	match me,c  with
    (**** Initialize with Checkerknowledge  **)
    | Checker x, li locali => if  (eqb state.(initialized_localinput)  false) then
                             (* let myneighbors := (neighbors g x) in*)
                             ( [] , (mkData (queue state) [] true (checkerresult state) (checkerinput state) locali true (initialized_checkerinput state) (control_neighbourlist state)) , [])

                              else ([], state, [])
    (**** Initialize with Checkerinput, send message to all neighbours **)
		| Checker x, ci checkeri => if  (eqb state.(initialized_checkerinput) false)   then
                                let cert := checkeri.(certificate) in
                                ( [] , (mkData (queue state) [] (consistent state) (checkerresult state) checkeri (localinput state)(initialized_localinput state) true (control_neighbourlist state) ), (sendlist state.(queue) x cert))

                                else ([], state, [])

	end.

(** Check Consistency for a single fact *)
Definition One_Fact_Consistency_Check (c1 c2 : list Fact)  (key : Key) : bool :=
match (overlap c1 c2 key) with
          | (Some x, Some y) => if (beqValue  (findValue  c1 (Some x)) (findValue  c2 (Some y))) then true else false
          | (None, None) => false
          | (None, Some _ ) => false
          | (Some _, None ) => false
end.

(** Check Consistency for all facts in a fact list; return true if consistency is given for two certificate lists *)
Fixpoint All_Fact_Consistency_Check_ (init: bool) (c1 c2 : list Fact)  (keys : list Key) : bool :=
match keys with
          | nil  => init
          | a :: b => ( One_Fact_Consistency_Check c1 c2 a ) && All_Fact_Consistency_Check_ init c1 c2 b
end.

Functional Scheme all_fact_ind := Induction for All_Fact_Consistency_Check_  Sort Prop.

(** Initialize Consistency Check with true - Consistency Check for an empty list of facts returns true as well *)
Definition All_Fact_Consistency_Check := All_Fact_Consistency_Check_ true.

(*stub-function for next phase of checker, e.g. decide sub-predicates*)
Variable Check : Checkerknowledge -> Checkerinput -> bool.

Definition NetHandler (me : Name) (src: Name) (m : Msg) (state: Data) :
    (list Output) * Data * list (Name * Msg) :=

   (****  Consistency Check **)
    match m with
      | Checkermessage certif => if  (state.(initialized_localinput) && state.(initialized_checkerinput)) then

                                     let c := state.(checkerinput) in
                                     let l := state.(localinput) in
                                     let mycertif := c.(certificate) in
                                     let consistent := state.(consistent) && All_Fact_Consistency_Check mycertif certif l.(facts) in

                                       if (empty (remove (name_component src) state.(queue)) && (eqb consistent true)) then
                                            let result := Check state.(localinput) state.(checkerinput) in (** check () **)
     	                                      ([], (set_checkeroutput_queue state (remove  (name_component src) state.(queue)) ([(name_component src)] ++ state.(messages_received)) result) , []) (** finales Resultat **)
                                       else ([], (set_queue_consistent state  (remove  (name_component src) state.(queue)) ([(name_component src)] ++ state.(messages_received))  consistent), [])
                                 else ([], state,[])
   end.

(* verdi stuff*)

Instance Checker_BaseParams : BaseParams :=
  {
    data := Data;
    input := Input;
    output := Output
  }.

Instance Checker_MultiParams : MultiParams Checker_BaseParams :=
  {
    name := Name;
    name_eq_dec := Name_eq_dec;
    msg := Msg;
    msg_eq_dec := Msg_eq_dec;
    nodes := Nodes;
    all_names_nodes := all_Names_Nodes;
    no_dup_nodes := NoDup_Nodes;
    init_handlers := init_Data;
    input_handlers := InputHandler ;
    net_handlers := NetHandler

    }.

(** helping functions for verification **)

(* get certificate in message *)
Definition certificate_from_message ( msg: Msg) :  list Fact :=
match msg with
  | Checkermessage certif => certif
end.

Definition initialized (state: Data) :=
(state.(initialized_localinput) && state.(initialized_checkerinput)).

(* If one fact consistency check returns true for x y na, then we have fact consistency for x y na *)
Lemma One_Fact_Consistency_Check_true:
forall cert1 cert2 key, One_Fact_Consistency_Check cert1 cert2 key = true -> consistent_in_var cert1 cert2 key.
Proof.
intros.
unfold One_Fact_Consistency_Check in *.
unfold consistent_in_var.
repeat break_match.
intros.
inversion H0.
apply beqValue_eq in Heqb.
trivial.
discriminate.
discriminate.
discriminate.
discriminate.
Qed.

(* helping lemma *)
Lemma Consistency_Check_List:
forall a c1 c2 keys, (forall k, In k (a :: keys) -> One_Fact_Consistency_Check c1 c2 k = true) -> (forall m : Key, In m keys -> One_Fact_Consistency_Check c1 c2 m = true ).
Proof.
intros.
apply in_cons with (a:=a0) in H0.
apply H in H0.
trivial.
Qed.

(* If one fact consistency check returns true for x y and all facts in fact list, then All_Fact_Consistency Check returns true for x y and fact list*)
Lemma one_fact_all_fact :
forall c1 c2 keys, (forall k,  In k keys ->  One_Fact_Consistency_Check c1 c2 k = true) -> All_Fact_Consistency_Check c1 c2 keys = true.
Proof.
intros.
unfold All_Fact_Consistency_Check.
induction keys.
unfold All_Fact_Consistency_Check_.
trivial.
unfold All_Fact_Consistency_Check_.
apply andb_true_iff.
split.
apply H with (k:=a0).
apply in_eq.
fold All_Fact_Consistency_Check_.
apply IHkeys.
intros.
apply Consistency_Check_List with (a:=a0) (keys :=keys).
apply H .
trivial.
Qed.

Lemma both_one_fact_all_fact :
forall c1 c2 keys, All_Fact_Consistency_Check c1 c2 keys = true -> (forall k,  In k keys ->  One_Fact_Consistency_Check c1 c2 k = true)  .
Proof.
intros.
unfold All_Fact_Consistency_Check in *.
unfold All_Fact_Consistency_Check_ in *.
induction keys.
unfold One_Fact_Consistency_Check.
  repeat break_match; repeat tuple_inversion;
      subst; simpl in *; subst; simpl in *.
trivial.
exfalso.
trivial.
exfalso.
trivial.
exfalso.
trivial.
exfalso.
trivial.

fold All_Fact_Consistency_Check_ in *.
apply andb_true_iff in H.
destruct H.
destruct H0.
rewrite H0 in H.
trivial.
apply IHkeys.
auto.
auto.
Qed.

Variable localin : Checkerknowledge.

Lemma both_one_fact_all_fact_allna :
forall c1 c2, All_Fact_Consistency_Check c1 c2 localin.(facts) = true ->
(forall k,  In k localin.(facts) ->  One_Fact_Consistency_Check c1 c2 k = true)  .
Proof.
intros.
apply both_one_fact_all_fact with (keys:=localin.(facts)).
trivial.
trivial.
Qed.

Definition keylist (a : list Fact) : list Key :=   map fact_key a.

Variable all_Keys: list Key.
Axiom all_in_all_Keys:
forall key: Key , In key all_Keys.

Axiom keylistprop: forall k cert1 n,  get_pos cert1 k = Some n -> In k (keylist cert1).

Axiom allkeylist: forall k cert1 , In k (facts localin) <-> In k (keylist cert1).

Lemma inkeylist:
forall cert1 cert2 k, overlapping_in_var cert1 cert2 k -> In k (keylist cert1).
Proof.
intros.
unfold overlapping_in_var in *.
unfold overlap in *.
repeat break_match.
apply keylistprop in Heqo; trivial.
destruct H. destruct H. discriminate.
destruct H. destruct H.  discriminate.
destruct H. destruct H.  discriminate.
Qed.

Lemma All_Fact_Consistency_Check_for_true:
forall cert1 cert2 , All_Fact_Consistency_Check cert1 cert2 localin.(facts) = true -> consistent_in_all_var cert1 cert2.
Proof.
intros.
apply consistency_defs.
unfold consistent_alt.
intros.
apply both_one_fact_all_fact_allna with (k:=k) in H.
unfold overlapping_in_var in H0.
apply One_Fact_Consistency_Check_true in H.
unfold consistent_in_var in H.
unfold overlap in *.
repeat break_match.
destruct H0. destruct H0.
assert (G:=H0). apply H in H0. inversion G. rewrite <- H2. rewrite <-  H3. trivial.
destruct H0. destruct H0. discriminate.
destruct H0. destruct H0. discriminate.
destruct H0. destruct H0. discriminate.
trivial.
apply inkeylist in H0.
apply allkeylist in H0.
trivial.
Qed.

(************************ FOR ALL IN MESSAGES RECEIVED -> ALL FACT CONSISTENCY ********************)

Lemma inititialized_nethandler_b:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
initialized dataout = true -> initialized data = true.
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
inversion H.
unfold initialized.
trivial.
trivial.
inversion H.
trivial.
Qed.

Lemma inititialized_nethandler_:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
initialized_localinput data &&
initialized_checkerinput data  = true ->
initialized_checkerinput dataout = true.
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
unfold set_checkeroutput_queue in H.
find_inversion. simpl in *.
apply andb_true_iff in Heqb.
destruct Heqb.
trivial.
find_inversion. simpl in *.
apply andb_true_iff in Heqb.
destruct Heqb.
trivial.
discriminate.
Qed.

Lemma inititialized_nethandler_2:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
initialized_localinput data &&
initialized_checkerinput data  = true ->
initialized_localinput dataout = true.
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
unfold set_checkeroutput_queue in H.
find_inversion. simpl in *.
apply andb_true_iff in Heqb.
destruct Heqb.
trivial.
find_inversion. simpl in *.
apply andb_true_iff in Heqb.
destruct Heqb.
trivial.
discriminate.
Qed.

Lemma consistent_nethandler_b:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
consistent dataout = true -> consistent data = true.
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
unfold set_checkeroutput_queue in H.
find_inversion. simpl in *. trivial.
find_inversion. simpl in *. apply andb_true_iff in H0.
destruct H0. trivial.
inversion H.
trivial.
Qed.

Lemma consistent_inputhandler_b:
forall me input data u dataout l ,
InputHandler me input data = (u, dataout, l) ->
initialized data = true ->
consistent dataout = true -> consistent data = true.
Proof.
intros.
unfold InputHandler in *.
repeat break_match.
find_inversion. simpl in *. trivial.
find_inversion. trivial.
find_inversion. simpl in *. unfold initialized in H0.
apply andb_true_iff in H0. destruct H0.
apply eqb_prop in Heqb. rewrite H in Heqb. discriminate.
find_inversion. trivial.
Qed.

Lemma initialized_inputhandler_b:
forall me input data u dataout l ,
InputHandler me input data = (u, dataout, l) ->
messages_received dataout <> [] ->
initialized dataout = true -> initialized data = true.
Proof.
intros.
unfold InputHandler in *.
repeat break_match.
find_inversion. simpl in *. contradiction.

find_inversion. trivial.
find_inversion. simpl in *. contradiction.
find_inversion. trivial.
Qed.

Axiom certificate_from_src :
forall l me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
msg = Checkermessage l ->
getCertificate (name_component src) =  l.

Lemma consistency_check_in_src :
forall me src msg data u dataout st',
initialized data = true ->
NetHandler me src msg data = (u, dataout, st') ->
dataout.(consistent) = true ->
All_Fact_Consistency_Check data.(checkerinput).(certificate) (getCertificate (name_component src))  data.(localinput).(facts) = true.
Proof.
intros.
assert (G:=H0).
unfold NetHandler in H0.
repeat break_match.
- apply andb_true_iff in Heqb0.
destruct Heqb0.
apply eqb_prop in H3.

rewrite  certificate_from_src with (data:=data)(me:=me)(src:=src)(msg:=msg)(u:=u)(dataout:=dataout)(st':=st')(l:=l).
trivial.
apply andb_true_iff  in H3.
destruct H3.
trivial.
trivial.
rewrite Heqm.
trivial.
trivial.
-
rewrite  certificate_from_src with (data:=data)(me:=me)(src:=src)(msg:=msg)(u:=u)(dataout:=dataout)(st':=st')(l:=l).
find_inversion. simpl in *. subst.
apply andb_true_iff  in H1.
destruct H1.
trivial.
rewrite Heqm.
trivial.
trivial.
- unfold initialized in H.
rewrite H in Heqb.
discriminate.
Qed.

Lemma consistency_check_NetHandler :
forall me src msg data u dataout st',
initialized dataout = true ->
dataout.(consistent) = true ->
NetHandler me src msg data = (u, dataout, st') ->
forall k,
(In k data.(messages_received)  ->
All_Fact_Consistency_Check data.(checkerinput).(certificate) (getCertificate  k)  data.(localinput).(facts) = true) ->
(In k dataout.(messages_received) ->
All_Fact_Consistency_Check data.(checkerinput).(certificate) (getCertificate  k)  data.(localinput).(facts) = true).
Proof.
intros.
assert (G:=H0).
assert (N:=H1).
unfold NetHandler in H1.
repeat break_match.
- apply andb_true_iff in Heqb0.
destruct Heqb0.
apply eqb_prop in H5.
apply andb_true_iff in H5.
inversion H1. simpl in *.
unfold set_checkeroutput_queue in H8.
find_inversion. simpl in *. subst.
destruct H3.
rewrite <- H1.
apply consistency_check_in_src with  (me:=me)(src:=src)(msg:=Checkermessage l)(u:=[])(dataout:= {|
    queue := remove (name_component src) (queue data);
    messages_received := name_component src :: messages_received data;
    consistent := consistent data;
    checkerresult := Check (localinput data) (checkerinput data);
    checkerinput := checkerinput data;
    localinput := localinput data;
    initialized_localinput := initialized_localinput data;
    initialized_checkerinput := initialized_checkerinput data;
    control_neighbourlist := control_neighbourlist data
  |})(st':=[]).
    unfold initialized.
    trivial.
    unfold NetHandler.
    apply N.
    simpl in *.
    destruct H5.
    trivial.
    apply H2.
    trivial.
   - apply andb_false_iff in Heqb0.
     destruct Heqb0.
     unfold set_queue_consistent in H1.
     find_inversion. simpl in *. subst.
     destruct H3.
     rewrite <- H1.
    apply consistency_check_in_src with  (me:=me)(src:=src)(msg:=Checkermessage l)(u:=[])(dataout:= {|
      queue := remove (name_component src) (queue data);
      messages_received := name_component src :: messages_received data;
      consistent := consistent data &&
                    All_Fact_Consistency_Check
                      (certificate (checkerinput data)) l
                      (facts (localinput data));
      checkerresult := checkerresult data;
      checkerinput := checkerinput data;
      localinput := localinput data;
      initialized_localinput := initialized_localinput data;
      initialized_checkerinput := initialized_checkerinput data;
      control_neighbourlist := control_neighbourlist data |} )(st':=[]).
    unfold initialized.
    trivial.
     unfold NetHandler.
    apply N.
    simpl in *.
    apply G.
    apply H2.
    trivial.
    inversion H1. simpl in *. subst.
    unfold set_queue_consistent in G. simpl in *.
    apply eqb_false_iff  in H4.
    contradiction.
   -apply inititialized_nethandler_b with (me:=me)(src:=src) (msg:=msg) (data:=data) (dataout:=dataout) (st':=st') (u:=u) in H.
    unfold initialized in H.
    rewrite H in Heqb.
    discriminate.
    rewrite Heqm.
    trivial.
Qed.

Lemma facts_nethandler:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
initialized dataout = true ->
facts (localinput (data)) = facts (localinput (dataout)).
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
find_inversion. simpl in *. reflexivity.
find_inversion. simpl in *. reflexivity.
find_inversion. simpl in *. reflexivity.
Qed.

Lemma certificate_nethandler:
forall me src msg data u dataout st',
NetHandler me src msg data = (u, dataout, st') ->
initialized dataout = true ->
(certificate (checkerinput data )) = (certificate (checkerinput dataout)).
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
find_inversion; simpl in *; reflexivity.
find_inversion; simpl in *; reflexivity.
find_inversion; simpl in *; reflexivity.
Qed.

Lemma certificate_inputhandler:
forall me input data u dataout l,
InputHandler me input data = (u, dataout, l) ->
messages_received dataout <> [] ->
(certificate (checkerinput data )) = (certificate (checkerinput dataout)).
Proof.
intros.
unfold InputHandler in *.
repeat break_match.
find_inversion. simpl in *. contradiction.
find_inversion. trivial.
find_inversion. simpl in *. contradiction.
find_inversion. trivial.
Qed.

Lemma facts_inputhandler:
forall me input data u dataout l,
InputHandler me input data = (u, dataout, l) ->
messages_received dataout <> [] ->
facts (localinput (data)) = facts (localinput (dataout)).
Proof.
intros.
unfold InputHandler in *.
repeat break_match.
find_inversion. simpl in *. contradiction.
find_inversion. trivial.
find_inversion. simpl in *. contradiction.
find_inversion. trivial.
Qed.

Lemma consistency_check_Inputhandler :
forall me input data u dataout l,
InputHandler me input data = (u, dataout, l) ->
messages_received dataout <> []  ->
dataout.(consistent) = true ->
forall k,
(In k data.(messages_received)  ->
All_Fact_Consistency_Check data.(checkerinput).(certificate) (getCertificate  k)  data.(localinput).(facts) = true) ->
(In k dataout.(messages_received) ->
All_Fact_Consistency_Check dataout.(checkerinput).(certificate) (getCertificate  k)  dataout.(localinput).(facts) = true).
Proof.
intros.
assert (G:=H).
assert (I:=H).
unfold InputHandler in H.
repeat break_match.
assert (K:=H0).

apply facts_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in H0.
rewrite <- H0.
apply certificate_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in K.
rewrite <- K.
apply H2.
find_inversion. simpl in *. subst.
trivial.
exfalso. trivial.
rewrite Heqi.
rewrite Heqn.
trivial.
rewrite Heqn.
rewrite Heqi.
trivial.

assert (K:=H0).
apply facts_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in H0.
rewrite <- H0.
apply certificate_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in K.
rewrite <- K.
apply H2.
find_inversion. simpl in *. subst.
trivial.
rewrite Heqn.
rewrite Heqi.
trivial.
rewrite Heqn.
rewrite Heqi.
trivial.

find_inversion. simpl in *. exfalso. trivial.

assert (K:=H0).
apply facts_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in H0.
rewrite <- H0.
apply certificate_inputhandler with (me:=me) (input:=input) (data:=data) (u:=u) (dataout:=dataout) (l:=l) in K.
rewrite <- K.
apply H2.
find_inversion. simpl in *. subst.
trivial.
rewrite Heqn.
rewrite Heqi.
trivial.
rewrite Heqn.
rewrite Heqi.
trivial.
Qed.

Lemma notEmptylist:
forall (clist : list Component), clist <> [] -> exists (m:Component), In m clist.
Proof.
intros.
destruct clist.
contradiction.
exists c.
apply  in_eq .
Qed.

Lemma notEmptylist_b:
forall (clist : list Component) m, In m clist -> clist <> [].
Proof.
intros.
destruct clist.
contradiction.
apply not_eq_sym.
apply nil_cons.
Qed.

Lemma All_Fact_Consistency_Check_Network:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall component c,
(nwState net (Checker c)).(initialized)  = true ->
(nwState net (Checker c)).(consistent)  = true ->
(In component (nwState net (Checker c)).(messages_received) ->
All_Fact_Consistency_Check  (nwState net (Checker c)).(checkerinput).(certificate) (getCertificate  component)  (nwState net (Checker c)).(localinput).(facts) = true).
Proof.
intros net tr H .
remember step_async_init as y in *.
induction H using refl_trans_1n_trace_n1_ind. intros. subst.
simpl in *.
exfalso.
trivial.
intros.
invc H0.

- destruct p. destruct pDst. unfold nwState in *. unfold update in *. repeat break_match.
+  unfold net_handlers in *. unfold Checker_MultiParams in *. simpl in *.
assert (J:=H3).

apply consistency_check_NetHandler with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l) (k:=component) (data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d)  in H3.
rewrite <- certificate_nethandler with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l) (data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d).
rewrite <- facts_nethandler with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l) (data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d).
apply H3.
trivial.
trivial.
trivial.
trivial.
trivial.
trivial.
apply IHrefl_trans_1n_trace1  with (c:=c0).
trivial.
apply consistent_nethandler_b  with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l)(data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d)  in H3.
apply inititialized_nethandler_b  with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l)(data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d)  in H2.
trivial.
trivial.
trivial.
apply consistent_nethandler_b  with (me :=(Checker c0)) (src:=pSrc)(u:=out) (st':=l)(data:=(nwState (Checker c0))) (msg:= pBody ) (dataout:=d)  in H3.
trivial.
trivial.
trivial.
+
concludes. apply IHrefl_trans_1n_trace1. trivial. trivial. trivial.
-destruct h. unfold nwState in *. unfold update in *. repeat break_match.
+  unfold input_handlers in *. unfold Checker_MultiParams in *. concludes.
apply consistency_check_Inputhandler with (k:=component) in H5 .
trivial.
assert (G:=H4).
apply notEmptylist_b in H4.
trivial.
trivial.
apply IHrefl_trans_1n_trace1 with (c:=c0).
apply initialized_inputhandler_b in H5.
trivial.
apply notEmptylist_b in H4.
trivial.
trivial.
apply consistent_inputhandler_b in H5.
trivial.
apply initialized_inputhandler_b in H5.
trivial.
apply notEmptylist_b in H4.
trivial.
trivial.
trivial.
trivial.
+ concludes. apply IHrefl_trans_1n_trace1. trivial. trivial. trivial.
Qed.

Axiom all_keys_in_nw:
forall  net tr c,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
facts (localinput (nwState net (Checker c))) = localin.(facts).

Lemma All_Fact_Check_Network:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall component c,
(nwState net (Checker c)).(initialized)  = true ->
(nwState net (Checker c)).(consistent)  = true ->
(In component (nwState net (Checker c)).(messages_received)) ->
consistent_in_all_var (nwState net (Checker c)).(checkerinput).(certificate) (getCertificate  component) .
Proof.
intros.
apply All_Fact_Consistency_Check_for_true.
rewrite <- all_keys_in_nw with (net:=net) (tr:=tr) (c:=c).
apply All_Fact_Consistency_Check_Network with (net:=net) (c:=c) (tr:=tr) (component:=component);trivial.
trivial.
Qed.

(********************************* QUEUE EMPTY -> ALL IN MESSAGES RECEIVED ***************************************************************)

Lemma removeprop:
forall name k l1 l2,
 In k (l1 ++ l2) ->
 In k   (remove (name_component name) l1 ++  name_component name :: l2).
Proof.
intros.
apply in_app_or in H.
destruct H.
apply in_or_app.
- assert ({k= name_component name} + {k <> name_component name}) .
  destruct name.
  destruct k.
  destruct Checker.
  destruct name_component.
  destruct index.
  apply V_eq_dec with (x:= index n1) (y:=index n0).
destruct H0.
right.
rewrite e.
apply in_eq .
left.
induction l1; auto.
destruct H.
rewrite H.
unfold remove.
repeat break_match.
apply beq_nat_true in Heqb.
unfold Component_index in Heqb.
repeat break_match.
rewrite Heqb in n.
contradiction.
simpl.
left.
reflexivity.
unfold remove.
repeat break_match.
trivial.
fold remove.
unfold In.
right.
unfold In in IHl1.
apply IHl1.
unfold In in H.
trivial.
- apply in_or_app.
right.
apply in_cons with (a:=name_component name) in H.
trivial.
Qed.

Lemma allincontrol_queue_messagesreceived_nethandler:
forall me src msg data u dataout st' k,
NetHandler me src msg data = (u, dataout, st') ->
(In k (control_neighbourlist data) -> In k ((queue data ) ++ (messages_received data))) ->
(In k (control_neighbourlist dataout) -> In k ( ( queue dataout ) ++ (messages_received dataout))).
Proof.
intros.
unfold NetHandler in *.
repeat break_match. inversion H.
unfold set_checkeroutput_queue in * .
find_inversion. simpl in *.
apply removeprop with (l1:=queue data) (l2:=messages_received data) (k:=k) (name:=src).

apply H0.
trivial.
intros.
find_inversion.
unfold set_queue_consistent.
simpl in *.
apply removeprop with (l1:=queue data) (l2:=messages_received data) (k:=k) (name:=src).
apply H0.
trivial.
intros.

unfold NetHandler in *.
repeat break_match. inversion H.
unfold set_checkeroutput_queue in * .
find_inversion. apply H0.
trivial.
Qed.

Lemma initialized_false__prop_nethandler_b:
forall me src msg data u dataout st' ,
NetHandler me src msg data = (u, dataout, st') ->
dataout.(initialized_checkerinput) = false ->
data.(initialized_checkerinput) = false.
Proof.
intros.
unfold NetHandler in *.
repeat break_match.
apply andb_true_iff in Heqb. destruct Heqb. unfold set_checkeroutput_queue. find_inversion. simpl in *.
rewrite  H0 in H2. discriminate.
unfold  set_queue_consistent . find_inversion. simpl in *.
apply andb_true_iff in Heqb. destruct Heqb. rewrite H0 in H1. discriminate.
find_inversion. trivial.
Qed.

Lemma initialized_false_network_nethandler:
forall me src msg data u dataout st' ,
NetHandler me src msg data = (u, dataout, st') ->
data.(initialized_checkerinput) = false ->
data.(queue) = data.(control_neighbourlist) ->
dataout.(queue) = dataout.(control_neighbourlist).
Proof.
intros.
assert (G:=H).
unfold NetHandler in *.
repeat break_match.
apply andb_true_iff in Heqb. destruct Heqb. unfold set_checkeroutput_queue. find_inversion. simpl in *. rewrite H0 in H3. discriminate.
apply andb_true_iff in Heqb. destruct Heqb. rewrite H0 in H3. discriminate.
find_inversion. trivial.
Qed.

Lemma initialized_false_network:
forall  net tr ,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall c,
(nwState net (Checker c)).(initialized_checkerinput) = false ->
(nwState net (Checker c)).(queue) = (nwState net (Checker c)).(control_neighbourlist).
Proof.
  intros net tr  H.
  remember step_async_init as y in *.
  induction H using refl_trans_1n_trace_n1_ind. intros. subst. reflexivity.
  invc H0.
  - intros.  destruct p. destruct pDst. unfold nwState in *. unfold update in *. repeat break_match.
  +  unfold net_handlers in *. unfold Checker_MultiParams in *. simpl in *.
     apply initialized_false_network_nethandler in H3. trivial.
     apply initialized_false__prop_nethandler_b with (msg:=pBody) (src:=pSrc) (data:=(nwState (Checker c0))) (me:=(Checker c0)) (dataout:=d) (u:=out) (st':=l) in H3. trivial. trivial.
     concludes. apply IHrefl_trans_1n_trace1  with (c:=c0). apply initialized_false__prop_nethandler_b with (msg:=pBody) (src:=pSrc) (data:=(nwState (Checker c0))) (me:=(Checker c0)) (dataout:=d) (u:=out) (st':=l) in H3. trivial. trivial.
  +  concludes. apply IHrefl_trans_1n_trace1. trivial.
  - intros. destruct h. unfold nwState in *. unfold update in *. repeat break_match.
  *   unfold input_handlers in *. unfold Checker_MultiParams in *. concludes.
  intros.
  unfold InputHandler in *.
  repeat break_match.
  find_inversion. simpl in *. discriminate.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
   find_inversion. simpl in *.  apply IHrefl_trans_1n_trace1  with (c:=c0). trivial. find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
 *  apply IHrefl_trans_1n_trace1. trivial. trivial.
Qed.

Lemma messages_received_not_empty_nethandler:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall c,
(nwState net (Checker c)).(initialized_checkerinput) = false ->
(nwState net (Checker c)).(queue) = (nwState net (Checker c)).(control_neighbourlist).
Proof.
  intros net tr  H.
  remember step_async_init as y in *.
  induction H using refl_trans_1n_trace_n1_ind. intros. subst. reflexivity.
  invc H0.

  - intros. destruct (pDst p) eqn:?. unfold nwState in *. unfold update in *. repeat break_match.
  +
     unfold net_handlers in *. unfold Checker_MultiParams in *. assert (K:=H3). unfold NetHandler in H3. concludes.
     repeat break_match.
   apply inititialized_nethandler_ in K.  rewrite K in H0. discriminate. trivial.
   apply inititialized_nethandler_ in K.  rewrite K in H0. discriminate. trivial.
     find_inversion. apply IHrefl_trans_1n_trace1.  trivial.
  + apply IHrefl_trans_1n_trace1. trivial. trivial.
   - intros. destruct h. unfold nwState in *. unfold update in *. repeat break_match.

  *   unfold input_handlers in *. unfold Checker_MultiParams in *. concludes.  unfold InputHandler in *.
  repeat break_match.
  find_inversion. simpl in *. discriminate.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
   find_inversion. simpl in *. trivial.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
 *  apply IHrefl_trans_1n_trace1. trivial. trivial.
Qed.

Lemma messages_received_not_empty_nethandler2:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall c,
(nwState net (Checker c)).(initialized_localinput) = false ->
(nwState net (Checker c)).(queue) = (nwState net (Checker c)).(control_neighbourlist).
Proof.
  intros net tr  H.
  remember step_async_init as y in *.
  induction H using refl_trans_1n_trace_n1_ind. intros. subst. reflexivity.
  invc H0.
 - intros. destruct (pDst p) eqn:?. unfold nwState in *. unfold update in *. repeat break_match.
     unfold net_handlers in *. unfold Checker_MultiParams in *. assert (K:=H3). unfold NetHandler in H3. concludes.
     repeat break_match.
     apply inititialized_nethandler_2 in K. rewrite K in H0. discriminate. trivial.
     apply inititialized_nethandler_2 in K.  rewrite K in H0. discriminate. trivial.
         find_inversion. apply IHrefl_trans_1n_trace1.  trivial.
      apply IHrefl_trans_1n_trace1. trivial. trivial.
 -  intros. destruct h. unfold nwState in *. unfold update in *. repeat break_match.
 * unfold input_handlers in *. unfold Checker_MultiParams in *. concludes. unfold InputHandler in *. repeat break_match.
  find_inversion. simpl in *.  apply IHrefl_trans_1n_trace1 with (c:=c0); trivial.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
  find_inversion.  simpl in *. apply IHrefl_trans_1n_trace1  with (c:=c0). apply eqb_prop in Heqb. discriminate.
  find_inversion. apply IHrefl_trans_1n_trace1  with (c:=c0). trivial.
 *  apply IHrefl_trans_1n_trace1. trivial. trivial.
Qed.

Lemma queue_message_received_equals_controllist:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall k c,
In k (nwState net (Checker c)).(control_neighbourlist) ->
In k ( (nwState net (Checker c)).(queue) ++ (nwState net (Checker c)).(messages_received)).
Proof.
intros net tr H.
  remember step_async_init as y in *.
  induction H using refl_trans_1n_trace_n1_ind. intros. subst. unfold step_async_init in *. unfold nwState in *. unfold init_handlers in *. unfold Checker_MultiParams in *. unfold init_Data in *. simpl in *. trivial. rewrite app_nil_r. trivial.
- invc H0.
+ destruct (pDst p) eqn:?.  unfold nwState in *. unfold update in *. intros. repeat break_match.
  unfold net_handlers in *. unfold Checker_MultiParams in *. concludes.
  apply allincontrol_queue_messagesreceived_nethandler with
  (st':=l)(u:=out) (k :=k)(me:= (pDst p)) (src:=(pSrc p)) (msg:= (pBody p) )(data:= (nwState (Checker c)) ) (dataout:=d) in H3.
  trivial.
  apply IHrefl_trans_1n_trace1 with (k:=k) (c:=c).
  simpl in *.
  trivial.
  apply IHrefl_trans_1n_trace1 with (k:=k) (c:=c0); trivial.
+ intros. destruct h. unfold nwState in *. unfold update in *. repeat break_match.
*
  unfold input_handlers in *. unfold Checker_MultiParams in *. concludes.
  intros.
  unfold InputHandler in *.   repeat break_match.  find_inversion. intros. simpl in *. rewrite app_nil_r.
  apply eqb_prop in Heqb.
  apply messages_received_not_empty_nethandler with (c:=c) in H. simpl in *.
  rewrite <- e. rewrite H. rewrite <-  e in H0. trivial. simpl in *. rewrite  e. trivial.
  intros. find_inversion. apply IHrefl_trans_1n_trace1 with (c:=c0). trivial.
  intros. find_inversion. simpl in *.  rewrite app_nil_r.   apply eqb_prop in Heqb.
  apply messages_received_not_empty_nethandler2 with (c:=c0) in H. simpl in *. rewrite H. trivial. simpl in *. trivial.
  find_inversion.  apply IHrefl_trans_1n_trace1 with (c:=c0). trivial. (*apply IHrefl_trans_1n_trace1 with (c:=c0). trivial.*)
* intros.  apply IHrefl_trans_1n_trace1 . trivial. trivial.
Qed.

Lemma queue_empty_message_received_equals_controllist:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall k c,
(nwState net (Checker c)).(queue) = [] ->
In k (nwState net (Checker c)).(control_neighbourlist) ->
In k  (nwState net (Checker c)).(messages_received).
Proof.
intros.
apply queue_message_received_equals_controllist with (k:=k) (c:=c) in H.
rewrite  H0 in H.
auto.
trivial.
Qed.

(***************** ALL IN CONTROLL LIST ARE NEIGHBOURS *******************)

Lemma neighbours_controllist_nethandler:
forall me src msg data u dataout st' k,
NetHandler me src msg data = (u, dataout, st') ->
(In k (neighbors g (name_component me) ) ->
In k (control_neighbourlist data))  ->
( In k (neighbors g (name_component me)) ->
In k (control_neighbourlist dataout )).
Proof.
intros.
assert (K:=H).
unfold NetHandler in *.
repeat break_match.
unfold set_checkeroutput_queue in *.
inversion H.
simpl in *.
apply  andb_true_iff in Heqb.
destruct Heqb.
apply H0.
trivial.
inversion H.
simpl in *.
trivial.
unfold set_queue_consistent.
inversion H.
simpl in *.
apply H0.
trivial.
inversion H.
rewrite <- H4.
apply H0.
trivial.
Qed.

Lemma local_input_Inputhandler :
forall me  data u input dataout l,
InputHandler me input data = (u, dataout, l) ->
forall k,
( In k (neighbors g  (name_component me)) ->
In k data.(control_neighbourlist)) ->
(In k (neighbors g  (name_component me)) ->
In k dataout.(control_neighbourlist)).
Proof.
intros.
unfold InputHandler in *.
repeat break_match.
find_inversion; simpl in *.
apply H0;trivial.
find_inversion; simpl in *.  apply H0;trivial.
find_inversion; simpl in *.  apply H0;trivial.
find_inversion; simpl in *.  apply H0;trivial.
Qed.

Lemma neighbours_in_controllist:
forall  net tr ,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall c k,
In k (neighbors g c) ->
In k (nwState net (Checker c)).(control_neighbourlist).
Proof.
intros net tr H.
  remember step_async_init as y in *.
  induction H using refl_trans_1n_trace_n1_ind. intros. subst. unfold initialized in *. unfold step_async_init in *. unfold nwState in *. unfold init_handlers in *. unfold Checker_MultiParams in *. unfold init_Data in *. simpl in *. trivial.
  (*step*)
   invc H0.

  (*NetHandler*)
  +
  intros. destruct (pDst p) eqn:?. unfold nwState in *. unfold update in *. repeat break_match.
 -   unfold net_handlers in *. unfold Checker_MultiParams in *.
     apply neighbours_controllist_nethandler with (k:=k) in H3. trivial. intros. apply IHrefl_trans_1n_trace1. trivial. trivial. rewrite <- e.  unfold name_component. trivial.
  -   apply IHrefl_trans_1n_trace1; trivial.
 (*InputHandler*)
  +   intros. destruct h. unfold nwState in *. unfold update in *. repeat break_match.
  *   unfold input_handlers in *. unfold Checker_MultiParams in *. concludes.   assert (G:=H2). unfold InputHandler in H2.  repeat break_match.

   apply local_input_Inputhandler with (k:=k) in G. trivial.  intros. apply IHrefl_trans_1n_trace1.  inversion e. rewrite <- H5. trivial. rewrite <- e.  unfold name_component. trivial.

    find_inversion.  simpl in *.  apply IHrefl_trans_1n_trace1 . trivial.  inversion e. rewrite <- H3. trivial.
       find_inversion.  simpl in *. inversion e. rewrite <- H3. apply IHrefl_trans_1n_trace1 . trivial.
    find_inversion. simpl in *. rewrite <- e. apply IHrefl_trans_1n_trace1. trivial.
 *  concludes. apply IHrefl_trans_1n_trace1; trivial.
Qed.

(*********************** FINAL THEOREM ***********************************)

Axiom getCertificate_prop:
forall  net c,
certificate (checkerinput (nwState net (Checker c))) =  (getCertificate (name_component (Checker c))).

Lemma Neighbourhood_Consistency_Ver:
forall  net tr,
step_async_star (params := Checker_MultiParams) step_async_init net tr ->
forall c,
(nwState net (Checker c)).(consistent) = true ->
(nwState net (Checker c)).(initialized) = true ->
(nwState net (Checker c)).(queue) = [] ->
neighbourhood_consistent( name_component (Checker c)).
Proof.
intros.
unfold neighbourhood_consistent.
intros.
apply All_Fact_Check_Network  with (component := comp1) (c:=c) in H.
trivial.
rewrite <- getCertificate_prop with (net:=net).
apply H.
apply queue_empty_message_received_equals_controllist with (k:=comp1) (c:=c) in H.
trivial.
trivial.
unfold initialized in H1.
apply  andb_true_iff in H1.
destruct H1.
apply neighbours_in_controllist with (k:=comp1) (c:=c) (tr:=tr) (net:=net) in H3.
trivial.
trivial.
unfold name_component in H3; trivial.
trivial.
apply queue_empty_message_received_equals_controllist with (k:=comp1) (c:=c) (tr:=tr).
trivial.
trivial.
apply neighbours_in_controllist with (k:=comp1) (tr:=tr).
trivial.
trivial.
Qed.

Extraction "Checker_Consistent.ml"  Checker_BaseParams Checker_MultiParams.


Require Import syntax.
Require Import partial.
Require Import heap.
Require Import classTable.
Require Import sframe.
Require Import reductions.
Require Import typing.
Require Import namesAndTypes.
Require Import preservation.

Require Import wf_env.

Import ConcreteEverything.

Section Preservation_fix.

  Variable P: Program.

  Definition subtypeP := subtype P.
  Definition fldP := fld P.
  Definition ftypeP := ftype P.
  Definition t_frame1' := t_frame1 P.
  Definition WF_Frame' := WF_Frame P.

  Definition Reduction_SF' := Reduction_SF P .
  Definition fieldsP := fields P.
  Definition TypeChecksP := TypeChecksTerm P.
  Definition TypeChecksExprP := TypeChecksExpr P.
  Definition Heap_okP := Heap_ok P.
  Definition Heap_dom_okP := Heap_dom_ok P .

  Require Import Coq.Lists.List.

  Notation "( p +++ a ↦ b )" := (p_env.updatePartFunc
                                     p a b) (at level 0).

  Notation "( H +*+ o ↦ obj )" := (p_heap.updatePartFunc
                                     H o obj)
                                    (at level 0).
  Notation "( Γ ⊍ x ↦ σ )" := (p_Γ.updatePartFunc
                                     Γ x σ)
                                (at level 0).
  Notation " a ⪳ b " := (subtype P a b) (at level 0).
  Notation " a ⪯ b " := (subclass P a b) (at level 0).

  Notation "[ L , t ] ^ a" := (ann_frame (sframe L t) a) (at level 0).

  Notation "y ∘ f ⟵ z" := (FieldAssignment y f z) (at level 0).

  Notation "a ⟿ b" :=  (Reduction_SF' a b) (at level 0).
  Notation " ⊢ H" := (Heap_okP H) (at level 0).
  Notation " ⊩ H" := (Heap_dom_okP H) (at level 0).
  Notation "( Γ , ef ⊩' t ▷ σ )" := (TypeChecksTerm P Γ ef t σ) (at level 0).
  Notation "( Γ , ef ⊩'' e ▷ σ )" := (TypeChecksExpr P Γ ef e σ) (at level 0).

  Notation "a ∉ lst" := (~ (In a lst)) (at level 0).

  Theorem preservation_case_box :
    forall H L σ ann t C x o flds,
      WF_Frame' H (ann_frame (sframe L t_let x <- Box C t_in (t)) ann) σ ->
      Heap_okP H ->
      ~ In o (p_heap.domain H) ->
      fieldsP C flds ->
      WF_Frame'
        (p_heap.updatePartFunc H o (obj C (p_FM.newPartFunc flds FM_null)))
        (ann_frame (sframe (p_env.updatePartFunc L x (envBox o)) t) ann) σ.
   Admitted.

    Theorem preservation_case_select :
    forall H L σ ann x y f t C FM fmVal o,
      WF_Frame' H (ann_frame (sframe L t_let x <- FieldSelection y f t_in (t)) ann) σ ->
      Heap_okP H ->
      p_env.func L y = Some (envRef o) ->
      p_heap.func H o = Some (obj C FM) ->
      p_FM.func FM f = Some fmVal ->
      WF_Frame'
        H
        (ann_frame (sframe (p_env.updatePartFunc L x (fm2env fmVal)) t) ann) σ.
    intros.

    (* 2 *)
    rename H1 into t_typ_σb.
    rename H2 into _2_cd.
    rename H3 into _2_e.
    rename H4 into t_is_term.
    rename H0 into _2_j.
    rename X into _2_k.

    (* 3 *)
    inversion _2_k.
    clear H3 sigma0 H5 ann0 H4 H1 H2.
    rename X into ΓL_sub.
    rename X0 into wf_vars.

    (* 4 *)
    inversion ΓL_sub.
    clear tau H3 H7 t1 H5 e H4 x0 eff0 H2.
    rewrite <- H1 in * ; clear H1 Gamma.
    inversion X.
    clear H5 f0 H1 x0 eff0 H3 gamma0 H2.
    rename C0 into D.
    rename H7 into typ_newC.
    rename witn into typ_next_frame.
    set (E := ftype P D f typ_next_frame).
    rewrite <- H4 in *.
    fold E in X, X0.
    clear H4.
    (* rename H4 into _4_c. *)
    rename X0 into _4_d.
    rename X into _4_e.
    set (L' := p_env.updatePartFunc L x (fm2env fmVal)).
    clear t0 L0 H0.

    (* 5 *)
    set (Gamma' := p_gamma.updatePartFunc gamma x (typt_class E)).
    fold Gamma' in _4_d.

    (* 6 *)
    inversion wf_vars.
    rename H0 into wf_vars_i.
    rename X into wf_vars_ii.
    set (_6 := subset_preserved gamma L x (typt_class E) (fm2env fmVal)  wf_vars_i).

    (* OTHER ORDER COMPARED TO paper proof*)
    clear H6 sigma0.
    apply (t_frame1 P _ Gamma' eff _ _ _ _ t_is_term _4_d).
    split.
    apply _6.
    intros z tau.

    (* END OTHER *)

    case_eq (v_eq_dec x z).
    (* 7 *)
    (* 7 a *)
    intros.
    rewrite <- e in *; clear e z.
    clear H0.
    assert (p_env.func L' x = Some (fm2env fmVal)) as gamma_L_subset_a.
    unfold L'.
    rewrite  ( proj1 (p_env.updatedFuncProp L x (fm2env fmVal) x) (eq_refl x)).
    reflexivity.

    assert (p_gamma.func Gamma' x = Some (typt_class E)) as gamma_x_E.
    unfold Gamma'.
    rewrite  ( proj1 (p_gamma.updatedFuncProp gamma x (typt_class E) x) (eq_refl x)).
    reflexivity.
    clear H1.

    (* 7 b *)
    induction fmVal; unfold fm2env in gamma_L_subset_a.

    (* 7 b i *)
    apply inl. apply inl.
    exact gamma_L_subset_a.

    (* 7 c *)
    rename r into o'.
    set (test := _2_j o C FM _2_cd f o').

    apply inl.  apply inr.
    exists (E, o').
    unfold Gamma'.
    assert (subclass P C D) as C_sub_D.

    induction ( wf_vars_ii y (typt_class D) typ_newC).
    induction a.
    rewrite  t_typ_σb in a; discriminate a.
    destruct b.
    destruct x0.
    destruct y0.
    destruct a.
    destruct H1.
    rewrite t_typ_σb in H0.
    inversion H0.
    rewrite H4 in *.
    rewrite typ_newC in H1.
    inversion H1.
    rewrite <- H5 in *.
    clear c H5.
    assert (heap_typeof H r x0 = C).
    unfold heap_typeof.
    (* TODO: rewriting *)
    admit.
    (* rewrite <- H4. *)
    (* rewrite _2_cd. *)
    (* reflexivity. *)
    rewrite H3 in H2.
    inversion H2.
    exact H7.
    destruct b.   destruct x0.
    destruct y0.
    destruct a.
    rewrite t_typ_σb in H0.
    inversion H0.

    assert (fld P C f) as f_field_C.
    apply (field_subclass P C D  _  typ_next_frame).

    exact C_sub_D.
    destruct (test f_field_C _2_e).
    clear test.
    exists x0.
    split.
    exact gamma_L_subset_a.
    split.
    exact gamma_x_E.

    (*  *)
    (*
     * know: Gamma' x = E
     * typeof(H, o') <: ftype(C, f)
     * --------------
     * ftype(C, f) = E
     * ---------------------
     * Goal:  heapof(H, o') <: E
     *
     *)
    apply classSub.
    assert (E = heap.ftypeP P C f f_field_C).
    unfold E.
    unfold heap.ftypeP.
    rewrite (unique_ftype P C f f_field_C (field_subclass P C D f f_field_C C_sub_D)).
    rewrite <- (ftype_subclass P C D f f_field_C C_sub_D).
    apply (unique_ftype P D f _ _).
    rewrite <- H0 in s.
    exact s.

    (* 8 *)
    intros.
    clear H0.

    (* 8 a b *)
    assert (p_gamma.func gamma z = Some tau).
    rewrite <- H1.
    symmetry.
    set (lem := proj2 (p_gamma.updatedFuncProp gamma x (typt_class E) z)).
    firstorder.
    rename H0 into _8_b.
    assert (In z (p_gamma.domain gamma)) as _8_a.
    apply (p_gamma.in_part_func_domain _ z tau _8_b).

    (* 8 c *)
    assert (In z (p_env.domain L)) as _8_c.
    apply (wf_vars_i _ _8_a).

    set (_8_e_i := wf_vars_ii z tau _8_b).
    unfold WF_Var.

    assert (p_env.func L z = p_env.func L' z) as _8_d.
    set (lem := proj2 (p_env.updatedFuncProp L x (fm2env fmVal) z)).
    symmetry. firstorder.
    rewrite <- _8_d.
    rewrite <- _8_b in H1.
    rewrite H1.
    exact _8_e_i.
  Admitted.

    Theorem preservation_case_assign H L x y f z t C FM o σ envVal ann:
    forall witn: is_not_box envVal,
      WF_Frame' H (ann_frame (sframe L t_let x <- (FieldAssignment y f z) t_in (t)) ann) σ ->
      Heap_okP H ->
      p_env.func L y = Some (envRef o) ->
      p_heap.func H o = Some (obj C FM) ->
      p_env.func L z = Some envVal ->
      (* isTerm t -> *)
      (WF_Frame'
         (p_heap.updatePartFunc H o
                                (obj C (p_FM.updatePartFunc FM f (env2fm envVal witn))))
         (ann_frame (sframe (p_env.updatePartFunc L x envVal ) t) ann) sigma) *
      (Heap_okP (p_heap.updatePartFunc H o
                                       (obj C (p_FM.updatePartFunc FM f (env2fm envVal witn))))
      ).

    (* 1 *)
    intros.
    rename H0 into _1_b.
    rename X into _1_c.

    (* 2 *)
    set (L' := (p_env.updatePartFunc L x envVal)).
    set (FM' := (p_FM.updatePartFunc FM f (env2fm envVal witn))).
    set (H' := (p_heap.updatePartFunc H o (obj C FM'))).
    split.

    (* 2b, L z = o_z or L_z = null*)
    assert ({o_z | envVal = envRef o_z} + (envVal = envNull)) as wf_H_Γ_L.
    case_eq envVal.
    intros.
    apply inr.
    reflexivity.
    intros.
    apply inl.
    exists r.
    reflexivity.
    intros.
    rewrite H0 in *.
    inversion _1_c.
    inversion X.
    inversion X1.

    (* L z = b(r), show Gamma z must be Box[D] *)

    inversion X0.
    set (lem := X4 z _ H23).
    inversion lem.
    destruct X5.
    rewrite e0 in H3.
    simplify_eq H3.
    destruct s.
    destruct x2.
    destruct y1.
    destruct a.
    rewrite H26 in H3.
    simplify_eq H3.

    destruct X5.
    destruct x2.
    destruct y1.
    destruct a.
    destruct H27.
    rewrite H23 in H27 .
    simplify_eq H27.

    rename o into o_y.
    rename H1 into _2_c.
    rename H2 into _2_d.

    (* 2 e says that f in fields(C) by reduction rules (this is wrong!)*)

    (* 3 *)
    inversion _1_c.
    clear H0 H2 t0 H5 ann0 H6 sigma0 H4 L0 H1.
    rename X into ΓL_sub.
    rename X0 into wf_vars.

    (* 4 *)
    inversion ΓL_sub.
    inversion X.
    clear y0 H13 f0 H9 x1 H8 eff1 H11 gamma0 H10.
    unfold typing.subtypeP in *.
    fold TypeChecksP in *.
    fold subtypeP in *.
    unfold typing.fldP in *.
    fold fldP in *.
    clear H2 tau.

    clear x0 H4.
    clear t0 H6.
    clear H1 eff0.
    clear e H5.
    clear gamma H0.
    rewrite <- H12 in *.
    clear sigma0 H12.
    inversion X1.
    clear eff0 H2 x0 H0 H5 f0 gamma H1.
    set (typ_newC := p_gamma.in_part_func_domain Gamma y (typt_class C1) H4).
    set (typ_next_frame := p_gamma.in_part_func_domain Gamma z (typt_class C0) H14).
    rename X1 into _4_c.

    (* unfold subtypeP in H15. *)
    rename H15 into _4_d.
    set (Gamma' := p_gamma.updatePartFunc Gamma x (typt_class C0)).
    fold Gamma' in X0.
    rename X0 into _4_e.

    clear witn2.
    rename C0 into D''.
    rename C into C'.
    rename C1 into C.
    rename H6 into _4_f.

    (* 5 *)
    inversion wf_vars.
    rename H0 into _5_a.
    rename X0 into _5_b.

    (* 6 *)

    apply (t_frame1 _ _ Gamma' eff).
    inversion H7.
    exact H1.
    exact _4_e.
    split.
    exact (subset_preserved _ _ _ _  _  _5_a).

    intros s.
    case_eq (v_eq_dec s x).
    intros.
    clear H0; rewrite -> e in *; clear e s.
    clear sigma0 H1.
    assert (p_gamma.func Gamma' x = p_gamma.func Gamma z ) as _6_a.
    set (lem := proj1 (p_gamma.updatedFuncProp Gamma x (typt_class D'') _) (eq_refl _)).
    fold Gamma' in lem.
    transitivity (Some (typt_class D'')).
    exact lem.
    symmetry.
    exact H14.

    assert (p_env.func L' x = p_env.func L z) as _6_b.
    transitivity (Some envVal).
    exact (proj1 (p_env.updatedFuncProp L x envVal _) (eq_refl _)).
    symmetry.
    exact H3.
    case_eq wf_H_Γ_L.
    intros.
    clear H0 wf_H_Γ_L.
    destruct s.
    rewrite -> e in *.
    rename x0 into o_z.
    assert (In o_z (p_heap.domain H)).
    destruct (_5_b z (typt_class D'') H14).
    destruct s.
    rewrite e0 in H3.
    inversion H3.
    destruct s. destruct x0.
    destruct y0.
    destruct a.
    rewrite H0 in H3.
    inversion H3.
    rewrite <- H5 in *.
    exact x0.
    destruct s.
    destruct x0.
    destruct y0.
    destruct a.
    rewrite H0 in H3; inversion H3.
    set (stays := p_heap.staysInDomain H o_y (obj C' FM') o_z H0).
    assert (heap_typeof H' o_z stays = heap_typeof H o_z H0) as _6_iv.
    case_eq (rn_eq_dec o_z o_y).
    intros.
    clear H1; rewrite e0 in *.
    transitivity C'.
    unfold heap_typeof.
    assert (p_heap.func H' o_z = Some (obj C' FM')).
    rewrite e0.
    unfold H'.
    exact (proj1 (p_heap.updatedFuncProp H o_y (obj C' FM') _) (eq_refl _)).

    (* TODO: rewrite *)
    admit.
    (* rewrite H1. *)
    (* reflexivity. *)
    symmetry.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite e0. *)
    (* rewrite _2_d. *)
    (* reflexivity. *)
    intros.
    clear H1.
    set (lem := proj2 (p_heap.updatedFuncProp H o_y (obj C' FM') _) n).
    fold H' in lem.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite lem. *)
    (* reflexivity. *)
    unfold WF_Var.
    apply inl.
    apply inr.
    rewrite _6_b.
    rewrite _6_a.
    exists (D'', o_z).
    exists stays.
    split.
    exact H3.
    split.
    exact H14.
    rewrite _6_iv.
    unfold wf_env.subtypeP.
    (* apply classSub. *)
    elim (_5_b z (typt_class D'') H14).
    intro.
    destruct a.
    rewrite e0 in H3; inversion H3.
    destruct s.
    destruct x0.
    destruct y0.
    destruct a.
    rewrite H1 in H3; inversion H3.
    rewrite H6 in *.
    destruct H2.
    rewrite H14 in H2; inversion H2.
    rewrite <- H9 in *.
    rewrite <- H6 in *.
    (* dependent rewrite H6 in x0. *)
    assert ((heap_typeof H r x0) = (heap_typeof H o_z H0)).
    case_eq (p_heap.func H r).
    intros.
    destruct b.
    transitivity c0.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite H8. *)
    (* reflexivity. *)
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite <- H6. *)
    (* rewrite H8. *)
    (* reflexivity. *)
    intros.
    elim (proj2 (p_heap.fDomainCompat H r) H8 x0).
    rewrite <- H8.
    exact H5.
    rename _6_iv into _6_d_iv.

    (* 6 e *)
    intros.
    destruct b.
    destruct x0.
    destruct y0.
    destruct a.
    destruct H2.
    rewrite H14 in H2; discriminate H2.

    (* L z = null *)
    intros.
    clear H0.
    rewrite e in *.
    apply inl.
    apply inl.
    rewrite _6_b.
    assumption.

    (* 7 a *)
    intros gamma_L_subset dummy tau gamma_L_subset';    clear dummy.
    assert (p_gamma.func Gamma' s = p_gamma.func Gamma s) as gamma_L_subset_a.
    apply (proj2 (p_gamma.updatedFuncProp _ _ _ _) gamma_L_subset).
    assert (p_env.func L' s = p_env.func L s) as gamma_L_subset_b.
    apply (proj2 (p_env.updatedFuncProp _ _ _ _) gamma_L_subset).
    rewrite gamma_L_subset' in gamma_L_subset_a.
    symmetry in gamma_L_subset_a.
    set (gamma_L_subset_c := _5_b s tau gamma_L_subset_a).

    case_eq (p_env.func L s).
    intros.
    case_eq b.
    intros.
    apply inl. apply inl.
    rewrite H1 in H0.
    rewrite H0 in gamma_L_subset_b.
    assumption.

    (* 7 e, b = envRef o_s *)
    clear _1_c.
    clear ann.
    intros.
    rename r into o_s.
    rewrite H1 in *.
    destruct gamma_L_subset_c. (* case analysis on WF-var Gamma L s *)
    destruct s0.
    rewrite H0 in e; discriminate e.
    destruct s0.
    destruct x0; destruct y0; destruct a; destruct H5.
    rewrite H2 in H0;    inversion H0.
    rewrite <- H9 in *; clear H9.
    clear o_s; rename r into o_s.
    clear H0 b H1.
    rename H5 into gamma_L_subset_e_i.
    rename c into G.
    rename H6 into gamma_L_subset_e_ii.
    set (stays := p_heap.staysInDomain H o_y (obj C' FM') o_s x0).
    fold H' in stays.

    (* 7 e iii *)
    assert (heap_typeof H o_s x0 = heap_typeof H' o_s stays) as gamma_L_subset_e_iii.
    case_eq (rn_eq_dec o_s o_y).
    intros.
    clear H0. rewrite <- e in *.
    transitivity C'.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite _2_d; reflexivity. *)

    unfold heap_typeof.
    assert (p_heap.func H' o_y = Some (obj C' FM')).
    unfold H'.
    exact (proj1 (p_heap.updatedFuncProp H o_y (obj C' FM') _) (eq_refl _)).

    (* TODO: rewrite *)
    admit.
    (* rewrite e. *)
    (* rewrite H0. *)
    (* reflexivity. *)
    intros.
    clear H0.

    set (lem := proj2 (p_heap.updatedFuncProp H o_y (obj C' FM') _) n).
    fold H' in lem.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite lem. *)
    (* reflexivity. *)
    (* end 7 e iii *)

    set (lem := _5_b s tau gamma_L_subset_a).
    unfold WF_Var.
    rewrite gamma_L_subset_b.
    rewrite gamma_L_subset'.

    (* Case analysis L s = null / o / box with H |- Gamma L s
     * leads to Gamma s = G, typeof(H, o_s) <: G
     *)
    destruct lem.
    destruct s0.
    apply inl. apply inl. assumption.
    apply inl.
    apply inr.
    destruct s0.
    destruct x1.
    exists (c, r).
    destruct y0.
    destruct a.
    rewrite H0 in H2; inversion H2.
    rewrite H6 in *.
    assert (In o_s (p_heap.domain H')).
    assumption.
    exists H5.
    split.
    assumption.
    split.
    destruct H1.
    rewrite H1 in gamma_L_subset_a.
    symmetry.
    assumption.
    assert ((heap_typeof H r x1) = (heap_typeof H' o_s H5)).
    transitivity (heap_typeof H o_s x0).
    case_eq (p_heap.func H r).
    intros.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite H8. *)
    (* rewrite H6 in H8. *)
    (* rewrite H8. *)
    (* reflexivity. *)
    intros.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite H8. *)
    (* rewrite H6 in H8. *)
    (* rewrite H8. *)
    (* assumption. *)

    case_eq (rn_eq_dec o_s o_y).
    intros.
    clear H8.
    transitivity C'.
    unfold heap_typeof.
    rewrite e in *.

    (* TODO: rewrite *)
    admit.
    (* rewrite _2_d. reflexivity. *)
    unfold heap_typeof.
    assert (p_heap.func H' o_y = Some (obj C' FM')).
    unfold H'.
    exact (proj1 (p_heap.updatedFuncProp H o_y (obj C' FM') _) (eq_refl _)).

    (* TODO: rewrite *)
    admit.
    (* rewrite e. *)
    (* rewrite H8. *)
    (* reflexivity. *)
    intros.
    clear H8.

    set (lem := proj2 (p_heap.updatedFuncProp H o_y (obj C' FM') _) n).
    fold H' in lem.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite lem. *)
    (* reflexivity. *)

    rewrite <- H8.
    destruct H1.
    exact H9.

    destruct s0.
    destruct x1.
    destruct y0.
    destruct a.
    destruct H1.
    rewrite H0 in H2; inversion H2.

    destruct s0.
    destruct x0; destruct y0. destruct a. destruct H5.
    rewrite H2 in H0; discriminate H0.
    (* END 7 e!!! *)

    intros.
    rename r into o_s.
    rewrite H1 in *.

    (* Case analysis on H |- Gamma ; L ; s to get box prop: *)
    set (lem := _5_b s tau gamma_L_subset_a).
    destruct lem.
    destruct s0.
    rewrite e in H0; discriminate H0.
    destruct s0; destruct x0; destruct y0; destruct a.
    rewrite H2 in H0; discriminate H0.
    destruct s0; destruct x0; destruct y0; destruct a; destruct H5.
    rewrite H2 in H0; simplify_eq H0.
    intro equRef; rewrite equRef in *.
    clear H0.
    rewrite gamma_L_subset_a in H5; simplify_eq H5.
    intro equTy; rewrite equTy in *.
    rename c into F.
    rename gamma_L_subset' into gamma_L_subset_f_i_A.
    assert (In o_s (p_heap.domain H)).
    rewrite <- equRef.
    assumption.
    assert (In o_s (p_heap.domain H')).
    unfold H'.
    apply (p_heap.staysInDomain H _ _ o_s).
    assumption.
    assert (heap_typeof H o_s H0  = heap_typeof H' o_s H8) as gamma_L_subset_f_ii.

    case_eq (rn_eq_dec o_s o_y).
    intros.
    rewrite e in *.
    clear H9.
    transitivity C'.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite e. *)
    (* rewrite _2_d. *)
    (* reflexivity. *)

    unfold heap_typeof.
    assert (p_heap.func H' o_y = Some (obj C' FM')).
    apply (p_heap.updatedFuncProp _ _ _ _).
    reflexivity.

    (* TODO: rewrite *)
    admit.
    (* rewrite e. *)
    (* rewrite H9. *)
    (* reflexivity. *)

    intros.
    clear H9.
    case_eq (p_heap.func H o_s).
    intros.
    destruct b0.
    transitivity c.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite H9. *)
    (* reflexivity. *)

    assert (p_heap.func H' o_s = Some (obj c f0)).
    unfold H'.
    transitivity  (p_heap.func H o_s).
    apply (proj2 (p_heap.updatedFuncProp H o_y (obj C' FM') o_s) ).
    assumption.
    assumption.
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite H10. *)
    (* reflexivity. *)

    intros.
    elim (proj2 (p_heap.fDomainCompat H o_s) H9 H0).
    unfold WF_Var.
    rewrite gamma_L_subset_b.
    rewrite gamma_L_subset_f_i_A.
    rewrite H2.
    apply inr.
    exists (F, o_s).
    exists H8.
    split.
    reflexivity.
    split.
    reflexivity.
    rewrite <- gamma_L_subset_f_ii.
    assert ((heap_typeof H o_s H0) = (heap_typeof H r x0)
           ).
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite equRef. *)
    (* induction (p_heap.func H o_s); *)
    (* reflexivity. *)

    rewrite H9.
    assumption.

    intro.
    set (s_in_gamma := p_gamma.in_part_func_domain Gamma s tau gamma_L_subset_a).
    set (lem := _5_a _ s_in_gamma).
    elim (proj2 (p_env.fDomainCompat _ _) H0 lem).

    (* HEAP OK *)

    intro.
    rename o into o_y.
    rename o0 into o.

    case_eq (rn_eq_dec o_y o).
    intros; clear H0.
    rewrite <- e in *.
    set (lem := proj1 (p_heap.updatedFuncProp H o_y (obj C FM') _) (eq_refl _)).
    fold H' in lem.
    rewrite lem in H4.
    inversion H4.
    rewrite <- H5 in *.
    rewrite <- H6 in *.
    clear H5 H6 C0 FM0.
    clear lem H4 e o.
    intro; intros.

    case_eq (fn_eq_dec f0 f).
    intros.
    clear H4; rewrite e in *.
    set (lem := proj1 (p_FM.updatedFuncProp FM f (env2fm envVal witn) f) (eq_refl _ )).
    fold FM' in lem.
    rewrite H0 in lem.
    inversion lem.
    induction envVal;
    inversion H5.
    rewrite <- H6 in *.
    rename o into o_z.
    rename H3 into _9_b_ii_B.
    rename H0 into _9_b_ii_A.

    inversion _1_c.
    destruct X0.
    inversion X.
    inversion X0.
    set (_9_b_iii_lem := w z (typt_class C0) H23).
    unfold WF_Var in _9_b_iii_lem.
    assert ({C_o : class * Ref_type |
             let (C, o) := C_o in
             {witn : In o (p_heap.domain H) |
              p_env.func L z = Some (envRef o) /\
              p_gamma.func Gamma z = Some (typt_class C) /\
              wf_env.subtypeP P (typt_class (heap_typeof H o witn))
                              (typt_class C)}}).
    induction _9_b_iii_lem.
    induction a.
    rewrite a in _9_b_ii_B; simplify_eq _9_b_ii_B.
    exact b.
    destruct b; destruct x2; destruct y1; destruct a.
    rewrite H25 in _9_b_ii_B; simplify_eq _9_b_ii_B.
    clear _9_b_iii_lem.

    destruct X3; destruct x2; destruct y1; destruct a.
    rewrite H25 in _9_b_ii_B; simplify_eq _9_b_ii_B.
    intro ref_eq; rewrite ref_eq in *.
    destruct H26.
    rename H26 into _9_b_v_C.
    rename H27 into _9_b_v_D.
    rename H25 into _9_b_v_A.
    assert (In o_z (p_heap.domain H)) as _9_b_v_B.
    rewrite <- ref_eq; assumption.
    rewrite _9_b_v_C in H23; simplify_eq H23; intro simpl_eq; rewrite simpl_eq in *.
    inversion X2.

    set (lemlem := w y (typt_class C1) H28).

    assert ({C_o : class * Ref_type |
           let (C, o) := C_o in
           {witn : In o (p_heap.domain H) |
           p_env.func L y = Some (envRef o) /\
           p_gamma.func Gamma y = Some (typt_class C) /\
           wf_env.subtypeP P (typt_class (heap_typeof H o witn))
                           (typt_class C)}}).
    induction lemlem.
    induction a.
    rewrite a in H1; simplify_eq H1.
    assumption.

    destruct b; destruct x4; destruct y1; destruct a; destruct H32.
    rewrite H32 in H28; simplify_eq H28.
    destruct X3.
    destruct x4.
    destruct y1.
    destruct a.
    destruct H32.
    rewrite H31 in H1; simplify_eq H1; intro equu; rewrite equu in *.
    rewrite H28 in H32; simplify_eq H32; intro equuu; rewrite <- equuu in *.
    assert (heap_typeof H r1 x4 = C).
    unfold heap_typeof.

    (* TODO: rewrite *)
    admit.
    (* rewrite equu. *)
    (* rewrite H2. *)
    (* reflexivity. *)

    rewrite H34 in H33.

    assert ((heap.ftypeP P C f f_witn) = D).
    rewrite <- H30.
    symmetry.
    inversion H33.
    apply (ftype_subclass _ _ _ _ _ H37).
    rewrite H35.

    exists (p_heap.staysInDomain H o_y (obj C FM') o_z _9_b_v_B).
    assert ((heap_typeof H' o_z
                         (p_heap.staysInDomain H o_y (obj C FM') o_z _9_b_v_B))
            = (heap_typeof H o_z _9_b_v_B)
           ).
    unfold heap_typeof.
    case_eq (rn_eq_dec o_z o_y).
    intros.

    (* TODO: rewrite *)
    admit.
    (* rewrite e1. *)
    (* assert (p_heap.func H' o_y = Some (obj C FM')). *)
    (* apply (p_heap.updatedFuncProp). *)
    (* reflexivity. *)
    (* rewrite H37. *)
    (* rewrite H2. *)
    (* reflexivity. *)

    intros.
    assert (p_heap.func H' o_z = p_heap.func H o_z).
    apply (p_heap.updatedFuncProp).
    assumption.

    (* TODO: rewrite *)
    admit.
    (* rewrite H37. *)
    (* induction (p_heap.func H o_z). *)
    (* reflexivity. *)
    Admitted.
  (*   reflexivity. *)
  (*   rewrite H36. *)

  (*   assert ((heap_typeof H o_z _9_b_v_B) = (heap_typeof H r0 x2)). *)
  (*   unfold heap_typeof. *)
  (*   rewrite ref_eq. *)
  (*   induction (p_heap.func H o_z). *)
  (*   reflexivity. *)
  (*   reflexivity. *)
  (*   rewrite H37. *)
  (*   inversion _9_b_v_D. *)
  (*   apply (subclass_trans P (heap_typeof H r0 x2) C0 D). *)
  (*   assumption. *)
  (*   inversion H24. *)
  (*   assumption. *)
  (*   inversion witn. *)

  (*   intros. *)
  (*   clear H4. *)

  (*   assert (p_FM.func FM' f0 = p_FM.func FM f0). *)
  (*   apply (p_FM.updatedFuncProp). *)
  (*   assumption. *)
  (*   rewrite H0 in H4. symmetry in H4. *)
  (*   set (lem := _1_b o_y C FM H2 f0 o f_witn H4). *)
  (*   destruct lem. *)
  (*   exists (p_heap.staysInDomain H o_y (obj C FM') o x0). *)

  (*   assert ((heap_typeof H' o (p_heap.staysInDomain H o_y (obj C FM') o x0)) *)
  (*           = (heap_typeof H o x0) *)
  (*          ). *)

  (*   case_eq (rn_eq_dec o o_y). *)
  (*   intros. *)
  (*   clear H5. *)
  (*   unfold heap_typeof. *)
  (*   rewrite e. *)
  (*   assert (p_heap.func H' o_y = Some (obj C FM')). *)
  (*   apply (p_heap.updatedFuncProp). *)
  (*   reflexivity. *)
  (*   rewrite H5. *)
  (*   rewrite H2. *)
  (*   reflexivity. *)
  (*   intros . *)
  (*   unfold heap_typeof. *)
  (*   assert (p_heap.func H' o = p_heap.func H o). *)
  (*   apply (p_heap.updatedFuncProp). *)
  (*   assumption. *)
  (*   rewrite H6. *)
  (*   induction (p_heap.func H o); *)
  (*     reflexivity. *)
  (*   rewrite H5. *)
  (*   assumption. *)

  (*   intros. *)
  (*   assert (p_heap.func H' o = p_heap.func H o). *)
  (*   apply (p_heap.updatedFuncProp). *)
  (*   firstorder. *)
  (*   case_eq (p_heap.func H o). *)
  (*   intros. *)
  (*   destruct b. *)
  (*   rewrite H5 in H4. *)
  (*   rewrite H6 in H4. *)
  (*   inversion H4. *)
  (*   rewrite H8, H9 in *. *)
  (*   clear H4 H8 H9 c f0. *)
  (*   intro; intros. *)
  (*   set (lem := _1_b o C0 FM0 H6 f0 o0 f_witn H4). *)
  (*   destruct lem. *)
  (*   exists (p_heap.staysInDomain H o_y (obj C FM') o0 x0). *)
  (*   assert ((heap_typeof H o0 x0) = (heap_typeof H' o0 (p_heap.staysInDomain H o_y (obj C FM') o0 x0))). *)
  (*   case_eq (rn_eq_dec o0 o_y). *)
  (*   intros. *)
  (*   unfold heap_typeof. *)
  (*   rewrite e. *)
  (*   rewrite H2. *)
  (*   assert (p_heap.func H' o_y = Some (obj C FM')). *)
  (*   apply (p_heap.updatedFuncProp). *)
  (*   reflexivity. *)
  (*   rewrite H8. *)
  (*   reflexivity. *)
  (*   intros. *)
  (*   unfold heap_typeof. *)
  (*   assert (p_heap.func H o0 = p_heap.func H' o0). *)
  (*   symmetry. *)
  (*   apply (p_heap.updatedFuncProp). *)
  (*   assumption. *)
  (*   rewrite H8. *)
  (*   induction (p_heap.func H' o0); *)
  (*     reflexivity. *)
  (*   rewrite <- H7. *)
  (*   assumption. *)
  (*   intros. *)
  (*   rewrite H6 in H5. *)
  (*   rewrite H5 in H4. *)
  (*   inversion H4. *)