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


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