           (*-------------------------------------------*
            |  The Dining Mathematicians in CSP-Prover  |
            |               August 2004                 |
            |             December 2004 (modified)      |
            |             November 2005 (modified)      |
            |                March 2007  (modified)     |
            |                April 2020  (modified)     |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DM3_hide
imports DM2_para
begin

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

         1. expands hiding operators in Imp
         2.
         3.
         4.

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

(******************** Hiding ********************)

(*** Back0 VAR Back1 HIDE ***)

lemma Back0_VAR_Back1_HIDE:
  "(Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                        |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F

        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                     -- (CH0 Un CH1))
        [+]
        Back1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                     -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules24)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules24)+
done

lemmas Back0_VAR_Back1_HIDE_simp = Back0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules25 = unfold_Imp_rules24 Back0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules25 = fold_Imp_rules24 Back0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Eat0 VAR Back1 HIDE ***)

lemma Eat0_VAR_Back1_HIDE:
  "EVEN n ==>
   (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F

        Eat0 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1))
        [+]
        Back1 -> ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules25)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules25)+
done

lemmas Eat0_VAR_Back1_HIDE_simp = Eat0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules26 = unfold_Imp_rules25 Eat0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules26 = fold_Imp_rules25 Eat0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR Eat1 HIDE ***)

lemma Back0_VAR_Eat1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        Eat1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                        |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1))
        [+]
        Back0 -> ((($TH0) |[CH0]| ($(VAR n))
                                |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules26)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules26)+
done

lemmas Back0_VAR_Eat1_HIDE_simp = Back0_VAR_Eat1_HIDE[simplified]
lemmas unfold_Imp_rules27 = unfold_Imp_rules26 Back0_VAR_Eat1_HIDE_simp
lemmas fold_Imp_rules27 = fold_Imp_rules26 Back0_VAR_Eat1_HIDE_simp[THEN cspF_sym]

(*** EAT0 VAR Back1 HIDE ***)

lemma EAT0_VAR_Back1_HIDE:
  "EVEN n ==>
   (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        End0 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1))
        [+]
        Back1 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules27)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules27)+
done

lemmas EAT0_VAR_Back1_HIDE_simp = EAT0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules28 = unfold_Imp_rules27 EAT0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules28 = fold_Imp_rules27 EAT0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR EAT1 HIDE ***)

lemma Back0_VAR_EAT1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        End1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                 |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                  -- (CH0 Un CH1))
        [+]
        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                  -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules28)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules28)+
done

lemmas Back0_VAR_EAT1_HIDE_simp = Back0_VAR_EAT1_HIDE[simplified]
lemmas unfold_Imp_rules29 = unfold_Imp_rules28 Back0_VAR_EAT1_HIDE_simp
lemmas fold_Imp_rules29 = fold_Imp_rules28 Back0_VAR_EAT1_HIDE_simp[THEN cspF_sym]

(**************************)
(*** Back0 VAR TH1 HIDE ***)

lemma Back0_VAR_TH1_HIDE:
  "(Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        IF ODD n
        THEN ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Eat1 -> ($(EAT1 n)))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules29)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)

apply (subgoal_tac "{Back0, (RD1 n)} Int (CH0 Un CH1) = {(RD1 n)}")
apply (case_tac "ODD n")
apply (cspF_simp fold_Imp_rules29)+
done

lemmas Back0_VAR_TH1_HIDE_simp = Back0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules30 = unfold_Imp_rules29 Back0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules30 = fold_Imp_rules29 Back0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(**************************)
(*** TH0 VAR Back1 HIDE ***)

lemma TH0_VAR_Back1_HIDE:
  "(($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back1 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        IF EVEN n
        THEN ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                         |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules30)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
apply (subgoal_tac "{Back1, (RD0 n)} Int (CH0 Un CH1) = {(RD0 n)}")
apply (case_tac "ODD n")
apply (cspF_simp fold_Imp_rules30)+
done

lemmas TH0_VAR_Back1_HIDE_simp = TH0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules31 = unfold_Imp_rules30 TH0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules31 = fold_Imp_rules30 TH0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Eat0 VAR TH1 HIDE ***)

lemma Eat0_VAR_TH1_HIDE:
  "EVEN n ==>
   (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1)
   =F
        Eat0 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules31)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas Eat0_VAR_TH1_HIDE_simp = Eat0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules32 = unfold_Imp_rules31 Eat0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules32 = fold_Imp_rules31 Eat0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR Eat1 HIDE ***)

lemma TH0_VAR_Eat1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        Eat1 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules32)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas TH0_VAR_Eat1_HIDE_simp = TH0_VAR_Eat1_HIDE[simplified]
lemmas unfold_Imp_rules33 = unfold_Imp_rules32 TH0_VAR_Eat1_HIDE_simp
lemmas fold_Imp_rules33 = fold_Imp_rules32 TH0_VAR_Eat1_HIDE_simp[THEN cspF_sym]

(*** EAT0 VAR TH1 HIDE ***)

lemma EAT0_VAR_TH1_HIDE:
  "EVEN n ==>
   (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1)
   =F
        End0 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| ($TH1))
                 -- (CH0 Un CH1))
        [>
        (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules33)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas EAT0_VAR_TH1_HIDE_simp = EAT0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules34 = unfold_Imp_rules33 EAT0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules34 = fold_Imp_rules33 EAT0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR EAT1 HIDE ***)

lemma TH0_VAR_EAT1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        End1 -> ((($TH0) |[CH0]| ($(VAR n))
                               |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules34)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas TH0_VAR_EAT1_HIDE_simp = TH0_VAR_EAT1_HIDE[simplified]
lemmas unfold_Imp_rules35 = unfold_Imp_rules34 TH0_VAR_EAT1_HIDE_simp
lemmas fold_Imp_rules35 = fold_Imp_rules34 TH0_VAR_EAT1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR TH1 HIDE step 1 ***)

lemma TH0_VAR_TH1_HIDE:
  "(($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
         -- (CH0 Un CH1)
   =F
       (IF EVEN n
        THEN ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
              -- (CH0 Un CH1)))
        |~|
       (IF ODD n
        THEN ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
              -- (CH0 Un CH1))
        ELSE ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1)))"
apply (cspF_simp_left unfold_Imp_rules35)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD0 n" in exI)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD1 n" in exI)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

(* => *)
 apply (subgoal_tac "{(RD0 n), (RD1 n)} Int (CH0 Un CH1) = {(RD0 n), (RD1 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

  apply (rule cspF_Int_choice_left2)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+
done

lemmas TH0_VAR_TH1_HIDE_simp = TH0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules36 = unfold_Imp_rules35 TH0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules36 = fold_Imp_rules35 TH0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** WR0 VAR Back1 HIDE ***)

lemma WR0_VAR_Back1_HIDE:
  "EVEN n ==>
   (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back1 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                 |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        (($TH0) |[CH0]| ($(VAR (n div 2))) |[CH1]| Back1 -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules36)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas WR0_VAR_Back1_HIDE_simp = WR0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules37 = unfold_Imp_rules36 WR0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules37 = fold_Imp_rules36 WR0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR WR1 HIDE ***)

lemma Back0_VAR_WR1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back0 -> ((($TH0) |[CH0]| ($(VAR n))
                                |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR (3 * n + 1))) |[CH1]| ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules37)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas Back0_VAR_WR1_HIDE_simp = Back0_VAR_WR1_HIDE[simplified]
lemmas unfold_Imp_rules38 = unfold_Imp_rules37 Back0_VAR_WR1_HIDE_simp
lemmas fold_Imp_rules38 = fold_Imp_rules37 Back0_VAR_WR1_HIDE_simp[THEN cspF_sym]

(*** WR0 VAR TH1 HIDE ***)

lemma WR0_VAR_TH1_HIDE:
  "EVEN n ==>
   (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                -- (CH0 Un CH1)
   =F
        (($TH0)  |[CH0]| ($(VAR (n div 2))) |[CH1]| ($TH1))
         -- (CH0 Un CH1)
        |~|
        (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                       |[CH1]| Back1 -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules38)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="WR0 (n div 2)" in exI)
  apply (simp, cspF_simp)  (* modified for Isabelle2020 *)
                           (* "+" is removed *)

  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD1 n" in exI)
  apply (simp, cspF_simp)

(* => *)
 apply (subgoal_tac "{(WR0 (n div 2)), (RD1 n)} Int (CH0 Un CH1) =
                     {(WR0 (n div 2)), (RD1 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left2)
  apply (cspF_simp)+
done

lemmas WR0_VAR_TH1_HIDE_simp = WR0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules39 = unfold_Imp_rules38 WR0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules39 = fold_Imp_rules38 WR0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR WR1 HIDE ***)

lemma TH0_VAR_WR1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                  -- (CH0 Un CH1)
   =F
        (($TH0) |[CH0]| ($(VAR (3 * n + 1))) |[CH1]| ($TH1))
        -- (CH0 Un CH1)
        |~|
        (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                               |[CH1]| WR1 (3 * n + 1) -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules39)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="WR1 (3 * n + 1)" in exI)
  apply (simp, cspF_simp)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD0 n" in exI)
  apply (simp, cspF_simp)

(* => *)
 apply (subgoal_tac "{(WR1 (3 * n + 1)), (RD0 n)} Int (CH0 Un CH1) =
                     {(WR1 (3 * n + 1)), (RD0 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left2)
  apply (cspF_simp)+
done

lemmas TH0_VAR_WR1_HIDE_simp = TH0_VAR_WR1_HIDE[simplified]
lemmas unfold_Imp_rules = unfold_Imp_rules39 TH0_VAR_WR1_HIDE_simp
lemmas fold_Imp_rules = fold_Imp_rules39 TH0_VAR_WR1_HIDE_simp[THEN cspF_sym]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory ML_Goal_Test
imports
  ML_Goal
  "ml-helpers/MLUtils"
begin
experiment begin

\<comment>\<open>
  Basic usage.
\<close>
ML_goal test: \<open>
  [@{term "(P \<longrightarrow> Q) \<and> P \<longrightarrow> Q"}]
\<close>
  apply clarsimp
  done

thm test

\<comment>\<open>
  A goal that we definitely don't want to write out by hand.

  In this case, we're going to show that if x is less than 10,
  we "only" need to consider the cases when x = 0, or x = 1, or...
\<close>
ML_goal big_goal: \<open>
  let
    val var_x = Free ("x", @{typ nat});
    val var_P = Free ("P", @{typ bool});
    val max = 10;

    \<comment>\<open>
      @{ML "HOLogic.mk_nat"} produces nested Suc's, which are pretty
      ugly, so we use this instead.
    \<close>
    val mk_nat = HOLogic.mk_number @{typ nat};

    \<comment>\<open>
      Turns (i: int) into @{term "x = i \<Longrightarrow> P"}.
    \<close>
    fun mk_case i =
        let
          val prem = HOLogic.mk_eq (var_x, mk_nat i) |> HOLogic.mk_Trueprop;
          val conc = var_P |> HOLogic.mk_Trueprop;
        in Logic.mk_implies (prem, conc) end

    val x_cases =
        ListExtras.range 0 max
        |> map mk_case;

    val assm =
        HOLogic.mk_binrel @{const_name "less"}
          (var_x,
          (mk_nat max))
        |> HOLogic.mk_Trueprop;

    val goal =
        Logic.list_implies (assm :: x_cases, var_P |> HOLogic.mk_Trueprop)

  in [goal] end
\<close>
  by force

\<comment>\<open>
  Names are optional.
\<close>
ML_goal \<open>
  [@{term "True"}]
\<close>
  by (rule TrueI)

\<comment>\<open>
  Multiple goals are supported, and result in similar
  "list of fact" lemmas
\<close>
ML_goal multiple_goals: \<open>
  [@{term "(P \<Longrightarrow> Q \<Longrightarrow> P)"}, @{term "(P \<Longrightarrow> Q \<Longrightarrow> Q)"}]
\<close>
  by simp+

thm multiple_goals[OF TrueI]

\<comment>\<open>
  Handles mixes of @{typ bool} and @{typ prop}.
\<close>
ML_goal \<open>
  [@{term "PROP A \<Longrightarrow> PROP A"}, @{term "B \<longrightarrow> B"}]
\<close>
  by simp+

\<comment>\<open>
  Turns out a lemma name can refer to nothing as well!
\<close>
ML_goal nothing: \<open>[]\<close>
  done

thm nothing[OF TrueI]

\<comment>\<open>
  Attributes can be applied, just like normal lemmas.
\<close>
definition magic where "magic = (5 :: nat)"

ML_goal declared_with_an_attribute[folded magic_def, simp]: \<open>
  [@{term "(5 :: nat) = 2 + 3"}]
\<close>
  by simp

lemma uses_our_new_magic_simp_rule:
  "magic = 1 + 4"
  by simp

end

end


theory SINVAR_SecGwExt
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant PolEnforcePointExtended\<close>
text \<open>A PolEnforcePoint is an application-level central policy enforcement point.
Legacy note: The old verions called it a SecurityGateway.

Hosts may belong to a certain domain.
Sometimes, a pattern where intra-domain communication between domain members must be approved by a central instance is required.

We call such a central instance PolEnforcePoint and present a template for this architecture.
Five host roles are distinguished:.
A PolEnforcePoint, aPolEnforcePointIN which accessible from the outside, a DomainMember,
a less-restricted AccessibleMember which is accessible from the outside world,
and a default value Unassigned that reflects none of these roles.\<close>

datatype secgw_member = PolEnforcePoint | PolEnforcePointIN | DomainMember  | AccessibleMember | Unassigned

definition default_node_properties :: "secgw_member"
  where  "default_node_properties \<equiv> Unassigned"

fun allowed_secgw_flow :: "secgw_member \<Rightarrow> secgw_member \<Rightarrow> bool" where
  "allowed_secgw_flow PolEnforcePoint _ = True" |
  "allowed_secgw_flow PolEnforcePointIN _ = True" |
  "allowed_secgw_flow DomainMember DomainMember = False" |
  "allowed_secgw_flow DomainMember _ = True" |
  "allowed_secgw_flow AccessibleMember DomainMember = False" |
  "allowed_secgw_flow AccessibleMember _ = True" |
  "allowed_secgw_flow Unassigned Unassigned = True" |
  "allowed_secgw_flow Unassigned PolEnforcePointIN = True" |
  "allowed_secgw_flow Unassigned AccessibleMember = True" |
  "allowed_secgw_flow Unassigned _ = False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. e1 \<noteq> e2 \<longrightarrow> allowed_secgw_flow (nP e1) (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection \<open>Preliminaries\<close>

subsubsection\<open>ENF\<close>
  lemma PolEnforcePoint_ENFnr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl sinvar allowed_secgw_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_def)
  lemma Unassigned_botdefault: "\<forall> e1 e2. e2 \<noteq> Unassigned \<longrightarrow> \<not> allowed_secgw_flow e1 e2 \<longrightarrow> \<not> allowed_secgw_flow Unassigned e2"
    apply(rule allI)+
    apply(case_tac e2)
        apply(simp_all)
     apply(case_tac e1)
          apply(simp_all)
    apply(case_tac e1)
        apply(simp_all)
    done
  lemma Unassigned_not_to_Member: "\<not> allowed_secgw_flow Unassigned DomainMember"
    by(simp)
  lemma All_to_Unassigned: "\<forall> e1. allowed_secgw_flow e1 Unassigned"
    by (rule allI, case_tac e1, simp_all)

  definition PolEnforcePointExtended_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> ('v \<times> 'v) set set" where
  "PolEnforcePointExtended_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_secgw_flow (nP e1) (nP e2)} })"
  lemma PolEnforcePointExtended_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = PolEnforcePointExtended_offending_set"
    apply(simp only: fun_eq_iff ENFnr_offending_set[OF PolEnforcePoint_ENFnr] PolEnforcePointExtended_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation PolEnforcePointExtended: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = PolEnforcePointExtended_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENFnr_fsts_weakrefl_instance[OF PolEnforcePoint_ENFnr Unassigned_botdefault All_to_Unassigned])[1]
     apply(simp)
    apply(simp)
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
      apply(rename_tac secgwcase)
      apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
      apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
     apply(rename_tac secgwINcase)
     apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
    apply(rename_tac membercase)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := PolEnforcePoint)" in exI, simp)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := PolEnforcePoint)" in exI, simp)
   apply(rule_tac x="vertex_1" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)

  apply(fact PolEnforcePointExtended_offending_set)
 done

  lemma TopoS_PolEnforcePointExtended: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation

end


(*  Title:      HOL/Auth/OtwayRees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Original Otway-Rees Protocol\<close>

theory OtwayRees imports Public begin

text\<open>From page 244 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This is the original version, which encrypts Nonce NB.\<close>

inductive_set otway :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> otway"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) \<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> otway"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "\<lbrakk>evsr \<in> otway;  Says A B X \<in>set evsr\<rbrakk>
               \<Longrightarrow> Gets B X # evsr \<in> otway"

         (*Alice initiates a protocol run*)
 | OR1:  "\<lbrakk>evs1 \<in> otway;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Nonce NA, Agent A, Agent B,
                         Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace> \<rbrace>
                 # evs1 \<in> otway"

         (*Bob's response to Alice's message.  Note that NB is encrypted.*)
 | OR2:  "\<lbrakk>evs2 \<in> otway;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Nonce NA, Agent A, Agent B, X\<rbrace> \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B Server
                  \<lbrace>Nonce NA, Agent A, Agent B, X,
                    Crypt (shrK B)
                      \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
                 # evs2 \<in> otway"

         (*The Server receives Bob's message and checks that the three NAs
           match.  Then he sends a new session key to Bob with a packet for
           forwarding to Alice.*)
 | OR3:  "\<lbrakk>evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server
                  \<lbrace>Nonce NA, Agent A, Agent B,
                    Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>,
                    Crypt (shrK B) \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
               \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says Server B
                  \<lbrace>Nonce NA,
                    Crypt (shrK A) \<lbrace>Nonce NA, Key KAB\<rbrace>,
                    Crypt (shrK B) \<lbrace>Nonce NB, Key KAB\<rbrace>\<rbrace>
                 # evs3 \<in> otway"

         (*Bob receives the Server's (?) message and compares the Nonces with
           those in the message he previously sent the Server.
           Need B \<noteq> Server because we allow messages to self.*)
 | OR4:  "\<lbrakk>evs4 \<in> otway;  B \<noteq> Server;
             Says B Server \<lbrace>Nonce NA, Agent A, Agent B, X',
                             Crypt (shrK B)
                                   \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
               \<in> set evs4;
             Gets B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               \<in> set evs4\<rbrakk>
          \<Longrightarrow> Says B A \<lbrace>Nonce NA, X\<rbrace> # evs4 \<in> otway"

         (*This message models possible leaks of session keys.  The nonces
           identify the protocol run.*)
 | Oops: "\<lbrakk>evso \<in> otway;
             Says Server B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               \<in> set evso\<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> otway"

declare Says_imp_analz_Spy [dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "\<lbrakk>B \<noteq> Server; Key K \<notin> used []\<rbrakk>
      \<Longrightarrow> \<exists>evs \<in> otway.
             Says B A \<lbrace>Nonce NA, Crypt (shrK A) \<lbrace>Nonce NA, Key K\<rbrace>\<rbrace>
               \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> otway\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

(** For reasoning about the encrypted portion of messages **)

lemma OR2_analz_knows_Spy:
     "\<lbrakk>Gets B \<lbrace>N, Agent A, Agent B, X\<rbrace> \<in> set evs;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

lemma OR4_analz_knows_Spy:
     "\<lbrakk>Gets B \<lbrace>N, X, Crypt (shrK B) X'\<rbrace> \<in> set evs;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

(*These lemmas assist simplification by removing forwarded X-variables.
  We can replace them by rewriting with parts_insert2 and proving using
  dest: parts_cut, but the proofs become more difficult.*)
lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

(*There could be OR4_parts_knows_Spy and Oops_parts_knows_Spy, but for
  some reason proofs work without them!*)

text\<open>Theorems of the form \<^term>\<open>X \<notin> parts (spies evs)\<close> imply that
NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection\<open>Towards Secrecy: Proofs Involving \<^term>\<open>analz\<close>\<close>

(*Describes the form of K and NA when the Server sends this message.  Also
  for Oops case.*)
lemma Says_Server_message_form:
     "\<lbrakk>Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and> (\<exists>i. NA = Nonce i) \<and> (\<exists>j. NB = Nonce j)"
by (erule rev_mp, erule otway.induct, simp_all)

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> -(range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy)
apply (drule_tac [5] OR2_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "\<lbrakk>evs \<in> otway;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message.\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, K\<rbrace>\<rbrace>   \<in> set evs;
         Says Server B' \<lbrace>NA',X',Crypt (shrK B') \<lbrace>NB',K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway\<rbrakk> \<Longrightarrow> X=X' \<and> B=B' \<and> NA=NA' \<and> NB=NB'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply blast+  \<comment> \<open>OR3 and OR4\<close>
done

subsection\<open>Authenticity properties relating to NA\<close>

text\<open>Only OR1 can have caused such a part of a message to appear.\<close>
lemma Crypt_imp_OR1 [rule_format]:
 "\<lbrakk>A \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
      Says A B \<lbrace>NA, Agent A, Agent B,
                 Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
        \<in> set evs"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Crypt_imp_OR1_Gets:
     "\<lbrakk>Gets B \<lbrace>NA, Agent A, Agent B,
                  Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         A \<notin> bad; evs \<in> otway\<rbrakk>
       \<Longrightarrow> Says A B \<lbrace>NA, Agent A, Agent B,
                      Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
             \<in> set evs"
by (blast dest: Crypt_imp_OR1)

text\<open>The Nonce NA uniquely identifies A's message\<close>
lemma unique_NA:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK A) \<lbrace>NA, Agent A, Agent C\<rbrace> \<in> parts (knows Spy evs);
         evs \<in> otway;  A \<notin> bad\<rbrakk>
      \<Longrightarrow> B = C"
apply (erule rev_mp, erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>It is impossible to re-use a nonce in both OR1 and OR2.  This holds because
  OR2 encrypts Nonce NB.  It prevents the attack that can occur in the
  over-simplified version of this protocol: see \<open>OtwayRees_Bad\<close>.\<close>
lemma no_nonce_OR1_OR2:
   "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
       A \<notin> bad;  evs \<in> otway\<rbrakk>
    \<Longrightarrow> Crypt (shrK A) \<lbrace>NA', NA, Agent A', Agent A\<rbrace> \<notin> parts (knows Spy evs)"
apply (erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>Crucial property: If the encrypted message appears, and A has used NA
  to start a run, then it originated with the Server!\<close>
lemma NA_Crypt_imp_Server_msg [rule_format]:
     "\<lbrakk>A \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs \<longrightarrow>
          Crypt (shrK A) \<lbrace>NA, Key K\<rbrace> \<in> parts (knows Spy evs)
          \<longrightarrow> (\<exists>NB. Says Server B
                         \<lbrace>NA,
                           Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                           Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs)"
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast)
  subgoal \<comment> \<open>OR1: by freshness\<close>
    by blast
  subgoal \<comment> \<open>OR3\<close>
    by (blast dest!: no_nonce_OR1_OR2 intro: unique_NA)
  subgoal \<comment> \<open>OR4\<close>
    by (blast intro!: Crypt_imp_OR1)
done

text\<open>Corollary: if A receives B's OR4 message and the nonce NA agrees
  then the key really did come from the Server!  CANNOT prove this of the
  bad form of this protocol, even though we can prove
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma A_trusts_OR4:
     "\<lbrakk>Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
     A \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>NB. Says Server B
               \<lbrace>NA,
                 Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                 Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NA_Crypt_imp_Server_msg)

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having \<^term>\<open>A=Spy\<close>\<close>
lemma secrecy_lemma:
 "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Says Server B
        \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
          Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs \<longrightarrow>
      Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs \<longrightarrow>
      Key K \<notin> analz (knows Spy evs)"
  apply (erule otway.induct, force, simp_all)
  subgoal \<comment> \<open>Fake\<close>
    by spy_analz
  subgoal \<comment> \<open>OR2\<close>
    by (drule OR2_analz_knows_Spy) (auto simp: analz_insert_eq)
  subgoal \<comment> \<open>OR3\<close>
    by (auto simp add: analz_insert_freshK pushes)
  subgoal \<comment> \<open>OR4\<close>
    by (drule OR4_analz_knows_Spy) (auto simp: analz_insert_eq)
  subgoal \<comment> \<open>Oops\<close>
    by (auto simp add: Says_Server_message_form analz_insert_freshK unique_session_keys)
  done

theorem Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server B
          \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

text\<open>This form is an immediate consequence of the previous result.  It is
similar to the assertions established by other methods.  It is equivalent
to the previous result in that the Spy already has \<^term>\<open>analz\<close> and
\<^term>\<open>synth\<close> at his disposal.  However, the conclusion
\<^term>\<open>Key K \<notin> knows Spy evs\<close> appears not to be inductive: all the cases
other than Fake are trivial, while Fake requires
\<^term>\<open>Key K \<notin> analz (knows Spy evs)\<close>.\<close>
lemma Spy_not_know_encrypted_key:
     "\<lbrakk>Says Server B
          \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> knows Spy evs"
by (blast dest: Spy_not_see_encrypted_key)

text\<open>A's guarantee.  The Oops premise quantifies over NB because A cannot know
  what it is.\<close>
lemma A_gets_good_key:
     "\<lbrakk>Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
         \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_OR4 Spy_not_see_encrypted_key)

subsection\<open>Authenticity properties relating to NB\<close>

text\<open>Only OR2 can have caused such a part of a message to appear.  We do not
  know anything about X: it does NOT have to have the right form.\<close>
lemma Crypt_imp_OR2:
     "\<lbrakk>Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> \<exists>X. Says B Server
                 \<lbrace>NA, Agent A, Agent B, X,
                   Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
                 \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>The Nonce NB uniquely identifies B's  message\<close>
lemma unique_NB:
     "\<lbrakk>Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace> \<in> parts(knows Spy evs);
         Crypt (shrK B) \<lbrace>NC, NB, Agent C, Agent B\<rbrace> \<in> parts(knows Spy evs);
           evs \<in> otway;  B \<notin> bad\<rbrakk>
         \<Longrightarrow> NC = NA \<and> C = A"
apply (erule rev_mp, erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all)
apply blast+  \<comment> \<open>Fake, OR2\<close>
done

text\<open>If the encrypted message appears, and B has used Nonce NB,
  then it originated with the Server!  Quite messy proof.\<close>
lemma NB_Crypt_imp_Server_msg [rule_format]:
 "\<lbrakk>B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Crypt (shrK B) \<lbrace>NB, Key K\<rbrace> \<in> parts (knows Spy evs)
      \<longrightarrow> (\<forall>X'. Says B Server
                     \<lbrace>NA, Agent A, Agent B, X',
                       Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs
           \<longrightarrow> Says Server B
                \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                      Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                    \<in> set evs)"
apply simp
apply (erule otway.induct, force, simp_all)
  subgoal \<comment> \<open>Fake\<close>
    by blast
  subgoal \<comment> \<open>OR2\<close>
    by (force dest!: OR2_parts_knows_Spy)
  subgoal \<comment> \<open>OR3\<close>
    by (blast dest: unique_NB dest!: no_nonce_OR1_OR2)  \<comment> \<open>OR3\<close>
  subgoal \<comment> \<open>OR4\<close>
    by (blast dest!: Crypt_imp_OR2)
done

text\<open>Guarantee for B: if it gets a message with matching NB then the Server
  has sent the correct message.\<close>
theorem B_trusts_OR3:
     "\<lbrakk>Says B Server \<lbrace>NA, Agent A, Agent B, X',
                         Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs;
         Gets B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Says Server B
               \<lbrace>NA,
                 Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                 Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NB_Crypt_imp_Server_msg)

text\<open>The obvious combination of \<open>B_trusts_OR3\<close> with
      \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "\<lbrakk>Says B Server \<lbrace>NA, Agent A, Agent B, X',
                         Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs;
         Gets B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_OR3 Spy_not_see_encrypted_key)

lemma OR3_imp_OR2:
     "\<lbrakk>Says Server B
              \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>X. Says B Server \<lbrace>NA, Agent A, Agent B, X,
                            Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
              \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply (blast dest!: Crypt_imp_OR2)+
done

text\<open>After getting and checking OR4, agent A can trust that B has been active.
  We could probably prove that X has the expected form, but that is not
  strictly necessary for authentication.\<close>
theorem A_auths_B:
     "\<lbrakk>Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
         Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>NB X. Says B Server \<lbrace>NA, Agent A, Agent B, X,
                               Crypt (shrK B)  \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast dest!: A_trusts_OR4 OR3_imp_OR2)

end


theory Indirections
imports Terms "Nominal-Utils" "AList-Utils-Nominal" "FMap-Heap" "FMap-Nominal"
begin

type_synonym indirections = "(var \<times> var) list "

class resolvable =
  fixes resolve :: "'a \<Rightarrow> indirections \<Rightarrow> 'a" (infixl "\<ominus>" 60)
  assumes resolve_append[simp]: "x \<ominus> (is'@is) = x \<ominus> is' \<ominus> is"
  assumes resolve_Nil[simp]: "x \<ominus> [] = x"

class resolvable_eqvt = resolvable + pt +
  assumes resolve_eqvt: "p \<bullet> (x \<ominus> is) = (p \<bullet> x) \<ominus> (p \<bullet> is)"
  assumes resolve_fresh_noop[simp]: "atom a \<sharp> x \<Longrightarrow> x \<ominus> ((a, b) # is) = x \<ominus> is"

declare resolve_eqvt[eqvt]

instantiation list :: (resolvable) resolvable
begin
  definition resolve_list :: "'a list \<Rightarrow> indirections \<Rightarrow> 'a list"
  where "m \<ominus> is = map (\<lambda>x. x \<ominus> is) m"

  lemma resolve_list_Nil[simp]: "[] \<ominus> is = []"
    unfolding resolve_list_def by simp

  lemma resolve_list_Cons[simp]: "(x # xs) \<ominus> is = (x \<ominus> is) # (xs \<ominus> is)"
    unfolding resolve_list_def by simp
instance
  apply default
  apply (induct_tac "x", auto)
  apply (simp add: resolve_list_def)
  done
end

instance list :: (resolvable_eqvt) resolvable_eqvt
  apply default
  apply (simp add: resolve_list_def)
  apply (simp add: resolve_list_def fresh_list_elem)
  done

instantiation var :: resolvable_eqvt
begin
  fun resolve_var :: "var \<Rightarrow> indirections \<Rightarrow> var"  where
    "v \<ominus> [] = (v::var)"
    | "v \<ominus> ((x,y)#is) = v[x ::v= y] \<ominus> is"

  lemma resolve_var_append: "(v::var) \<ominus> (is'@is) = v \<ominus> is' \<ominus> is"
    by (induct "is'" arbitrary: v) auto
instance
  apply default
  apply (rule resolve_var_append)
  apply (simp)
  apply (induct_tac x "is" rule:resolve_var.induct, simp+)
  done
end

lemma resove_var_noop[simp]: "x \<notin> heapVars is \<Longrightarrow> x \<ominus> is = x"
  by (induct x "is" rule: resolve_var.induct) auto

instantiation exp :: resolvable_eqvt
begin
  fun resolve_exp :: "exp \<Rightarrow> indirections \<Rightarrow> exp" where
    "e \<ominus> [] = (e::exp)"
    | "e \<ominus> ((x,y)#is) = (e[x ::= y]) \<ominus> is"

  lemma resolve_exp_append: "(e::exp) \<ominus> (is'@is) = e \<ominus> is' \<ominus> is"
    by (induct "is'" arbitrary: e) auto

  lemma resolve_exp_eqvt[eqvt]: "p \<bullet> ((e::exp) \<ominus> is) = (p \<bullet> e) \<ominus> (p \<bullet> is)"
    by (induction e "is" rule:resolve_exp.induct) simp+

instance
  apply default
  apply (rule resolve_exp_append)
  apply simp
  apply (rule resolve_exp_eqvt)
  apply (simp add: subst_fresh_noop)
  done
end

instantiation assn :: resolvable_eqvt
begin
  fun resolve_assn :: "assn \<Rightarrow> indirections \<Rightarrow> assn" where
    "as \<ominus> [] = (as::assn)"
    | "as \<ominus> ((x,y)#is) = (as[x ::a= y]) \<ominus> is"

  lemma resolve_assn_append: "(as::assn) \<ominus> (is'@is) = as\<ominus> is' \<ominus> is"
    by (induct "is'" arbitrary: as) auto

  lemma resolve_assn_eqvt[eqvt]: "p \<bullet> ((as::assn) \<ominus> is) = (p \<bullet> as) \<ominus> (p \<bullet> is)"
    by (induction as "is" rule:resolve_assn.induct) simp+

instance
  apply default
  apply (rule resolve_assn_append)
  apply simp
  apply (rule resolve_assn_eqvt)
  apply (simp add: subst_assn_fresh_noop)
  done
end

lemma resolve_var_fresh: "atom ` heapVars is \<sharp>* v \<Longrightarrow> (v::var) \<ominus> is = v"
  by (induct "is" rule:resolve_var.induct)(auto simp add: fresh_star_def fresh_def )

lemma resolve_var_fresh'[simp]: "atom v \<sharp> is \<Longrightarrow> (v::var) \<ominus> is = v"
  by (induct "is" rule:resolve_var.induct)(auto simp add: fresh_Cons fresh_Pair)

lemma resolve_var_list_fresh: "atom ` heapVars is \<sharp>* L \<Longrightarrow> (L::var list) \<ominus> is = L"
  by (induct L) (auto simp add: fresh_star_list resolve_var_fresh)

lemma resolveExp_Lam: "atom x \<sharp> is \<Longrightarrow> (Lam [x]. e) \<ominus> is = Lam [x]. (e \<ominus> is)"
  apply (induction "is" arbitrary: e)
  apply simp
  apply (auto simp add: fresh_Cons)
  done

lemma resolveExp_App: "App e x \<ominus> is = App (e \<ominus> is) (x \<ominus> is)"
  by (induction "is" arbitrary: e x) auto

lemma resolveExp_Var: "Var x \<ominus> is = Var (x \<ominus> is)"
  by (induction "is" arbitrary: x) auto

lemma resolveExp_Let: "set (bn as) \<sharp>* is \<Longrightarrow> (Let as e) \<ominus> is = Let (as \<ominus> is) (e \<ominus> is)"
  by (induction "is" arbitrary: as e) (auto simp add: fresh_star_list)

lemma resolve_assn_ANil[simp]: "ANil \<ominus> is = ANil"
  by (induction "is") auto

lemma resolve_assn_ACons[simp]: "x \<notin> heapVars is \<Longrightarrow> (ACons x e as) \<ominus> is = (ACons (x \<ominus> is) (e \<ominus> is) (as \<ominus> is))"
  by (induction "is" arbitrary: x e as) auto

definition resolveHeap' :: "Heap \<Rightarrow> indirections \<Rightarrow> Heap"  (infixl "\<ominus>\<^sub>H" 60) where
  "\<Gamma> \<ominus>\<^sub>H is = fmap_map (\<lambda>e. e \<ominus> is) (\<Gamma> f|` (- heapVars is))"

lemma resolveHeap'_empty[simp]: "f\<emptyset> \<ominus>\<^sub>H is = f\<emptyset>"
  unfolding resolveHeap'_def by auto

lemma resolveHeap'_Nil[simp]: "\<Gamma> \<ominus>\<^sub>H [] = \<Gamma>"
  unfolding resolveHeap'_def by auto

lemma resolveHeap'fdom[simp]:
  "fdom (\<Gamma> \<ominus>\<^sub>H is) = fdom \<Gamma> - heapVars is"
  unfolding resolveHeap'_def by auto

lemma resolveHeap'_fmap_upd[simp]: "x \<in> heapVars is \<Longrightarrow> (\<Gamma>(x f\<mapsto> e)) \<ominus>\<^sub>H is = \<Gamma> \<ominus>\<^sub>H is"
  unfolding resolveHeap'_def by auto

lemma resolveHeap'_fmap_upd_other[simp]: "x \<notin> heapVars is \<Longrightarrow> (\<Gamma>(x f\<mapsto> e)) \<ominus>\<^sub>H is = (\<Gamma> \<ominus>\<^sub>H is)(x f\<mapsto> e \<ominus> is)"
  unfolding resolveHeap'_def by simp

lemma resolveHeap'_fun_merge[simp]: "fdom \<Delta> \<inter> heapVars is = {} \<Longrightarrow> (\<Gamma> f++ \<Delta>) \<ominus>\<^sub>H is = (\<Gamma> \<ominus>\<^sub>H is) f++ (\<Delta> \<ominus>\<^sub>H is)"
  by (induction \<Delta> rule:fmap_induct) (auto simp add: fun_merge_upd)

lemma resolveHeap'_fmap_copy[simp]: "x \<in> heapVars is \<Longrightarrow> (fmap_copy \<Gamma> y x) \<ominus>\<^sub>H is = \<Gamma> \<ominus>\<^sub>H is"
  unfolding resolveHeap'_def by simp

lemma resolveHeap'_fmap_copy_other[simp]: "x \<notin> heapVars is \<Longrightarrow> y \<notin> heapVars is \<Longrightarrow> (fmap_copy \<Gamma> y x) \<ominus>\<^sub>H is = fmap_copy (\<Gamma> \<ominus>\<^sub>H is) y x"
  unfolding resolveHeap'_def by auto

lemma resolveHeap'_fresh_Cons[simp]: "atom y \<sharp> \<Gamma> \<Longrightarrow> \<Gamma> \<ominus>\<^sub>H (y,x)#is = \<Gamma> \<ominus>\<^sub>H is"
  unfolding resolveHeap'_def
  by (rule fmap_map_cong[OF resolve_fresh_noop])
     (auto dest: set_mp[OF fran_fmap_restr_subset] intro: fmap_restr_cong simp add: fresh_def supp_fmap supp_set_elem_finite)

lemma resolveHeap'_eqvt[eqvt]: "p \<bullet> resolveHeap' \<Gamma> is = resolveHeap' (p \<bullet> \<Gamma>) (p \<bullet> is)"
  unfolding resolveHeap'_def
  by (simp add: fmap_restr_eqvt Compl_eqvt)

fun resolveHeapOne :: "heap \<Rightarrow> var \<Rightarrow> var \<Rightarrow> heap"  where
  "resolveHeapOne [] _ _ = []"
 | "resolveHeapOne ((x,e)#\<Gamma>) a b = (if a = x then (resolveHeapOne \<Gamma> a b) else (x, e[a ::= b]) # (resolveHeapOne \<Gamma> a b))"

lemma resolveHeapOneFresh: "atom y \<sharp> x \<Longrightarrow> atom y \<sharp> resolveHeapOne \<Gamma> y x"
  by (induction \<Gamma> y x rule:resolveHeapOne.induct)
     (auto simp add: fresh_Nil fresh_Cons fresh_Pair)

lemma resolveHeapOne_eqvt[eqvt]: "p \<bullet> resolveHeapOne \<Gamma> a b = resolveHeapOne (p \<bullet> \<Gamma>) (p \<bullet> a) (p \<bullet> b)"
  by (induction \<Gamma> a b rule:resolveHeapOne.induct) simp_all

lemma resolveHeapOneNoop[simp]: "atom y \<sharp> \<Gamma> \<Longrightarrow> resolveHeapOne \<Gamma> y x = \<Gamma>"
  by (induction \<Gamma> y x rule:resolveHeapOne.induct)
     (auto simp add: fresh_Nil fresh_Cons fresh_Pair subst_fresh_noop)

fun resolveHeap :: "heap \<Rightarrow> indirections \<Rightarrow> heap" (infixl "\<ominus>\<^sub>h" 60) where
  "\<Gamma> \<ominus>\<^sub>h [] = \<Gamma>"
 | "\<Gamma> \<ominus>\<^sub>h ((a,b)#is) = resolveHeapOne \<Gamma> a b \<ominus>\<^sub>h is"

lemma resolveHeapNil[simp]: "[] \<ominus>\<^sub>h is = []"
  by (induct "[]::heap" "is" rule:resolveHeap.induct) simp_all

lemma resolveHeapConsRemoved[simp]: "x \<in> heapVars is \<Longrightarrow> (x,e)#\<Gamma> \<ominus>\<^sub>h is = \<Gamma> \<ominus>\<^sub>h is"
  apply (induct "(x,e)#\<Gamma>" "is" arbitrary: x e \<Gamma> rule:resolveHeap.induct)
  apply simp_all
  apply (erule disjE)
  apply auto
  done

lemma resolveHeapCons[simp]: "x \<notin> heapVars is \<Longrightarrow> (x,e)#\<Gamma> \<ominus>\<^sub>h is = (x, e \<ominus> is) # (\<Gamma> \<ominus>\<^sub>h is)"
  apply (induct "(x,e)#\<Gamma>" "is" arbitrary: x e \<Gamma> rule:resolveHeap.induct)
  apply simp_all
  done

lemma resolveHeapConsRemoved'[simp]: "x \<in> heapVars is \<Longrightarrow> (y,z)#(x,e)#\<Gamma> \<ominus>\<^sub>h is = ((y,z)#\<Gamma>) \<ominus>\<^sub>h is"
  apply (cases "y \<in> heapVars is")
  apply simp_all
  done

lemma resolveHeapOneDelete[simp]: "resolveHeapOne (delete x \<Gamma>) a b = delete x (resolveHeapOne \<Gamma> a b)"
  by (induct \<Gamma> a b rule:resolveHeapOne.induct) auto

lemma resolveHeapDelete[simp]: "delete x \<Gamma> \<ominus>\<^sub>h is = delete x (\<Gamma> \<ominus>\<^sub>h is)"
  by (induct \<Gamma> "is" arbitrary: x rule:resolveHeap.induct) simp_all

lemma resolveHeapOneHeapVars[simp]:
  "heapVars (resolveHeapOne \<Gamma> a b) = heapVars \<Gamma> - {a}"
  by (induct \<Gamma> a b rule:resolveHeapOne.induct) auto

lemma resolveHeapHeapVars[simp]:
  "heapVars (\<Gamma> \<ominus>\<^sub>h is) = heapVars \<Gamma> - heapVars is"
  by (induct \<Gamma> "is" rule:resolveHeap.induct) auto

lemma resolveHeapOneDeleted[simp]:
  "delete a (resolveHeapOne \<Gamma> a b \<ominus>\<^sub>h is) = resolveHeapOne \<Gamma> a b \<ominus>\<^sub>h is"
  by (rule delete_no_there, simp)

lemma resolveHeapDeleted[simp]: "x \<in> heapVars is \<Longrightarrow> delete x (\<Gamma> \<ominus>\<^sub>h is) = \<Gamma> \<ominus>\<^sub>h is"
  by (rule delete_no_there, simp)

lemma resolveHeap_eqvt[eqvt]: "p \<bullet> resolveHeap \<Gamma> is = resolveHeap (p \<bullet> \<Gamma>) (p \<bullet> is)"
  by(induction \<Gamma> "is" rule:resolveHeap.induct) simp_all

lemma resolveHeap_append[simp]: "\<Gamma> \<ominus>\<^sub>h (is'@is) = \<Gamma> \<ominus>\<^sub>h is' \<ominus>\<^sub>h is"
  apply (induct \<Gamma> "is'" rule:resolveHeap.induct)
  apply (auto)
  done

lemma resolveHeapOne_set: "(y, e) \<in> set \<Gamma> \<Longrightarrow> y \<noteq> a \<Longrightarrow> (y, e[a ::= b]) \<in> set (resolveHeapOne \<Gamma> a b)"
  by (induct \<Gamma> a b rule:resolveHeapOne.induct) auto

lemma resolveHeap_set: "(y, e) \<in> set \<Gamma> \<Longrightarrow> y \<notin> heapVars is \<Longrightarrow> (y, e \<ominus> is) \<in> set (\<Gamma> \<ominus>\<^sub>h is)"
  by (induct \<Gamma> "is" arbitrary: e rule:resolveHeap.induct) (auto dest: resolveHeapOne_set)

definition indirection_related :: "heap \<Rightarrow> exp \<Rightarrow> indirections \<Rightarrow> heap \<Rightarrow> exp \<Rightarrow> bool" where
  "indirection_related \<Gamma> e is \<Gamma>' e' = (resolveHeap \<Gamma> is = \<Gamma>' \<and>  e \<ominus> is = e')"

lemma subst_subst: "a \<noteq> y \<Longrightarrow> b \<noteq> y \<Longrightarrow> e[y ::= x][a ::= b] = (e[a ::= b])[y ::= x[a ::v= b]]"
    and  "a \<noteq> y \<Longrightarrow> b \<noteq> y \<Longrightarrow> as[y ::a= x][a ::a= b] = (as[a ::a= b])[y ::a= x[a ::v= b]]"
  apply (nominal_induct e and as avoiding: x y a b  rule:exp_assn.strong_induct)
  apply (auto simp add: fresh_star_Pair)
  done

lemma resolve_subst: "atom y \<sharp> is \<Longrightarrow> e[y ::= x] \<ominus> is = (e \<ominus> is)[y ::= (x \<ominus> is)]"
proof (induct e "is" arbitrary: x y rule: resolve_exp.induct)
case goal1 thus ?case by simp
next
case (goal2 e a b "is" x y)
  from goal2(2)
  have ab_ne_y: "a \<noteq> y" "b \<noteq> y" and  "atom y \<sharp> is"
   by (auto simp add: fresh_Pair fresh_Cons fresh_at_base)

  have "e[y::=x] \<ominus> (a, b) # is = e[y::=x][a ::= b] \<ominus> is" by simp
  also
  have "\<dots> = e[a ::= b][y ::=x[a ::v= b]] \<ominus> is"
    by (rule arg_cong[OF subst_subst[OF ab_ne_y]])
  also
  have "\<dots> = (e[a ::= b] \<ominus> is)[y ::= (x[a ::v= b]  \<ominus> is)]"
    by (rule goal2(1)[OF `atom y \<sharp> is`])
  also
  have "\<dots> = (e \<ominus> (a, b) # is)[y ::= (x \<ominus> (a, b) # is)]"
    by simp
  finally show ?case.
qed

lemma
  flip_subst: "atom y' \<sharp> (e,x) \<Longrightarrow> ((y \<leftrightarrow> y') \<bullet> e)[y' ::=x ] = e[y ::= x]"
    and  "atom y \<notin> set (bn as) \<Longrightarrow> atom y' \<sharp> (as,x) \<Longrightarrow> ((y \<leftrightarrow> y') \<bullet> as)[y' ::a=x ] = as[y ::a= x]"
proof (nominal_induct e and as avoiding: y y' x rule:exp_assn.strong_induct)
case (Let as exp y y' x)
  have "atom y \<notin> set (bn as)"
    using Let(1) by (auto simp add: fresh_star_def)
  moreover
  have "(y \<leftrightarrow> y') \<bullet> bn as = bn as"
    apply -
    apply (rule flip_fresh_fresh)
    using calculation apply (simp add: fresh_def supp_of_atom_list)
    using  Let.hyps(2) apply (metis fresh_def fresh_star_def not_self_fresh supp_of_atom_list)
    done
  moreover note Let
  ultimately
  show ?case
    by (auto simp add: fresh_Pair fresh_star_Pair fresh_star_def simp del: exp_assn.eq_iff)
next
qed (auto simp add: fresh_Pair fresh_star_Pair exp_assn.bn_defs  flip_fresh_fresh simp del: exp_assn.eq_iff)

lemma supp_atom_set: "supp L = atom ` set L"
  apply (induct L)
  apply (simp add: supp_Nil)
  apply (clarsimp simp add: supp_Nil supp_Cons supp_at_base)
  done

inductive valid_ind :: "indirections \<Rightarrow> bool" where
  ValidIndNil[simp]: "valid_ind []" |
  ValidIndCons: "valid_ind is \<Longrightarrow> atom x \<sharp> (is,y) \<Longrightarrow> valid_ind ((x,y) # is)"

lemma heapVarFresh: "x \<in> heapVars is \<Longrightarrow> atom x \<sharp> ((v::var) \<ominus> is)" oops

lemma resolveHeap_fresh:  "valid_ind is \<Longrightarrow> x \<in> heapVars is \<Longrightarrow> atom x \<sharp> (\<Gamma> \<ominus>\<^sub>h is)"
  by (induct arbitrary: \<Gamma> rule:valid_ind.induct)
     (auto simp add: fresh_Pair resolveHeapOneFresh eqvt_fresh_cong2[where f = resolveHeap, OF resolveHeap_eqvt])

lemma resolve_expr_fresh:
  assumes "valid_ind is"
  assumes "x \<in> heapVars is"
  shows "atom x \<sharp> ((e :: exp) \<ominus> is)"
using assms
  by (induct arbitrary: e rule:valid_ind.induct)
     (auto simp add: fresh_Pair eqvt_fresh_cong2[where f = resolve, OF resolve_eqvt])

lemma resolveHeap'_fresh:
  assumes "valid_ind is"
  assumes "x \<in> heapVars is"
  shows "atom x \<sharp> (\<Gamma> \<ominus>\<^sub>H is)"
proof (induction \<Gamma> rule:fmap_induct)
  case empty show ?case by auto
next
  case (update \<Gamma> x' v)
  show ?case
  proof(cases "x' \<in> heapVars is")
    case True with update assms
    show ?thesis by auto
  next
    case False
    moreover
    hence "x \<noteq> x'" using assms(2) by auto
    ultimately
    show ?thesis
    using update assms
    by (auto simp add: resolve_expr_fresh eqvt_fresh_cong3[where f = fmap_upd, OF fmap_upd_eqvt])
  qed
qed

lemma resolveHeapOne_distinctVars: "distinctVars \<Gamma> \<Longrightarrow> distinctVars (resolveHeapOne \<Gamma> a b)"
  by (induct \<Gamma> a b rule:resolveHeapOne.induct) (auto simp add: distinctVars_Cons)

lemma resolveHeap_distinctVars[simp]: "distinctVars \<Gamma> \<Longrightarrow> distinctVars (\<Gamma> \<ominus>\<^sub>h is)"
  by (induct \<Gamma> "is" rule:resolveHeap.induct) (auto simp add: resolveHeapOne_distinctVars)

lemma resolve_var_same_image[dest]: "valid_ind is \<Longrightarrow> (x,y) \<in> set is \<Longrightarrow> x \<ominus> is = y \<ominus> is"
  apply (induct  "is" rule: valid_ind.induct)
  apply (auto simp add: fresh_Pair)
  apply (metis fresh_Pair fresh_list_elem not_self_fresh)
  by (metis fresh_Pair fresh_list_elem not_self_fresh)

lemma valid_ind_smaller_index:
  assumes "valid_ind is"
  assumes "i < length is"
  assumes "j < length is"
  assumes "is ! i = (x,y)"
  assumes "is ! j = (y,y')"
  shows "j > i"
using assms
proof (induct arbitrary: i j rule:valid_ind.induct)
case ValidIndNil thus ?case by simp
next
case (ValidIndCons "is" a b i j)
  show ?case
  proof(cases i)
    case 0
    with ValidIndCons
    show ?thesis
      by (cases j) (auto simp add: fresh_Pair fresh_at_base)
  next
    case (Suc i')
    with ValidIndCons have "i' < length is" by auto

    show ?thesis
    proof (cases j)
    case 0
      with ValidIndCons  `i = Suc i'`
      have "atom y \<sharp> is" and "is ! i' = (x, y)" by (simp_all add: fresh_Pair)
      hence "(x,y) \<in> set is" using `i' < length is`
      by (metis nth_mem)
      with `atom y \<sharp> is` have "atom y \<sharp> (x,y)" by (metis fresh_list_elem)
      hence False by (simp add: fresh_Pair fresh_at_base)
      thus ?thesis by simp
    next
    case Suc with `i = Suc i'` ValidIndCons
      show ?thesis by (auto simp add: fresh_Pair fresh_at_base)
    qed
  qed
qed

lemma valid_ind_induct[consumes 1, case_names NoInd Ind, induct pred: valid_ind]:
  assumes "valid_ind is"
  assumes NoInd: "\<And> x. valid_ind is \<Longrightarrow> x \<notin> heapVars is \<Longrightarrow> P x"
  assumes Ind: "\<And> x y.  valid_ind is \<Longrightarrow> P y \<Longrightarrow> (x,y) \<in> set is \<Longrightarrow> P x"
  shows "P x"
proof(cases "x \<in> heapVars is")
case True
  then obtain y i where "i < length is" and "is ! i = (x,y)" unfolding heapVars_def
    by (auto simp add: in_set_conv_nth)
  thus ?thesis
  proof (induction i arbitrary: x y rule:measure_induct_rule[where f = "\<lambda>x . length is - x"])
  case (less i x y)
    have "P y"
    proof(cases "y \<in> heapVars is")
    case True
      then obtain y' j where "j < length is" and "is ! j = (y,y')" unfolding heapVars_def
        by (auto simp add: in_set_conv_nth)
      from `valid_ind is` `i < length is` `j < length is` `is ! i = _` `is ! j = _`
      have "i < j" by (rule valid_ind_smaller_index)
      hence "length is - j < length is - i" by (metis diff_less_mono2 less.prems(1))
      from less.IH[OF this `j < length is` `is ! j = (y,y')`]
      show ?thesis.
    next
    case False
      thus ?thesis by (rule NoInd[OF assms(1)])
    qed
    moreover
    from less have "(x,y) \<in> set is" by (metis nth_mem)
    ultimately
    show ?case by (rule Ind[OF assms(1)])
  qed
next
case False
  thus ?thesis by (rule NoInd[OF assms(1)])
qed

lemma valid_ind_different: "valid_ind is \<Longrightarrow> (x,y) \<in> set is \<Longrightarrow> x \<noteq> y"
  by (induct  "is" rule: valid_ind.induct) (auto simp add: fresh_Pair)

lemma valid_ind_in_is: "valid_ind is \<Longrightarrow> x \<in> heapVars is \<Longrightarrow> x \<ominus> is \<in> snd `set is"
  apply (induct x rule: valid_ind_induct)
  apply auto
  apply (case_tac "y \<in> heapVars is")
  apply (auto simp add: resolve_var_same_image intro: imageI)
  by (metis image_iff snd_conv)

lemma resolve_var_fresh_self: "valid_ind is \<Longrightarrow> atom (y \<ominus> is) \<sharp> is \<Longrightarrow> y \<notin> heapVars is"
  apply (auto dest!: valid_ind_in_is)
  by (metis fresh_Pair fresh_list_elem not_self_fresh)

lemma resolve_var_modifies: "valid_ind is \<Longrightarrow> x \<in> heapVars is \<Longrightarrow> x \<noteq> x \<ominus> is"
  by (induction "is" rule: valid_ind.induct)
     (auto simp add: fresh_Pair dest: resolve_var_fresh_self)

lemma resolve_resolved: "valid_ind is \<Longrightarrow> x \<ominus> is \<notin> heapVars is"
  by (induct x rule:valid_ind_induct) (simp_all add: resolve_var_same_image)

lemma valid_ind_idemp[simp]: "valid_ind is \<Longrightarrow> (y::var) \<ominus> is \<ominus> is = y \<ominus> is"
   by (intro resove_var_noop resolve_resolved)

end


theory Term5
imports "../Nominal2_Atoms" "../Nominal2_Eqvt" "../Nominal2_Supp" "../Abs" "../Perm" "../Fv" "../Rsp"
begin

atom_decl name

datatype rtrm5 =
  rVr5 "name"
| rAp5 "rtrm5" "rtrm5"
| rLt5 "rlts" "rtrm5" --"bind (bv5 lts) in (rtrm5)"
and rlts =
  rLnil
| rLcons "name" "rtrm5" "rlts"

primrec
  rbv5
where
  "rbv5 rLnil = {}"
| "rbv5 (rLcons n t ltl) = {atom n} \<union> (rbv5 ltl)"

setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Term5.rtrm5") 2 *}
print_theorems

local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Term5.rtrm5")
  [[[], [], [(SOME (@{term rbv5}, false), 0, 1)]], [[], []]] [(@{term rbv5}, 1, [[], [(0,NONE), (2,SOME @{term rbv5})]])] *}
print_theorems

notation
  alpha_rtrm5 ("_ \<approx>5 _" [100, 100] 100) and
  alpha_rlts ("_ \<approx>l _" [100, 100] 100)
thm alpha_rtrm5_alpha_rlts_alpha_rbv5.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha5_inj}, []), (build_rel_inj @{thms alpha_rtrm5_alpha_rlts_alpha_rbv5.intros} @{thms rtrm5.distinct rtrm5.inject rlts.distinct rlts.inject} @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} ctxt)) ctxt)) *}
thm alpha5_inj

lemma rbv5_eqvt[eqvt]:
  "pi \<bullet> (rbv5 x) = rbv5 (pi \<bullet> x)"
  apply (induct x)
  apply (simp_all add: eqvts atom_eqvt)
  done

lemma fv_rtrm5_rlts_eqvt[eqvt]:
  "pi \<bullet> (fv_rtrm5 x) = fv_rtrm5 (pi \<bullet> x)"
  "pi \<bullet> (fv_rlts l) = fv_rlts (pi \<bullet> l)"
  "pi \<bullet> (fv_rbv5 l) = fv_rbv5 (pi \<bullet> l)"
  apply (induct x and l)
  apply (simp_all add: eqvts atom_eqvt)
  done

local_setup {*
(fn ctxt => snd (Local_Theory.note ((@{binding alpha5_eqvt}, []),
build_alpha_eqvts [@{term alpha_rtrm5}, @{term alpha_rlts}, @{term alpha_rbv5}] (fn _ => alpha_eqvt_tac  @{thm alpha_rtrm5_alpha_rlts_alpha_rbv5.induct} @{thms alpha5_inj permute_rtrm5_permute_rlts.simps} ctxt 1) ctxt) ctxt)) *}
print_theorems

lemma alpha5_reflp:
"y \<approx>5 y \<and> (x \<approx>l x \<and> alpha_rbv5 x x)"
apply (rule rtrm5_rlts.induct)
apply (simp_all add: alpha5_inj)
apply (rule_tac x="0::perm" in exI)
apply (simp add: eqvts alpha_gen fresh_star_def fresh_zero_perm)
done

lemma alpha5_symp:
"(a \<approx>5 b \<longrightarrow> b \<approx>5 a) \<and>
(x \<approx>l y \<longrightarrow> y \<approx>l x) \<and>
(alpha_rbv5 x y \<longrightarrow> alpha_rbv5 y x)"
apply (rule alpha_rtrm5_alpha_rlts_alpha_rbv5.induct)
apply (simp_all add: alpha5_inj)
apply (erule conjE)+
apply (erule exE)
apply (rule_tac x="-pi" in exI)
apply (rule alpha_gen_sym)
apply (simp add: alphas)
apply (simp add: alpha5_eqvt)
apply (simp add: alphas)
apply clarify
apply simp
done

lemma alpha5_transp:
"(a \<approx>5 b \<longrightarrow> (\<forall>c. b \<approx>5 c \<longrightarrow> a \<approx>5 c)) \<and>
(x \<approx>l y \<longrightarrow> (\<forall>z. y \<approx>l z \<longrightarrow> x \<approx>l z)) \<and>
(alpha_rbv5 k l \<longrightarrow> (\<forall>m. alpha_rbv5 l m \<longrightarrow> alpha_rbv5 k m))"
apply (rule alpha_rtrm5_alpha_rlts_alpha_rbv5.induct)
apply (rule_tac [!] allI)
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
defer
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (erule conjE)+
apply (erule exE)+
apply (rule_tac x="pi + pia" in exI)
apply (rule alpha_gen_trans)
prefer 6
apply assumption
apply (simp_all add: alphas alpha5_eqvt)
apply (clarify)
apply simp
done

lemma alpha5_equivp:
  "equivp alpha_rtrm5"
  "equivp alpha_rlts"
  unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
  apply (simp_all only: alpha5_reflp)
  apply (meson alpha5_symp alpha5_transp)
  apply (meson alpha5_symp alpha5_transp)
  done

quotient_type
  trm5 = rtrm5 / alpha_rtrm5
and
  lts = rlts / alpha_rlts
  by (auto intro: alpha5_equivp)

local_setup {*
(fn ctxt => ctxt
 |> snd o (Quotient_Def.quotient_lift_const ("Vr5", @{term rVr5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Ap5", @{term rAp5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lt5", @{term rLt5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lnil", @{term rLnil}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lcons", @{term rLcons}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_trm5", @{term fv_rtrm5}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_lts", @{term fv_rlts}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_bv5", @{term fv_rbv5}))
 |> snd o (Quotient_Def.quotient_lift_const ("bv5", @{term rbv5}))
 |> snd o (Quotient_Def.quotient_lift_const ("alpha_bv5", @{term alpha_rbv5})))
*}
print_theorems

lemma alpha5_rfv:
  "(t \<approx>5 s \<Longrightarrow> fv_rtrm5 t = fv_rtrm5 s)"
  "(l \<approx>l m \<Longrightarrow> (fv_rlts l = fv_rlts m \<and> fv_rbv5 l = fv_rbv5 m))"
  "(alpha_rbv5 b c \<Longrightarrow> fv_rbv5 b = fv_rbv5 c)"
  apply(induct rule: alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts)
  apply(simp_all)
  apply(simp add: alpha_gen)
  done

lemma bv_list_rsp:
  shows "x \<approx>l y \<Longrightarrow> rbv5 x = rbv5 y"
  apply(induct rule: alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts(2))
  apply(simp_all)
  apply(clarify)
  apply simp
  done

local_setup {* snd o Local_Theory.note ((@{binding alpha_dis}, []), (flat (map (distinct_rel @{context} @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases}) [(@{thms rtrm5.distinct}, @{term alpha_rtrm5}), (@{thms rlts.distinct}, @{term alpha_rlts}), (@{thms rlts.distinct}, @{term alpha_rbv5})]))) *}
print_theorems

local_setup {* snd o Local_Theory.note ((@{binding alpha_bn_rsp}, []), prove_alpha_bn_rsp [@{term alpha_rtrm5}, @{term alpha_rlts}] @{thms alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts} @{thms alpha5_inj alpha_dis} @{thms alpha5_equivp} @{context} (@{term alpha_rbv5}, 1)) *}
thm alpha_bn_rsp

lemma [quot_respect]:
  "(alpha_rlts ===> op =) fv_rlts fv_rlts"
  "(alpha_rlts ===> op =) fv_rbv5 fv_rbv5"
  "(alpha_rtrm5 ===> op =) fv_rtrm5 fv_rtrm5"
  "(alpha_rlts ===> op =) rbv5 rbv5"
  "(op = ===> alpha_rtrm5) rVr5 rVr5"
  "(alpha_rtrm5 ===> alpha_rtrm5 ===> alpha_rtrm5) rAp5 rAp5"
  "(alpha_rlts ===> alpha_rtrm5 ===> alpha_rtrm5) rLt5 rLt5"
  "(op = ===> alpha_rtrm5 ===> alpha_rlts ===> alpha_rlts) rLcons rLcons"
  "(op = ===> alpha_rtrm5 ===> alpha_rtrm5) permute permute"
  "(op = ===> alpha_rlts ===> alpha_rlts) permute permute"
  "(alpha_rlts ===> alpha_rlts ===> op =) alpha_rbv5 alpha_rbv5"
  apply (simp_all add: alpha5_inj alpha5_rfv alpha5_eqvt bv_list_rsp alpha5_reflp alpha_bn_rsp)
  apply (clarify)
  apply (rule_tac x="0" in exI) apply (simp add: fresh_star_def fresh_zero_perm alpha_gen alpha5_rfv)
done

lemma
  shows "(alpha_rlts ===> op =) rbv5 rbv5"
  by (simp add: bv_list_rsp)

lemmas trm5_lts_inducts = rtrm5_rlts.inducts[quot_lifted]

instantiation trm5 and lts :: pt
begin

quotient_definition
  "permute_trm5 :: perm \<Rightarrow> trm5 \<Rightarrow> trm5"
is
  "permute :: perm \<Rightarrow> rtrm5 \<Rightarrow> rtrm5"

quotient_definition
  "permute_lts :: perm \<Rightarrow> lts \<Rightarrow> lts"
is
  "permute :: perm \<Rightarrow> rlts \<Rightarrow> rlts"

instance by default
  (simp_all add: permute_rtrm5_permute_rlts_zero[quot_lifted] permute_rtrm5_permute_rlts_append[quot_lifted])

end

lemmas permute_trm5_lts = permute_rtrm5_permute_rlts.simps[quot_lifted]
lemmas bv5[simp] = rbv5.simps[quot_lifted]
lemmas fv_trm5_bv5[simp] = fv_rtrm5_fv_rbv5.simps[quot_lifted]
lemmas fv_lts[simp] = fv_rlts.simps[quot_lifted]
lemmas alpha5_INJ = alpha5_inj[unfolded alpha_gen, quot_lifted, folded alpha_gen]

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory CustomWordAbs
imports "AutoCorres.AutoCorres"
begin

external_file "custom_word_abs.c"
install_C_file "custom_word_abs.c"

lemma [word_abs]:
  "\<lbrakk> abstract_val P x sint x'; abstract_val Q y sint y' \<rbrakk> \<Longrightarrow>
        abstract_val (P \<and> Q) (max x y)
          sint (x' xor (x' xor y') && - (if x' <s y' then (1 :: sword32) else 0))"
  apply (clarsimp simp: max_def word_sless_def word_sle_def)
  done

lemma [word_abs]:
  "\<lbrakk> abstract_val P x unat x'; abstract_val Q y unat y' \<rbrakk> \<Longrightarrow>
         abstract_val (P \<and> Q \<and> y < 32) (x mod (2 ^ y)) unat (x' && 2 ^ unat y' - (1 :: word32))"
  apply (clarsimp simp del: shiftl_1 simp: shiftl_1 [symmetric])
  apply (fold mask_def)
  apply (subst word_mod_2p_is_mask [symmetric])
  apply (subst p2_gt_0)
  by (auto simp: unat_mod)

lemma [word_abs]:
  "\<lbrakk> abstract_val P x unat (x' :: word32);
     abstract_val Q y unat y' \<rbrakk> \<Longrightarrow>
      abstract_val (P \<and> Q) (x + y > UINT_MAX) id (x' + y' < x')"
  apply (subst not_le [symmetric], subst no_plus_overflow_unat_size)
  apply (clarsimp simp: not_less UINT_MAX_def word_size)
  apply arith
  done

autocorres [unsigned_word_abs = b c] "custom_word_abs.c"

context custom_word_abs begin

lemma "a' x y = max x y"
  by (unfold a'_def, rule refl)

lemma "b' x 4 s = Some (x mod 16)"
  by (unfold b'_def, simp)

lemma "c' x y = (if UINT_MAX < x + y then 1 else 0)"
  by (unfold c'_def, simp)

end

end


(*  Title:      HOL/MicroJava/BV/LBVJVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section {* LBV for the JVM \label{sec:JVM} *}

theory LBVJVM
imports Typing_Framework_JVM
begin

type_synonym prog_cert = "cname \<Rightarrow> sig \<Rightarrow> JVMType.state list"

definition check_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> JVMType.state list \<Rightarrow> bool" where
  "check_cert G mxs mxr n cert \<equiv> check_types G mxs mxr cert \<and> length cert = n+1 \<and>
                                 (\<forall>i<n. cert!i \<noteq> Err) \<and> cert!n = OK None"

definition lbvjvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow>
             JVMType.state list \<Rightarrow> instr list \<Rightarrow> JVMType.state \<Rightarrow> JVMType.state" where
  "lbvjvm G maxs maxr rT et cert bs \<equiv>
  wtl_inst_list bs cert  (JVMType.sup G maxs maxr) (JVMType.le G maxs maxr) Err (OK None) (exec G maxs rT et bs) 0"

definition wt_lbv :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             exception_table \<Rightarrow> JVMType.state list \<Rightarrow> instr list \<Rightarrow> bool" where
  "wt_lbv G C pTs rT mxs mxl et cert ins \<equiv>
   check_bounded ins et \<and>
   check_cert G mxs (1+size pTs+mxl) (length ins) cert \<and>
   0 < size ins \<and>
   (let start  = Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err));
        result = lbvjvm G mxs (1+size pTs+mxl) rT et cert ins (OK start)
    in result \<noteq> Err)"

definition wt_jvm_prog_lbv :: "jvm_prog \<Rightarrow> prog_cert \<Rightarrow> bool" where
  "wt_jvm_prog_lbv G cert \<equiv>
  wf_prog (\<lambda>G C (sig,rT,(maxs,maxl,b,et)). wt_lbv G C (snd sig) rT maxs maxl et (cert C sig) b) G"

definition mk_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow> instr list
              \<Rightarrow> method_type \<Rightarrow> JVMType.state list" where
  "mk_cert G maxs rT et bs phi \<equiv> make_cert (exec G maxs rT et bs) (map OK phi) (OK None)"

definition prg_cert :: "jvm_prog \<Rightarrow> prog_type \<Rightarrow> prog_cert" where
  "prg_cert G phi C sig \<equiv> let (C,rT,(maxs,maxl,ins,et)) = the (method (G,C) sig) in
                           mk_cert G maxs rT et ins (phi C sig)"

lemma wt_method_def2:
  fixes pTs and mxl and G and mxs and rT and et and bs and phi
  defines [simp]: "mxr   \<equiv> 1 + length pTs + mxl"
  defines [simp]: "r     \<equiv> sup_state_opt G"
  defines [simp]: "app0  \<equiv> \<lambda>pc. app (bs!pc) G mxs rT pc et"
  defines [simp]: "step0 \<equiv> \<lambda>pc. eff (bs!pc) G pc et"

  shows
  "wt_method G C pTs rT mxs mxl bs et phi =
  (bs \<noteq> [] \<and>
   length phi = length bs \<and>
   check_bounded bs et \<and>
   check_types G mxs mxr (map OK phi) \<and>
   wt_start G C pTs mxl phi \<and>
   wt_app_eff r app0 step0 phi)"
  by (auto simp add: wt_method_def wt_app_eff_def wt_instr_def lesub_def
           dest: check_bounded_is_bounded boundedD)

lemma check_certD:
  "check_cert G mxs mxr n cert \<Longrightarrow> cert_ok cert n Err (OK None) (states G mxs mxr)"
  apply (unfold cert_ok_def check_cert_def check_types_def)
  apply (auto simp add: list_all_iff)
  done

lemma wt_lbv_wt_step:
  assumes wf:  "wf_prog wf_mb G"
  assumes lbv: "wt_lbv G C pTs rT mxs mxl et cert ins"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  defines [simp]: "mxr \<equiv> 1+length pTs+mxl"

  shows "\<exists>ts \<in> list (size ins) (states G mxs mxr).
            wt_step (JVMType.le G mxs mxr) Err (exec G mxs rT et ins) ts
          \<and> OK (Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err))) <=_(JVMType.le G mxs mxr) ts!0"
proof -
  let ?step = "exec G mxs rT et ins"
  let ?r    = "JVMType.le G mxs mxr"
  let ?f    = "JVMType.sup G mxs mxr"
  let ?A    = "states G mxs mxr"

  have "semilat (JVMType.sl G mxs mxr)"
    by (rule semilat_JVM_slI, rule wf_prog_ws_prog, rule wf)
  hence "semilat (?A, ?r, ?f)" by (unfold sl_triple_conv)
  moreover
  have "top ?r Err"  by (simp add: JVM_le_unfold)
  moreover
  have "Err \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  have "bottom ?r (OK None)"
    by (simp add: JVM_le_unfold bottom_def)
  moreover
  have "OK None \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  from lbv
  have "bounded ?step (length ins)"
    by (clarsimp simp add: wt_lbv_def exec_def)
       (intro bounded_lift check_bounded_is_bounded)
  moreover
  from lbv
  have "cert_ok cert (length ins) Err (OK None) ?A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover
  from wf have "pres_type ?step (length ins) ?A" by (rule exec_pres_type)
  moreover
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"
  from lbv
  have "wtl_inst_list ins cert ?f ?r Err (OK None) ?step 0 ?start \<noteq> Err"
    by (simp add: wt_lbv_def lbvjvm_def)
  moreover
  from C pTs have "?start \<in> ?A"
    by (unfold JVM_states_unfold) (auto intro: list_appendI, force)
  moreover
  from lbv have "0 < length ins" by (simp add: wt_lbv_def)
  ultimately
  show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed

lemma wt_lbv_wt_method:
  assumes wf:  "wf_prog wf_mb G"
  assumes lbv: "wt_lbv G C pTs rT mxs mxl et cert ins"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  shows "\<exists>phi. wt_method G C pTs rT mxs mxl ins et phi"
proof -
  let ?mxr   = "1 + length pTs + mxl"
  let ?step  = "exec G mxs rT et ins"
  let ?r     = "JVMType.le G mxs ?mxr"
  let ?f     = "JVMType.sup G mxs ?mxr"
  let ?A     = "states G mxs ?mxr"
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"

  from lbv have l: "ins \<noteq> []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C pTs
  obtain phi where
    list:  "phi \<in> list (length ins) ?A" and
    step:  "wt_step ?r Err ?step phi" and
    start: "?start <=_?r phi!0"
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "length phi = length ins" by simp
  have "length (map ok_val phi) = length ins" by simp
  moreover
  from l have 0: "0 < length phi" by simp
  with step obtain phi0 where "phi!0 = OK phi0"
    by (unfold wt_step_def) blast
  with start 0
  have "wt_start G C pTs mxl (map ok_val phi)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def)
  moreover
  from lbv  have chk_bounded: "check_bounded ins et"
    by (simp add: wt_lbv_def)
  moreover {
    from list
    have "check_types G mxs ?mxr phi"
      by (simp add: check_types_def)
    also from step
    have [symmetric]: "map OK (map ok_val phi) = phi"
      by (auto intro!: nth_equalityI simp add: wt_step_def)
    finally have "check_types G mxs ?mxr (map OK (map ok_val phi))" .
  }
  moreover {
    let ?app = "\<lambda>pc. app (ins!pc) G mxs rT pc et"
    let ?eff = "\<lambda>pc. eff (ins!pc) G pc et"

    from chk_bounded
    have "bounded (err_step (length ins) ?app ?eff) (length ins)"
      by (blast dest: check_bounded_is_bounded boundedD intro: bounded_err_stepI)
    moreover
    from step
    have "wt_err_step (sup_state_opt G) ?step phi"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately
    have "wt_app_eff (sup_state_opt G) ?app ?eff (map ok_val phi)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def)
  }
  ultimately
  have "wt_method G C pTs rT mxs mxl ins et (map ok_val phi)"
    by - (rule wt_method_def2 [THEN iffD2], simp)
  thus ?thesis ..
qed

lemma wt_method_wt_lbv:
  assumes wf:  "wf_prog wf_mb G"
  assumes wt:  "wt_method G C pTs rT mxs mxl ins et phi"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  defines [simp]: "cert \<equiv> mk_cert G mxs rT et ins phi"

  shows "wt_lbv G C pTs rT mxs mxl et cert ins"
proof -
  let ?mxr  = "1 + length pTs + mxl"
  let ?step = "exec G mxs rT et ins"
  let ?app  = "\<lambda>pc. app (ins!pc) G mxs rT pc et"
  let ?eff  = "\<lambda>pc. eff (ins!pc) G pc et"
  let ?r    = "JVMType.le G mxs ?mxr"
  let ?f    = "JVMType.sup G mxs ?mxr"
  let ?A    = "states G mxs ?mxr"
  let ?phi  = "map OK phi"
  let ?cert = "make_cert ?step ?phi (OK None)"

  from wt have
    0:          "0 < length ins" and
    length:     "length ins = length ?phi" and
    ck_bounded: "check_bounded ins et" and
    ck_types:   "check_types G mxs ?mxr ?phi" and
    wt_start:   "wt_start G C pTs mxl phi" and
    app_eff:    "wt_app_eff (sup_state_opt G) ?app ?eff phi"
    by (simp_all add: wt_method_def2)

  have "semilat (JVMType.sl G mxs ?mxr)"
    by (rule semilat_JVM_slI) (rule wf_prog_ws_prog [OF wf])
  hence "semilat (?A, ?r, ?f)" by (unfold sl_triple_conv)
  moreover
  have "top ?r Err"  by (simp add: JVM_le_unfold)
  moreover
  have "Err \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  have "bottom ?r (OK None)"
    by (simp add: JVM_le_unfold bottom_def)
  moreover
  have "OK None \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  from ck_bounded
  have bounded: "bounded ?step (length ins)"
    by (clarsimp simp add: exec_def)
       (intro bounded_lift check_bounded_is_bounded)
  with wf
  have "mono ?r ?step (length ins) ?A"
    by (rule wf_prog_ws_prog [THEN exec_mono])
  hence "mono ?r ?step (length ?phi) ?A" by (simp add: length)
  moreover
  from wf have "pres_type ?step (length ins) ?A" by (rule exec_pres_type)
  hence "pres_type ?step (length ?phi) ?A" by (simp add: length)
  moreover
  from ck_types
  have "set ?phi \<subseteq> ?A" by (simp add: check_types_def)
  hence "\<forall>pc. pc < length ?phi \<longrightarrow> ?phi!pc \<in> ?A \<and> ?phi!pc \<noteq> Err" by auto
  moreover
  from bounded
  have "bounded (exec G mxs rT et ins) (length ?phi)" by (simp add: length)
  moreover
  have "OK None \<noteq> Err" by simp
  moreover
  from bounded length app_eff
  have "wt_err_step (sup_state_opt G) ?step ?phi"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def)
  hence "wt_step ?r Err ?step ?phi"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"
  from 0 length have "0 < length phi" by auto
  hence "?phi!0 = OK (phi!0)" by simp
  with wt_start have "?start <=_?r ?phi!0"
    by (clarsimp simp add: wt_start_def lesub_def JVM_le_Err_conv)
  moreover
  from C pTs have "?start \<in> ?A"
    by (unfold JVM_states_unfold) (auto intro: list_appendI, force)
  moreover
  have "?start \<noteq> Err" by simp
  moreover
  note length
  ultimately
  have "wtl_inst_list ins ?cert ?f ?r Err (OK None) ?step 0 ?start \<noteq> Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover
  from 0 length have "phi \<noteq> []" by auto
  moreover
  from ck_types
  have "check_types G mxs ?mxr ?cert"
    by (auto simp add: make_cert_def check_types_def JVM_states_unfold)
  moreover
  note ck_bounded 0 length
  ultimately
  show ?thesis
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def
      check_cert_def make_cert_def nth_append)
qed

theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv G Cert \<Longrightarrow> \<exists>Phi. wt_jvm_prog G Phi"
proof -
  let ?Phi = "\<lambda>C sig. let (C,rT,(maxs,maxl,ins,et)) = the (method (G,C) sig) in
              SOME phi. wt_method G C (snd sig) rT maxs maxl ins et phi"

  assume "wt_jvm_prog_lbv G Cert"
  hence "wt_jvm_prog G ?Phi"
    apply (unfold wt_jvm_prog_def wt_jvm_prog_lbv_def)
    apply (erule jvm_prog_lift)
    apply (auto dest: wt_lbv_wt_method intro: someI)
    done
  thus ?thesis by blast
qed

theorem jvm_lbv_complete:
  "wt_jvm_prog G Phi \<Longrightarrow> wt_jvm_prog_lbv G (prg_cert G Phi)"
  apply (unfold wt_jvm_prog_def wt_jvm_prog_lbv_def)
  apply (erule jvm_prog_lift)
  apply (auto simp add: prg_cert_def intro: wt_method_wt_lbv)
  done

end


theory Ex_CFG
imports Monad
begin
  term fold

  datatype err = STATIC_ERROR

  type_synonym state = "string \<Rightarrow> int"
  type_synonym label = string
  type_synonym proc_name = string
  type_synonym val = "int"

  datatype nt_instr = I_BASIC "state \<Rightarrow> state" | I_CALL proc_name

  datatype t_instr = TI_RETURN | TI_BR label | TI_CBR "state\<Rightarrow>bool" label label

  datatype bblock = BBLOCK (nt_instrs: "nt_instr list") (t_instr: "t_instr")

  type_synonym proc_body = "label \<rightharpoonup> bblock"
  type_synonym prog = "proc_name \<rightharpoonup> proc_body"

  context
    fixes \<pi> :: prog
  begin

    context
      fixes execute :: "proc_body \<times> label \<Rightarrow> (unit,unit,state,err) M"
    begin

      definition "exec_nt_instr ins \<equiv> case ins of
        I_BASIC f \<Rightarrow> doM { s\<leftarrow>get; set (f s)}
      | I_CALL p \<Rightarrow> doM {
          \<beta> \<leftarrow> lookup STATIC_ERROR \<pi> p;
          handle (doM {execute (\<beta>,''__start''); fail STATIC_ERROR}) (\<lambda>_. return ());
          return ()
        }"

      fun exec_t_instr where
        "exec_t_instr (TI_RETURN) = doM {
          raise ()
        }"
      | "exec_t_instr (TI_BR l) = return l"
      | "exec_t_instr (TI_CBR c l1 l2) = doM {
          s\<leftarrow>get;
          if c s then return l1 else return l2
      }"

      definition "execute_body \<equiv> \<lambda>(\<beta>,l). doM {
        bb \<leftarrow> lookup STATIC_ERROR \<beta> l;
        mfold' exec_nt_instr (nt_instrs bb);
        l \<leftarrow> exec_t_instr (t_instr bb);
        execute (\<beta>,l)
      }"
    end

    definition "execute \<equiv> REC execute_body"

    lemma mono_mfold[partial_function_mono]:
      "\<lbrakk>\<And>x s. M.mono_body (\<lambda>f. F f x s)\<rbrakk> \<Longrightarrow> M.mono_body (\<lambda>f. mfold (F f) xs s)"
      apply (induction xs arbitrary: s)
      apply simp_all
      apply pf_mono_prover
      apply pf_mono_prover
      apply simp_all
      done

    lemma mono_exec_ntinstr[partial_function_mono]: "M.mono_body (\<lambda>f. local.exec_nt_instr f ins)"
      by (cases ins; simp add: exec_nt_instr_def; pf_mono_prover)

    lemma mono_execute_body[partial_function_mono]: "\<And>x. M.mono_body (\<lambda>fa. local.execute_body fa x)"
      unfolding execute_body_def
      by pf_mono_prover

  end

  lemmas
        execute_unfold[code] = REC_unfold[OF execute_def, discharge_monos]
    and execute_partial = lrmwpe_REC_partial[OF execute_def, discharge_monos, consumes 1, case_names nonterm step]
    and execute_total = lrmwpe_REC_total[OF execute_def, discharge_monos, consumes 1, case_names wf step]
    and execute_sim[sim_rules] = sim_REC[OF execute_def execute_def, discharge_monos]

  term execute

  thm sim_rules

  lemma execute_sm_sim[sim_rules]:
    assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
    shows "sim (execute \<pi> \<beta>l) (execute \<pi>' \<beta>l)"
    using assms
    by (auto intro!: sim_rules split!: nt_instr.split simp: execute_body_def exec_nt_instr_def)

  fun wf_nt_instr where
    "wf_nt_instr \<pi> (I_BASIC f) \<longleftrightarrow> True"
  | "wf_nt_instr \<pi> (I_CALL p) \<longleftrightarrow> p\<in>dom \<pi>"

  fun wf_t_instr where
    "wf_t_instr \<pi> \<beta> (TI_RETURN) \<longleftrightarrow> True"
  | "wf_t_instr \<pi> \<beta> (TI_BR l) \<longleftrightarrow> l\<in>dom \<beta>"
  | "wf_t_instr \<pi> \<beta> (TI_CBR c l1 l2) \<longleftrightarrow> l1\<in>dom \<beta> \<and> l2\<in>dom \<beta>"

  fun wf_basic_block where
    "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti) \<longleftrightarrow> (\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti) \<and> wf_t_instr \<pi> \<beta> ti"

  definition "wf_proc_body \<pi> b \<equiv> ''__start''\<in>dom b \<and> (\<forall>bb\<in>ran b. wf_basic_block \<pi> b bb)"

  definition "wf_prog \<pi> \<equiv> \<forall>b\<in>ran \<pi>. wf_proc_body \<pi> b"

  definition "wf_pos \<pi> \<equiv> \<lambda>(\<beta>,l). \<beta> \<in> ran \<pi> \<and> l\<in>dom \<beta>"

  lemma
    assumes "run (execute \<pi> \<beta>l) s = r"
    assumes "wf_pos \<pi> \<beta>l"
    assumes "wf_prog \<pi>"
    shows "mwp r True bot top bot"
    using assms(1,2)
  proof (induction rule: execute_partial)
    case (nonterm x s)
    then show ?case by simp
  next
    case (step f x s r)

    note step.IH[OF refl, THEN mwp_cons, intro!]

    obtain \<beta> l where [simp]: "x = (\<beta>,l)" by (cases x)
    with \<open>wf_pos \<pi> x\<close> obtain ntis ti where [simp]: "\<beta> l = Some (BBLOCK ntis ti)" and "\<beta>\<in>ran \<pi>"
      apply (auto simp: wf_pos_def)
      using bblock.exhaust by blast

    have [THEN mwp_cons, intro!]:
      "mwp (run (exec_nt_instr \<pi> f i) s) top bot bot top" if "wf_nt_instr \<pi> i" for i s
      using that
      apply (auto simp: run_simps exec_nt_instr_def split: nt_instr.splits option.split)
      by (metis (mono_tags, lifting) assms(3) old.prod.case ranI wf_pos_def wf_proc_body_def wf_prog_def)

    from \<open>wf_prog \<pi>\<close> \<open>\<beta>\<in>ran \<pi>\<close> have "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti)"
      unfolding wf_prog_def wf_proc_body_def apply (auto)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      done
    hence WF_NTI: "(\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti)"
      and WF_TI: "wf_t_instr \<pi> \<beta> ti" by simp_all

    from WF_NTI have [THEN mwp_cons, intro!]:
      "mwp (run (mfold' (exec_nt_instr \<pi> f) ntis) s) top bot bot top"
      apply (induction ntis arbitrary: s)
      by (auto simp: run_simps)

    from WF_TI have [THEN mwp_cons, intro!]: "mwp (run (exec_t_instr ti) s) top bot top (\<lambda>l _. l\<in>dom \<beta>)" for s
      apply (cases ti)
      apply (auto simp: run_simps)
      done

    from step.hyps step.prems show ?case
      by (auto simp: execute_body_def run_simps wf_pos_def split: prod.splits option.splits)

  qed

end