(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 107 to 164, whose indices in         *)
(* the_configs range over segment [106, 164).                                 *)
(******************************************************************************)

Lemma red106to164 : reducible_in_range 106 164 the_configs.
Proof. CheckReducible. Qed.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(*     A development written by Pierre Castéran for Coq V6.1

Coq : A product of inria : "http://pauillac.inria.fr/coq/coq-eng.html"

Pierre Castéran : A product of LaBRI :

LaBRI, Universite Bordeaux-I      |    12 place Puy Paulin
351 Cours de la Liberation        |    33000 Bordeaux
F-33405 TALENCE Cedex             |    France
France                            |    (+ 33) 5 56 81 15 80
tel : (+ 33) 5 56 84 69 31
fax : (+ 33) 5 56 84 66 69
email: casteran@labri.u-bordeaux.fr
www: http://dept-info.labri.u-bordeaux.fr/~casteran

"Les rêves sont aussi beaux que la réalité, mais ils ne sont pas mieux".
( J.L.Borges )

*)
Require Import nat_trees.
Require Import search_trees.
Require Import Compare_dec.

(* V:        INSERTION
**********************************
**********************************

V.1   Definition of an INSERT predicate (a la  Prolog)
***************************************************

We begin with the definition of a predicate:

(INSERT n t t') if t' is a binary search tree containing exactly
  n and the elements of t *)

Inductive INSERT (n : nat) (t t' : nat_tree) : Prop :=
    insert_intro :
      (forall p : nat, occ t p -> occ t' p) ->
      occ t' n ->
      (forall p : nat, occ t' p -> occ t p \/ n = p) ->
      search t' -> INSERT n t t'.

Hint Resolve insert_intro: searchtrees.

(* ZZZZ ! insert_rec is defined ! yep ! *)

(* the specification of an insertion algorithm *)

Definition INSERT_SPEC (n : nat) (t : nat_tree) :=
  {t' : nat_tree | INSERT n t t'}.

(* technical lemmas preparing our algorithm *)

Lemma insert_nil : forall n : nat, INSERT n NIL (bin n NIL NIL).
(******************************************************)
Proof.
 intro n; split; auto with searchtrees.
 intros p H; inversion_clear H; auto with searchtrees. (* miraculous, no ? *)
Defined.
Hint Resolve insert_nil: searchtrees.

(* Inserting in the left son *)

Lemma insert_l :
 forall (n p : nat) (t1 t'1 t2 : nat_tree),
 n < p ->
 search (bin p t1 t2) ->
 INSERT n t1 t'1 -> INSERT n (bin p t1 t2) (bin p t'1 t2).
(**********************************************************)
Proof.
 intros n p t1 t'1 t2 H H0 H1; split.
 intros p0 H2; inversion_clear H2.
 auto with searchtrees.
 elim H1; auto with searchtrees.
 auto with searchtrees.
 constructor 2; elim H1; auto with searchtrees.
 intros p0 H2.
 inversion_clear H2.
 auto with searchtrees.
 elim H1; intros.
 elim (H5 p0); auto with searchtrees.
 auto with searchtrees.
 elim H1; constructor 2; auto with searchtrees.
 eapply search_r; eauto with searchtrees.
 split; intros.
 elim (H4 q).
 intro; cut (maj p t1).
 simple induction 1; auto with searchtrees.
 eapply maj_l; eauto with searchtrees.
 simple induction 1; auto with searchtrees.
 auto with searchtrees.
 eapply min_r; eauto with searchtrees.
Defined.

(*  inserting in the right son *)
(* ici *)

Lemma insert_r :
 forall (n p : nat) (t1 t2 t'2 : nat_tree),
 p < n ->
 search (bin p t1 t2) ->
 INSERT n t2 t'2 -> INSERT n (bin p t1 t2) (bin p t1 t'2).
(*******************************************************)
Proof.
 intros n p t1 t2 t'2 H H0 H1; split.
 intros p0 H2; inversion_clear H2; auto with searchtrees.
 elim H1; auto with searchtrees.
 constructor 3; elim H1; auto with searchtrees.
 intros p0 H2; inversion_clear H2; auto with searchtrees.
 elim H1; intros.
 elim (H5 p0); auto with searchtrees.
 elim H1; constructor 2; auto with searchtrees.
 eapply search_l; eauto with searchtrees.
 split; intros.
 elim (maj_l _ _ _ H0); auto with searchtrees.
 split; intros q H6.
 elim (H4 q H6).
 intro.
 elim (min_r _ _ _ H0); auto with searchtrees.
 simple induction 1; auto with searchtrees.
Defined.

(* no need for insertion  ! *)

Lemma insert_eq :
 forall (n : nat) (t1 t2 : nat_tree),
 search (bin n t1 t2) -> INSERT n (bin n t1 t2) (bin n t1 t2).
(******************************************************)
Proof.
 auto with searchtrees.
Defined.

Hint Resolve insert_l insert_r insert_eq: searchtrees.

(* V.2   The insertion algorithm itself
***************************************)

(* realization *)

Lemma insert : forall (n : nat) (t : nat_tree), search t -> INSERT_SPEC n t.
Proof.
 refine
  (fix insert (n : nat) (t : nat_tree) {struct t} :
     search t -> INSERT_SPEC n t :=
     match t return (search t -> INSERT_SPEC n t) with
     | NIL => fun s => exist _ (bin n NIL NIL) _
     | bin p t1 t2 =>
         fun s =>
         match le_gt_dec n p with
         | left h =>
             match le_lt_eq_dec n p h with
             | left _ =>
                 match insert n t1 _ with
                 | exist t3 _ => exist _ (bin p t3 t2) _
                 end
             | right _ => exist _ (bin n t1 t2) _
             end
         | right _ =>
             match insert n t2 _ with
             | exist t3 _ => exist _ (bin p t1 t3) _
             end
         end
     end).
(*
 Realizer Fix insert{insert/2 : nat-> nat_tree -> nat_tree :=
               [n:nat][t:nat_tree]<nat_tree>
                Cases t of
                NIL  =>  (bin n NIL NIL )
               |( bin p t1 t2 ) =>
                  <nat_tree> if (le_gt_dec n p)
                            then <nat_tree> if (le_lt_eq_dec n p)
                                           then  (bin p (insert n t1) t2)
                                           else (bin n t1 t2)
                            else (bin p t1 (insert n t2)) end}.
 Program_all.
*)
 auto with searchtrees.
 eapply search_l; eauto with searchtrees.
 auto with searchtrees.
 rewrite e; auto with searchtrees.
 eapply search_r; eauto with searchtrees.
 auto with searchtrees.

Defined.
Hint Resolve insert: searchtrees.


Require Import Primitives Layer.Core
        Layer.LayerImplementation
        Layer.HorizontalComposition.

Ltac invert_exec'' H :=
  inversion H; subst; clear H; repeat sigT_eq.

Lemma bind_sep:
  forall O (L: Layer O) T T' u o d (p1: prog L T) (p2: T -> prog L T') ret,
    exec L u o d (Bind p1 p2) ret ->
    match ret with
    | Finished d' r =>
    (exists o1 o2 d1 r1,
       exec L u o1 d p1 (Finished d1 r1) /\
       exec L u o2 d1 (p2 r1) ret /\
       o = o1++o2)
  | Crashed d' =>
    (
    (exec L u o d p1 (Crashed d') \/
     (exists d1 r1 o1 o2,
     o = o1++o2 /\
        exec L u o1 d p1 (Finished d1 r1) /\
        exec L u o2 d1 (p2 r1) ret)))
    end.
Proof.
  intros.
  invert_exec'' H; eauto.
  destruct ret.
  do 2 eexists; eauto.
  right; do 4 eexists; intuition eauto.
 Qed.

Lemma lift1_invert_exec :
    forall O1 O2 (L1: Layer O1) (Lc: Layer (HorizontalComposition O1 O2))
      T (p1: L1.(prog) T) (o: Lc.(oracle)) u s s' t,
      exec Lc u o s (lift_L1 O2 p1) (Finished s' t) ->
      exists o1,
        o = map (fun o =>
                   match o with
                   |OpToken _ o1 =>
                    OpToken (HorizontalComposition O1 O2)
                             (Token1 O1 O2 o1)
                   |LayerImplementation.Cont _ =>
                    LayerImplementation.Cont _
                   |LayerImplementation.Crash _ =>
                    LayerImplementation.Crash _
                   end) o1 /\
        snd s = snd s' /\
        exec L1 u o1 (fst s) p1 (Finished (fst s') t).
  Proof.
    induction p1; simpl; intros.
    {
      invert_exec'' H.
      invert_exec'' H6.
      eexists; intuition eauto.
      simpl; eauto.
    }
    {
      invert_exec'' H.
      eexists; intuition eauto.
      2: econstructor.
      simpl; eauto.
    }
    {
      invert_exec'' H0.
      edestruct IHp1; eauto; cleanup.
      edestruct H; eauto; cleanup.

      eexists; intuition eauto.
      2: econstructor; eauto.
      rewrite map_app; eauto.
    }
  Qed.

Lemma lift2_invert_exec :
    forall O1 O2 (L2: Layer O2) (Lc: Layer (HorizontalComposition O1 O2))
      T (p2: L2.(prog) T) (o: Lc.(oracle)) u s s' t,
      exec Lc u o s (lift_L2 O1 p2) (Finished s' t) ->
      exists o2,
        o = map (fun o =>
                   match o with
                   |OpToken _ o1 =>
                    OpToken (HorizontalComposition O1 O2)
                             (Token2 O1 O2 o1)
                   |LayerImplementation.Cont _ =>
                    LayerImplementation.Cont _
                   |LayerImplementation.Crash _ =>
                    LayerImplementation.Crash _
                   end) o2 /\
        fst s = fst s' /\
        exec L2 u o2 (snd s) p2 (Finished (snd s') t).
  Proof.
    induction p2; simpl; intros.
    {
      invert_exec'' H.
      invert_exec'' H6.
      eexists; intuition eauto.
      simpl; eauto.
    }
    {
      invert_exec'' H.
      eexists; intuition eauto.
      2: econstructor.
      simpl; eauto.
    }
    {
      invert_exec'' H0.
      edestruct IHp2; eauto; cleanup.
      edestruct H; eauto; cleanup.

      eexists; intuition eauto.
      2: econstructor; eauto.
      rewrite map_app; eauto.
    }
  Qed.

  Lemma lift2_exec_step :
    forall O1 O2 (L2: Layer O2) (Lc: Layer (HorizontalComposition O1 O2))
      T (p2: L2.(prog) T) o u s s' t fs,
      exec L2 u o s p2 (Finished s' t) ->
      exec Lc u (map (fun o =>
      match o with
      |OpToken _ o1 =>
       OpToken (HorizontalComposition O1 O2)
                (Token2 O1 O2 o1)
      |LayerImplementation.Cont _ =>
       LayerImplementation.Cont _
      |LayerImplementation.Crash _ =>
       LayerImplementation.Crash _
      end) o) (fs, s) (lift_L2 O1 p2) (Finished (fs, s') t).

  Proof.
    induction p2; simpl; intros.
    {
      invert_exec'' H.
      simpl.
      repeat econstructor; eauto.
    }
    {
      invert_exec'' H; simpl.
      repeat econstructor; eauto.
    }
    {
      invert_exec'' H0.
      eapply IHp2 in H7.
      eapply H in H10.
      rewrite map_app; repeat econstructor; eauto.
    }
  Qed.

  Lemma lift2_exec_step_crashed :
  forall O1 O2 (L2: Layer O2) (Lc: Layer (HorizontalComposition O1 O2))
    T (p2: L2.(prog) T) o u s s' fs,
    exec L2 u o s p2 (Crashed s') ->
    exec Lc u (map (fun o =>
    match o with
    |OpToken _ o1 =>
     OpToken (HorizontalComposition O1 O2)
              (Token2 O1 O2 o1)
    |LayerImplementation.Cont _ =>
     LayerImplementation.Cont _
    |LayerImplementation.Crash _ =>
     LayerImplementation.Crash _
    end) o) (fs, s) (lift_L2 O1 p2) (Crashed (fs, s')).

Proof.
  induction p2; simpl; intros.
  {
    invert_exec'' H.
    simpl.
    repeat econstructor; eauto.
  }
  {
    invert_exec'' H; simpl.
    repeat econstructor; eauto.
  }
  {
    invert_exec'' H0.
    eapply lift2_exec_step in H7; eauto.
    eapply H in H10.
    rewrite map_app; repeat econstructor; eauto.
    eapply H7.

    eapply IHp2 in H6.
    eapply ExecBindCrash; repeat econstructor; eauto.
  }
  Unshelve.
  eauto.
Qed.

Lemma lift1_invert_exec_crashed :
    forall O1 O2 (L1: Layer O1) (Lc: Layer (HorizontalComposition O1 O2))
      T (p1: L1.(prog) T) (o: Lc.(oracle)) u s s',
      exec Lc u o s (lift_L1 O2 p1) (Crashed s') ->
      exists o1,
        o = map (fun o =>
                   match o with
                   |OpToken _ o1 =>
                    OpToken (HorizontalComposition O1 O2)
                             (Token1 O1 O2 o1)
                   |LayerImplementation.Cont _ =>
                    LayerImplementation.Cont _
                   |LayerImplementation.Crash _ =>
                    LayerImplementation.Crash _
                   end) o1 /\
        snd s = snd s' /\
        exec L1 u o1 (fst s) p1 (Crashed (fst s')).
  Proof.
    induction p1; simpl; intros.
    {
      invert_exec'' H.
      invert_exec'' H6.
      do 2 eexists; intuition eauto.
      2: simpl; constructor; eauto.
      simpl; eauto.
    }
    {
      invert_exec'' H.
      do 2 eexists; intuition eauto.
      2: econstructor.
      simpl; eauto.
    }
    {
      invert_exec'' H0.
      eapply lift1_invert_exec in H7; cleanup.
      edestruct H; eauto; cleanup.

      eexists; split.
      2: split; eauto; econstructor; eauto.
      rewrite map_app; eauto.

      edestruct IHp1; eauto; cleanup.
      do 2 eexists; intuition eauto.
      solve [econstructor; eauto].
    }
    Unshelve.
    eauto.
  Qed.

Lemma lift2_invert_exec_crashed :
    forall O1 O2 (L2: Layer O2) (Lc: Layer (HorizontalComposition O1 O2))
      T (p2: L2.(prog) T) (o: Lc.(oracle)) u s s',
      exec Lc u o s (lift_L2 O1 p2) (Crashed s') ->
      exists o2,
        o = map (fun o =>
                   match o with
                   |OpToken _ o1 =>
                    OpToken (HorizontalComposition O1 O2)
                             (Token2 O1 O2 o1)
                   |LayerImplementation.Cont _ =>
                    LayerImplementation.Cont _
                   |LayerImplementation.Crash _ =>
                    LayerImplementation.Crash _
                   end) o2 /\
        fst s = fst s' /\
        exec L2 u o2 (snd s) p2 (Crashed (snd s')).
  Proof.
    induction p2; simpl; intros.
    {
      invert_exec'' H.
      invert_exec'' H6.
      do 2 eexists; intuition eauto.
      2: simpl; constructor; eauto.
      simpl; eauto.
    }
    {
      invert_exec'' H.
      do 2 eexists; intuition eauto.
      2: econstructor.
      simpl; eauto.
    }
    {
      invert_exec'' H0.
      eapply lift2_invert_exec in H7; cleanup.
      edestruct H; eauto; cleanup.

      eexists; split.
      2: split; eauto; econstructor; eauto.
      rewrite map_app; eauto.

      edestruct IHp2; eauto; cleanup.
      do 2 eexists; intuition eauto.
      solve [econstructor; eauto].
    }
    Unshelve.
    eauto.
  Qed.

  Ltac invert_exec' :=
    match goal with
    |[H : exec_with_recovery _ _ _ _ _ _ _ _ |- _ ] =>
     invert_exec'' H
    | [ H: exec _ _ _ _ ?p _ |- _ ] =>
      match p with
      | Bind _ _ => fail
      | Op _ _ => invert_exec'' H
      | Ret _ => invert_exec'' H
      end
    | [ H: exec' _ _ _ ?p _ |- _ ] =>
      match p with
      | Bind _ _ => fail
      | Op _ _ => invert_exec'' H
      | Ret _ => invert_exec'' H
      end
    | [ H: exec _ _ _ _ (lift_L1 _ _) (Finished _ _) |- _ ] =>
      eapply lift1_invert_exec in H; logic_clean
    | [ H: exec _ _ _ _ (lift_L2 _ _) (Finished _ _) |- _ ] =>
      eapply lift2_invert_exec in H; logic_clean
    | [ H: exec _ _ _ _ (lift_L1 _ _) (Crashed _) |- _ ] =>
      eapply lift1_invert_exec_crashed in H; logic_clean
    | [ H: exec _ _ _ _ (lift_L2 _ _) (Crashed _) |- _ ] =>
      eapply lift2_invert_exec_crashed in H; logic_clean
    | [ H: exec' _ _ _ (lift_L1 _ _) (Finished _ _) |- _ ] =>
      eapply lift1_invert_exec in H; logic_clean
    | [ H: exec' _ _ _ (lift_L2 _ _) (Finished _ _) |- _ ] =>
      eapply lift2_invert_exec in H; logic_clean
    | [ H: exec' _ _ _ (lift_L1 _ _) (Crashed _) |- _ ] =>
      eapply lift1_invert_exec_crashed in H; logic_clean
    | [ H: exec' _ _ _ (lift_L2 _ _) (Crashed _) |- _ ] =>
      eapply lift2_invert_exec_crashed in H; logic_clean
    | [H: exec' _ _ _ (Op _ (P1 _)) _ |- _ ]=>
        invert_exec'' H
    | [H: exec' _ _ _ (Op _ (P2 _)) _ |- _ ]=>
        invert_exec'' H
    | [ H: HorizontalComposition.exec' _ _ _ _ _ |- _ ] =>
      invert_exec'' H
    | [ H: Core.exec _ _ _ _ _ _ |- _ ] =>
      invert_exec'' H
    end.

  Ltac invert_exec :=
  invert_exec' +
  match goal with
  |[H : exec _ _ _ _ (Bind _ _) _ |- _ ] =>
   apply bind_sep in H; repeat cleanup
  |[H : exec' _ _ _ (Bind _ _) _ |- _ ] =>
   apply bind_sep in H; repeat cleanup
  end.

  Ltac invert_exec_no_match :=
  invert_exec' +
  match goal with
  |[H : exec _ _ _ _ (Bind _ _) _ |- _ ] =>
   apply bind_sep in H; repeat cleanup_no_match
  |[H : exec' _ _ _ (Bind _ _) _ |- _ ] =>
   apply bind_sep in H; repeat cleanup_no_match
  end.

  Ltac unify_execs :=
    match goal with
    |[H : exec_with_recovery ?u ?x ?y ?z ?a ?b ?c _,
      H0 : exec_with_recovery ?u ?x ?y ?z ?a ?b ?c _ |- _ ] =>
     eapply exec_with_recovery_deterministic_wrt_reboot_state in H; [| apply H0]
    | [ H: exec ?u ?x ?y ?z ?a _,
        H0: exec ?u ?x ?y ?z ?a _ |- _ ] =>
      eapply exec_deterministic_wrt_oracle in H; [| apply H0]
    | [ H: exec' ?u ?x ?y ?z _,
        H0: exec' ?u ?x ?y ?z _ |- _ ] =>
      eapply exec_deterministic_wrt_oracle in H; [| apply H0]
    | [ H: exec _ ?u ?x ?y ?z _,
        H0: LayerImplementation.exec' ?u ?x ?y ?z _ |- _ ] =>
      eapply exec_deterministic_wrt_oracle in H; [| apply H0]
    end.

Lemma bind_reorder:
  forall O (L: Layer O) T
  (p1: prog L T) T' (p2: T -> prog L T')
  T'' (p3: T' -> prog L T'')
  u o s r,
      exec L u o s (Bind p1 (fun t => Bind (p2 t) p3)) r <->
      exec L u o s (Bind (Bind p1 p2) p3) r.
Proof.
  intros; split; intros.
  {
    repeat invert_exec.
    {
      rewrite app_assoc.
      repeat econstructor; eauto.
    }
    split_ors; cleanup;
    repeat invert_exec.
    {
    repeat eapply ExecBindCrash; eauto.
    }
    split_ors; cleanup;
    repeat invert_exec.
    {
      eapply ExecBindCrash.
      econstructor; eauto.
    }
    {
      rewrite app_assoc.
      repeat econstructor; eauto.
    }
  }
  {
    repeat invert_exec.
    {
      rewrite <- app_assoc.
      repeat econstructor; eauto.
    }
    split_ors; cleanup;
    repeat invert_exec.
    split_ors; cleanup;
    repeat invert_exec.
    {
    repeat eapply ExecBindCrash; eauto.
    }
    {
      eapply ExecBind; eauto.
      eapply ExecBindCrash; eauto.
    }
    {
      rewrite <- app_assoc.
      repeat econstructor; eauto.
    }
  }
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C IB XB IA XA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ X A /\ (wd_ X B /\ (wd_ XB B /\ (wd_ XA A /\ (col_ A B X /\ (col_ A B IB /\ (col_ IB B C /\ (col_ XA X A /\ (col_ XB X B /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall P Q R S U V W X Y I : Universe, ((wd_ P W /\ (wd_ P Y /\ (wd_ P Q /\ (wd_ Q S /\ (wd_ P S /\ (wd_ Q R /\ (wd_ S R /\ (wd_ P R /\ (wd_ R V /\ (wd_ P V /\ (wd_ P X /\ (col_ I Q S /\ (col_ P I Y /\ (col_ X Q Y /\ (col_ P U Y /\ (col_ P V X /\ (col_ U W V /\ (col_ P W Q /\ col_ P R V)))))))))))))))))) -> col_ P U I)).
Proof.
  time tac.
Qed.

End FOFProblem.


From cap_machine Require Export rules_binary_base rules_Mov.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import frac.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invGS Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma step_Mov Ep K pc_p pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = Mov dst src ->
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    regs !! PC = Some (WCap pc_p pc_b pc_e pc_a) →
    regs_of (Mov dst src) ⊆ dom regs →

    nclose specN ⊆ Ep →

    spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ pc_a ↣ₐ w ∗ ([∗ map] k↦y ∈ regs, k ↣ᵣ y)
    ={Ep}=∗ ∃ retv regs', ⤇ fill K (of_val retv) ∗ ⌜ Mov_spec regs dst src regs' retv ⌝ ∗ pc_a ↣ₐ w ∗ ([∗ map] k↦y ∈ regs', k ↣ᵣ y).
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hcls) "(#Hinv & Hj & Hpc_a & Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.
    have Hx := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (spec_heap_valid with "[$Hown $Hpc_a]") as %Hpc_a.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.

    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.
    pose proof (Hstep' := Hstep). unfold exec in Hstep.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    assert (exists w, word_of_argument regs src = Some w) as [wsrc Hwsrc].
    { destruct src as [| r0]; eauto; cbn.
      destruct (Hri r0) as [? [? ?]]. set_solver+. eauto. }

    pose proof Hwsrc as Hwsrc'. eapply word_of_argument_Some_inv' in Hwsrc; eauto.

    assert (exec_opt (Mov dst src) (σr, σm) = updatePC (update_reg (σr, σm) dst wsrc)) as HH.
    { destruct Hwsrc as [ [? [? ?] ] | [? (? & ? & Hr') ] ]; simplify_eq; eauto.
      cbn. by rewrite /= Hr'. }
    rewrite HH in Hstep. rewrite /update_reg /= in Hstep.

    destruct (incrementPC (<[ dst := wsrc ]> regs)) as [regs''|] eqn:Hregs';
      pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=σm) in Hregs'.
      eapply updatePC_fail_incl with (m':=σm) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      rewrite Hregs' in Hstep. simplify_pair_eq.
      iExists FailedV,_. iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
      iFrame.
      iMod ("Hclose" with "[Hown]") as "_".
      { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
        prim_step_from_exec.
      }
      iModIntro. iPureIntro. econstructor; eauto.
    }

    eapply (incrementPC_success_updatePC _ σm) in H'regs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & HuPC & ->).
    eapply updatePC_success_incl with (m':=σm) in HuPC. 2: by eapply insert_mono; eauto.
    rewrite HuPC in Hstep. simplify_pair_eq. iFrame.

    iMod ((regspec_heap_update_inSepM _ _ _ dst wsrc) with "Hown Hmap") as "[Hown Hmap]"; eauto.
    iMod ((regspec_heap_update_inSepM _ _ _ PC (WCap p' g' b' a'')) with "Hown Hmap") as "[Hown Hmap]"; eauto.
    iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
    iExists NextIV,_. iFrame.
    iMod ("Hclose" with "[Hown]") as "_".
    { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      prim_step_from_exec.
    }
    iModIntro. iPureIntro. econstructor; eauto.
  Qed.

  Lemma step_move_success_reg_fromPC E K pc_p pc_b pc_e pc_a pc_a' w r1 wr1 :
    decodeInstrW w = Mov r1 (inr PC) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ wr1
    ={E}=∗
         ⤇ fill K (of_val NextIV)
         ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
         ∗ pc_a ↣ₐ w
         ∗ r1 ↣ᵣ WCap pc_p pc_b pc_e pc_a.
  Proof.
    iIntros (Hinstr Hvpc Hpca' Hclose) "(Hown & Hj & >HPC & >Hpc_a & >Hr1)".
    iDestruct (rules_binary_base.map_of_regs_2  with "HPC Hr1") as "[Hmap %]".
    iMod (step_Mov with "[$Hmap $Hpc_a $Hj $Hown]") as (retv regs') "(Hj & #Hspec & Hpc_a & Hmap)"; eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iFrame. incrementPC_inv; rewrite lookup_insert_ne// lookup_insert in H3.
      rewrite /= lookup_insert in H2. simplify_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (rules_binary_base.regs_of_map_2 with "Hmap") as "(?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; [|rewrite lookup_insert_ne// lookup_insert;eauto]. congruence. }
  Qed.

  Lemma step_move_success_reg E K pc_p pc_b pc_e pc_a pc_a' w r1 wr1 rv wrv :
    decodeInstrW w = Mov r1 (inr rv) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ wr1
             ∗ ▷ rv ↣ᵣ wrv
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
        ∗ pc_a ↣ₐ w
        ∗ r1 ↣ᵣ wrv
        ∗ rv ↣ᵣ wrv.
  Proof.
    iIntros (Hinstr Hvpc Hpca' Hnclose) "(Hown & Hj & >HPC & >Hpc_a & >Hr1 & >Hrv)".
    iDestruct (rules_binary_base.map_of_regs_3 with "HPC Hr1 Hrv") as "[Hmap (%&%&%)]".
    iMod (step_Mov with "[$Hmap $Hpc_a $Hj $Hown]") as (retv regs') "(Hj & #Hspec & Hpc_a & Hmap)"; eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iFrame. incrementPC_inv. rewrite lookup_insert_ne// lookup_insert in H5.
      rewrite /= lookup_insert_ne// lookup_insert_ne// lookup_insert in H4. simplify_eq.
      rewrite (insert_commute _ PC r1) // insert_insert (insert_commute _ PC r1) // insert_insert.
      iDestruct (rules_binary_base.regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv;[|rewrite lookup_insert_ne// lookup_insert;eauto]. congruence. }
  Qed.

   Lemma step_move_success_z E K pc_p pc_b pc_e pc_a pc_a' w r1 wr1 z :
    decodeInstrW w = Mov r1 (inl z) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ wr1
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ WCap pc_p pc_b pc_e pc_a'
        ∗ pc_a ↣ₐ w
        ∗ r1 ↣ᵣ WInt z.
  Proof.
    iIntros (Hinstr Hvpc Hpca' Hnclose) "(Hown & Hj & >HPC & >Hpc_a & >Hr1)".
    iDestruct (rules_binary_base.map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iMod (step_Mov with "[$Hmap $Hpc_a $Hj $Hown]") as (retv regs') "(Hj & #Hspec & Hpc_a & Hmap)"; eauto; simplify_map_eq; eauto.
      by unfold regs_of; rewrite !dom_insert; set_solver+. iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iFrame. simpl in *; incrementPC_inv; simplify_map_eq_alt.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (rules_binary_base.regs_of_map_2 with "Hmap") as "(?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; [|rewrite lookup_insert_ne// lookup_insert;eauto]. congruence. }
  Qed.

End cap_lang_spec_rules.


Require Import Raft.
Require Import RaftRefinementInterface.

Section LeadersHaveLeaderLogs.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaders_have_leaderLogs net :=
    forall h,
      type (snd (nwState net h)) = Leader ->
      exists ll,
        In (currentTerm (snd (nwState net h)), ll) (leaderLogs (fst (nwState net h))).

  Class leaders_have_leaderLogs_interface : Prop :=
    {
      leaders_have_leaderLogs_invariant :
        forall (net : network),
          refined_raft_intermediate_reachable net ->
          leaders_have_leaderLogs net
    }.
End LeadersHaveLeaderLogs.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition emulate_mmio_read_spec (esr: Z64) (rt: Z) (rec: Pointer) (adt: RData) : option RData :=
    match esr with
    | VZ64 esr =>
      rely is_int64 esr; rely is_int rt;
      rely (peq (base rec) buffer_loc);
      when gidx ==  (buffer (priv adt)) @ (offset rec);
      let gn := (gs (share adt)) @ gidx in
      rely (ref_accessible gn CPU_ID);
      rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
      let read_val := ((rec_run (priv adt)) @ 14) in
      let mask := __access_mask esr in
      rely is_int64 read_val; rely is_int64 mask;
      let val := Z.land read_val mask in
      let extend := __esr_sign_extend esr in
      rely is_int extend;
      if extend =? 0 then
        let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
      else
        let len := __access_len esr in
        rely is_int len;
        let bitcount := len * 8 in
        rely is_int bitcount; rely is_int (bitcount - 1);
        let mask := Z.shiftl 1 (bitcount - 1) in
        rely is_int64 mask; rely is_int64 (Z.lxor val mask);
        let val := (Z.lxor val mask) - mask in
        rely is_int64 val;
        if __esr_sixty_four esr then
          let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))}} in
          Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
        else
          let val := Z.land val 4294967295 in
          let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))}} in
          Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
    end.

End Spec.


(** **********************************************************

Benedikt Ahrens, Ralph Matthes

SubstitutionSystems

2015

Extended by: Anders Mörtberg, 2016

************************************************************)

(** **********************************************************

Contents:

- Definition of global right Kan extension as right adjoint to precomposition

- Construction of right Kan extensions when the target category has limits
    ([RightKanExtension_from_limits])

************************************************************)

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.CommaCategories.

Local Open Scope cat.

(** * Definition of global right Kan extension as right adjoint to precomposition *)
Section RightKanExtension.

Context (C D : category) (F : functor C D) (E : category).

Let PrecompWithF : [D, E] ⟶ [C, E]
  := pre_composition_functor C D E F.

Definition GlobalRightKanExtensionExists : UU
  := is_left_adjoint PrecompWithF.

Definition GlobalRan (H : GlobalRightKanExtensionExists)
  : [C, E] ⟶ [D, E] := right_adjoint H.

End RightKanExtension.

(** * Construction of right Kan extensions when the target category has limits *)
Section RightKanExtensionFromLims.

Context (M C A : category) (K : functor M C) (LA : Lims A).

Local Notation "c ↓ K" := (cComma _ _ K c) (at level 30).

Section fix_T.

Variable (T : functor M A).

Local Definition Q (c : C) : functor (c ↓ K) M := cComma_pr1 _ _ K c.

Local Definition QT (c : C) : diagram (c ↓ K) A :=
  diagram_from_functor _ _ (functor_composite (Q c) T).

Local Definition R (c : C) : A := lim (LA _ (QT c)).

Local Definition lambda (c : C) : cone (QT c) (R c) := limCone (LA _ (QT c)).

Local Definition Rmor_cone (c c' : C) (g : C⟦c,c'⟧) : cone (QT c') (R c).
Proof.
use make_cone.
- intro m1f1.
  transparent assert (m1gf1 : (c ↓ K)).
  { use tpair.
    + apply (pr1 m1f1).
    + apply (g · pr2 m1f1). }
  exact (coneOut (lambda c) m1gf1).
- intros x y f; simpl in *.
  transparent assert (e : ((c ↓ K) ⟦ pr1 x,, g · pr2 x, pr1 y,, g · pr2 y ⟧)).
  { use tpair.
    + exact (pr1 f).
    + change (g · pr2 x · # K (pr1 f) = g · pr2 y).
      rewrite <- assoc. rewrite (pr2 f). apply idpath. }
  exact (coneOutCommutes (lambda c) _ _ e).
Defined.

Local Definition Rmor (c c' : C) (g : C⟦c,c'⟧) : A⟦R c,R c'⟧ :=
  limArrow (LA (c' ↓ K) (QT c')) (R c) (Rmor_cone c c' g).

Local Definition R_data : functor_data C A := R,,Rmor.
Local Lemma R_is_functor : is_functor R_data.
Proof.
split.
- intros c; simpl.
  apply pathsinv0, limArrowUnique.
  intro c'; simpl; rewrite !id_left.
  now destruct c'.
- intros c c' c'' f f'; simpl.
  apply pathsinv0, limArrowUnique; intros x; simpl.
  rewrite <- assoc; eapply pathscomp0.
  apply maponpaths, (limArrowCommutes _ _ (Rmor_cone c' c'' f')).
  eapply pathscomp0.
  apply (limArrowCommutes _ _ (Rmor_cone c c' f) (pr1 x,,f' · pr2 x)).
  destruct x.
  now rewrite <- assoc.
Qed.

Local Definition R_functor : functor C A := tpair _ R_data R_is_functor.

Local Definition eps_n (n : M) : A⟦R_functor (K n),T n⟧ :=
  coneOut (lambda (K n)) (n,,identity (K n)).

Local Definition Kid n : K n ↓ K := (n,, identity (K n)).

Local Lemma eps_is_nat_trans : is_nat_trans (functor_composite_data K R_data) T eps_n.
Proof.
intros n n' h; simpl.
eapply pathscomp0.
apply (limArrowCommutes (LA (K n' ↓ K) (QT (K n'))) (R (K n))
       (Rmor_cone (K n) (K n') (# K h)) (Kid n')).
unfold eps_n; simpl.
transparent assert (v : (K n ↓ K)).
{ apply (n',, # K h · identity (K n')). }
transparent assert (e : (K n ↓ K ⟦ Kid n, v ⟧)).
{ use tpair.
  + apply h.
  + abstract (cbn ; now rewrite id_left, id_right).
}
now apply pathsinv0; eapply pathscomp0; [apply (coneOutCommutes (lambda (K n)) _ _ e)|].
Qed.

Local Definition eps : [M, A]⟦functor_composite K R_functor, T⟧ :=
  tpair _ eps_n eps_is_nat_trans.

End fix_T.

(** Construction of right Kan extensions based on MacLane, CWM, X.3 (p. 233) *)
Lemma RightKanExtension_from_limits : GlobalRightKanExtensionExists _ _ K A.
Proof.
unfold GlobalRightKanExtensionExists.
use left_adjoint_from_partial.
- apply R_functor.
- apply eps.
- intros T S α; simpl in *.

  transparent assert (cc : (∏ c, cone (QT T c) (S c))).
  { intro c.
    use make_cone.
    + intro mf; apply (# S (pr2 mf) · α (pr1 mf)).
    + abstract (intros fm fm' h; simpl; rewrite <- assoc;
                eapply pathscomp0; [apply maponpaths, (pathsinv0 (nat_trans_ax α _ _ (pr1 h)))|];
                simpl; rewrite assoc, <- functor_comp; apply cancel_postcomposition, maponpaths, (pr2 h)).
  }

  transparent assert (σ : (∏ c, A ⟦ S c, R T c ⟧)).
  { intro c; apply (limArrow _ _ (cc c)). }

  set (lambda' := λ c' mf', limOut (LA (c' ↓ K) (QT T c')) mf').

  (* this is the conclusion from the big diagram (8) in MacLane's proof *)
  assert (H : ∏ c c' (g : C ⟦ c, c' ⟧) (mf' : c' ↓ K),
                # S g · σ c' · lambda' _ mf' = σ c · Rmor T c c' g · lambda' _ mf').
  { intros c c' g mf'.
    rewrite <- !assoc.
    apply pathsinv0; eapply pathscomp0.
    apply maponpaths, (limArrowCommutes _ _ (Rmor_cone T c c' g) mf').
    apply pathsinv0; eapply pathscomp0.
    eapply maponpaths, (limArrowCommutes _ _ (cc c') mf').
    simpl; rewrite assoc, <- functor_comp.
    set (mf := tpair _ (pr1 mf') (g · pr2 mf') : c ↓ K).
    apply pathsinv0.
    exact (limArrowCommutes (LA (c ↓ K) (QT T c)) (S c) (cc c) mf).
  }

  assert (is_nat_trans_σ : is_nat_trans S (R_data T) σ).
  { intros c c' g; simpl.
    transparent assert (ccc : (cone (QT T c') (S c))).
    { use make_cone.
      - intro mf'; apply (σ c · Rmor T c c' g · limOut (LA (c' ↓ K) (QT T c')) mf').
      - abstract (intros u v e; simpl; rewrite <- !assoc;
                  apply maponpaths, maponpaths, (limOutCommutes (LA (c' ↓ K) (QT T c')) u v e)).
    }
    rewrite (limArrowUnique (LA (c' ↓ K) (QT T c')) _ ccc (# S g · σ c') (H _ _ _)).
    now apply pathsinv0, limArrowUnique.
  }

  use tpair.
  + apply (tpair _ (tpair _ σ is_nat_trans_σ)).
    apply nat_trans_eq; [apply homset_property | intro n; cbn].
    generalize (limArrowCommutes (LA (K n ↓ K) (QT T (K n))) _ (cc _) (Kid n)); simpl.
    now rewrite functor_id, id_left.
  + intro x.
    apply subtypePath; [intros xx; apply (isaset_nat_trans (homset_property A))|].
    apply subtypePath; [intros xx; apply (isaprop_is_nat_trans _ _ (homset_property A))|]; simpl.
    apply funextsec; intro c.
    apply limArrowUnique; intro u; simpl.
    destruct x as [t p]; simpl.
    assert (temp : α (pr1 u) = nat_trans_comp _ _ T (pre_whisker K t) (eps T) (pr1 u)).
      now rewrite p.
    rewrite temp; simpl.
    destruct u as [n g]; simpl in *.
    apply pathsinv0; eapply pathscomp0;
    [rewrite assoc; apply cancel_postcomposition, (nat_trans_ax t _ _ g)|].
    rewrite <- !assoc; apply maponpaths.
    generalize (limArrowCommutes (LA (K n ↓ K) _) _ (Rmor_cone T c (K n) g) (Kid n)).
    now simpl; rewrite id_right.
Defined.

End RightKanExtensionFromLims.


Load "CPA_CCA".

(***********i1, i2, r3, r4****************************************************)
(*****************Real or random Secrecy*****************************************)
(********************************************************************************)
(******protocol Pi1 :The oracle reveals the actual nonce *************)

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

(********************NSL Protocol *********************************************)
(* A -> B : {(Na , A) }^r1_pkb
  B -> A : { (Na , (Nb, B))}^r2_pka
   A -> B : { Nb}^r3_pkb
*)

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

Definition phi0  := [ msg (pk (N 1)) ; msg (pk (N 2))].
Definition mphi0 := (conv_mylist_listm phi0).
Definition x1 := (f mphi0).

(******start state****************)
Definition sr (n:nat) := (rs (N (n+4))).

Check pk.
SearchAbout pk.

Definition qa00 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
(enc ( (N 3) , (pk (N 1)) ) (m x1) (sr 1))
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) (enc ( pi1 (dec x1 (sk (N 2)) ) , ((N 4) , (pk (N 2)))) ( pi2 (dec x1 (sk (N 2))))  (sr 2))  O)).

(************************)
Definition t12:= qa00.
Definition phi1 := phi0 ++ [ msg t12 ].

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

Definition mphi1 := (conv_mylist_listm phi1).
Definition x2 := (f mphi1).

(**********qa00 -> qa10, qa01*************************************************)

Definition qa10 :=
 (if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M   (pi1  (dec x2 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x2 (sk (N 1))))) (m x1)) (enc  (pi1 (pi2 (dec x2 (sk (N 1))))) (m x1) (sr 3))
 (if_then_else_M (EQ_M (to x2) (i 2))& (EQ_M ( pi2 (dec x2 (sk (N 2)))) (pk (N 1)))   (enc  ( pi1(dec x2 (sk (N 2)) ) , ((N 4) , (pk (N 2)))) ( pi2 (dec x2 (sk (N 2))))  (sr 4)) O)).

Definition qa01 :=
(if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M (act x2) new)  (enc  ( (N 3) , (pk (N 1))) (m x2) (sr 5)) (if_then_else_M (EQ_M (to x2) (i 2)) &(EQ_M  (dec x2 (sk (N 2))) (N 4)) acc O)).

Definition t13 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
qa10
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) qa01  O)).

Definition phi2:= phi1 ++ [msg t13].

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

Definition mphi2 := (conv_mylist_listm phi2).
Definition x3 := (f mphi2).

Definition qa20 :=   (if_then_else_M (EQ_M (to  x3) (i 2))& (EQ_M ( pi2 (dec x3 (sk (N 2)))) (pk (N 1))) (enc ( pi1 (dec x3 (sk (N 2)) ) , ((N 4) , (pk (N 2)))) ( pi2 (dec x3 (sk (N 2))))   (sr 6))   O).

Definition qa11 :=
 (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M   (pi1  (dec x3 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x3 (sk (N 1))))) (m x1)) (enc  (pi1 (pi2 (dec x3 (sk (N 1))))) (m x1) (sr 7))
(if_then_else_M (EQ_M (to x3) (i 2)) &(EQ_M  (dec x3 (sk (N 2))) (N 4)) acc O)).

Definition qa02 := (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M (act x3) new)   (enc  ( (N 3) , (pk (N 1))) (m x1) (sr 8)) O).
(**********************************************************************)

Definition qa10_s :=
 (if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M   (pi1  (dec x2 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x2 (sk (N 1))))) (m x1)) qa20
 (if_then_else_M (EQ_M (to x2) (i 2))& (EQ_M ( pi2 (dec x2 (sk (N 2)))) (pk (N 1))) qa11 O)).

Definition qa01_s :=
(if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M (act x2) new)  qa11 (if_then_else_M (EQ_M (to x2) (i 2)) &(EQ_M  (dec x2 (sk (N 2))) (N 4)) qa02 O)).

Definition t14 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
qa10_s
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) qa01_s  O)).

Definition phi3:= phi2 ++ [msg t14].

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

Definition mphi3 := (conv_mylist_listm phi3).
Definition x4 := (f mphi3).

(********************qa2000 ->qbar, qa3000, qa2100, qa2001,qbar****************************************************)
(*
Definition qa30 :=
(if_then_else_M (EQ_M (to  x4) (i 2)) &(EQ_M (L (pi1 (dec x4 (sk (N 2))))) lnc)  (enc   ( pi1(dec x4 (sk (N 2)) ) , ( (nc 4) , (pk (N 2))))   (pi2  (dec x4 (sk (N 2)) )) (sr 9))  O ).
  *)
Definition qa21 := (if_then_else_M (EQ_M (to x4) (i 2)) &(EQ_M  (dec x4 (sk (N 2))) (N 4)) acc O).

Definition qa12 := (if_then_else_M (EQ_M (to x4) (i 1)) & (EQ_M   (pi1  (dec x4 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x4 (sk (N 1))))) (m x1)) (enc  (pi1 (pi2 (dec x4 (sk (N 1))))) (m x1) (sr 9)) O) .

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

Definition qa20_s :=   (if_then_else_M (EQ_M (to  x3) (i 2))& (EQ_M ( pi2 (dec x3 (sk (N 2)))) (pk (N 1))) qa21  O).

Definition qa11_s :=
 (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M   (pi1  (dec x3 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x3 (sk (N 1))))) (m x1)) qa21
(if_then_else_M (EQ_M (to x3) (i 2)) &(EQ_M  (dec x3 (sk (N 2))) (N 4)) qa12 O)).

Definition qa02_s := (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M (act x3) new) qa12 O).
(**********************************************************************)

Definition qa10_ss :=
 (if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M   (pi1  (dec x2 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x2 (sk (N 1))))) (m x1)) qa20_s
 (if_then_else_M (EQ_M (to x2) (i 2))& (EQ_M ( pi2 (dec x2 (sk (N 2)))) (pk (N 1))) qa11_s O)).

Definition qa01_ss :=
(if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M (act x2) new)  qa11_s (if_then_else_M (EQ_M (to x2) (i 2)) &(EQ_M  (dec x2 (sk (N 2))) (N 4)) qa02_s O)).

Definition t15 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
qa10_ss
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) qa01_ss  O)).

Definition phi4:= phi3 ++ [msg t15].

(*******************************************phi5****************************************************************)
(***************************************************************************************************************)

Definition mphi4 := (conv_mylist_listm phi4).
Definition x5 := (f mphi4).
(*
Definition qa31 := (if_then_else_M (EQ_M (to x5) (i 2)) &(EQ_M  (dec x5 (sk (N 2))) (nc 4)) acc O).
*)

Definition qa22 := (if_then_else_M (EQ_M (reveal x5) (i 1)) (N 3) O).
(**************************************************************************************************************)

Definition qa21_s := (if_then_else_M (EQ_M (to x4) (i 2)) &(EQ_M  (dec x4 (sk (N 2))) (N 4)) qa22 O).

Definition qa12_s := (if_then_else_M (EQ_M (to x4) (i 1)) & (EQ_M   (pi1  (dec x4 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x4 (sk (N 1))))) (m x1)) qa22 O) .

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

Definition qa20_ss :=   (if_then_else_M (EQ_M (to  x3) (i 2))& (EQ_M ( pi2 (dec x3 (sk (N 2)))) (pk (N 1))) qa21_s  O).

Definition qa11_ss :=
 (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M   (pi1  (dec x3 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x3 (sk (N 1))))) (m x1)) qa21_s
(if_then_else_M (EQ_M (to x3) (i 2)) &(EQ_M  (dec x3 (sk (N 2))) (N 4)) qa12_s O)).

Definition qa02_ss := (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M (act x3) new) qa12_s O).
(**********************************************************************)

Definition qa10_sss :=
 (if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M   (pi1  (dec x2 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x2 (sk (N 1))))) (m x1)) qa20_ss
 (if_then_else_M (EQ_M (to x2) (i 2))& (EQ_M ( pi2 (dec x2 (sk (N 2)))) (pk (N 1))) qa11_ss O)).

Definition qa01_sss :=
(if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M (act x2) new)  qa11_ss (if_then_else_M (EQ_M (to x2) (i 2)) &(EQ_M  (dec x2 (sk (N 2))) (N 4)) qa02_ss O)).

Definition t16 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
qa10_sss
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) qa01_sss  O)).

Definition phi5:= phi3 ++ [msg t16].

(******************************************************************************************************************************************************)
(******************************************************************************************************************************************************)
(***********************protocol Pi2 : add transitions to qa2001************)
(***************************************************************************)

Definition phi21 := phi1.
Definition phi22 := phi2.
Definition phi23 := phi3.
Definition phi24 := phi4.

Definition qb22 := (if_then_else_M (EQ_M (reveal x5) (i 1)) & (EQ_M (m x1) (pk (N 2))) (N 14) (if_then_else_M (EQ_M (reveal x5) (i 1)) (N 3) O)).

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

Definition qb21_s := (if_then_else_M (EQ_M (to x4) (i 2)) &(EQ_M  (dec x4 (sk (N 2))) (N 4)) qb22 O).

Definition qb12_s := (if_then_else_M (EQ_M (to x4) (i 1)) & (EQ_M   (pi1  (dec x4 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x4 (sk (N 1))))) (m x1)) qb22 O) .

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

Definition qb20_ss :=   (if_then_else_M (EQ_M (to  x3) (i 2))& (EQ_M ( pi2 (dec x3 (sk (N 2)))) (pk (N 1))) qb21_s  O).

Definition qb11_ss :=
 (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M   (pi1  (dec x3 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x3 (sk (N 1))))) (m x1)) qb21_s
(if_then_else_M (EQ_M (to x3) (i 2)) &(EQ_M  (dec x3 (sk (N 2))) (N 4)) qb12_s O)).

Definition qb02_ss := (if_then_else_M (EQ_M (to x3) (i 1)) & (EQ_M (act x3) new) qb12_s O).
(**********************************************************************)

Definition qb10_sss :=
 (if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M   (pi1  (dec x2 (sk (N 1)))) (N 3)) &(EQ_M (pi2 (pi2 (dec x2 (sk (N 1))))) (m x1)) qb20_ss
 (if_then_else_M (EQ_M (to x2) (i 2))& (EQ_M ( pi2 (dec x2 (sk (N 2)))) (pk (N 1))) qb11_ss O)).

Definition qb01_sss :=
(if_then_else_M (EQ_M (to x2) (i 1)) & (EQ_M (act x2) new)  qb11_ss (if_then_else_M (EQ_M (to x2) (i 2)) &(EQ_M  (dec x2 (sk (N 2))) (N 4)) qb02_ss O)).

Definition t26 :=
(if_then_else_M (EQ_M (to x1) (i 1)) & (EQ_M (act x1) new)
qb10_sss
(if_then_else_M (EQ_M (to x1) (i 2)) & (EQ_M ( pi2 (dec x1 (sk (N 2)))) (pk (N 1))) qb01_sss  O)).

Definition phi25:= phi4 ++ [msg t26].