(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Quicksort.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Example: Quicksort on Heap Lists"

theory Quicksort
imports "../Vcg" "../HeapList" "HOL-Library.Multiset"
begin

record globals_heap =
  next_' :: "ref \<Rightarrow> ref"
  cont_' :: "ref \<Rightarrow> nat"

record 'g vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  le_'   :: "ref"
  gt_'   :: "ref"
  hd_'   :: "ref"
  tl_'   :: "ref"

procedures
  append(p,q|p) =
    "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"

  append_spec:
   "\<forall>\<sigma> Ps Qs.
     \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
           \<acute>p :== PROC append(\<acute>p,\<acute>q)
         \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  append_modifies:
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in append_impl) append_modifies:
  shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in append_impl) append_spec:
  shows "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>
            \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
                \<acute>p :== PROC append(\<acute>p,\<acute>q)
            \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply fastforce
  done

primrec sorted:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list  \<Rightarrow> bool"
where
"sorted le [] = True" |
"sorted le (x#xs) = ((\<forall>y\<in>set xs. le x y) \<and> sorted le xs)"

lemma sorted_append[simp]:
 "sorted le (xs@ys) = (sorted le xs \<and> sorted le ys \<and>
                       (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
by (induct xs, auto)

procedures quickSort(p|p) =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI"

  quickSort_spec:
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC quickSort(\<acute>p)
       \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
        sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
        mset Ps = mset sortedPs) \<and>
        (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  quickSort_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

lemma (in quickSort_impl) quickSort_modifies:
  shows
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

lemma (in quickSort_impl) quickSort_spec:
shows
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace>
                  \<acute>p :== PROC quickSort(\<acute>p)
                \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
                 sorted (\<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
                 mset Ps = mset sortedPs) \<and>
                 (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (hoare_rule anno =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null
       INV \<lbrace> (\<exists>les grs tls. List \<acute>le \<acute>next les \<and> List \<acute>gt \<acute>next grs \<and>
               List \<acute>tl \<acute>next tls \<and>
               mset Ps = mset (\<acute>p#tls@les@grs) \<and>
               distinct(\<acute>p#tls@les@grs) \<and>
               (\<forall>x\<in>set les. x\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont) \<and>
               (\<forall>x\<in>set grs. \<acute>p\<rightarrow>\<acute>cont < x\<rightarrow>\<acute>cont)) \<and>
               \<acute>p=\<^bsup>\<sigma>\<^esup>p \<and>
               \<acute>cont=\<^bsup>\<sigma>\<^esup>cont \<and>
               List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>
               (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>
       DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI" in HoarePartial.annotateI)
  apply vcg
    apply fastforce
   apply clarsimp
   apply (rule conjI)
    apply clarify
    apply (rule conjI)
     apply (rule_tac x="tl#les" in exI)
     apply simp
     apply (rule_tac x="grs" in exI)
     apply simp
     apply (rule_tac x="ps" in exI)
     apply simp
    apply (metis insertCI set_mset_add_mset_insert set_mset_mset)
   apply clarify
   apply (rule conjI)
    apply (rule_tac x="les" in exI)
    apply simp
    apply (rule_tac x="tl#grs" in exI)
    apply simp
    apply (rule_tac x="ps" in exI)
    apply simp
   apply (metis insertCI set_mset_add_mset_insert set_mset_mset)
  apply clarsimp
  apply (rule_tac ?x=grs in exI)
  apply (rule conjI)
  apply (erule heap_eq_ListI1)
   apply clarify
   apply (erule_tac x=x in allE) back
   apply blast
  apply clarsimp
  apply (rule_tac x="sortedPs" in exI)
  apply (rule conjI)
   apply (erule heap_eq_ListI1)
   apply (clarsimp)
   apply (erule_tac x=x in allE) back back
   apply (metis IntI empty_iff set_mset_mset)
  apply (rule_tac x="p#sortedPsa" in exI)
  apply (rule conjI)
   apply (metis List_cons List_updateI Null_notin_List fun_upd_same insert_iff set_mset_add_mset_insert set_mset_mset)
  apply (rule conjI)
   apply (metis disjoint_iff mset_eq_setD set_ConsD)
  apply clarsimp
  apply (rule conjI)
   apply (metis less_or_eq_imp_le mset_eq_setD)
  apply (rule conjI)
   apply (metis leD less_le_trans mset_eq_setD nat_le_linear)
  apply clarsimp
  apply (erule_tac x=x in allE)+
  apply (metis Un_iff insert_iff list.set(2) mset.simps(2) mset_append set_append set_mset_mset)
  done

end


theory Hotel_Example
imports Main "HOL-Library.Predicate_Compile_Quickcheck"
begin

datatype guest = Guest0 | Guest1
datatype key = Key0 | Key1 | Key2 | Key3
datatype room = Room0

type_synonym card = "key * key"

datatype event =
  Check_in guest room card
| Enter guest room card
| Exit guest room

definition initk :: "room \<Rightarrow> key"
  where "initk = (%r. Key0)"

declare initk_def[code_pred_def, code]

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option"
where
  "owns [] r = None"
| "owns (e#s) r = (case e of
    Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
    Enter g r' c \<Rightarrow> owns s r |
    Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "currk [] r = initk r"
| "currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' (k1, k2) \<Rightarrow> if r' = r then k2 else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set"
where
  "issued [] = range initk"
| "issued (e#s) = issued s \<union>
  (case e of Check_in g r (k1, k2) \<Rightarrow> {k2} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set"
where
  "cards [] g = {}"
| "cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "roomk [] r = initk r"
| "roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r \<^cancel>\<open>\<and> x = k\<close> then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set"
where
  "isin [] r = {}"
| "isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool"
where
  "hotel []  = True"
| "hotel (e # s) = (hotel s & (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') \<in> cards s g & (roomk s r \<in> {k, k'}) |
  Exit g r \<Rightarrow> g \<in> isin s r))"

definition no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
[code del]: "no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
where
  "feels_safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
   s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 \<and>
   no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

section \<open>Some setup\<close>

lemma issued_nil: "issued [] = {Key0}"
by (auto simp add: initk_def)

lemmas issued_simps[code] = issued_nil issued.simps(2)

setup \<open>Predicate_Compile_Data.ignore_consts [\<^const_name>\<open>Set.member\<close>,
  \<^const_name>\<open>issued\<close>, \<^const_name>\<open>cards\<close>, \<^const_name>\<open>isin\<close>,
  \<^const_name>\<open>Collect\<close>, \<^const_name>\<open>insert\<close>]\<close>
ML_val \<open>Core_Data.force_modes_and_compilations\<close>

fun find_first :: "('a => 'b option) => 'a list => 'b option"
where
  "find_first f [] = None"
| "find_first f (x # xs) = (case f x of Some y => Some y | None => find_first f xs)"

axiomatization cps_of_set :: "'a set => ('a => term list option) => term list option"
where cps_of_set_code [code]: "cps_of_set (set xs) f = find_first f xs"

axiomatization pos_cps_of_set :: "'a set => ('a => (bool * term list) option) => natural => (bool * term list) option"
where pos_cps_of_set_code [code]: "pos_cps_of_set (set xs) f i = find_first f xs"

axiomatization find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
    => 'b list => 'a Quickcheck_Exhaustive.three_valued"
where find_first'_Nil: "find_first' f [] = Quickcheck_Exhaustive.No_value"
  and find_first'_Cons: "find_first' f (x # xs) =
    (case f (Quickcheck_Exhaustive.Known x) of
      Quickcheck_Exhaustive.No_value => find_first' f xs
    | Quickcheck_Exhaustive.Value x => Quickcheck_Exhaustive.Value x
    | Quickcheck_Exhaustive.Unknown_value =>
        (case find_first' f xs of Quickcheck_Exhaustive.Value x =>
          Quickcheck_Exhaustive.Value x
        | _ => Quickcheck_Exhaustive.Unknown_value))"

lemmas find_first'_code [code] = find_first'_Nil find_first'_Cons

axiomatization neg_cps_of_set :: "'a set => ('a Quickcheck_Exhaustive.unknown => term list Quickcheck_Exhaustive.three_valued) => natural => term list Quickcheck_Exhaustive.three_valued"
where neg_cps_of_set_code [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"

setup \<open>
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val oi = Fun (Output, Fun (Input, Bool))
  val ii = Fun (Input, Fun (Input, Bool))
  fun of_set compfuns \<^Type>\<open>fun T _\<close> =
    case body_type (Predicate_Compile_Aux.mk_monadT compfuns T) of
      \<^Type>\<open>Quickcheck_Exhaustive.three_valued _\<close> =>
        Const(\<^const_name>\<open>neg_cps_of_set\<close>, \<^Type>\<open>set T\<close> --> Predicate_Compile_Aux.mk_monadT compfuns T)
    | _ => Const(\<^const_name>\<open>pos_cps_of_set\<close>, \<^Type>\<open>set T\<close> --> Predicate_Compile_Aux.mk_monadT compfuns T)
  fun member compfuns (U as \<^Type>\<open>fun T _\<close>) =
    (absdummy T (absdummy \<^Type>\<open>set T\<close> (Predicate_Compile_Aux.mk_if compfuns
      (\<^Const>\<open>Set.member T for \<open>Bound 1\<close> \<open>Bound 0\<close>\<close>))))

in
  Core_Data.force_modes_and_compilations \<^const_name>\<open>Set.member\<close>
    [(oi, (of_set, false)), (ii, (member, false))]
end
\<close>
section \<open>Property\<close>

lemma "\<lbrakk> hotel s; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
quickcheck[tester = exhaustive, size = 6, expect = counterexample]
quickcheck[tester = smart_exhaustive, depth = 6, expect = counterexample]
oops

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
quickcheck[smart_exhaustive, depth = 10, allow_function_inversion, expect = counterexample]
oops

section \<open>Refinement\<close>

fun split_list
where
  "split_list [] = [([], [])]"
| "split_list (z # zs) = (([], z # zs) # [(z # xs', ys'). (xs', ys') <- split_list zs])"

lemma split_list: "((xs, ys) \<in> set (split_list zs)) = (zs = xs @ ys)"
apply (induct zs arbitrary: xs ys)
apply fastforce
apply (case_tac xs)
apply auto
done

lemma [code]: "feels_safe s r = list_ex (%(s3, s2, s1, g, c, c'). no_Check_in (s3 @ s2) r &
    isin (s2 @ [Check_in g r c] @ s1) r = {}) ([(s3, s2, s1, g, c, c'). (s3, Enter g' r' c # r3) <- split_list s, r' = r, (s2, Check_in g r'' c' # s1) <- split_list r3, r'' = r, g = g'])"
unfolding feels_safe_def list_ex_iff
by auto (metis split_list)+

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
(* quickcheck[exhaustive, size = 9, timeout = 2000] -- maybe possible with a lot of time *)
quickcheck[narrowing, size = 7, expect = counterexample]
oops

end


theory Lens_Record_Example
imports Lens_Instances
begin

text \<open>The alphabet command supports syntax illustrated in the following comments.\<close>

alphabet mylens =
  x :: nat
  y :: string

lemma mylens_bij_lens:
  "bij_lens (x +\<^sub>L y +\<^sub>L mylens_child_lens)"
  by (unfold_locales, simp_all add: lens_plus_def x_def y_def mylens_child_lens_def id_lens_def sublens_def lens_comp_def prod.case_eq_if)

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat

end


(*  Title:      HOL/Imperative_HOL/ex/Subarray.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Theorems about sub arrays\<close>

theory Subarray
imports "~~/src/HOL/Imperative_HOL/Array" List_Sublist
begin

definition subarray :: "nat \<Rightarrow> nat \<Rightarrow> ('a::heap) array \<Rightarrow> heap \<Rightarrow> 'a list" where
  "subarray n m a h \<equiv> nths' n m (Array.get h a)"

lemma subarray_upd: "i \<ge> m \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (simp add: nths'_update1)
done

lemma subarray_upd2: " i < n  \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (subst nths'_update2)
apply fastforce
apply simp
done

lemma subarray_upd3: "\<lbrakk> n \<le> i; i < m\<rbrakk> \<Longrightarrow> subarray n m a (Array.update a i v h) = (subarray n m a h)[i - n := v]"
unfolding subarray_def Array.update_def
by (simp add: nths'_update3)

lemma subarray_Nil: "n \<ge> m \<Longrightarrow> subarray n m a h = []"
by (simp add: subarray_def nths'_Nil')

lemma subarray_single: "\<lbrakk> n < Array.length h a \<rbrakk> \<Longrightarrow> subarray n (Suc n) a h = [Array.get h a ! n]"
by (simp add: subarray_def length_def nths'_single)

lemma length_subarray: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray n m a h) = m - n"
by (simp add: subarray_def length_def length_nths')

lemma length_subarray_0: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray 0 m a h) = m"
by (simp add: length_subarray)

lemma subarray_nth_array_Cons: "\<lbrakk> i < Array.length h a; i < j \<rbrakk> \<Longrightarrow> (Array.get h a ! i) # subarray (Suc i) j a h = subarray i j a h"
unfolding Array.length_def subarray_def
by (simp add: nths'_front)

lemma subarray_nth_array_back: "\<lbrakk> i < j; j \<le> Array.length h a\<rbrakk> \<Longrightarrow> subarray i j a h = subarray i (j - 1) a h @ [Array.get h a ! (j - 1)]"
unfolding Array.length_def subarray_def
by (simp add: nths'_back)

lemma subarray_append: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow> subarray i j a h @ subarray j k a h = subarray i k a h"
unfolding subarray_def
by (simp add: nths'_append)

lemma subarray_all: "subarray 0 (Array.length h a) a h = Array.get h a"
unfolding Array.length_def subarray_def
by (simp add: nths'_all)

lemma nth_subarray: "\<lbrakk> k < j - i; j \<le> Array.length h a \<rbrakk> \<Longrightarrow> subarray i j a h ! k = Array.get h a ! (i + k)"
unfolding Array.length_def subarray_def
by (simp add: nth_nths')

lemma subarray_eq_samelength_iff: "Array.length h a = Array.length h' a \<Longrightarrow> (subarray i j a h = subarray i j a h') = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> Array.get h a ! i' = Array.get h' a ! i')"
unfolding Array.length_def subarray_def by (rule nths'_eq_samelength_iff)

lemma all_in_set_subarray_conv: "(\<forall>j. j \<in> set (subarray l r a h) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule all_in_set_nths'_conv)

lemma ball_in_set_subarray_conv: "(\<forall>j \<in> set (subarray l r a h). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule ball_in_set_nths'_conv)

end


section \<open>State and Lens integration\<close>

theory Lens_State
imports
  "HOL-Library.State_Monad"
  Lens_Algebra
begin

text \<open>Inspired by Haskell's lens package\<close>

definition zoom :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a, 'c) state \<Rightarrow> ('b, 'c) state" where
"zoom l m = State (\<lambda>b. case run_state m (lens_get l b) of (c, a) \<Rightarrow> (c, lens_put l b a))"

definition use :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b, 'a) state" where
"use l = zoom l State_Monad.get"

definition modify :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, unit) state" where
"modify l f = zoom l (State_Monad.update f)"

definition assign :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b, unit) state" where
"assign l b = zoom l (State_Monad.set b)"

context begin

qualified abbreviation "add l n \<equiv> modify l (\<lambda>x. x + n)"
qualified abbreviation "sub l n \<equiv> modify l (\<lambda>x. x - n)"
qualified abbreviation "mul l n \<equiv> modify l (\<lambda>x. x * n)"
qualified abbreviation "inc l \<equiv> add l 1"
qualified abbreviation "dec l \<equiv> sub l 1"

end

bundle lens_state_notation begin
  notation zoom (infixr "\<rhd>" 80)
  notation modify (infix "%=" 80)
  notation assign (infix ".=" 80)
  notation Lens_State.add (infix "+=" 80)
  notation Lens_State.sub (infix "-=" 80)
  notation Lens_State.mul (infix "*=" 80)
  notation Lens_State.inc ("_ ++")
  notation Lens_State.dec ("_ --")
end

context includes lens_state_notation begin

lemma zoom_comp1: "l1 \<rhd> l2 \<rhd> s = (l2 ;\<^sub>L l1) \<rhd> s"
unfolding zoom_def lens_comp_def
by (auto split: prod.splits)

lemma zoom_zero[simp]: "zero_lens \<rhd> s = s"
unfolding zoom_def zero_lens_def
by simp

lemma zoom_id[simp]: "id_lens \<rhd> s = s"
unfolding zoom_def id_lens_def
by simp

end

lemma (in mwb_lens) zoom_comp2[simp]: "zoom x m \<bind> (\<lambda>a. zoom x (n a)) = zoom x (m \<bind> n)"
unfolding zoom_def State_Monad.bind_def
by (auto split: prod.splits simp: put_get put_put)

lemma (in wb_lens) use_alt_def: "use x = map_state (lens_get x) State_Monad.get"
unfolding State_Monad.get_def use_def zoom_def
by (simp add: comp_def get_put)

lemma (in wb_lens) modify_alt_def: "modify x f = State_Monad.update (update f)"
  unfolding modify_def zoom_def lens_update_def State_Monad.update_def State_Monad.get_def State_Monad.set_def State_Monad.bind_def
  by (auto)

lemma (in wb_lens) modify_id[simp]: "modify x (\<lambda>x. x) = State_Monad.return ()"
unfolding lens_update_def modify_alt_def
by (simp add: get_put)

lemma (in mwb_lens) modify_comp[simp]: "bind (modify x f) (\<lambda>_. modify x g) = modify x (g \<circ> f)"
unfolding modify_def
by simp

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

(* Miscellaneous additional library definitions and lemmas for the word type.
   Builds on WORD image.
*)

theory WordLib
imports NICTACompat SignedWords
begin

(* stuff to move to word/* *)

lemma shiftl_power:
  "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
  apply (induct x)
   apply simp
  apply (simp add: shiftl1_2t)
  done

lemma to_bl_use_of_bl:
   "(to_bl w = bl) = (w = of_bl bl \<and> length bl = length (to_bl w))"
  by (fastforce elim!: word_bl.Abs_inverse [simplified])

lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append

lemma uint_of_bl_is_bl_to_bin:
  "length l\<le>len_of TYPE('a) \<Longrightarrow>
   uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
  apply (simp add: of_bl_def)
  apply (rule word_uint.Abs_inverse)
  apply (simp add: uints_num bl_to_bin_ge0)
  apply (rule order_less_le_trans, rule bl_to_bin_lt2p)
  apply (rule order_trans, erule power_increasing)
   apply simp_all
  done

lemma bin_to_bl_or:
  "bin_to_bl n (a OR b) = map2 (op \<or>) (bin_to_bl n a) (bin_to_bl n b)"
  using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
  by simp

lemma word_ops_nth [simp]:
  shows
  word_or_nth:  "(x || y) !! n = (x !! n \<or> y !! n)" and
  word_and_nth: "(x && y) !! n = (x !! n \<and> y !! n)" and
  word_xor_nth: "(x xor y) !! n = (x !! n \<noteq> y !! n)"
  by ((cases "n < size x",
      auto dest: test_bit_size simp: word_ops_nth_size word_size)[1])+

lemma word_nth_1 [iff]:
  "(1::'a::len word) !! n = (n = 0)"
proof -
  have "(2 ^ 0 ::'a::len word) !! n = (n = 0)"
    by (subst nth_w2p) auto
  thus ?thesis by simp
qed

(* test: *)
lemma "1 < (1024::32 word) \<and> 1 \<le> (1024::32 word)" by simp

lemma and_not_mask: "w AND NOT mask n = (w >> n) << n"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma and_mask: "w AND mask n = (w << (size w - n)) >> (size w - n)"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma AND_twice:
  "(w && m) && m = w && m"
by (simp add: word_eqI)

lemma nth_w2p_same: "(2^n :: 'a :: len word) !! n = (n < len_of TYPE('a::len))"
  by (simp add : nth_w2p)

lemma p2_gt_0: "(0 < (2 ^ n :: 'a :: len word)) = (n < len_of TYPE('a))"
  apply (simp add : word_gt_0 del : word_neq_0_conv)
  apply safe
   apply (erule swap)
   apply (rule word_eqI)
   apply (simp add : nth_w2p)
  apply (drule word_eqD)
  apply simp
  apply (erule notE)
  apply (erule nth_w2p_same [THEN iffD2])
  done

lemmas uint_2p_alt = uint_2p [unfolded p2_gt_0]

lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
  apply (unfold word_div_def)
  apply (simp add : uint_2p_alt word_size)
  apply (rule word_uint.Rep_inverse' [THEN sym])
  apply (rule shiftr_div_2n)
  done

lemmas less_def = less_eq [symmetric]
lemmas le_def = not_less [symmetric, where ?'a = nat]

lemmas p2_eq_0 = trans [OF eq_commute
  iffD2 [OF Not_eq_iff p2_gt_0, folded le_def, unfolded word_gt_0 not_not]]

lemma neg_mask_is_div':
  "n < size w \<Longrightarrow> w AND NOT mask n = ((w div (2 ^ n)) * (2 ^ n))"
  apply (simp add : and_not_mask)
  apply (simp add : shiftr_div_2n_w shiftl_t2n word_size)
  done

lemma neg_mask_is_div: "w AND NOT mask n = ((w div (2 ^ n)) * (2 ^ n))"
  apply (cases "n < size w")
  apply (erule neg_mask_is_div')
  apply (simp add : word_size)
  apply (frule p2_gt_0 [THEN Not_eq_iff [THEN iffD2], THEN iffD2])
  apply (simp add : word_gt_0 del : word_neq_0_conv)
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  done

lemma and_mask_arith':
  "0 < n \<Longrightarrow> w AND mask n = ((w * (2 ^ (size w - n))) div (2 ^ (size w - n)))"
  apply (simp add : and_mask)
  apply (simp add : shiftr_div_2n_w shiftl_t2n word_size)
  apply (simp add : mult.commute)
  done

lemma mask_0 [simp]: "mask 0 = 0"
  apply (unfold mask_def)
  by simp

lemmas p2len = iffD2 [OF p2_eq_0 order_refl]

lemma mask_2pm1: "mask n = 2 ^ n - 1"
  apply (simp add : mask_def)
  done

lemma is_aligned_AND_less_0:
  "u && mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u && v = 0"
apply (drule less_mask_eq)
apply (simp add: mask_2pm1)
apply (rule word_eqI)
apply (clarsimp simp add: word_size)
apply (drule_tac x=na in word_eqD)
apply (drule_tac x=na in word_eqD)
apply simp
done

lemma len_0_eq: "len_of (TYPE('a :: len0)) = 0 ==> (x :: 'a :: len0 word) = y"
  apply (rule word_uint.Rep_eqD)
  apply (rule box_equals)
    apply (rule_tac [2] word_ubin.norm_Rep)
   apply (rule_tac [2] word_ubin.norm_Rep)
  apply simp
  done

lemma le_shiftr1: "u <= v ==> shiftr1 u <= shiftr1 v"
  apply (unfold word_le_def shiftr1_def word_ubin.eq_norm)
  apply (unfold bin_rest_trunc_i
                trans [OF bintrunc_bintrunc_l word_ubin.norm_Rep,
                          unfolded word_ubin.norm_Rep,
                       OF order_refl [THEN le_SucI]])
  apply (case_tac "uint u" rule: bin_exhaust)
  apply (rename_tac bs bit)
  apply (case_tac "uint v" rule: bin_exhaust)
  apply (rename_tac bs' bit')
  apply (case_tac "bit")
   apply (case_tac "bit'", auto simp: less_eq_int_code le_Bits)[1]
  apply (case_tac bit')
   apply (simp add: le_Bits less_eq_int_code)
  apply (auto simp: le_Bits less_eq_int_code)
  done

lemma le_shiftr: "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len0 word) >> n"
  apply (unfold shiftr_def)
  apply (induct_tac "n")
   apply auto
  apply (erule le_shiftr1)
  done

lemma shiftr_mask_le: "n <= m ==> mask n >> m = 0"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftr)
  done

lemmas shiftr_mask = order_refl [THEN shiftr_mask_le, simp]

lemma word_leI: "(!!n::nat.  n < size (u::'a::len0 word)
   ==> u !! n ==> (v::'a::len0 word) !! n) ==> u <= v"
  apply (rule xtr4)
   apply (rule word_and_le2)
  apply (rule word_eqI)
  apply (simp add: word_ao_nth)
  apply safe
    apply assumption
   apply (erule_tac [2] asm_rl)
  apply (unfold word_size)
  by auto

lemma le_mask_iff: "(w \<le> mask n) = (w >> n = 0)"
  apply safe
   apply (rule word_le_0_iff [THEN iffD1])
   apply (rule xtr3)
    apply (erule_tac [2] le_shiftr)
   apply simp
  apply (rule word_leI)
  apply (drule_tac x = "na - n" in word_eqD)
  apply (simp add : nth_shiftr word_size)
  apply (case_tac "n <= na")
   by auto

lemma and_mask_eq_iff_shiftr_0: "(w AND mask n = w) = (w >> n = 0)"
  apply (unfold test_bit_eq_iff [THEN sym])
  apply (rule iffI)
   apply (rule ext)
   apply (rule_tac [2] ext)
   apply (auto simp add : word_ao_nth nth_shiftr)
    apply (drule arg_cong)
    apply (drule iffD2)
     apply assumption
    apply (simp add : word_ao_nth)
   prefer 2
   apply (simp add : word_size test_bit_bin)
  apply (drule_tac f = "%u. u !! (x - n)" in arg_cong)
  apply (simp add : nth_shiftr)
  apply (case_tac "n <= x")
   apply auto
  done

lemmas and_mask_eq_iff_le_mask = trans
  [OF and_mask_eq_iff_shiftr_0 le_mask_iff [THEN sym]]

lemma one_bit_shiftl: "set_bit 0 n True = (1 :: 'a :: len word) << n"
  apply (rule word_eqI)
  apply (auto simp add: test_bit_set_gen nth_shiftl word_size
              simp del: word_set_bit_0 shiftl_1)
  done

lemmas one_bit_pow = trans [OF one_bit_shiftl shiftl_1]

lemma bin_sc_minus: "0 < n ==> bin_sc (Suc (n - 1)) b i = bin_sc n b i"
  by auto

lemmas bin_sc_minus_simps =
  bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]

lemma NOT_eq: "NOT (x :: 'a :: len word) = - x - 1"
  apply (cut_tac x = "x" in word_add_not)
  apply (drule add.commute [THEN trans])
  apply (drule eq_diff_eq [THEN iffD2])
  by simp

lemma NOT_mask: "NOT (mask n :: 'a :: len word) = - (2 ^ n)"
  apply (simp add : NOT_eq mask_2pm1)
  done

(* should be valid for len0 as well *)
lemma power_2_pos_iff:
  "(2 ^ n > (0 :: 'a :: len word)) = (n < len_of TYPE ('a))"
  apply (unfold word_gt_0)
  apply safe
   apply (erule swap)
   apply (rule word_eqI)
   apply (simp add : nth_w2p word_size)
  apply (drule_tac x = "n" in word_eqD)
  apply (simp add : nth_w2p)
  done

lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
  apply uint_arith
  done

lemmas gt0_iff_gem1 =
  iffD1 [OF iffD1 [OF iff_left_commute le_m1_iff_lt] order_refl]

lemmas power_2_ge_iff = trans [OF gt0_iff_gem1 [THEN sym] power_2_pos_iff]

lemma le_mask_iff_lt_2n:
  "n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
  apply (unfold mask_2pm1)
  apply (rule trans [OF power_2_pos_iff [THEN sym] le_m1_iff_lt])
  done

lemmas mask_lt_2pn =
  le_mask_iff_lt_2n [THEN iffD1, THEN iffD1, OF _ order_refl]

lemma mask_eq_iff_w2p_alt:
  "n < size (w::'a::len word) ==> (w AND mask n = w) = (w < 2 ^ n)"
  apply (unfold and_mask_eq_iff_le_mask word_size)
  apply (simp add : le_mask_iff_lt_2n [THEN iffD1])
  done

lemma and_mask_less_size_alt:  "n < size x ==> x AND mask n < 2 ^ n"
  apply (rule xtr7)
   apply (rule_tac [2] word_and_le1)
  apply (unfold word_size)
  apply (erule mask_lt_2pn)
  done

lemma bang_eq:
  fixes x :: "'a::len0 word"
  shows "(x = y) = (\<forall>n. x !! n = y !! n)"
  apply (subst test_bit_eq_iff[symmetric])
  apply (rule iffI)
   apply simp
  apply (rule ext)
  apply simp
  done

declare of_nat_power [simp]
declare of_nat_mult [simp]

lemma word_unat_power:
  "(2 :: ('a :: len) word) ^ n = of_nat (2 ^ n)"
  by (induct n) simp+

(*
lemmas no_power_simps =
  power_int.simps power_nat.simps
  power_nat_number_of_number_of power_Suc_no power_pred_simp_no
*)

lemma of_nat_mono_maybe:
  fixes Y :: "nat"
  assumes xlt: "X < 2 ^ len_of TYPE ('a :: len)"
  shows   "(Y < X) \<Longrightarrow> of_nat Y < (of_nat X :: 'a :: len word)"
  apply (subst word_less_nat_alt)
  apply (subst unat_of_nat)+
  apply (subst mod_less)
    apply (erule order_less_trans [OF _ xlt])
    apply (subst mod_less [OF xlt])
   apply assumption
   done

lemma shiftl_over_and_dist:
  fixes a::"'a::len word"
  shows "(a AND b) << c = (a << c) AND (b << c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftl word_ao_nth nth_shiftl, safe)
done

lemma shiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >> c = (a >> c) AND (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
done

lemma sshiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
done

lemma shiftl_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b << c = (a << c) OR (b << c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftl word_ao_nth, safe)
done

lemma shiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >> c = (a >> c) OR (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
done

lemma sshiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
done

lemmas shift_over_ao_dists =
  shiftl_over_or_dist shiftr_over_or_dist
  sshiftr_over_or_dist shiftl_over_and_dist
  shiftr_over_and_dist sshiftr_over_and_dist

lemma shiftl_shiftl:
  fixes a::"'a::len word"
  shows "a << b << c = a << (b + c)"
 apply(rule word_eqI)
 apply(auto simp:word_size nth_shiftl
                 add.commute add.left_commute)
done

lemma shiftr_shiftr:
  fixes a::"'a::len word"
  shows "a >> b >> c = a >> (b + c)"
 apply(rule word_eqI)
 apply(simp add:word_size nth_shiftr
                add.left_commute add.commute)
done

lemma shiftl_shiftr1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow>
    a << b >> c =
    a AND (mask (size a - b)) << (b - c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ao_nth)
done

lemma shiftl_shiftr2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow>
    a << b >> c =
    (a >> (c - b)) AND (mask (size a - c))"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ao_nth)
done

lemma shiftr_shiftl1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow>
         a >> b << c = (a >> (b - c)) AND
                       (NOT mask c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ops_nth_size)
done

lemma shiftr_shiftl2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow>
         a >> b << c = (a << (c - b)) AND
                       (NOT mask c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ops_nth_size)
done

lemmas multi_shift_simps =
  shiftl_shiftl shiftr_shiftr
  shiftl_shiftr1 shiftl_shiftr2
  shiftr_shiftl1 shiftr_shiftl2

lemma word_and_max_word:
  fixes a::"'a::len word"
  shows "x = max_word \<Longrightarrow> a AND x = a"
 apply(simp)
done

lemma word_and_1:
  fixes x::"'a::len word"
  shows "(x AND 1) = (if x!!0 then 1 else 0)"
 apply(rule word_eqI)
 apply(simp add:word_ao_nth)
 apply(rule conjI)
  apply(auto)[1]
 apply clarsimp
 apply (case_tac n)
  apply simp
 apply simp
 done

lemma word_and_1_bl:
  fixes x::"'a::len word"
  shows "(x AND 1) = of_bl [x !! 0]"
  by (simp add: word_and_1)

lemma word_1_and_bl:
  fixes x::"'a::len word"
  shows "(1 AND x) = of_bl [x !! 0]"
  by (subst word_bw_comms)
     (simp add: word_and_1)

(* can stay here: *)
(* some Haskellish syntax *)

notation (input)
  test_bit ("testBit")

definition
  w2byte :: "'a :: len word \<Rightarrow> 8 word" where
  "w2byte \<equiv> ucast"

lemma scast_scast_id':
  fixes x :: "('a::len) word"
  assumes is_up: "is_up (scast :: 'a word \<Rightarrow> ('b::len) word)"
  shows "scast (scast x :: 'b word) = (x :: 'a word)"
  apply (subst scast_up_scast)
   apply fact
  apply (rule scast_id)
  done

lemma scast_scast_id [simp]:
  "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
  "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
  by (auto simp: is_up scast_scast_id')

lemma scast_ucast_id [simp]:
    "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
  by (metis down_cast_same is_down len_signed order_refl scast_scast_id(1))

lemma ucast_scast_id [simp]:
    "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
  by (metis scast_scast_id(2) scast_ucast_id)

lemma scast_of_nat [simp]:
    "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
  by (metis (hide_lams, no_types) len_signed scast_def uint_sint
         word_of_nat word_ubin.Abs_norm word_ubin.eq_norm)

lemma ucast_of_nat:
  "is_down (ucast :: ('a :: len) word \<Rightarrow> ('b :: len) word)
    \<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
  apply (rule sym)
  apply (subst word_unat.inverse_norm)
  apply (simp add: ucast_def word_of_int[symmetric]
                   of_nat_nat[symmetric] unat_def[symmetric])
  apply (simp add: unat_of_nat)
  apply (rule nat_int.Rep_eqD)
  apply (simp only: zmod_int)
  apply (rule mod_mod_cancel)
  apply (subst zdvd_int[symmetric])
  apply (rule le_imp_power_dvd)
  apply (simp add: is_down_def target_size_def source_size_def word_size)
  done

lemma word32_sint_1[simp]:
 "sint (1::word32) = 1"
  by (simp add: sint_word_ariths)

lemma sint_1 [simp]:
  "sint (1::'a::len word) = (if len_of TYPE('a) = 1 then -1 else 1)"
  apply (case_tac "len_of TYPE('a) \<le> 1")
   apply (metis diff_is_0_eq sbintrunc_0_numeral(1) sint_n1 word_1_wi
           word_m1_wi word_msb_1 word_msb_n1 word_sbin.Abs_norm)
  apply (metis bin_nth_1 diff_is_0_eq neq0_conv sbintrunc_minus_simps(4)
            sint_word_ariths(8) uint_1 word_msb_1 word_msb_nth)
  done

lemma scast_1':
  "(scast (1::'a::len word) :: 'b::len word) =
   (word_of_int (sbintrunc (len_of TYPE('a::len) - Suc 0) (1::int)))"
  by (clarsimp simp only: scast_sbintr semiring_norm)

lemma scast_1 [simp]:
  "(scast (1::'a::len word) :: 'b::len word) =
      (if len_of TYPE('a) = 1 then -1 else 1)"
  apply (clarsimp simp: scast_1')
  apply (metis Suc_pred len_gt_0 nat.exhaust sbintrunc_Suc_numeral(1)
           uint_1 word_uint.Rep_inverse')
  done

lemma scast_eq_scast_id [simp]:
    "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
  by (metis ucast_scast_id)

lemma ucast_eq_ucast_id [simp]:
    "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
  by (metis scast_ucast_id)

lemma scast_ucast_norm [simp]:
  "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
  "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
  by (metis scast_ucast_id ucast_scast_id)+

lemma of_bl_drop:
  "of_bl (drop n xs) = (of_bl xs && mask (length xs - n))"
  apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth
                  cong: rev_conj_cong)
  apply (safe, simp_all add: word_size to_bl_nth)
  done

lemma of_int_uint [simp]:
    "of_int (uint x) = x"
  by (metis word_of_int word_uint.Rep_inverse')

lemma shiftr_mask2:
  "n \<le> len_of TYPE('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
  apply (rule word_eqI)
  apply (simp add: nth_shiftr word_size)
  apply arith
  done

(* from GeneralLib *)
corollary word_plus_and_or_coroll:
  "x && y = 0 \<Longrightarrow> x + y = x || y"
  using word_plus_and_or[where x=x and y=y]
  by simp

(* from GeneralLib *)
corollary word_plus_and_or_coroll2:
  "(x && w) + (x && ~~ w) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply blast
  done

(* FIXME: The two lemmas below are not exactly word-related but they
     correspond to the lemmas less_le_mult' and less_le_mult from the theory
     isabelle/src/HOL/Word/Num_Lemmas.
 *)
lemma less_le_mult_nat':
  "w * c < b * c ==> 0 \<le> c ==> Suc w * c \<le> b * (c::nat)"
  apply (rule mult_right_mono)
   apply (rule Suc_leI)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemmas less_le_mult_nat = less_le_mult_nat'[simplified distrib_right, simplified]

(* FIXME: these should be moved to Word and declared [simp]
   but that will probably break everything. *)
lemmas extra_sle_sless_unfolds
    = word_sle_def[where a=0 and b=1]
    word_sle_def[where a=0 and b="numeral n"]
    word_sle_def[where a=1 and b=0]
    word_sle_def[where a=1 and b="numeral n"]
    word_sle_def[where a="numeral n" and b=0]
    word_sle_def[where a="numeral n" and b=1]
    word_sless_alt[where a=0 and b=1]
    word_sless_alt[where a=0 and b="numeral n"]
    word_sless_alt[where a=1 and b=0]
    word_sless_alt[where a=1 and b="numeral n"]
    word_sless_alt[where a="numeral n" and b=0]
    word_sless_alt[where a="numeral n" and b=1]
  for n

(*
 * Signed division: when the result of a division is negative,
 * we will round towards zero instead of towards minus infinity.
 *)
class signed_div =
  fixes sdiv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "sdiv" 70)
  fixes smod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "smod" 70)

instantiation int :: signed_div
begin
definition "(a :: int) sdiv b \<equiv> sgn (a * b) * (abs a div abs b)"
definition "(a :: int) smod b \<equiv> a - (a sdiv b) * b"
instance ..
end

instantiation word :: (len) signed_div
begin
definition "(a :: ('a::len) word) sdiv b = word_of_int (sint a sdiv sint b)"
definition "(a :: ('a::len) word) smod b = word_of_int (sint a smod sint b)"
instance ..
end

(* Tests *)
lemma
  "( 4 :: word32) sdiv  4 =  1"
  "(-4 :: word32) sdiv  4 = -1"
  "(-3 :: word32) sdiv  4 =  0"
  "( 3 :: word32) sdiv -4 =  0"
  "(-3 :: word32) sdiv -4 =  0"
  "(-5 :: word32) sdiv -4 =  1"
  "( 5 :: word32) sdiv -4 = -1"
  by (simp_all add: sdiv_word_def sdiv_int_def)

lemma
  "( 4 :: word32) smod  4 =   0"
  "( 3 :: word32) smod  4 =   3"
  "(-3 :: word32) smod  4 =  -3"
  "( 3 :: word32) smod -4 =   3"
  "(-3 :: word32) smod -4 =  -3"
  "(-5 :: word32) smod -4 =  -1"
  "( 5 :: word32) smod -4 =   1"
  by (simp_all add: smod_word_def smod_int_def sdiv_int_def)

end


section\<open>The Axiom of Foundation in $M[G]$\<close>

theory Foundation_Axiom
  imports
    Names
begin

context forcing_data1
begin

(* Slick proof essentially by Paulson (adapted from L) *)
lemma foundation_in_MG : "foundation_ax(##(M[G]))"
  unfolding foundation_ax_def
  by (rule rallI, cut_tac A=x in foundation, auto intro: transitivity_MG)

(* Same theorem as above, declarative proof,
   without using transitivity *)
lemma "foundation_ax(##(M[G]))"
proof -
  {
    fix x
    assume "x\<in>M[G]" "\<exists>y\<in>M[G] . y\<in>x"
    then
    have "\<exists>y\<in>M[G] . y\<in>x\<inter>M[G]"
      by simp
    then
    obtain y where "y\<in>x\<inter>M[G]" "\<forall>z\<in>y. z \<notin> x\<inter>M[G]"
      using foundation[of "x\<inter>M[G]"]  by blast
    then
    have "\<exists>y\<in>M[G] . y \<in> x \<and> (\<forall>z\<in>M[G] . z \<notin> x \<or> z \<notin> y)"
      by auto
  }
  then
  show ?thesis
    unfolding foundation_ax_def by auto
qed

end \<comment> \<open>\<^locale>\<open>forcing_data1\<close>\<close>

end


(*<*)
(*
   Title: FR.thy  (FlexRay: Verification)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
section \<open>FlexRay: Verification\<close>

theory  FR_proof
imports FR
begin

subsection \<open>Properties of the function Send\<close>

lemma Send_L1:
assumes "Send return send get activation"
       and "send t  \<noteq> []"
shows  "(activation t) \<noteq> []"
using assms by (simp add: Send_def, auto)

lemma Send_L2:
assumes "Send return send get activation"
       and "(activation t)  \<noteq> []"
       and "return t \<noteq> []"
shows  "(send t) \<noteq> []"
using assms  by (simp add: Send_def)

subsection \<open>Properties of the component Scheduler\<close>

lemma Scheduler_L1:
assumes h1:"Scheduler C activation"
        and h2:"(activation t) \<noteq> []"
shows "(t mod (cycleLength C)) mem (schedule C)"
using assms
proof -
   { assume  a1:"\<not> t mod cycleLength C mem schedule C"
      from h1 have
      "if t mod cycleLength C mem schedule C
       then activation t = [t mod cycleLength C]
       else activation t = []"
         by (simp add: Scheduler_def Let_def)
     from a1 and this have "activation t = []" by simp
     from this and h2 have sg3:"False" by simp
   } from this have  sg4:"(t mod (cycleLength C)) mem (schedule C)" by blast
  from this show ?thesis by simp
qed

lemma Scheduler_L2:
assumes "Scheduler C activation"
       and "\<not> (t mod cycleLength C) mem (schedule C)"
shows "activation t = []"
using assms by (simp add: Scheduler_def Let_def)

lemma Scheduler_L3:
assumes "Scheduler C activation"
       and "(t mod cycleLength C) mem (schedule C)"
shows "activation t \<noteq> []"
using assms by (simp add: Scheduler_def Let_def)

lemma Scheduler_L4:
assumes "Scheduler C activation"
       and "(t mod cycleLength C) mem (schedule C)"
shows "activation t = [t mod cycleLength C]"
using assms by (simp add: Scheduler_def Let_def)

lemma correct_DisjointSchedules1:
assumes h1:"DisjointSchedules n nC"
       and h2:"IdenticCycleLength n nC"
       and h3:"(t mod cycleLength (nC i)) mem schedule (nC i)"
       and h4:"i < n"
       and h5:"j < n"
       and h6:"i \<noteq> j"
shows "\<not> (t mod cycleLength (nC j) mem schedule (nC j))"
proof -
  from h1 and h4 and h5 and h6 have sg1:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from h2 and h4 and h5 have sg2:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from sg1 and h3 have sg3:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg2 and sg3 show ?thesis by simp
qed

subsection \<open>Disjoint Frames\<close>

lemma disjointFrame_L1:
assumes h1:"DisjointSchedules n nC"
       and h2:"IdenticCycleLength n nC"
       and h3:"\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
       and h4:"nSend i t \<noteq> []"
       and h5:"i < n"
       and h6:"j < n"
       and h7:"i \<noteq> j"
shows "nSend j t = []"
proof -
  from h3 and h5 have sg1:
   "FlexRayController (nReturn i) rcv (nC i) (nStore i) (nSend i) (nGet i)"
    by auto
  from h3 and h6 have sg2:
   "FlexRayController (nReturn j) rcv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
  from sg1 obtain activation1 where
     a1:"Scheduler (nC i) activation1" and
     a2:"BusInterface activation1 (nReturn i) rcv (nStore i) (nSend i) (nGet i)"
     by (simp add: FlexRayController_def, auto)
  from sg2 obtain activation2 where
     a3:"Scheduler (nC j) activation2" and
     a4:"BusInterface activation2 (nReturn j) rcv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from h1 and h5 and h6 and h7 have sg3:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from a2 have  sg4a:"Send (nReturn i) (nSend i) (nGet i) activation1"
     by (simp add:  BusInterface_def)
  from sg4a and h4 have sg5:"activation1 t  \<noteq> []" by (simp add: Send_L1)
  from a1 and sg5 have sg6:"(t mod (cycleLength (nC i))) mem (schedule (nC i))"
     by (simp add: Scheduler_L1)
  from h2 and h5 and h6 have sg7:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from sg3 and sg6 have sg8:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg8 and sg7 have sg9:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from sg9 and a3 have sg10:"activation2 t = []" by (simp add: Scheduler_L2)
  from a4 have sg11:"Send (nReturn j) (nSend j) (nGet j) activation2"
     by (simp add:  BusInterface_def)
  from sg11 and sg10 show ?thesis by (simp add: Send_def)
qed

lemma disjointFrame_L2:
assumes "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
shows "inf_disj n nSend"
using assms
  apply (simp add: inf_disj_def, clarify)
  by (rule disjointFrame_L1, auto)

lemma disjointFrame_L3:
assumes h1:"DisjointSchedules n nC"
     and h2:"IdenticCycleLength n nC"
     and h3:"\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
    and h4:"t mod cycleLength (nC i) mem schedule (nC i)"
    and h5:"i < n"
    and h6:"j < n"
    and h7:"i \<noteq> j"
shows "nSend j t = []"
proof -
  from h2 and h5 and h6 have sg1:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from h1 and h5 and h6 and h7 have sg2:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from sg2 and h4 have sg3:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg1 and sg3 have sg4:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from h3 and h6 have sg5:
   "FlexRayController (nReturn j) rcv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
  from sg5 obtain activation2 where
     a1:"Scheduler (nC j) activation2" and
     a2:"BusInterface activation2 (nReturn j) rcv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from sg4 and a1 have sg6:"activation2 t = []" by (simp add: Scheduler_L2)
  from a2 have sg7:"Send (nReturn j) (nSend j) (nGet j) activation2"
     by (simp add:  BusInterface_def)
  from sg7 and sg6 show ?thesis by (simp add: Send_def)
qed

subsection \<open>Properties of the sheaf of channels nSend\<close>

lemma fr_Send1:
assumes frc:"FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
        and h1:"\<not> (t mod cycleLength (nC i) mem schedule (nC i))"
 shows      "(nSend i) t = []"
proof -
  from frc obtain activation where
    a1:"Scheduler (nC i) activation"  and
    a2:"BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayController_def, auto)
  from a1 and h1 have sg1:"activation t = []" by (simp add: Scheduler_L2)
  from a2 have sg2:"Send (nReturn i) (nSend i) (nGet i) activation"
    by (simp add: BusInterface_def)
  from sg2 and sg1 show ?thesis by (simp add: Send_def)
qed

lemma fr_Send2:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h5:"k < n"
 shows "nSend k t = nReturn k t"
proof -
 from h1 and h5 have sg1:
   "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from sg1 obtain activation where
     a1:"Scheduler (nC k) activation" and
     a2:"BusInterface activation (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from a1 and h4 have sg3:"activation t \<noteq> []" by (simp add: Scheduler_L3)
  from a2 have  sg4:"Send (nReturn k) (nSend k) (nGet k) activation"
     by (simp add:  BusInterface_def)
  from sg4 and sg3 show ?thesis by (simp add: Send_def)
qed

lemma fr_Send3:
 assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
     and "nReturn k t \<noteq> []"
 shows "nSend k t \<noteq> []"
using assms by (simp add: fr_Send2)

lemma fr_Send4:
 assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
     and "nReturn k t \<noteq> []"
 shows "\<exists>k. k < n \<longrightarrow> nSend k t \<noteq> []"
using assms
by (metis  fr_Send3)

lemma fr_Send5:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h5:"k < n"
     and h6:"nReturn k t \<noteq> []"
     and h7:"\<forall>k<n. nSend k t = []"
 shows "False"
proof -
  from h1 and h2 and h3 and h4 and h5 and h6 have sg1:"nSend k t \<noteq> []"
    by (simp add: fr_Send2)
  from h7 and h5 have sg2:"nSend k t = []" by blast
  from sg1 and sg2 show ?thesis by simp
qed

lemma fr_Send6:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "nReturn k t \<noteq> []"
shows "\<exists>k<n. nSend k t \<noteq> []"
using assms
by (metis fr_Send3)

lemma fr_Send7:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "j < n"
       and "nReturn k t = []"
shows "nSend j t = []"
using assms
by (metis (full_types) disjointFrame_L3 fr_Send2)

lemma fr_Send8:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "nReturn k t = []"
shows "\<not> (\<exists>k<n. nSend k t \<noteq> [])"
using assms by (auto, simp add: fr_Send7)

lemma fr_nC_Send:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "k < n"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
shows "\<forall>j. j < n \<and> j \<noteq> k \<longrightarrow> (nSend j) t = []"
using assms by (clarify, simp add: disjointFrame_L3)

lemma length_nSend:
assumes h1:"BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
       and h2:"\<forall>t. length (nReturn i t) \<le> Suc 0"
shows   "length (nSend i t) \<le> Suc 0"
proof -
  from h1 have sg1:"Send (nReturn i) (nSend i) (nGet i) activation"
    by (simp add: BusInterface_def)
  from sg1 have sg2:
   "if activation t = [] then nGet i t = [] \<and> nSend i t = []
    else nGet i t = activation t \<and> nSend i t = nReturn i t"
    by (simp add: Send_def)
  show ?thesis
  proof (cases "activation t = []")
    assume a1:"activation t = []"
    from sg2 and a1 show ?thesis by simp
  next
    assume a2:"activation t \<noteq> []"
    from h2 have sg3:"length (nReturn i t) \<le> Suc 0" by auto
    from sg2 and a2 and sg3 show ?thesis by simp
  qed
qed

lemma msg_nSend:
assumes "BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
       and "msg (Suc 0) (nReturn i)"
shows "msg (Suc 0) (nSend i)"
using assms by (simp add: msg_def, clarify, simp add: length_nSend)

lemma Broadcast_nSend_empty1:
assumes h1:"Broadcast n nSend recv"
       and h2:"\<forall>k<n. nSend k t = []"
shows      "recv t = []"
using assms
by (metis Broadcast_def)

subsection \<open>Properties of the sheaf of channels  nGet\<close>

lemma fr_nGet1a:
assumes h1:"FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
       and h2:"t mod cycleLength (nC k) mem schedule (nC k)"
shows "nGet k t = [t mod cycleLength (nC k)]"
proof -
  from h1  obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
   from a2 have sg1:"Send (nReturn k) (nSend k) (nGet k) activation1"
     by (simp add: BusInterface_def)
   from sg1 have sg2:
    "if activation1 t = [] then nGet k t = [] \<and> nSend k t = []
     else nGet k t = activation1 t \<and> nSend k t = nReturn k t"
     by (simp add: Send_def)
  from a1 and h2 have sg3:"activation1 t = [t mod cycleLength (nC k)]"
     by (simp add: Scheduler_L4)
  from sg2 and sg3 show ?thesis  by simp
qed

lemma fr_nGet1:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
shows "nGet k t = [t mod cycleLength (nC k)]"
using assms
by (metis  fr_nGet1a)

lemma fr_nGet2:
assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"\<not> (t mod cycleLength (nC k) mem schedule (nC k))"
     and h3:"k < n"
 shows "nGet k t = []"
proof -
  from h1 and h3 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from sg1 and h2 show ?thesis by (rule fr_nGet2a)
qed

lemma length_nGet1:
 assumes "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
 shows    "length (nGet k t) \<le> Suc 0"
proof (cases "t mod cycleLength (nC k) mem schedule (nC k)")
  assume "t mod cycleLength (nC k) mem schedule (nC k)"
  from assms and this have "nGet k t = [t mod cycleLength (nC k)]"
    by (rule fr_nGet1a)
  then show ?thesis by auto
next
  assume "\<not> (t mod cycleLength (nC k) mem schedule (nC k))"
  from assms and this have "nGet k t = []" by (rule fr_nGet2a)
  then show ?thesis by auto
qed

lemma msg_nGet1:
 assumes "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
 shows    "msg (Suc 0) (nGet k)"
using assms
by (simp add: msg_def, auto, rule length_nGet1)

lemma msg_nGet2:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "k < n"
shows "msg (Suc 0) (nGet k)"
using assms
by (metis msg_nGet1)

subsection \<open>Properties of the sheaf of channels nStore\<close>

lemma fr_nStore_nReturn1:
 assumes h0:"Broadcast n nSend recv"
     and h1:"inf_disj n nSend"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h6:"k < n"
     and h7:"j < n"
     and h8:"j \<noteq> k"
 shows  "nStore j t = nReturn k t"
proof -
  from h2 and h6 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from h2 and h7 have sg2:
    "FlexRayController (nReturn j) recv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
   from sg1 obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from sg2 obtain activation2 where
     a3:"Scheduler (nC j) activation2" and
     a4:"BusInterface activation2 (nReturn j) recv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from a4 have sg3:"Receive recv (nStore j) activation2"
     by (simp add: BusInterface_def)
  from this have sg4:
   "if activation2 t = [] then nStore j t = recv t else nStore j t = []"
    by (simp add: Receive_def)
  from a1 and h5 have sg5:"activation1 t \<noteq> []"
     by (simp add: Scheduler_L3)
 from h4 and h6 and h7 have sg6:"cycleLength (nC k) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from h3 and h6 and h7 and h8 have sg7:"disjoint (schedule (nC k)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from sg7 and h5 have sg8:"\<not> (t mod (cycleLength (nC k))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg6 and sg8 have sg9:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from sg9 and a3 have sg10:"activation2 t = []" by (simp add: Scheduler_L2)
  from sg10 and sg4 have sg11:"nStore j t = recv t" by simp
  from h0 have sg15:
   "if \<exists>k<n. nSend k t \<noteq> []
    then recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t
    else recv t = []"
    by (simp add: Broadcast_def)
  show ?thesis
  proof (cases "nReturn k t = []")
    assume a5: "nReturn k t = []"
    from h2 and h3 and h4 and h5 and h6 and a5 have sg16:"\<not> (\<exists>k<n. nSend k t \<noteq> [])"
      by (simp add: fr_Send8)
    from sg16 and sg15 have sg17:"recv t = []" by simp
    from sg11 and sg17 have sg18:"nStore j t = []" by simp
    from this and a5 show ?thesis by simp
  next
    assume a6:"nReturn k t \<noteq> []"
    from h2 and h3 and h4 and h5 and h6 and a6 have sg19:"\<exists>k<n. nSend k t \<noteq> []"
      by (simp add: fr_Send6)
    from h2 and h3 and h4 and h5 and h6 and a6 have sg20:"nSend k t \<noteq> []"
      by (simp add: fr_Send3)
    from h1 and sg20 and h6 have sg21:"(SOME k. k < n \<and> nSend k t \<noteq> []) = k"
      by (simp add: inf_disj_index)
    from sg15 and sg19 have sg22:"recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t"
      by simp
    from sg22 and sg21 have sg23:"recv t = nSend k t" by simp
    from h2 and h3 and h4 and h5 and h6 have sg24:"nSend k t =  nReturn k t"
      by (simp add: fr_Send2)
    from sg11 and sg23 and sg24 show ?thesis by simp
  qed
qed

lemma fr_nStore_nReturn2:
 assumes h1:"Cable n nSend recv"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h6:"k < n"
     and h7:"j < n"
     and h8:"j \<noteq> k"
 shows  "nStore j t = nReturn k t"
proof -
  from h1 have sg1:"inf_disj n nSend \<longrightarrow> Broadcast n nSend recv"
    by (simp add: Cable_def)
  from  h3 and h4 and h2 have sg2:"inf_disj n nSend"
    by (simp add: disjointFrame_L2)
  from sg1 and sg2 have sg3:"Broadcast n nSend recv" by simp
  from sg3 and sg2 and assms show ?thesis  by (simp add: fr_nStore_nReturn1)
qed

lemma fr_nStore_empty1:
 assumes h1:"Cable n nSend recv"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"(t mod cycleLength (nC k) mem schedule (nC k))"
     and h6:"k < n"
 shows  "nStore k t = []"
proof -
  from h2 and h6 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
   from sg1 obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from a2 have sg2:"Receive recv (nStore k) activation1"
     by (simp add: BusInterface_def)
  from this have sg3:
   "if activation1 t = [] then nStore k t = recv t else nStore k t = []"
    by (simp add: Receive_def)
  from a1 and h5 have sg4:"activation1 t \<noteq> []"
     by (simp add: Scheduler_L3)
 from sg3 and sg4 show ?thesis by simp
qed

lemma fr_nStore_nReturn3:
 assumes "Cable n nSend recv"
     and "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
 shows  "\<forall>j. j < n \<and> j \<noteq> k \<longrightarrow> nStore j t = nReturn k t"
using assms
by (clarify, simp add: fr_nStore_nReturn2)

lemma length_nStore:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"inf_disj n nSend"
     and h5:"i < n"
     and h6:"\<forall> i<n. msg (Suc 0) (nReturn i)"
     and h7:"Broadcast n nSend recv"
 shows "length (nStore i t) \<le> Suc 0"
proof -
  from h7 have sg1:
   "if \<exists>k<n. nSend k t \<noteq> []
    then recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t
    else recv t = []"
   by (simp add: Broadcast_def)
  show ?thesis
  proof (cases "\<exists>k<n. nSend k t \<noteq> []")
    assume "\<exists>k<n. nSend k t \<noteq> []"
    from this obtain k where a2:"k<n" and a3:"nSend k t \<noteq> []"  by auto
    from h1 and a2 have
      "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
      by auto
    then obtain activation1 where
      a4:"Scheduler (nC k) activation1" and
      a5:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
      by (simp add: FlexRayController_def, auto)
    from a5 have sg5:"Send (nReturn k) (nSend k) (nGet k) activation1"
      by (simp add:  BusInterface_def)
    from a5 have sg6:"Receive recv (nStore k) activation1"
      by (simp add: BusInterface_def)
    from sg5 and a3 have sg7:"(activation1 t) \<noteq> []" by (simp add: Send_L1)
    from sg6 have sg8:
     "if activation1 t = []
      then nStore k t = recv t else nStore k t = []"
      by (simp add: Receive_def)
    from sg8 and sg7 have sg9:"nStore k t = []" by simp
    from a4 and sg7 have sg10:"(t mod (cycleLength (nC k))) mem (schedule (nC k))"
      by (simp add: Scheduler_L1)
    show ?thesis
    proof (cases "i = k")
      assume  "i = k"
      from sg9 and this show ?thesis by simp
    next
      assume "i \<noteq> k"
      from h7 and h4 and h1 and h2 and h3 and sg10 and a2 and h5 and this have sg11:
       "nStore i t = nReturn k t"
        by (simp add: fr_nStore_nReturn1)
      from h6 and a2 have sg12:"msg (Suc 0) (nReturn k)" by auto
      from a2 and h6 have sg13:"length (nReturn k t) \<le> Suc 0"
        by (simp add: msg_def)
      from sg11 and sg13  show ?thesis by simp
    qed
  next
    assume "\<not> (\<exists>k<n. nSend k t \<noteq> [])"
    from h7 and this have sg14:"recv t = []" by (simp add: Broadcast_nSend_empty1)
    from h1 and h5 have
      "FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
      by auto
   then obtain activation2 where
      a11:"Scheduler (nC i) activation2" and
      a12:"BusInterface activation2 (nReturn i) recv (nStore i) (nSend i) (nGet i)"
      by (simp add: FlexRayController_def, auto)
    from a12 have "Receive recv (nStore i) activation2"
      by (simp add: BusInterface_def)
    then have sg17:
     "if activation2 t = []
      then nStore i t = recv t else nStore i t = []"
      by (simp add: Receive_def)
    show ?thesis
    proof (cases "activation2 t = []")
      assume aa3:"activation2 t = []"
      from sg17 and aa3 and sg14 have "nStore i t = []" by simp
      then show ?thesis by simp
    next
      assume aa4:"activation2 t \<noteq> []"
      from sg17 and aa4 have "nStore i t = []" by simp
      then show ?thesis by simp
    qed
  qed
qed

lemma msg_nStore:
assumes " \<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "inf_disj n nSend"
       and "i < n"
       and "\<forall> i<n. msg (Suc 0) (nReturn i)"
       and "Cable n nSend recv"
shows "msg (Suc 0) (nStore i)"
using assms
  apply (simp (no_asm) add: msg_def, simp add: Cable_def, clarify)
  by (simp add: length_nStore)

subsection \<open>Refinement Properties\<close>

lemma fr_refinement_FrameTransmission:
assumes "Cable n nSend recv"
       and "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
shows "FrameTransmission n nStore nReturn nGet nC"
using assms
  apply (simp add: FrameTransmission_def Let_def, auto)
  apply (simp add: fr_nGet1)
  by (simp add: fr_nStore_nReturn3)

lemma FlexRayArch_CorrectSheaf:
 assumes "FlexRayArch n nReturn nC nStore nGet"
 shows    "CorrectSheaf n"
using assms by (simp add: FlexRayArch_def)

lemma FlexRayArch_FrameTransmission:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
 shows      "FrameTransmission n nStore nReturn nGet nC"
proof -
  from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from a1 and a2 and h3 and h4 show ?thesis
    by (rule fr_refinement_FrameTransmission)
qed

lemma FlexRayArch_nGet:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"i < n"
 shows      "msg (Suc 0) (nGet i)"
proof -
 from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from a2 and h5 show ?thesis by (rule msg_nGet2)
qed

lemma FlexRayArch_nStore:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"i < n"
 shows      "msg (Suc 0) (nStore i)"
proof -
 from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from h3 and h4 and a2 have sg1:"inf_disj n nSend" by (simp add: disjointFrame_L2)
  from a2 and h3 and h4 and sg1 and h5 and h2 and a1  show ?thesis
    by (rule msg_nStore)
qed

theorem main_fr_refinement:
 assumes "FlexRayArch n nReturn nC nStore nGet"
 shows     "FlexRay n nReturn nC nStore nGet"
using assms
  by (simp add: FlexRay_def
                FlexRayArch_CorrectSheaf
                FlexRayArch_FrameTransmission
                FlexRayArch_nGet
                FlexRayArch_nStore)

end


theory weird_nat_mul3acc_assoc3
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!!
     (x1 :: Nat) (x2 :: Nat) (x3acc :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (mul3acc x1 (mul3acc x2 x3acc x4) x5) =
       (mul3acc x1 x2 (mul3acc x3acc x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end