section \<open>Infrastructures for School Attendance\<close>
text \<open>This theory provides the adaptation of the IIIf for School attendance.\<close>
subsection \<open>Actors, actions, and data labels\<close>
theory SchoolAttendanceInfrastructure
  imports Refinement
begin
datatype action = delete | move | eval | put

typedecl actor
type_synonym identity = string
consts Actor :: "string \<Rightarrow> actor"
type_synonym policy = "((actor \<Rightarrow> bool) * action set)"

definition ID :: "[actor, string] \<Rightarrow> bool"
  where "ID a s \<equiv> (a = Actor s)"

subsection \<open>Infrastructure graphs and policies\<close>
text\<open>Actors are contained in an infrastructure graph. An @{text \<open>igraph\<close>} contains
a set of location pairs representing the topology of the infrastructure
as a graph of nodes and a list of actor identities associated to each node
(location) in the graph. \<close>
datatype location = Location nat

text \<open>The Decentralised Label Model (DLM) \cite{ml:98} introduced the idea to
label data by owners and readers. We pick up this idea and formalize
a new type to encode the owner and the set of readers as a pair.
The first element is the owner of a data item, the second one is the
set of all actors that may access the data item.
This enables the unique security
labelling of data within the system additionally taking the ownership into
account.\<close>
type_synonym dob = nat
datatype gender = male | female | null
datatype ethnicity = black |  white | asian
(* special educational needs, free school meal, education and  health care and child in social care,
   ... *)
datatype disadvantaged = sen | fsm | ehc | csc
datatype year = primary | secondary
(* nursery | reception | year1 | year2 | year3 | year4
  | year5 |year6 | year7 | year8 | year9 | year10 | year11 | year12 *)
datatype season = winter | spring | summer | autumn
datatype transport = good | bad
type_synonym data = \<open>location \<times> disadvantaged set \<times> gender \<times> year \<times> season \<times> transport \<times> ethnicity \<close>
type_synonym dlm = \<open>actor \<times> actor set\<close>
type_synonym absence = nat

datatype igraph = Lgraph
                    (gra: \<open>(location \<times> location)set\<close>)
                    (agra: \<open>location \<Rightarrow> identity set\<close>)
                    (dgra: \<open> identity \<Rightarrow> dlm \<times> data\<close>)
                    (bb: \<open> data \<Rightarrow> bool\<close>)
                    (attendance: \<open>identity \<Rightarrow> bool\<close>)

datatype infrastructure =
         Infrastructure (graphI: \<open>igraph\<close>)
                        (delta: \<open>[igraph, location] \<Rightarrow> policy set\<close>)

thm igraph.sel

lemma agra_simps: \<open>agra (Lgraph g a d b e) = a\<close>
 by (rule SchoolAttendanceInfrastructure.igraph.sel(2))

definition nodes :: \<open>igraph \<Rightarrow> location set\<close>
where \<open>nodes g == { x. (\<exists> y. ((x,y): gra g) | ((y,x): gra g))}\<close>

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

lemma graphI_simps[simp]: \<open>graphI (Infrastructure g d) = g\<close>
  by (rule infrastructure.sel(1))

lemma delta_simps[simp]: \<open>delta (Infrastructure g d) = d\<close>
  by (rule infrastructure.sel(2))
text \<open>Predicates and projections for the labels to encode their meaning.\<close>
definition owner :: "dlm * data \<Rightarrow> actor" where "owner d \<equiv> fst(fst d)"
definition owns :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"
definition readers :: "dlm * data \<Rightarrow> actor set"
  where "readers d \<equiv> snd (fst d)"

text \<open>The predicate @{text \<open>has_access\<close>} is true for owners or readers.\<close>
definition has_access :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

text \<open>We define a type of functions that preserves the security labeling and a
   corresponding function application  operator.\<close>
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
  by (fastforce)

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" (infixr "\<Updown>" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

text \<open>The predicate atI -- mixfix syntax @{text \<open>@\<^bsub>G\<^esub>\<close>} -- expresses that an actor (identity)
      is at a certain location in an igraph.\<close>
definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

text \<open>Policies specify the expected behaviour of actors of an infrastructure.
They are defined by the @{text \<open>enables\<close>} predicate:
an actor @{text \<open>h\<close>} is enabled to perform an action @{text \<open>a\<close>}
in infrastructure @{text \<open>I\<close>}, at location @{text \<open>l\<close>}
if there exists a pair @{text \<open>(p,e)\<close>} in the local policy of @{text \<open>l\<close>}
(@{text \<open>delta I l\<close>} projects to the local policy) such that the action
@{text \<open>a\<close>} is a member of the action set @{text \<open>e\<close>} and the policy
predicate @{text \<open>p\<close>} holds for actor @{text \<open>h\<close>}.\<close>
definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

text \<open>The behaviour is the good behaviour, i.e. everything allowed by the policy of infrastructure I.\<close>
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

text \<open>The misbehaviour is the complement of the behaviour of an infrastructure I.\<close>
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "misbehaviour I \<equiv> -(behaviour I)"

subsection "State transition on infrastructures"
text \<open>The state transition defines how actors may act on infrastructures through actions
    within the boundaries of the policy. It is given as an inductive definition over the
    states which are infrastructures.  This state transition relation is dependent on actions but also on
    enabledness and the current state of the infrastructure.\<close>

text \<open>The @{text \<open>move_graph_a\<close>} function encapsulates the infrastructure state change for a
      move action used in the subsequent rule move. It relocates the actor from a location l
      to a new location l' if the actor is actually at l and is not at l'. Additionally,
      here for the CreditScoring application, the new location l' needs to be updated in the
      actors data by adapting the dgra component of the infrastructure state graph.\<close>
definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' G \<equiv> Lgraph (gra G)
                                 (if n \<in> ((agra G) l) &  n \<notin> ((agra G) l') then
                                      ((agra G)(l := (agra G l) - {n}))(l' := (insert n (agra G l')))
                                      else (agra G))
                               ((dgra G)(n := (fst (dgra G n),(l',snd(snd(dgra G n))))))
                    (bb G)(attendance G)"

definition put_graph_a
  where "put_graph_a a d G \<equiv> (Lgraph (gra G)(agra G)
                ((dgra G)(a := (fst(dgra G a),
                          (fst (snd (dgra G a)),
                             insert d (fst(snd(snd(dgra G a)))), snd(snd(snd (dgra G a)))))))
                                      (bb G)(attendance G))"

definition delete_graph_a
  where "delete_graph_a a d G \<equiv> (Lgraph (gra G)(agra G)
                ((dgra G)(a := (fst(dgra G a),
                          (fst (snd (dgra G a)),
                             (fst(snd(snd(dgra G a)))) - {d}, snd(snd(snd (dgra G a)))))))
                                      (bb G)(attendance G))"

definition eval_graph_a
  where "eval_graph_a a G \<equiv> (Lgraph (gra G)(agra G)(dgra G)(bb G)
                          ((attendance G)(a := (bb G (snd (dgra G a))))))"

text \<open>The state transition relation defines the semantics for the actions. We concentrate
     only on two: move and get. Move models the moving of actors from one locations to another
     automatically posting the ephemeral ids at the new location (and stop posting them at the
     old location, i.e. deleting them there) -- this is implemented in @{text \<open>move_graph_a\<close>}
     above.
     For get, an actor a at a location can use get, if he's entitled to do that by the policy,
     to extend hos knowledge set. He adds all combinations of the actors a sees at the location
     with all ephemeral ids she measures, i.e. which are in the set @{text \<open>egra G l\<close>}. If a
     already has a nonempty knowledge set @{text \<open>kgra G (Actor a)\<close>} she can already improve
     her knowledge by building an intersection with the previous knowledge set.\<close>
inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
  where
move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          a \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' G)(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
          enables I l (Actor a) put \<Longrightarrow>
          I' = Infrastructure
                  (put_graph_a a d G)
                  (delta I) \<Longrightarrow>
          I \<rightarrow>\<^sub>n I'"
| delete : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
          d \<in> (fst(snd(snd(dgra G a)))) \<Longrightarrow>
          enables I l (Actor a) delete \<Longrightarrow>
          I' = Infrastructure
                  (delete_graph_a a d G)
                  (delta I) \<Longrightarrow>
          I \<rightarrow>\<^sub>n I'"
|   eval : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
           c \<in> actors_graph G \<Longrightarrow>
           Actor c \<in> readers (dgra G a) \<or> Actor c = owner (dgra G a) \<Longrightarrow>
           enables I l (Actor c) eval \<Longrightarrow>
          I' = Infrastructure
                  (eval_graph_a a G)
                  (delta I) \<Longrightarrow>
          I \<rightarrow>\<^sub>n I'"

text \<open>Note that the type infrastructure can now be instantiated to the axiomatic type class
      @{text\<open>state\<close>} which enables the use of the underlying Kripke structures and CTL.\<close>
instantiation "infrastructure" :: state
begin
definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

text \<open>PCR algorithm\<close>
text \<open>The definition of closest gives a unique predecessor s wrt @{text \<open>\<rightarrow>\<^sub>n*\<close>} for two points s' s''.\<close>
definition \<open>closest s s' s'' \<equiv> ((s \<rightarrow>\<^sub>n*  s') \<and> (s \<rightarrow>\<^sub>n* s'') \<and>
               (\<forall> s0. s0 \<rightarrow>\<^sub>n* s' \<and> s0 \<rightarrow>\<^sub>n* s'' \<longrightarrow> s0 \<rightarrow>\<^sub>n* s))\<close>

text \<open>Using the definition of closest we can define counterfactuals for a state s wrt a desirable property
      P as states s'' with common predecessor s' if these exist. \<close>
definition \<open>counterfactuals s P \<equiv> {s''. P s'' \<and> (\<exists> s'. (s' \<rightarrow>\<^sub>n* s'') \<and> closest s' s s'')}\<close>

(* standard invariants *)
lemma delta_invariant: "\<forall> z z'. (z \<rightarrow>\<^sub>n z') \<longrightarrow>  delta(z) = delta(z')"
  by (clarify, erule state_transition_in.cases, simp+)

lemma init_state_policy0:
  assumes "\<forall> z z'. (z \<rightarrow>\<^sub>n z') \<longrightarrow>  delta(z) = delta(z')"
      and "(x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
    shows "delta(x) = delta(y)"
  sorry

lemma init_state_policy: "\<lbrakk> (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  by (rule init_state_policy0, rule delta_invariant)

lemma same_nodes0[rule_format]: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow> nodes(graphI z) = nodes(graphI z')"
  oops

end


(*  Title:      Jinja/Compiler/Compiler1.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

header {* \isaheader{Compilation Stage 1} *}

theory Compiler1 imports PCompiler J1 Hidden begin

text{* Replacing variable names by indices. *}

primrec compE\<^sub>1  :: "vname list \<Rightarrow> expr \<Rightarrow> expr\<^sub>1"
  and compEs\<^sub>1 :: "vname list \<Rightarrow> expr list \<Rightarrow> expr\<^sub>1 list" where
  "compE\<^sub>1 Vs (new C) = new C"
| "compE\<^sub>1 Vs (Cast C e) = Cast C (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (Val v) = Val v"
| "compE\<^sub>1 Vs (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1) \<guillemotleft>bop\<guillemotright> (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (Var V) = Var(last_index Vs V)"
| "compE\<^sub>1 Vs (V:=e) = (last_index Vs V):= (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (e\<bullet>F{D}) = (compE\<^sub>1 Vs e)\<bullet>F{D}"
| "compE\<^sub>1 Vs (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1)\<bullet>F{D} := (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (e\<bullet>M(es)) = (compE\<^sub>1 Vs e)\<bullet>M(compEs\<^sub>1 Vs es)"
| "compE\<^sub>1 Vs {V:T; e} = {(size Vs):T; compE\<^sub>1 (Vs@[V]) e}"
| "compE\<^sub>1 Vs (e\<^sub>1;;e\<^sub>2) = (compE\<^sub>1 Vs e\<^sub>1);;(compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (if (e) e\<^sub>1 else e\<^sub>2) = if (compE\<^sub>1 Vs e) (compE\<^sub>1 Vs e\<^sub>1) else (compE\<^sub>1 Vs e\<^sub>2)"
| "compE\<^sub>1 Vs (while (e) c) = while (compE\<^sub>1 Vs e) (compE\<^sub>1 Vs c)"
| "compE\<^sub>1 Vs (throw e) = throw (compE\<^sub>1 Vs e)"
| "compE\<^sub>1 Vs (try e\<^sub>1 catch(C V) e\<^sub>2) =
    try(compE\<^sub>1 Vs e\<^sub>1) catch(C (size Vs)) (compE\<^sub>1 (Vs@[V]) e\<^sub>2)"

| "compEs\<^sub>1 Vs []     = []"
| "compEs\<^sub>1 Vs (e#es) = compE\<^sub>1 Vs e # compEs\<^sub>1 Vs es"

primrec fin\<^sub>1:: "expr \<Rightarrow> expr\<^sub>1" where
  "fin\<^sub>1(Val v) = Val v"
| "fin\<^sub>1(throw e) = throw(fin\<^sub>1 e)"

lemma comp_final: "final e \<Longrightarrow> compE\<^sub>1 Vs e = fin\<^sub>1 e"
(*<*)by(erule finalE, simp_all)(*>*)

lemma [simp]:
      "\<And>Vs. max_vars (compE\<^sub>1 Vs e) = max_vars e"
and "\<And>Vs. max_varss (compEs\<^sub>1 Vs es) = max_varss es"
(*<*)by (induct e and es rule: max_vars.induct max_varss.induct) simp_all(*>*)

text{* Compiling programs: *}

definition compP\<^sub>1 :: "J_prog \<Rightarrow> J\<^sub>1_prog"
where
  "compP\<^sub>1  \<equiv>  compP (\<lambda>(pns,body). compE\<^sub>1 (this#pns) body)"

(*<*)
declare compP\<^sub>1_def[simp]
(*>*)

end


(*
 * Copyright 2023, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ArchKernelInit_AI
imports
  ADT_AI
  Tcb_AI
  Arch_AI
begin

context Arch begin global_naming RISCV64

text \<open>
  Showing that there is a state that satisfies the abstract invariants.
\<close>

lemmas ptr_defs = idle_thread_ptr_def init_irq_node_ptr_def riscv_global_pt_ptr_def
lemmas state_defs = init_A_st_def init_kheap_def init_arch_state_def init_global_pt_def
                    init_vspace_uses_def ptr_defs

lemma is_tcb_TCB[simp]: "is_tcb (TCB t)" by (simp add: is_tcb_def)

lemma ran_empty_cnode[simp]: "ran (empty_cnode n) = {NullCap}"
  apply (rule equalityI; clarsimp simp: ran_def empty_cnode_def)
  apply (rule_tac x="replicate n False" in exI)
  apply simp
  done

lemma empty_cnode_apply[simp]:
  "(empty_cnode n xs = Some cap) = (length xs = n \<and> cap = NullCap)"
  by (auto simp add: empty_cnode_def)

lemma valid_cs_size_empty[simp]:
  "valid_cs_size n (empty_cnode n) = (n < word_bits - cte_level_bits)"
  using wf_empty_bits [of n] by (simp add: valid_cs_size_def)

lemma init_cdt [simp]:
  "cdt init_A_st = init_cdt"
  by (simp add: state_defs)

lemma mdp_parent_empty[simp]:
  "\<not>Map.empty \<Turnstile> x \<rightarrow> y"
  by (auto simp: cdt_parent_of_def dest: tranclD)

lemma descendants_empty[simp]:
  "descendants_of x Map.empty = {}"
  by (clarsimp simp: descendants_of_def)

lemma is_reply_cap_NullCap[simp]: "\<not>is_reply_cap NullCap"
  by (simp add: is_reply_cap_def)

declare cap_range_NullCap [simp]

lemma pptr_base_num:
  "pptr_base = 0xFFFFFFC000000000"
  by (simp add: pptr_base_def pptrBase_def canonical_bit_def)

(* IRQ nodes occupy 11 bits of address space in this RISCV example state:
   6 for irq number, 5 for cte_level_bits. *)
lemma init_irq_ptrs_ineqs:
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) + mask cte_level_bits
                \<le> init_irq_node_ptr + mask 11"
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits)
                \<le> init_irq_node_ptr + mask 11"
proof -
  have P: "ucast irq < (2 ^ (11 - cte_level_bits) :: machine_word)"
    apply (rule order_le_less_trans[OF
        ucast_le_ucast[where 'a=6 and 'b=64, simplified, THEN iffD2, OF word_n1_ge]])
    apply (simp add: cte_level_bits_def minus_one_norm)
    done
  show "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
    apply (rule is_aligned_no_wrap'[where sz=11])
     apply (simp add: is_aligned_def init_irq_node_ptr_def pptr_base_num)
    apply (rule shiftl_less_t2n[OF P])
    apply simp
    done
  show Q: "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) + mask cte_level_bits
                \<le> init_irq_node_ptr + mask 11"
    apply (simp only: add_diff_eq[symmetric] add.assoc)
    apply (rule word_add_le_mono2)
     apply (simp only: trans [OF shiftl_t2n mult.commute] mask_def mult_1)
     apply (rule nasty_split_lt[OF P])
      apply (auto simp: cte_level_bits_def init_irq_node_ptr_def mask_def pptr_base_num)
    done
  show "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits)
                \<le> init_irq_node_ptr + mask 11"
    apply (simp only: add_diff_eq[symmetric] mask_def mult_1 shiftl_t2n mult.commute)
    apply (rule word_add_le_mono2)
     apply (rule word_le_minus_one_leq)
     apply (rule shiftl_less_t2n[OF P, simplified shiftl_t2n mult.commute])
     apply simp
    apply (simp add: cte_level_bits_def init_irq_node_ptr_def pptr_base_num)
    done
qed

lemmas init_irq_ptrs_less_ineqs
   = init_irq_ptrs_ineqs(1)[THEN order_less_le_trans[rotated]]
     init_irq_ptrs_ineqs(2-3)[THEN order_le_less_trans]

lemmas init_irq_ptrs_all_ineqs[unfolded init_irq_node_ptr_def cte_level_bits_def]
   = init_irq_ptrs_ineqs(1)[THEN order_trans[rotated]]
     init_irq_ptrs_ineqs(2-3)[THEN order_trans]
     init_irq_ptrs_less_ineqs
     init_irq_ptrs_less_ineqs[THEN less_imp_neq]
     init_irq_ptrs_less_ineqs[THEN less_imp_neq, THEN not_sym]

lemma init_irq_ptrs_eq:
  "((ucast irq << cte_level_bits) = (ucast (irq' :: irq) << cte_level_bits :: machine_word))
   = (irq = irq')"
  by word_bitwise (clarsimp simp: cte_level_bits_def)

lemma pspace_aligned_init_A:
  "pspace_aligned init_A_st"
  apply (clarsimp simp: pspace_aligned_def state_defs wf_obj_bits [OF wf_empty_bits]
                        dom_if_Some cte_level_bits_def bit_simps pptr_base_num kernel_elf_base_def)
  apply (safe intro!: aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl],
           simp_all add: is_aligned_def word_bits_def)[1]
  done

lemma pspace_distinct_init_A: "pspace_distinct init_A_st"
  unfolding pspace_distinct_def
  apply (clarsimp simp: state_defs bit_simps empty_cnode_bits kernel_elf_base_def
                        cte_level_bits_def linorder_not_le cong: if_cong)
  apply (safe; simp add: pptr_base_num init_irq_ptrs_all_ineqs[simplified pptr_base_num mask_def, simplified])
  apply (cut_tac x="init_irq_node_ptr + (ucast irq << cte_level_bits)"
             and y="init_irq_node_ptr + (ucast irqa << cte_level_bits)"
             and sz=cte_level_bits in aligned_neq_into_no_overlap;
         simp add: init_irq_node_ptr_def pptr_base_num cte_level_bits_def)
    apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
    apply (simp add: is_aligned_def)
   apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
   apply (simp add: is_aligned_def)
  apply (simp add: linorder_not_le)
  done

lemma caps_of_state_init_A_st_Null:
  "caps_of_state (init_A_st::'z::state_ext state) x
     = (if cte_at x (init_A_st::'z::state_ext state) then Some NullCap else None)"
  apply (subgoal_tac "\<not> cte_wp_at ((\<noteq>) NullCap) x init_A_st")
   apply (auto simp add: cte_wp_at_caps_of_state)[1]
  apply (clarsimp, erule cte_wp_atE)
   apply (auto simp add: state_defs tcb_cap_cases_def split: if_split_asm)
  done

lemma cte_wp_at_init_A_st_Null:
  "cte_wp_at P p init_A_st \<Longrightarrow> P cap.NullCap"
  apply (subst(asm) cte_wp_at_caps_of_state)
  apply (simp add:caps_of_state_init_A_st_Null split: if_splits)
  done

lemmas cte_wp_at_caps_of_state_eq
    = cte_wp_at_caps_of_state[where P="(=) cap" for cap]

declare ptrFormPAddr_addFromPPtr[simp]

lemma pspace_respects_device_region_init[simp]:
  "pspace_respects_device_region init_A_st"
   apply (clarsimp simp: pspace_respects_device_region_def state_defs init_machine_state_def
                         device_mem_def in_device_frame_def obj_at_def a_type_def)
   apply (rule ext)
   apply clarsimp
   done

lemma cap_refs_respects_device_region_init[simp]:
  "cap_refs_respects_device_region init_A_st"
   apply (clarsimp simp: cap_refs_respects_device_region_def)
   apply (frule cte_wp_at_caps_of_state[THEN iffD1])
   apply clarsimp
   apply (subst(asm) caps_of_state_init_A_st_Null)
   apply (clarsimp simp: cte_wp_at_caps_of_state cap_range_respects_device_region_def)
   done

lemma kernel_mapping_slot: "0x1FF \<in> kernel_mapping_slots"
  by (clarsimp simp: kernel_mapping_slots_def pptr_base_def pptrBase_def canonical_bit_def
                     pt_bits_left_def bit_simps level_defs)

lemma pool_for_asid_init_A_st[simp]:
  "pool_for_asid asid init_A_st = None"
  by (simp add: pool_for_asid_def state_defs)

lemma vspace_for_asid_init_A_st[simp]:
  "vspace_for_asid asid init_A_st = None"
  by (simp add: vspace_for_asid_def obind_def)

lemma global_pt_init_A_st[simp]:
  "global_pt init_A_st = riscv_global_pt_ptr"
  by (simp add: state_defs riscv_global_pt_def)

lemma is_aligned_riscv_global_pt_ptr[simp]:
  "is_aligned riscv_global_pt_ptr pt_bits"
  by (simp add: riscv_global_pt_ptr_def pptr_base_num bit_simps is_aligned_def)

lemma ptes_of_init_A_st_global:
  "ptes_of init_A_st =
   (\<lambda>p. if table_base p = riscv_global_pt_ptr \<and> is_aligned p pte_bits then
        Some ((un_PageTable (the_arch_obj init_global_pt)) (table_index p)) else None)"
  by (auto simp add: state_defs pte_of_def obind_def opt_map_def split: option.splits)

lemma pt_walk_init_A_st[simp]:
  "pt_walk max_pt_level level riscv_global_pt_ptr vref (ptes_of init_A_st) =
   Some (max_pt_level, riscv_global_pt_ptr)"
  apply (subst pt_walk.simps)
  apply (simp add: in_omonad ptes_of_init_A_st_global init_global_pt_def
                   is_aligned_pt_slot_offset_pte global_pte_def)
  done

(* Since the bottom 30 bits don't matter for 1GB pages, kernelELFPAddrBase and physBase don't have
   any influence on the index in the page table, i.e. the virtual address kernel_elf_base is always
   within the same 1GB page. *)
lemma elf_index_value:
  "elf_index = 0x1FE"
proof -
  have mask_0: "\<And>n m x. n < m \<Longrightarrow> - (1 << m) && x && mask n = 0"
    by (metis and.commute and_zero_eq word_mask_and_neg_shift_eq_0 word_bw_assocs(1))
  have "pt_index max_pt_level kernel_elf_base = 0x1FE"
    unfolding pt_index_def pt_bits_left_def level_defs bit_simps kernel_elf_base_def
              kernelELFBase_def pptrTop_def
    apply (subst word_plus_and_or_coroll)
     apply (subst mask_0; simp)
    apply (simp add: word_and_mask_shift_eq_0 shiftr_over_or_dist)
    apply (simp add: mask_def)
    done
  then show ?thesis
    unfolding elf_index_def
    by (simp add: bit_simps ucast_ucast_mask)
qed

lemma table_index_riscv_global_pt_ptr:
  "table_index (pt_slot_offset max_pt_level riscv_global_pt_ptr vref) =
  ucast ((vref >> toplevel_bits) && mask ptTranslationBits)"
  apply (simp add: pt_slot_offset_def pt_index_def pt_bits_left_def bit_simps level_defs
                   riscv_global_pt_ptr_def pptr_base_def pptrBase_def canonical_bit_def
                   toplevel_bits_def)
  apply (subst word_plus_and_or_coroll)
   apply word_bitwise
   apply simp
  apply word_bitwise
  apply (clarsimp simp: word_size)
  done

schematic_goal toplevel_bits_value:
  "toplevel_bits = ?v"
  by (simp add: toplevel_bits_def level_defs bit_simps pt_bits_left_def)

lemma kernel_window_bits_table_index:
  "\<lbrakk> pptr_base \<le> vref; vref < pptr_base + (1 << kernel_window_bits) \<rbrakk> \<Longrightarrow>
    table_index (pt_slot_offset max_pt_level riscv_global_pt_ptr vref) = 0x100"
  apply (simp add: table_index_riscv_global_pt_ptr toplevel_bits_value kernel_window_bits_def)
  apply (simp add: bit_simps pptr_base_def pptrBase_def neg_mask_le_high_bits word_size flip: NOT_mask)
  apply (subst (asm) mask_def)
  apply (simp add: canonical_bit_def)
  apply word_bitwise
  apply (clarsimp simp: word_size)
  done

lemma kernel_mapping_slots_0x100[simp]:
  "0x100 \<in> kernel_mapping_slots"
  by (simp add: kernel_mapping_slots_def pptr_base_def bit_simps pt_bits_left_def level_defs
                pptrBase_def canonical_bit_def)

lemma translate_address_kernel_window:
  "\<lbrakk> pptr_base \<le> vref; vref < pptr_base + (1 << kernel_window_bits) \<rbrakk>\<Longrightarrow>
   translate_address riscv_global_pt_ptr vref (ptes_of init_A_st) = Some (addrFromPPtr vref)"
  apply (clarsimp simp: translate_address_def in_omonad pt_lookup_target_def
                        pt_lookup_slot_from_level_def)
  apply (simp add: ptes_of_init_A_st_global[THEN fun_cong] init_global_pt_def global_pte_def pte_ref_def)
  apply (simp add: kernel_window_bits_table_index is_aligned_pt_slot_offset_pte)
  apply (simp add: bit_simps addr_from_ppn_def shiftl_shiftl)
  apply (simp add: ptrFromPAddr_def addrFromPPtr_def)
  apply (simp add: pptrBaseOffset_def paddrBase_def)
  apply (simp add: pt_bits_left_def bit_simps level_defs elf_index_value toplevel_bits_def)
  apply (rule conjI)
   apply (rule is_aligned_add)
    apply (simp add: mask_def)
   apply (simp add: pptrBase_def canonical_bit_def is_aligned_def)
  apply (simp add: pptr_base_def kernel_window_bits_def)
  apply (simp add: pptrBase_def neg_mask_le_high_bits flip: NOT_mask)
  apply (subst word_plus_and_or_coroll; simp add: canonical_bit_def word_size mask_def)
  apply word_bitwise
  apply clarsimp
  done

lemma kernelELF_plus_page:
  "((kernelELFPAddrBase && mask toplevel_bits) + 2^pageBits) \<le> 2^toplevel_bits"
  by (fastforce intro: aligned_mask_plus_bounded is_page_aligned_kernelELFPAddrBase
                simp: toplevel_bits_value bit_simps)

lemma elf_window_4k:
  "\<lbrakk> kernel_elf_base \<le> vref; vref < kernel_elf_base + (1 << pageBits) \<rbrakk> \<Longrightarrow>
    table_index (pt_slot_offset max_pt_level riscv_global_pt_ptr vref) = elf_index"
  using is_page_aligned_kernelELFPAddrBase
  apply (simp add: table_index_riscv_global_pt_ptr elf_index_value toplevel_bits_value
                   kernel_elf_base_def kernelELFBase_def)
  apply (simp add: bit_simps add_ac)
  apply (drule order_less_le_trans)
   apply (rule word_plus_mono_right)
    apply (rule kernelELF_plus_page[unfolded bit_simps toplevel_bits_value, simplified])
   apply (simp add: pptrTop_def)
  apply (simp add: bit_simps pptrTop_def mask_def is_aligned_nth)
  apply word_bitwise
  apply clarsimp
  done

lemma leq_elf_index:
  "0x100 \<le> elf_index"
  by (simp add: elf_index_value)

lemma kernel_mapping_slots_elf_index[simp]:
  "elf_index \<in> kernel_mapping_slots"
  by (simp add: kernel_mapping_slots_def pptr_base_def bit_simps pt_bits_left_def level_defs
                pptrBase_def canonical_bit_def leq_elf_index)

lemma rewrite_eq_minus_to_plus_eq:
  "(x = a - b) = (b + x = a)" for x :: "'a::ring"
  by auto

lemma merge_kernelELFPAddrBase_masks:
  "((kernelELFPAddrBase && ~~ mask 30) +
    (pptrTop + (kernelELFPAddrBase && mask 30) - kernelELFPAddrBase))
   = pptrTop"
  by (simp add: mask_out_sub_mask)

lemma is_aligned_ptrFromPAddr_kernelELFPAddrBase:
  "is_aligned
     (ptrFromPAddr
       (addr_from_ppn (ucast (kernelELFPAddrBase && ~~ mask toplevel_bits >> pageBits))))
     (pt_bits_left max_pt_level)"
  apply (simp add: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def elf_index_value)
  apply (simp add: pt_bits_left_def bit_simps level_defs ucast_ucast_mask toplevel_bits_value)
  apply (simp add: pptrBase_def pptrBaseOffset_def paddrBase_def canonical_bit_def)
  apply (rule is_aligned_add)
   apply (metis and_not_mask is_aligned_andI1 is_aligned_shiftl_self shiftr_and_eq_shiftl)
  apply (simp add: is_aligned_def)
  done

lemma kernelELFPAddrBase_addrFromKPPtr:
  "\<lbrakk> kernel_elf_base \<le> vref; vref < kernel_elf_base + (1 << pageBits) \<rbrakk>
   \<Longrightarrow> addr_from_ppn (ucast (kernelELFPAddrBase && ~~ mask toplevel_bits >> pageBits)) +
       (vref && mask (pt_bits_left max_pt_level))
       = addrFromKPPtr vref"
  apply (simp add: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def elf_index_value)
  apply (simp add: pt_bits_left_def bit_simps level_defs ucast_ucast_mask toplevel_bits_value)
  apply (simp add: addrFromKPPtr_def mask_shiftl_decompose flip: word_and_mask_shiftl)
  apply (simp add: ac_simps neg_mask_combine)
  apply (simp add: kernel_elf_base_def kernelELFBaseOffset_def)
  apply (simp only: kernelELFBase_def)
  apply (subst rewrite_eq_minus_to_plus_eq)
  apply (simp add: add_ac merge_kernelELFPAddrBase_masks)
  apply (subst word_plus_and_or_coroll)
   apply (simp add: pptrTop_def mask_def)
   apply word_bitwise
  apply (subst (asm) word_plus_and_or_coroll)
   apply (simp add: pptrTop_def mask_def)
   apply word_bitwise
  apply (drule order_less_le_trans)
   apply (rule word_plus_mono_right)
    apply (rule kernelELF_plus_page[unfolded bit_simps toplevel_bits_value, simplified])
   apply (simp add: pptrTop_def)
  apply (simp add: pptrTop_def mask_def)
  apply word_bitwise
  apply clarsimp
  done

lemma translate_address_kernel_elf_window:
  "\<lbrakk> kernel_elf_base \<le> vref; vref < kernel_elf_base + (1 << pageBits) \<rbrakk> \<Longrightarrow>
   translate_address riscv_global_pt_ptr vref (ptes_of init_A_st) = Some (addrFromKPPtr vref)"
  apply (clarsimp simp: translate_address_def in_omonad pt_lookup_target_def
                        pt_lookup_slot_from_level_def)
  apply (simp add: ptes_of_init_A_st_global[THEN fun_cong] init_global_pt_def global_pte_def pte_ref_def)
  apply (simp add: elf_window_4k is_aligned_pt_slot_offset_pte elf_index_value)
  apply (clarsimp simp: is_aligned_ptrFromPAddr_kernelELFPAddrBase kernelELFPAddrBase_addrFromKPPtr)
  done

lemma kernel_window_init_st:
  "kernel_window init_A_st = { pptr_base ..< pptr_base + (1 << kernel_window_bits) }"
  by (auto simp: state_defs kernel_window_def toplevel_bits_def bit_simps)

lemma abs_kernel_window_sufficient:
  "pptr_base + (1 << kernel_window_bits) \<le> kernel_elf_base"
  unfolding pptr_base_def kernel_elf_base_def
  using kernel_window_sufficient
  by simp

lemma abs_kernel_elf_window_at_least_page:
  "kernel_elf_base + 2 ^ pageBits \<le> kdev_base"
  unfolding kernel_elf_base_def kdev_base_def
  using kernel_elf_window_at_least_page
  by simp

lemma kernel_elf_base_no_overflow:
  "kernel_elf_base < kernel_elf_base + 2 ^ pageBits"
  unfolding kernel_elf_base_def
  by (rule kernelELFBase_no_overflow)

lemma kernel_elf_window_init_st:
  "kernel_elf_window init_A_st = { kernel_elf_base ..< kernel_elf_base + (1 << pageBits) }"
  using abs_kernel_window_sufficient
  by (force simp: state_defs kernel_elf_window_def)

lemma valid_global_vspace_mappings_init_A_st[simp]:
  "valid_global_vspace_mappings init_A_st"
  unfolding valid_global_vspace_mappings_def
  by (simp add: translate_address_kernel_window kernel_window_init_st
                translate_address_kernel_elf_window kernel_elf_window_init_st)

lemma valid_uses_init_A_st[simp]: "valid_uses_2 init_vspace_uses"
proof -
  note canonical_bit_def[simp]
  have [simplified, simp]: "pptr_base < pptr_base + (1 << kernel_window_bits)"
    by (simp add: pptr_base_def pptrBase_def kernel_window_bits_def)
  have [simp]: "p \<le> canonical_user \<Longrightarrow> \<not> pptr_base \<le> p" for p
    by (rule notI, drule (1) order_trans)
       (simp add: canonical_user_def mask_def pptr_base_def pptrBase_def)
  have [simp]: "p \<le> canonical_user \<Longrightarrow> \<not> kernel_elf_base \<le> p" for p
    using canonical_user_kernel_elf_base by simp
  have [simp]: "p \<le> canonical_user \<Longrightarrow> \<not> kdev_base \<le> p" for p
    by (rule notI, drule (1) order_trans)
       (simp add: canonical_user_def mask_def kdev_base_def kdevBase_def)
  have [simplified, simp]: "kernel_elf_base \<le> p \<Longrightarrow> \<not> p < pptr_base + (1 << kernel_window_bits)" for p
    using abs_kernel_window_sufficient by simp
  have [simp]: "kdev_base \<le> p \<Longrightarrow> \<not> p < kernel_elf_base + 2 ^ pageBits" for p
    using abs_kernel_elf_window_at_least_page by simp
  have "pptr_base + (1 << kernel_window_bits) < kernel_elf_base + 2 ^ pageBits"
    using abs_kernel_window_sufficient kernel_elf_base_no_overflow by simp
  thus ?thesis
    using canonical_user_pptr_base pptr_base_kernel_elf_base
    unfolding valid_uses_2_def init_vspace_uses_def window_defs
    by (auto simp: canonical_user_canonical above_pptr_base_canonical)
qed

lemma valid_global_arch_objs_init_A_st[simp]:
  "valid_global_arch_objs init_A_st"
  by (simp add: valid_global_arch_objs_def state_defs level_defs obj_at_def)

lemma valid_global_tables_init_A_st[simp]:
  "valid_global_tables init_A_st"
  apply (simp add: valid_global_tables_def Let_def riscv_global_pt_def[symmetric])
  apply (clarsimp simp: state_defs pte_rights_of_def vm_kernel_only_def global_pte_def)
  done

lemma vspace_for_pool_init_A_st[simp]:
  "vspace_for_pool ap asid (asid_pools_of init_A_st) = None"
  by (clarsimp simp: vspace_for_pool_def obind_def in_opt_map_eq state_defs split: option.splits)

lemma user_region_vs_lookup_target_init_A_st[simp]:
  "vref \<in> user_region \<Longrightarrow> vs_lookup_target bot_level asid vref init_A_st = None"
  by (clarsimp simp: vs_lookup_target_def obind_def vs_lookup_slot_def vs_lookup_table_def
               split: option.splits)

lemma valid_vs_lookup_init_A_st[simp]:
  "valid_vs_lookup init_A_st"
  by (clarsimp simp: valid_vs_lookup_def)

lemma valid_vspace_objs_init_A_st[simp]:
  "valid_vspace_objs init_A_st"
  by (clarsimp simp: valid_vspace_objs_def in_omonad vs_lookup_table_def)

lemma global_pt_kernel_window_init_arch_state[simp]:
  "obj_addrs init_global_pt riscv_global_pt_ptr \<subseteq>
     kernel_window_2 (riscv_kernel_vspace init_arch_state)"
  apply (clarsimp simp: state_defs pptr_base_num bit_simps kernel_window_def kernel_elf_base_def
                        kernel_window_bits_def)
  apply (rule conjI; unat_arith)
  done

lemma idle_thread_in_kernel_window_init_arch_state[simp]:
  "{idle_thread_ptr..0x3FF + idle_thread_ptr} \<subseteq>
     kernel_window_2 (riscv_kernel_vspace init_arch_state)"
  apply (clarsimp simp: state_defs pptr_base_num bit_simps kernel_window_def kernel_elf_base_def
                        kernel_window_bits_def)
  apply (rule conjI; unat_arith)
  done

lemma pptr_base_kernel_window_no_overflow:
  "pptr_base \<le> pptr_base + (1 << kernel_window_bits)"
  by (simp add: pptr_base_def pptrBase_def canonical_bit_def kernel_window_bits_def)

lemma irq_node_pptr_base_kernel_elf_base:
  fixes irq::irq
  assumes "x \<le> pptr_base + (m + (mask cte_level_bits + 0x3000))"
  assumes "m \<le> mask (size irq) << cte_level_bits"
  shows "\<not> kernel_elf_base \<le> x"
proof -
  have less:
    "\<And>m x. \<lbrakk> m \<le> x; x < 1 << kernel_window_bits \<rbrakk> \<Longrightarrow> pptr_base + m < kernel_elf_base"
    using order_le_less_trans word_plus_strict_mono_right pptr_base_kernel_elf_base
          pptr_base_kernel_window_no_overflow abs_kernel_window_sufficient
    by fastforce
  from assms show ?thesis
    apply (simp add: not_le)
    apply (erule order_le_less_trans)
    apply (rule less[where x="mask cte_level_bits + 0x3000 + mask (size irq) << cte_level_bits"];
           simp add: word_size cte_level_bits_def mask_def kernel_window_bits_def)
    apply unat_arith
    done
qed

lemma irq_node_in_kernel_window_init_arch_state':
  "\<lbrakk> init_irq_node_ptr + m \<le> x; x \<le> init_irq_node_ptr + m + mask cte_level_bits;
     m \<le> mask (size (irq::irq)) << cte_level_bits\<rbrakk>
   \<Longrightarrow> x \<in> kernel_window_2 (riscv_kernel_vspace init_arch_state)"
  apply (clarsimp simp: kernel_window_def init_vspace_uses_def init_arch_state_def)
  apply (rule conjI)
   apply (clarsimp simp: state_defs)
   apply (rule ccontr, simp add:not_le)
   apply (drule(1) le_less_trans)
   apply (cut_tac is_aligned_no_wrap'[where ptr=pptr_base
                                      and off="0x3000 + m"
                                      and sz=canonical_bit, simplified])
     apply (simp add: add_ac)
     apply (auto simp: pptr_base_kernel_elf_base irq_node_pptr_base_kernel_elf_base)[1]
    apply (simp add: pptr_base_num canonical_bit_def is_aligned_def)
   apply (simp add: pptr_base_num cte_level_bits_def canonical_bit_def mask_def word_size)
   apply unat_arith
  apply clarsimp
  apply (thin_tac "kernel_elf_base \<le> x \<longrightarrow> P" for x P)
  apply (simp add: cte_level_bits_def canonical_bit_def mask_def init_irq_node_ptr_def
                   pptr_base_num word_size kernel_window_bits_def)
  apply unat_arith
  apply clarsimp
  done

lemma irq_node_in_kernel_window_init_arch_state[simp]:
  "\<lbrakk> init_irq_node_ptr + (ucast (irq::irq) << cte_level_bits) \<le> x;
     x \<le> init_irq_node_ptr + (ucast irq << cte_level_bits) + 2 ^ cte_level_bits - 1 \<rbrakk>
   \<Longrightarrow> x \<in> kernel_window_2 (riscv_kernel_vspace init_arch_state)"
  apply (erule irq_node_in_kernel_window_init_arch_state')
   apply (simp add: mask_def add_diff_eq)
  apply (simp add: word_size mask_def cte_level_bits_def)
  apply (thin_tac P for P)
  apply word_bitwise
  done

lemma invs_A:
  "invs init_A_st" (is "invs ?st")
  supply is_aligned_def[THEN iffD2, simp]
  supply image_cong_simp [cong del]
  supply pptr_base_num[simp] kernel_elf_base_def[simp]
  apply (simp add: invs_def)
  apply (rule conjI)
   prefer 2
   apply (simp add: cur_tcb_def state_defs obj_at_def)
  apply (simp add: valid_state_def)
  apply (rule conjI)
   apply (simp add: valid_pspace_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_objs_def state_defs wellformed_pte_def global_pte_def
                          valid_obj_def valid_vm_rights_def vm_kernel_only_def
                          dom_if_Some cte_level_bits_def)
    apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def is_master_reply_cap_def
                          valid_cap_def obj_at_def valid_tcb_state_def valid_arch_tcb_def
                          cap_aligned_def word_bits_def valid_ipc_buffer_cap_simps)+
    apply (clarsimp simp: valid_cs_def word_bits_def cte_level_bits_def
                          init_irq_ptrs_all_ineqs valid_tcb_def
                   split: if_split_asm)
    apply auto[1]
   apply (simp add: pspace_aligned_init_A pspace_distinct_init_A)
   apply (rule conjI)
    apply (clarsimp simp: if_live_then_nonz_cap_def obj_at_def state_defs live_def hyp_live_def)
   apply (rule conjI)
    apply (clarsimp simp: zombies_final_def cte_wp_at_cases state_defs
                          tcb_cap_cases_def is_zombie_def)
   apply (clarsimp simp: sym_refs_def state_refs_of_def state_defs state_hyp_refs_of_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_mdb_def init_cdt_def no_mloop_def
                         mdb_cte_at_def)
   apply (clarsimp simp: untyped_mdb_def caps_of_state_init_A_st_Null
                         untyped_inc_def ut_revocable_def
                         irq_revocable_def reply_master_revocable_def
                         reply_mdb_def reply_caps_mdb_def
                         reply_masters_mdb_def valid_arch_mdb_def)
   apply (simp add:descendants_inc_def)
  apply (rule conjI)
   apply (simp add: valid_ioc_def init_A_st_def init_ioc_def cte_wp_at_cases2)
   apply (intro allI impI, elim exE conjE)
   apply (case_tac obj, simp_all add: cap_of_def)
   apply (clarsimp simp: init_kheap_def init_global_pt_def split: if_split_asm)
  apply (rule conjI)
   apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def state_defs valid_arch_idle_def)
  apply (rule conjI, clarsimp simp: only_idle_def pred_tcb_at_def obj_at_def state_defs)
  apply (rule conjI, clarsimp simp: if_unsafe_then_cap_def caps_of_state_init_A_st_Null)
  apply (subgoal_tac "valid_reply_caps ?st \<and> valid_reply_masters ?st \<and> valid_global_refs ?st")
   prefer 2
   subgoal
     using cte_wp_at_init_A_st_Null
     by (fastforce simp: valid_reply_caps_def unique_reply_caps_def
                         has_reply_cap_def is_reply_cap_to_def pred_tcb_at_def obj_at_def
                         caps_of_state_init_A_st_Null is_master_reply_cap_to_def
                         valid_reply_masters_def valid_global_refs_def
                         valid_refs_def[unfolded cte_wp_at_caps_of_state])
  apply (clarsimp, (thin_tac "_")+) (* use new proven assumptions, then drop them *)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_state_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_asid_table_def state_defs)
   apply (simp add: valid_arch_state_def state_defs obj_at_def a_type_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_node_def obj_at_def state_defs
                         is_cap_table_def wf_empty_bits
                         init_irq_ptrs_all_ineqs cte_level_bits_def
                         init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply (intro conjI)
    apply (rule inj_onI)
    apply (simp add: init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply (clarsimp; word_bitwise)
  apply (simp add: valid_irq_handlers_def caps_of_state_init_A_st_Null
                   ran_def cong: rev_conj_cong)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_states_def state_defs init_machine_state_def
                         valid_irq_masks_def init_irq_masks_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_machine_state_def state_defs
                         init_machine_state_def init_underlying_memory_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_caps_def valid_asid_pool_caps_def unique_table_caps_def
                         caps_of_state_init_A_st_Null valid_table_caps_def unique_table_refs_def)
   apply (clarsimp simp: state_defs)
  apply (clarsimp simp: valid_global_objs_def valid_kernel_mappings_def valid_asid_map_def)
  apply (rule conjI)
   apply (clarsimp simp: equal_kernel_mappings_def)
  apply (rule conjI)
   apply (clarsimp simp: pspace_in_kernel_window_def init_A_st_def init_kheap_def)
  apply (simp add: cap_refs_in_kernel_window_def caps_of_state_init_A_st_Null
                  valid_refs_def[unfolded cte_wp_at_caps_of_state])
  done

end

end


theory Post_Observation_Setup_RECEIVER
  imports "../Safety_Properties"
begin

subsection \<open>Confidentiality for a secret receiver node\<close>

text \<open>We verify that a group of users of a given node \<open>j\<close>
can learn nothing about the updates to the content of a post
\<open>PID\<close> located at a different node \<open>i\<close> beyond the
existence of an update unless \<open>PID\<close> is being shared between
the two nodes and one of the users is the admin at node \<open>j\<close> or becomes
a remote friend of \<open>PID\<close>'s owner, or \<open>PID\<close> is marked as public.
This is formulated as a BD Security
property and is proved by unwinding.

See \<^cite>\<open>"cosmedis-SandP2017"\<close> for more details.
\<close>

subsubsection\<open>Observation setup\<close>

(* *)
type_synonym obs = "act * out"

(* The observers are an arbitrary, but fixed set of users *)
locale Fixed_UIDs = fixes UIDs :: "userID set"
(* The secret is PID received from AID:  *)
locale Fixed_PID = fixes PID :: "postID"
locale Fixed_AID = fixes AID :: "apiID"

locale ObservationSetup_RECEIVER = Fixed_UIDs + Fixed_PID + Fixed_AID
begin

(*  *)
fun \<gamma> :: "(state,act,out) trans \<Rightarrow> bool" where
"\<gamma> (Trans _ a _ _) \<longleftrightarrow>
   (\<exists> uid. userOfA a = Some uid \<and> uid \<in> UIDs)
   \<or>
   (\<exists>ca. a = COMact ca)
   \<or>
   (\<exists>uid p. a = Sact (sSys uid p))"

(* Note: the passwords don't really have to be purged (since identity theft is not
considered in the first place); however, purging passwords looks more sane. *)

(* Purging the password in starting actions: *)
fun sPurge :: "sActt \<Rightarrow> sActt" where
"sPurge (sSys uid pwd) = sSys uid emptyPass"

(* Purging communicating actions: user-password information is removed, and post content for PID
  is removed from the only kind of action that may contain such info: comReceivePost.
  Note: server-password info is not purged --todo: discuss this.  *)
fun comPurge :: "comActt \<Rightarrow> comActt" where
 "comPurge (comSendServerReq uID p aID reqInfo) = comSendServerReq uID emptyPass aID reqInfo"
|"comPurge (comConnectClient uID p aID sp) = comConnectClient uID emptyPass aID sp"
(* *)
|"comPurge (comReceivePost aID sp pID pst uID vs) =
  (let pst' = (if aID = AID \<and> pID = PID then emptyPost else pst)
   in comReceivePost aID sp pID pst' uID vs)"
(* *)
|"comPurge (comSendPost uID p aID pID) = comSendPost uID emptyPass aID pID"
|"comPurge (comSendCreateOFriend uID p aID uID') = comSendCreateOFriend uID emptyPass aID uID'"
|"comPurge (comSendDeleteOFriend uID p aID uID') = comSendDeleteOFriend uID emptyPass aID uID'"
|"comPurge ca = ca"

(* Note: No output purge here -- only for the issuer. *)

fun g :: "(state,act,out)trans \<Rightarrow> obs" where
 "g (Trans _ (Sact sa) ou _) = (Sact (sPurge sa), ou)"
|"g (Trans _ (COMact ca) ou _) = (COMact (comPurge ca), ou)"
|"g (Trans _ a ou _) = (a,ou)"

lemma comPurge_simps:
  "comPurge ca = comSendServerReq uID p aID reqInfo \<longleftrightarrow> (\<exists>p'. ca = comSendServerReq uID p' aID reqInfo \<and> p = emptyPass)"
  "comPurge ca = comReceiveClientReq aID reqInfo \<longleftrightarrow> ca = comReceiveClientReq aID reqInfo"
  "comPurge ca = comConnectClient uID p aID sp \<longleftrightarrow> (\<exists>p'. ca = comConnectClient uID p' aID sp \<and> p = emptyPass)"
  "comPurge ca = comConnectServer aID sp \<longleftrightarrow> ca = comConnectServer aID sp"
  "comPurge ca = comReceivePost aID sp pID pst' uID v \<longleftrightarrow> (\<exists>pst. ca = comReceivePost aID sp pID pst uID v \<and> pst' = (if pID = PID \<and> aID = AID then emptyPost else pst))"
  "comPurge ca = comSendPost uID p aID pID \<longleftrightarrow> (\<exists>p'. ca = comSendPost uID p' aID pID \<and> p = emptyPass)"
  "comPurge ca = comSendCreateOFriend uID p aID uID' \<longleftrightarrow> (\<exists>p'. ca = comSendCreateOFriend uID p' aID uID' \<and> p = emptyPass)"
  "comPurge ca = comReceiveCreateOFriend aID cp uID uID' \<longleftrightarrow> ca = comReceiveCreateOFriend aID cp uID uID'"
  "comPurge ca = comSendDeleteOFriend uID p aID uID' \<longleftrightarrow> (\<exists>p'. ca = comSendDeleteOFriend uID p' aID uID' \<and> p = emptyPass)"
  "comPurge ca = comReceiveDeleteOFriend aID cp uID uID' \<longleftrightarrow> ca = comReceiveDeleteOFriend aID cp uID uID'"
by (cases ca; auto)+

lemma g_simps:
  "g (Trans s a ou s') = (COMact (comSendServerReq uID p aID reqInfo), ou')
\<longleftrightarrow> (\<exists>p'. a = COMact (comSendServerReq uID p' aID reqInfo) \<and> p = emptyPass \<and> ou = ou')"
  "g (Trans s a ou s') = (COMact (comReceiveClientReq aID reqInfo), ou')
\<longleftrightarrow> a = COMact (comReceiveClientReq aID reqInfo) \<and> ou = ou'"
  "g (Trans s a ou s') = (COMact (comConnectClient uID p aID sp), ou')
\<longleftrightarrow> (\<exists>p'. a = COMact (comConnectClient uID p' aID sp) \<and> p = emptyPass \<and> ou = ou')"
  "g (Trans s a ou s') = (COMact (comConnectServer aID sp), ou')
\<longleftrightarrow> a = COMact (comConnectServer aID sp) \<and> ou = ou'"
  "g (Trans s a ou s') = (COMact (comReceivePost aID sp pID pst' uID v), ou')
\<longleftrightarrow> (\<exists>pst. a = COMact (comReceivePost aID sp pID pst uID v) \<and> pst' = (if pID = PID \<and> aID = AID then emptyPost else pst) \<and> ou = ou')"
   "g (Trans s a ou s') = (COMact (comSendPost uID p aID nID), O_sendPost (aid, sp, pid, pst, own, v))
\<longleftrightarrow> (\<exists>p'. a = COMact (comSendPost uID p' aID nID) \<and> p = emptyPass \<and> ou = O_sendPost (aid, sp, pid, pst, own, v))"
  "g (Trans s a ou s') = (COMact (comSendCreateOFriend uID p aID uID'), ou')
\<longleftrightarrow> (\<exists>p'. a = (COMact (comSendCreateOFriend uID p' aID uID')) \<and> p = emptyPass \<and> ou = ou')"
  "g (Trans s a ou s') = (COMact (comReceiveCreateOFriend aID cp uID uID'), ou')
\<longleftrightarrow> a = COMact (comReceiveCreateOFriend aID cp uID uID') \<and> ou = ou'"
  "g (Trans s a ou s') = (COMact (comSendDeleteOFriend uID p aID uID'), ou')
\<longleftrightarrow> (\<exists>p'. a = COMact (comSendDeleteOFriend uID p' aID uID') \<and> p = emptyPass \<and> ou = ou')"
  "g (Trans s a ou s') = (COMact (comReceiveDeleteOFriend aID cp uID uID'), ou')
\<longleftrightarrow> a = COMact (comReceiveDeleteOFriend aID cp uID uID') \<and> ou = ou'"
by (cases a; auto simp: comPurge_simps ObservationSetup_RECEIVER.comPurge.simps)+

end

end


(*
  IMP_Minus_Nat_Bijection is now Primities_IMP_Minus
  It was not updated to use the new format...
  In particular the "letification" step is missing
  TODO: Change everything to fit this

*)

theory IMP_Minus_Max_Constant_IMP_Minus
  imports IMP_Minus_Max_Constant_Nat
    "IMP-_To_IMP--/Primitives_IMP_Minus"
    (* "../../IMP-/IMP_Minus_Nat_Bijection" This theory does not exist... Search for it*)
begin

unbundle IMP_Minus_Minus_Com.no_com_syntax

definition atomExp_to_constant_IMP_Minus where "atomExp_to_constant_IMP_Minus \<equiv>
  ''atomExp_to_constant'' ::= (A (V ''a'')) ;;
  fst'_IMP_Minus ;;
  ''a'' ::= (A (V ''atomExp_to_constant'')) ;;
  snd'_IMP_Minus ;;
  (IF ''fst_nat'' \<noteq>0
  THEN
    ''atomExp_to_constant'' ::= (A (V ''snd_nat''))
  ELSE
    ''atomExp_to_constant'' ::=  (A (N 0)));;
  ''fst_nat'' ::= (A (N 0)) ;;
  ''snd_nat'' ::= (A (N 0))"

definition atomExp_to_constant_IMP_Minus_time where "atomExp_to_constant_IMP_Minus_time x \<equiv>
  11 + 2 * fst'_imp_time x"

(*lemma atomExp_to_constant_IMP_Minus_time_polynomial: "poly atomExp_to_constant_IMP_Minus_time"*)

lemma atomExp_to_constant_IMP_Minus_correct:
  "(atomExp_to_constant_IMP_Minus, s) \<Rightarrow>\<^bsup>atomExp_to_constant_IMP_Minus_time (s ''a'')\<^esup>
    s(''a'' := 0,
      ''b'' := 0,
      ''c'' := 0,
      ''fst_nat'' := 0,
      ''snd_nat'' := 0,
      ''atomExp_to_constant'' := atomExp_to_constant_tail (s ''a''))"
  apply(cases "fst_nat (s ''a'')")
  unfolding atomExp_to_constant_IMP_Minus_def atomExp_to_constant_tail_def
    atomExp_to_constant_nat_def atomExp_to_constant_IMP_Minus_time_def
  by (fastforce
      intro!: terminates_in_state_intro[OF Seq]
      IMP_Minus_fst_nat_correct
      IMP_Minus_snd_nat_correct)+

definition aexp_max_constant_IMP_Minus where "aexp_max_constant_IMP_Minus \<equiv>
  ''aexp_max_constant'' ::= (A (V ''a'')) ;;

  ''a'' ::= (A (N 1)) ;;
  ''b'' ::= (A (V ''aexp_max_constant'')) ;;
  nth_nat_IMP_Minus ;;

  ''a'' ::= (A (V ''nth_nat'')) ;;
  atomExp_to_constant_IMP_Minus ;;

  ''a'' ::= (A (N 2)) ;;
  ''b'' ::= (A (V ''aexp_max_constant'')) ;;
  nth_nat_IMP_Minus ;;

  ''a'' ::= (A (V ''nth_nat'')) ;;
  ''nth_nat'' ::= (A (V ''atomExp_to_constant'')) ;;
  atomExp_to_constant_IMP_Minus ;;

  ''a'' ::= ((V ''aexp_max_constant'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;

  ''a'' ::= ((N 3) \<ominus> (V ''fst_nat'')) ;;
  IF ''a'' \<noteq>0
  THEN
  (
    IF ''fst_nat'' \<noteq>0
    THEN
      ''b'' ::= (A (V ''atomExp_to_constant''))
    ELSE
      ''b'' ::= (A (V ''nth_nat''))
  )
  ELSE
  (
    IF ''fst_nat'' \<noteq>0
    THEN
      ''b'' ::= (A (V ''nth_nat''))
    ELSE
      ''b'' ::= (A (V ''nth_nat''))
  );;

  ''a'' ::= (A (V ''nth_nat'')) ;;

  IMP_Minus_max_a_min_b ;;
  ''aexp_max_constant'' ::= (A (V ''a'')) ;;
  ''a'' ::= (A (N 0)) ;;
  ''b'' ::= (A (N 0)) ;;
  ''nth_nat'' ::= (A (N 0)) ;;
  ''atomExp_to_constant'' ::= (A (N 0)) ;;
  ''fst_nat'' ::= (A (N 0))"

definition aexp_max_constant_IMP_Minus_time where "aexp_max_constant_IMP_Minus_time x \<equiv>
  38 + nth_nat_IMP_Minus_time 1 x + atomExp_to_constant_IMP_Minus_time (nth_nat 1 x)
  + nth_nat_IMP_Minus_time 2 x +  atomExp_to_constant_IMP_Minus_time (nth_nat 2 x)
  + IMP_Minus_fst_nat_time (x - 1) + 11"

lemma aexp_max_constant_IMP_Minus_correct:
  "(aexp_max_constant_IMP_Minus, s)
    \<Rightarrow>\<^bsup>aexp_max_constant_IMP_Minus_time (s ''a'')\<^esup>
    s(''a'' := 0,
      ''b'' := 0,
      ''c'' := 0,
      ''fst_nat'' := 0,
      ''snd_nat'' := 0,
      ''nth_nat'' := 0,
      ''atomExp_to_constant'' := 0,
      ''aexp_max_constant'' := aexp_max_constant_tail (s ''a''))"
  unfolding aexp_max_constant_IMP_Minus_def aexp_max_constant_IMP_Minus_time_def
    aexp_max_constant_tail_def
  apply(cases "3 - fst_nat (s ''a'' - Suc 0)"; cases "fst_nat (s ''a'' - Suc 0)")
     apply simp
  apply(fastforce simp: numeral_eq_Suc hd_nat_def
        intro!: terminates_in_time_state_intro[OF Seq]
        atomExp_to_constant_IMP_Minus_correct
        nth_nat_IMP_Minus_correct
        IMP_Minus_max_a_min_b_correct
        IMP_Minus_fst_nat_correct)
  (*apply(fastforce simp: numeral_eq_Suc hd_nat_def
        intro!: terminates_in_time_state_intro[OF Seq]
        atomExp_to_constant_IMP_Minus_correct
        nth_nat_IMP_Minus_correct
        IMP_Minus_max_a_min_b_correct
        IMP_Minus_fst_nat_correct)*)
  subgoal
    by(fastforce simp: numeral_eq_Suc hd_nat_def
        intro!: terminates_in_time_state_intro[OF Seq]
        atomExp_to_constant_IMP_Minus_correct
        nth_nat_IMP_Minus_correct
        IMP_Minus_max_a_min_b_correct
        IMP_Minus_fst_nat_correct)
  subgoal
    by(fastforce simp: numeral_eq_Suc hd_nat_def
        intro!: terminates_in_time_state_intro[OF Seq]
        atomExp_to_constant_IMP_Minus_correct
        nth_nat_IMP_Minus_correct
        IMP_Minus_max_a_min_b_correct
        IMP_Minus_fst_nat_correct)
  done

definition add_res_nat_first_part where "add_res_nat_first_part \<equiv>
  ''d'' ::= (A (V ''a'')) ;;
  ''e'' ::= (A (V ''b'')) ;;

  ''a'' ::= ((V ''e'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;
  ''f'' ::= (A (V ''fst_nat'')) ;;

  ''a'' ::= ((V ''e'') \<ominus> (N 1)) ;;
  IMP_Minus_snd_nat ;;
  ''g'' ::= (A (V ''snd_nat'')) ;;

  ''a'' ::= ((V ''f'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;
  ''h'' ::= (A (V ''fst_nat'')) ;;

  ''a'' ::= (A (N (Suc 0))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''i'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc 0)))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''j'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc (Suc 0))))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus"

definition add_res_nat_first_part_time where "add_res_nat_first_part_time n s \<equiv>
  (let h = hd_nat s in
    32 + 2 * IMP_Minus_fst_nat_time (s - 1) + IMP_Minus_fst_nat_time (h - 1)
    + nth_nat_IMP_Minus_time (Suc 0) h + nth_nat_IMP_Minus_time (Suc (Suc 0)) h
    + nth_nat_IMP_Minus_time (Suc (Suc (Suc 0))) h)"

lemma add_res_nat_first_part_correct:
  "(add_res_nat_first_part, s) \<Rightarrow>\<^bsup>add_res_nat_first_part_time (s ''a'') (s ''b'')\<^esup>
    (let h = hd_nat (s ''b'');
         t = tl_nat (s ''b'');
         c = hd_nat h;
         e1 = nth_nat (Suc 0) h ;
         e2 = nth_nat (Suc (Suc 0)) h;
         e3 = nth_nat (Suc (Suc (Suc 0))) h in
       s(''a'' := 0,
         ''b'' := 0,
         ''c'' := 0,
         ''d'' := s ''a'',
         ''e'' := s ''b'',
         ''f'' := h,
         ''g'' := t,
         ''h'' := c,
         ''i'' := e1,
         ''j'' := e2,
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := e3))"
  unfolding Let_def add_res_nat_first_part_def add_res_nat_first_part_time_def hd_nat_def tl_nat_def
  by (fastforce intro: terminates_in_time_state_intro[OF Seq]
      terminates_in_state_intro[OF nth_nat_IMP_Minus_correct]
      IMP_Minus_fst_nat_correct IMP_Minus_snd_nat_correct)

definition add_res_nat_second_part where "add_res_nat_second_part \<equiv>
  ''k'' ::= (A (V ''d'')) ;;

  cons_list_IMP_Minus [N 7, V ''k'', N 0] ;;
  cons_IMP_Minus (V ''cons'') (N 0) ;;
  ''l'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 3, V ''i'', V ''j'', V ''k'', N 0] ;;
  cons_IMP_Minus (V ''cons'') (V ''g'') ;;
  ''m'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 4, V ''i'', V ''j'', V ''nth_nat'', V ''k'', N 0] ;;
  cons_IMP_Minus (V ''cons'') (V ''g'') ;;
  ''n'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 6, V ''i'', V ''k'', N 0] ;;
  cons_IMP_Minus (V ''cons'') (V ''g'') ;;

  ''f'' ::= (A (N 0)) ;;
  ''g'' ::= (A (N 0)) ;;
  ''i'' ::= (A (N 0)) ;;
  ''j'' ::= (A (N 0)) ;;
  ''nth_nat'' ::= (A (N 0)) "

definition add_res_nat_second_part_time where "add_res_nat_second_part_time n s \<equiv>
  (let h = hd_nat s;
       t = tl_nat s;
       c = hd_nat h;
       e1 = nth_nat (Suc 0) h ;
       e2 = nth_nat (Suc (Suc 0)) h;
       e3 = nth_nat (Suc (Suc (Suc 0))) h;
       l1 = [7, n, 0];
       l2 = [3, e1, e2, n, 0];
       l3 = [4, e1, e2, e3, n, 0];
       l4 = [6, e1, n, 0]
    in
      18 + cons_list_IMP_Minus_time l1 + cons_list_IMP_Minus_time l2
         + cons_list_IMP_Minus_time l3 + cons_list_IMP_Minus_time l4
         + cons_IMP_Minus_time (cons_list l1) 0 + cons_IMP_Minus_time (cons_list l2) t
         + cons_IMP_Minus_time (cons_list l3) t + cons_IMP_Minus_time (cons_list l4) t)"

lemma add_res_nat_second_part_correct:
  "(add_res_nat_first_part ;; add_res_nat_second_part, s)
    \<Rightarrow>\<^bsup>add_res_nat_first_part_time (s ''a'') (s ''b'')
      + add_res_nat_second_part_time (s ''a'') (s ''b'') \<^esup>
    (let h = hd_nat (s ''b'');
       t = tl_nat (s ''b'');
       c = hd_nat h;
       e1 = nth_nat (Suc 0) h ;
       e2 = nth_nat (Suc (Suc 0)) h;
       e3 = nth_nat (Suc (Suc (Suc 0))) h;
       l1 = [7, s ''a'', 0];
       l2 = [3, e1, e2, s ''a'', 0];
       l3 = [4, e1, e2, e3, s ''a'', 0];
       l4 = [6, e1, s ''a'', 0]
    in
      s(''a'' := 0,
        ''b'' := 0,
        ''c'' := 0,
        ''d'' := 0,
        ''e'' := s ''b'',
        ''f'' := 0,
        ''g'' := 0,
        ''h'' := c,
        ''i'' := 0,
        ''j'' := 0,
        ''fst_nat'' := 0,
        ''snd_nat'' := 0,
        ''nth_nat'' := 0,
        ''k'' := s ''a'',
        ''l'' := (cons_list l1) ## 0,
        ''m'' := (cons_list l2) ## t,
        ''n'' := (cons_list l3) ## t,
        ''cons'' := (cons_list l4) ## t,
        ''triangle'' := 0,
        ''prod_encode'' := 0))"
  apply(rule terminates_in_state_intro[OF Seq'[OF add_res_nat_first_part_correct]])
  unfolding add_res_nat_second_part_def add_res_nat_second_part_time_def Let_def
  by (fastforce intro: cons_IMP_Minus_correct cons_list_IMP_Minus_correct)+

definition add_res_nat_third_part where "add_res_nat_third_part \<equiv>
  IF ''e'' \<noteq>0
  THEN
  (
    ''a'' ::= ((V ''h'') \<ominus> (N 1)) ;;
    IF ''a'' \<noteq>0
    THEN
    (
      ''a'' ::= ((V ''h'') \<ominus> (N 3)) ;;
      IF ''a'' \<noteq>0
      THEN
      (
        ''a'' ::= ((V ''h'') \<ominus> (N 4)) ;;
        IF ''a'' \<noteq>0
        THEN
        (
           ''a'' ::= ((V ''h'') \<ominus> (N 5)) ;;
           IF ''a'' \<noteq>0
           THEN
           (
            ''add_res'' ::= (A (V ''l''))
           )
           ELSE
           (
            ''add_res'' ::= (A (V ''cons''))
           )
        )
        ELSE
        (
          ''add_res'' ::= (A (V ''l'')) ;;
          Com.SKIP ;; Com.SKIP ;; Com.SKIP
        )
      )
      ELSE
      (
         ''a'' ::= ((V ''h'') \<ominus> (N 2)) ;;
         IF ''a'' \<noteq>0
         THEN
         (
          ''add_res'' ::= (A (V ''n''))
         )
         ELSE
         (
          ''add_res'' ::= (A (V ''m''))
         ) ;;
        Com.SKIP ;; Com.SKIP ;; Com.SKIP
      )
    )
    ELSE
    (
      ''add_res'' ::= (A (V ''l'')) ;;
      Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
      Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
      Com.SKIP ;; Com.SKIP ;; Com.SKIP
    )
  )
  ELSE
  (
    ''add_res'' ::= (A (V ''l'')) ;;
    Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
    Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
    Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
    Com.SKIP ;; Com.SKIP ;; Com.SKIP
  );;
  zero_variables [''a'', ''e'', ''h'', ''k'', ''l'', ''m'', ''n'', ''cons'']"

definition add_res_nat_IMP_Minus where "add_res_nat_IMP_Minus \<equiv>
  add_res_nat_first_part ;;
  add_res_nat_second_part ;;
  add_res_nat_third_part"

definition add_res_nat_IMP_Minus_time where "add_res_nat_IMP_Minus_time n s \<equiv>
  add_res_nat_first_part_time n s
  + add_res_nat_second_part_time n s
  + 15
  + zero_variables_time [''a'', ''e'', ''h'', ''k'', ''l'', ''m'', ''n'', ''cons'']"

lemma add_res_nat_IMP_Minus_correct:
  "(add_res_nat_IMP_Minus, s)
   \<Rightarrow>\<^bsup>add_res_nat_IMP_Minus_time (s ''a'') (s ''b'') \<^esup>
      s(''a'' := 0,
        ''b'' := 0,
        ''c'' := 0,
        ''d'' := 0,
        ''e'' := 0,
        ''f'' := 0,
        ''g'' := 0,
        ''h'' := 0,
        ''i'' := 0,
        ''j'' := 0,
        ''fst_nat'' := 0,
        ''snd_nat'' := 0,
        ''nth_nat'' := 0,
        ''k'' := 0,
        ''l'' := 0,
        ''m'' := 0,
        ''n'' := 0,
        ''cons'' := 0,
        ''triangle'' := 0,
        ''prod_encode'' := 0,
        ''add_res'' := add_res_nat (s ''a'') (s ''b''))"
proof(cases "s ''b''")
  case 0
  show ?thesis
    unfolding add_res_nat_IMP_Minus_def add_res_nat_IMP_Minus_time_def
    apply(rule terminates_in_time_state_intro[OF Seq'
          [OF add_res_nat_second_part_correct]])
    unfolding add_res_nat_third_part_def Let_def add_res_nat_def
    using \<open>s ''b'' = 0\<close>
    by(fastforce intro: zero_variables_correct)+
next
  case (Suc nat)
  let ?c = "hd_nat (hd_nat (s ''b''))"
  have "?c = 0 \<or> ?c = 1 \<or> ?c = 2 \<or> ?c = 3 \<or> ?c = 4 \<or> ?c = 5 \<or> ?c > 5"
    by auto
  then show ?thesis
    apply(elim disjE)
    unfolding add_res_nat_IMP_Minus_def add_res_nat_IMP_Minus_time_def
    unfolding add_res_nat_third_part_def Let_def add_res_nat_def
    using \<open>s ''b'' = Suc nat\<close>
          apply simp
    using \<open>s ''b'' = Suc nat\<close>
    by (fastforce
         intro!: terminates_in_time_state_intro[OF Seq'[OF
            add_res_nat_second_part_correct Seq'[OF _ zero_variables_correct]]]
         simp: Let_def)+
qed

definition push_con_first_part where "push_con_first_part \<equiv>
  ''e'' ::= (A (V ''a'')) ;;
  ''f'' ::= (A (V ''b'')) ;;

  ''a'' ::= ((V ''a'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;
  ''g'' ::= (A (V ''fst_nat'')) ;;

  ''a'' ::= (A (N (Suc 0))) ;;
  ''b'' ::= (A (V ''e'')) ;;
  nth_nat_IMP_Minus ;;
  ''h'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc 0)))) ;;
  ''b'' ::= (A (V ''e'')) ;;
  nth_nat_IMP_Minus ;;
  ''i'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc (Suc 0))))) ;;
  ''b'' ::= (A (V ''e'')) ;;
  nth_nat_IMP_Minus"

definition push_con_first_part_time where "push_con_first_part_time c s \<equiv>
  (let con = hd_nat c in
    24 + IMP_Minus_fst_nat_time (c - 1) + nth_nat_IMP_Minus_time (Suc 0) c
     + nth_nat_IMP_Minus_time (Suc (Suc 0)) c
     + nth_nat_IMP_Minus_time (Suc (Suc (Suc 0))) c)"

lemma push_con_first_part_correct:
  "(push_con_first_part, s) \<Rightarrow>\<^bsup>push_con_first_part_time (s ''a'') (s ''b'')\<^esup>
    (let con = hd_nat (s ''a'');
         e1 = nth_nat (Suc 0) (s ''a'') ;
         e2 = nth_nat (Suc (Suc 0)) (s ''a'');
         e3 = nth_nat (Suc (Suc (Suc 0))) (s ''a'') in
       s(''a'' := 0,
         ''b'' := 0,
         ''c'' := 0,
         ''e'' := s ''a'',
         ''f'' := s ''b'',
         ''g'' := con,
         ''h'' := e1,
         ''i'' := e2,
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := e3))"
  unfolding Let_def push_con_first_part_def push_con_first_part_time_def
    hd_nat_def
  by (fastforce simp: Let_def intro: terminates_in_time_state_intro[OF Seq]
      terminates_in_state_intro[OF nth_nat_IMP_Minus_correct]
      IMP_Minus_fst_nat_correct)

definition push_con_second_part where "push_con_second_part \<equiv>
  cons_IMP_Minus (N 0) (N 0) ;;
  ''j'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 1, V ''i'', N 0] ;;
  ''k'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 2, V ''i'', V ''nth_nat'', N 0] ;;
  ''l'' ::= (A (V ''cons'')) ;;

  cons_list_IMP_Minus [N 5, V ''i'', N 0];;

  ''nth_nat'' ::= (A (N 0)) ;;
  ''h'' ::= (A (N 0)) ;;
  ''i'' ::= (A (N 0))"

definition push_con_second_part_time where "push_con_second_part_time c s \<equiv>
  (let
    con = hd_nat c;
    e1 = nth_nat (Suc 0) c;
    e2 = nth_nat (Suc (Suc 0)) c;
    e3 = nth_nat (Suc (Suc (Suc 0))) c in
      12 + cons_IMP_Minus_time 0 0
      + cons_list_IMP_Minus_time [1, e2, 0]
      + cons_list_IMP_Minus_time [2, e2, e3, 0]
      + cons_list_IMP_Minus_time [5, e2, 0])"

lemma push_con_second_part_correct:
  "(push_con_first_part ;; push_con_second_part, s)
    \<Rightarrow>\<^bsup>push_con_first_part_time (s ''a'') (s ''b'')
      + push_con_second_part_time (s ''a'') (s ''b'') \<^esup>
    (let con = hd_nat (s ''a'');
         e1 = nth_nat (Suc 0) (s ''a'');
         e2 = nth_nat (Suc (Suc 0)) (s ''a'');
         e3 = nth_nat (Suc (Suc (Suc 0))) (s ''a'');
         l1 = [0, 0];
         l2 = [1, e2, 0];
         l3 = [2, e2, e3, 0];
         l4 = [5, e2, 0]
    in
      s(''a'' := 0,
        ''b'' := 0,
        ''c'' := 0,
        ''d'' := 0,
        ''e'' := s ''a'',
        ''f'' := s ''b'',
        ''g'' := con,
        ''h'' := 0,
        ''i'' := 0,
        ''fst_nat'' := 0,
        ''snd_nat'' := 0,
        ''nth_nat'' := 0,
        ''j'' := cons_list l1,
        ''k'' := cons_list l2,
        ''l'' := cons_list l3,
        ''cons'' := cons_list l4,
        ''triangle'' := 0,
        ''prod_encode'' := 0))"
  apply(rule terminates_in_state_intro[OF Seq'[OF push_con_first_part_correct]])
  unfolding push_con_second_part_def push_con_second_part_time_def Let_def
  by (fastforce intro: cons_IMP_Minus_correct cons_list_IMP_Minus_correct)+

definition push_con_third_part where "push_con_third_part \<equiv>
  ''a'' ::= ((V ''g'') \<ominus> (N 1)) ;;
  IF ''a'' \<noteq>0 THEN
  (
    ''a'' ::= ((V ''g'') \<ominus> (N 2)) ;;
    IF ''a'' \<noteq>0 THEN
    (
      ''a'' ::= ((V ''g'') \<ominus> (N 3)) ;;
      IF ''a'' \<noteq>0 THEN
      (
        ''a'' ::= (A (V ''cons''))
      )
      ELSE
      (
        ''a'' ::= (A (V ''l''))
      )
    )
    ELSE
    (
      Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
      ''a'' ::= (A (V ''e''))
    )
  )
  ELSE
  (
    Com.SKIP ;; Com.SKIP ;; Com.SKIP ;;
    Com.SKIP ;; Com.SKIP ;;
    IF ''g'' \<noteq>0 THEN
    (
      ''a'' ::= (A (V ''k''))
    )
    ELSE
    (
      ''a'' ::= (A (V ''j''))
    )
  ) ;;
  cons_IMP_Minus (V ''a'') (V ''f'') ;;
  ''push_con'' ::= (A (V ''cons'')) ;;
  ''e'' ::= (A (N 0)) ;;
  ''f'' ::= (A (N 0)) ;;
  ''g'' ::= (A (N 0)) ;;
  ''j'' ::= (A (N 0)) ;;
  ''k'' ::= (A (N 0)) ;;
  ''l'' ::= (A (N 0)) ;;
  ''cons'' ::= (A (N 0)) ;;
  ''a'' ::= (A (N 0))"

definition push_con_third_part_time where "push_con_third_part_time c s \<equiv>
  (let
    con = hd_nat c;
    e1 = nth_nat (Suc 0) c;
    e2 = nth_nat (Suc (Suc 0)) c;
    e3 = nth_nat (Suc (Suc (Suc 0))) c;
    l = (
     if con = 0 then (0##0) else
     if con = 1 then (1##e2##0) else
     if con = 2 then c else
     if con = 3 then (2 ## e2 ## e3 ## 0) else
     (5 ## e2 ## 0)) in
      11 + 18 + cons_IMP_Minus_time l s)"

definition push_con_IMP_Minus where "push_con_IMP_Minus \<equiv>
  push_con_first_part ;;
  push_con_second_part ;;
  push_con_third_part"

definition push_con_IMP_Minus_time where "push_con_IMP_Minus_time c s \<equiv>
  push_con_first_part_time c s
  + push_con_second_part_time c s
  + push_con_third_part_time c s"

lemma push_con_IMP_Minus_correct:
  "(push_con_IMP_Minus, s)
    \<Rightarrow>\<^bsup>push_con_IMP_Minus_time (s ''a'') (s ''b'') \<^esup>
     (s(''a'' := 0,
        ''b'' := 0,
        ''c'' := 0,
        ''d'' := 0,
        ''e'' := 0,
        ''f'' := 0,
        ''g'' := 0,
        ''h'' := 0,
        ''i'' := 0,
        ''fst_nat'' := 0,
        ''snd_nat'' := 0,
        ''nth_nat'' := 0,
        ''j'' := 0,
        ''k'' := 0,
        ''l'' := 0,
        ''cons'' := 0,
        ''triangle'' := 0,
        ''prod_encode'' := 0,
        ''push_con'' := push_con_nat (s ''a'') (s ''b'')))"
proof -
  have "hd_nat (s ''a'') = 0 \<or> hd_nat (s ''a'') = 1 \<or> hd_nat (s ''a'') = 2
    \<or> hd_nat (s ''a'') = 3 \<or> hd_nat (s ''a'') > 3"
    by auto
  thus ?thesis
    apply(elim disjE)
    unfolding push_con_IMP_Minus_def push_con_IMP_Minus_time_def push_con_nat_def
    by(rule terminates_in_state_intro[OF Seq'
          [OF  push_con_second_part_correct]] ;
        fastforce
        simp: push_con_third_part_def push_con_third_part_time_def Let_def
        intro: terminates_in_state_intro[OF Seq]
        terminates_in_state_intro[OF Big_StepT.Assign]
        cons_IMP_Minus_correct)+
qed

definition max_constant_iteration_first_part where
  "max_constant_iteration_first_part \<equiv>
  ''e'' ::= (A (V ''a'')) ;;

  ''a'' ::= ((V ''e'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;
  ''f'' ::= (A (V ''fst_nat'')) ;;

  ''a'' ::= ((V ''e'') \<ominus> (N 1)) ;;
  IMP_Minus_snd_nat ;;
  ''g'' ::= (A (V ''snd_nat'')) ;;

  ''a'' ::= ((V ''f'') \<ominus> (N 1)) ;;
  IMP_Minus_fst_nat ;;
  ''h'' ::= (A (V ''fst_nat'')) ;;

  ''a'' ::= (A (N (Suc 0))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''i'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc 0)))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''j'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc (Suc 0))))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''k'' ::= (A (V ''nth_nat'')) ;;

  ''a'' ::= (A (N (Suc (Suc (Suc (Suc 0)))))) ;;
  ''b'' ::= (A (V ''f'')) ;;
  nth_nat_IMP_Minus ;;
  ''l'' ::= (A (V ''nth_nat''))"

definition max_constant_iteration_first_part_time
  where "max_constant_iteration_first_part_time s \<equiv>
  (let h = hd_nat s in
    38 + 2 * IMP_Minus_fst_nat_time (s - 1) + IMP_Minus_fst_nat_time (h - 1)
    + nth_nat_IMP_Minus_time (Suc 0) h + nth_nat_IMP_Minus_time (Suc (Suc 0)) h
    + nth_nat_IMP_Minus_time (Suc (Suc (Suc 0))) h
    + nth_nat_IMP_Minus_time (Suc (Suc (Suc (Suc 0)))) h)"

lemma max_constant_iteration_first_part_correct:
  "(max_constant_iteration_first_part, s)
    \<Rightarrow>\<^bsup>max_constant_iteration_first_part_time (s ''a'')\<^esup>
    (let h = hd_nat (s ''a'');
         t = tl_nat (s ''a'');
         c = hd_nat h;
         e1 = nth_nat (Suc 0) h ;
         e2 = nth_nat (Suc (Suc 0)) h;
         e3 = nth_nat (Suc (Suc (Suc 0))) h;
         e4 = nth_nat (Suc (Suc (Suc (Suc 0)))) h in
       s(''a'' := 0,
         ''b'' := 0,
         ''c'' := 0,
         ''e'' := s ''a'',
         ''f'' := h,
         ''g'' := t,
         ''h'' := c,
         ''i'' := e1,
         ''j'' := e2,
         ''k'' := e3,
         ''l'' := e4,
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := e4))"
  unfolding Let_def max_constant_iteration_first_part_def
    max_constant_iteration_first_part_time_def hd_nat_def tl_nat_def
  by (fastforce intro: terminates_in_time_state_intro[OF Seq]
      nth_nat_IMP_Minus_correct
      terminates_in_state_intro[OF Big_StepT.Assign]
      IMP_Minus_fst_nat_correct IMP_Minus_snd_nat_correct)+

(*if c = 0 then  max_constant_stack_nat (add_res_nat 0 t)
else if c = 1 then max_constant_stack_nat (add_res_nat (aexp_max_constant_tail e1) t)
else if c = 2 then  max_constant_stack_nat (push_con_nat e1 s)
else if c = 3 then   max_constant_stack_nat (push_con_nat e2 s)
else if c = 4 then   max_constant_stack_nat (add_res_nat (max e3 e4) t)
else if c = 5 then   max_constant_stack_nat (push_con_nat e1 s)
else if c = 6 then  max_constant_stack_nat (add_res_nat e2 t)
else e1*)

definition max_constant_iteration_second_part where "max_constant_iteration_second_part \<equiv>
  ''max_constant'' ::= (A (N 1)) ;;
  IF ''e'' \<noteq>0 THEN
    IF ''h'' \<noteq>0 THEN
    (
      ''a'' ::= ((V ''h'') \<ominus> (N 1)) ;;
      IF ''a'' \<noteq>0 THEN
      (
        ''a'' ::= ((V ''h'') \<ominus> (N 2)) ;;
        IF ''a'' \<noteq>0 THEN
        (
          ''a'' ::= ((V ''h'') \<ominus> (N 3)) ;;
          IF ''a'' \<noteq>0 THEN
          (
            ''a'' ::= ((V ''h'') \<ominus> (N 4)) ;;
            IF ''a'' \<noteq>0 THEN
            (
              ''a'' ::= ((V ''h'') \<ominus> (N 5)) ;;
              IF ''a'' \<noteq>0 THEN
              (
                ''a'' ::= ((V ''h'') \<ominus> (N 6)) ;;
                IF ''a'' \<noteq>0 THEN
                (
                  ''a'' ::= (A (V ''i'')) ;;
                  ''max_constant'' ::= (A (N 0))
                )
                ELSE
                (
                  ''a'' ::= (A (V ''j'')) ;;
                  ''b'' ::= (A (V ''g'')) ;;
                  add_res_nat_IMP_Minus ;;
                  ''a'' ::= (A (V ''add_res''))
                )
              )
              ELSE
              (
                ''a'' ::= (A (V ''i'')) ;;
                ''b'' ::= (A (V ''e'')) ;;
                push_con_IMP_Minus ;;
                ''a'' ::= (A (V ''push_con''))
              )
            )
            ELSE
            (
              ''a'' ::= (A (V ''k'')) ;;
              ''b'' ::= (A (V ''l'')) ;;
              IMP_Minus_max_a_min_b ;;
              ''b'' ::= (A (V ''g'')) ;;
              add_res_nat_IMP_Minus ;;
              ''a'' ::= (A (V ''add_res''))
            )
          )
          ELSE
          (
            ''a'' ::= (A (V ''j'')) ;;
            ''b'' ::= (A (V ''e'')) ;;
            push_con_IMP_Minus ;;
            ''a'' ::= (A (V ''push_con''))
          )
        )
        ELSE
        (
          ''a'' ::= (A (V ''i'')) ;;
          ''b'' ::= (A (V ''e'')) ;;
          push_con_IMP_Minus ;;
          ''a'' ::= (A (V ''push_con''))
        )
      )
      ELSE
      (
        ''a'' ::= (A (V ''i'')) ;;
        aexp_max_constant_IMP_Minus ;;
        ''a'' ::= (A (V ''aexp_max_constant'')) ;;
        ''b'' ::= (A (V ''g'')) ;;
        add_res_nat_IMP_Minus ;;
        ''a'' ::= (A (V ''add_res''))
      )
    )
    ELSE
    (
      ''a'' ::= (A (N 0)) ;;
      ''b'' ::= (A (V ''g'')) ;;
      add_res_nat_IMP_Minus ;;
      ''a'' ::= (A (V ''add_res''))
    )
  ELSE
  (
    ''a'' ::= (A (N 0)) ;;
    ''max_constant'' ::= (A (N 0))
  ) ;;
  zero_variables [''d'', ''e'', ''f'', ''g'', ''h'', ''i'', ''j'', ''k'', ''l'', ''m'', ''n'',
    ''nth_nat'', ''aexp_max_constant'', ''add_res'', ''cons'', ''triangle'',
        ''prod_encode'', ''add_res'', ''atomExp_to_constant'', ''push_con'']"

definition max_constant_iteration_second_part_time where
  "max_constant_iteration_second_part_time s \<equiv>
  Suc (Suc 0) +
  (let h = hd_nat s;
       t = tl_nat s;
       c = hd_nat h;
       e1 = nth_nat (Suc 0) h ;
       e2 = nth_nat (Suc (Suc 0)) h;
       e3 = nth_nat (Suc (Suc (Suc 0))) h;
       e4 = nth_nat (Suc (Suc (Suc (Suc 0)))) h in
      (if s = 0 then 1 + 4
       else 1 +
       (if c = 0 then 1 + 6 + (add_res_nat_IMP_Minus_time 0 t)
       else if c = 1 then 4 + 8
          + (add_res_nat_IMP_Minus_time (aexp_max_constant_tail e1) t)
          + (aexp_max_constant_IMP_Minus_time e1)
       else if c = 2 then 7 + 6 + (push_con_IMP_Minus_time e1 s)
       else if c = 3 then 10 + 6 + (push_con_IMP_Minus_time e2 s)
       else if c = 4 then 13 + 8 + 11 + (add_res_nat_IMP_Minus_time (max e3 e4) t)
       else if c = 5 then 16 + 6 + (push_con_IMP_Minus_time e1 s)
       else if c = 6 then 19 + 6 + (add_res_nat_IMP_Minus_time e2 t)
       else 19 + 4)))
  + zero_variables_time [''d'', ''e'', ''f'', ''g'', ''h'', ''i'', ''j'', ''k'', ''l'', ''m'', ''n'',
    ''nth_nat'', ''aexp_max_constant'', ''add_res'', ''cons'', ''triangle'',
        ''prod_encode'', ''add_res'', ''atomExp_to_constant'', ''push_con'']"

definition max_constant_iteration where "max_constant_iteration \<equiv>
  max_constant_iteration_first_part ;;
  max_constant_iteration_second_part"

definition max_constant_iteration_time where "max_constant_iteration_time s \<equiv>
  max_constant_iteration_first_part_time s
  + max_constant_iteration_second_part_time s"

lemma max_constant_iteration_correct:
"(max_constant_iteration, s')
    \<Rightarrow>\<^bsup>max_constant_iteration_time (s' ''a'')\<^esup>
    (let s = s' ''a'';
         h = hd_nat s;
         t = tl_nat s;
         c = hd_nat h;
         e1 = nth_nat (Suc 0) h ;
         e2 = nth_nat (Suc (Suc 0)) h;
         e3 = nth_nat (Suc (Suc (Suc 0))) h;
         e4 = nth_nat (Suc (Suc (Suc (Suc 0)))) h in
       s'(''a'' :=
          (if s = 0 then 0
           else (if c = 0 then (add_res_nat 0 t)
           else if c = 1 then (add_res_nat (aexp_max_constant_tail e1) t)
           else if c = 2 then (push_con_nat e1 s)
           else if c = 3 then (push_con_nat e2 s)
           else if c = 4 then (add_res_nat (max e3 e4) t)
           else if c = 5 then (push_con_nat e1 s)
           else if c = 6 then (add_res_nat e2 t)
           else e1)),
         ''b'' := 0,
         ''c'' := 0,
         ''d'' := 0,
         ''e'' := 0,
         ''f'' := 0,
         ''g'' := 0,
         ''h'' := 0,
         ''i'' := 0,
         ''j'' := 0,
         ''k'' := 0,
         ''l'' := 0,
         ''m'' := 0,
         ''n'' := 0,
         ''max_constant'' := (if s \<noteq> 0 \<and> c < 7 then 1 else 0),
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := 0,
         ''cons'' := 0,
         ''triangle'' := 0,
         ''prod_encode'' := 0,
         ''aexp_max_constant'' := 0,
         ''atomExp_to_constant'' := 0,
         ''add_res'' := 0,
         ''push_con'' := 0))"
proof (cases "s' ''a''")
  case 0
  then show ?thesis
     unfolding max_constant_iteration_def max_constant_iteration_time_def
      max_constant_iteration_second_part_def max_constant_iteration_second_part_time_def
    by(fastforce
        simp: Let_def
        intro:
          aexp_max_constant_IMP_Minus_correct IMP_Minus_max_a_min_b_correct
          add_res_nat_IMP_Minus_correct push_con_IMP_Minus_correct
        intro!:
          terminates_in_state_intro[OF Seq'
          [OF max_constant_iteration_first_part_correct
            Seq'[OF Seq'[OF Big_StepT.Assign] zero_variables_correct]]])
next
  case (Suc nat)

  let ?c = "hd_nat (hd_nat (s' ''a''))"
  have "?c = 0 \<or> ?c = 1 \<or> ?c = 2 \<or> ?c = 3 \<or> ?c = 4 \<or> ?c = 5 \<or> ?c = 6 \<or> ?c > 6"
    by auto
  thus ?thesis
    unfolding max_constant_iteration_def max_constant_iteration_time_def
      max_constant_iteration_second_part_def max_constant_iteration_second_part_time_def
    apply(elim disjE)
    using Suc
    by(fastforce
        simp: Let_def
        intro:
          aexp_max_constant_IMP_Minus_correct IMP_Minus_max_a_min_b_correct
          add_res_nat_IMP_Minus_correct push_con_IMP_Minus_correct
        intro!:
          terminates_in_state_intro[OF Seq'
          [OF max_constant_iteration_first_part_correct
            Seq'[OF Seq'[OF Big_StepT.Assign] zero_variables_correct]]])+
qed

function (domintros) max_constant_loop_time :: "nat \<Rightarrow> nat" where
"max_constant_loop_time s =
  1 + max_constant_iteration_time s +
  (if s = 0 then 2
   else (let h = hd_nat s;
         t = tl_nat s;
         c = hd_nat h;
         e1 = nth_nat (Suc 0) h;
         e2 = nth_nat (Suc (Suc 0)) h;
         e3 = nth_nat (Suc (Suc (Suc 0))) h;
         e4 = nth_nat (Suc (Suc (Suc (Suc 0)))) h in
      if c = 0 then max_constant_loop_time (add_res_nat 0 t)
      else if c = 1 then max_constant_loop_time (add_res_nat (aexp_max_constant_tail e1) t)
      else if c = 2 then max_constant_loop_time (push_con_nat e1 s)
      else if c = 3 then max_constant_loop_time (push_con_nat e2 s)
      else if c = 4 then max_constant_loop_time (add_res_nat (max e3 e4) t)
      else if c = 5 then max_constant_loop_time (push_con_nat e1 s)
      else if c = 6 then max_constant_loop_time (add_res_nat e2 t)
      else 2))"
  by pat_completeness auto

lemma max_constant_stack_nat_domain_then_max_constant_loop_time_domain:
  "max_constant_stack_nat_dom x \<Longrightarrow> max_constant_loop_time_dom x"
proof(induction x rule: max_constant_stack_nat.pinduct)
  case (1 s)

  show ?case
  proof (cases s)
    case 0
    then show ?thesis
      using max_constant_loop_time.domintros[where ?s=s]
      by auto
  next
    case (Suc nat)
    show ?thesis
      by(fastforce intro:
          max_constant_loop_time.domintros[where ?s=s]
          "1.IH"[where ?x="hd_nat s", simplified])
  qed
qed

lemma max_constant_loop_correct:
   "max_constant_stack_nat_dom s \<Longrightarrow> s' ''a'' = s \<Longrightarrow>
    0 < s' ''max_constant'' \<Longrightarrow>
(WHILE ''max_constant''\<noteq>0 DO max_constant_iteration, s')
    \<Rightarrow>\<^bsup>max_constant_loop_time s\<^esup>
      s'(''a'' := max_constant_stack_nat s,
         ''b'' := 0,
         ''c'' := 0,
         ''d'' := 0,
         ''e'' := 0,
         ''f'' := 0,
         ''g'' := 0,
         ''h'' := 0,
         ''i'' := 0,
         ''j'' := 0,
         ''k'' := 0,
         ''l'' := 0,
         ''m'' := 0,
         ''n'' := 0,
         ''max_constant'' := 0,
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := 0,
         ''cons'' := 0,
         ''triangle'' := 0,
         ''prod_encode'' := 0,
         ''aexp_max_constant'' := 0,
         ''atomExp_to_constant'' := 0,
         ''add_res'' := 0,
         ''push_con'' := 0)"
proof(induction s arbitrary: s' rule: max_constant_stack_nat.pinduct)
  case (1 s)

  let ?c = "hd_nat (hd_nat s)"

  show ?case
  proof (cases "s \<noteq> 0 \<and> ?c < 7")
    case True

    hence "?c = 0 \<or> ?c = 1 \<or> ?c = 2 \<or> ?c = 3 \<or> ?c = 4 \<or> ?c = 5 \<or> ?c = 6"
      by auto

    then show ?thesis
      apply(elim disjE)
      using \<open>0 < s' ''max_constant''\<close>
        \<open>s \<noteq> 0 \<and> hd_nat (hd_nat s) < 7\<close> \<open>s' ''a'' = s\<close>
        max_constant_loop_time.psimps
        max_constant_stack_nat.psimps
        max_constant_stack_nat_domain_then_max_constant_loop_time_domain
        \<open>max_constant_stack_nat_dom s\<close>
            apply -
            apply (fastforce
              simp: Let_def
              intro!:
                terminates_in_state_intro
                [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(1)]])
           apply (fastforce
              simp: Let_def
              intro!:
                terminates_in_state_intro
                [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(2)]])
          apply (fastforce
            simp: Let_def
            intro!:
            terminates_in_state_intro
            [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(3)]])
         apply (fastforce
          simp: Let_def
          intro!:
          terminates_in_state_intro
          [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(4)]])
        apply (fastforce
          simp: Let_def
          intro!:
          terminates_in_state_intro
          [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(5)]])
       apply (fastforce
          simp: Let_def
          intro!:
          terminates_in_state_intro
          [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(6)]])
      by (fastforce
          simp: Let_def
          intro!:
          terminates_in_state_intro
          [OF Big_StepT.WhileTrue[OF _ max_constant_iteration_correct "1.IH"(7)]])
  next
    case False

    show ?thesis
    proof(cases s)
      case 0
      thus ?thesis
        using
          \<open>0 < s' ''max_constant''\<close>
          max_constant_loop_time.psimps[OF max_constant_loop_time.domintros]
          max_constant_stack_nat.psimps[OF max_constant_stack_nat.domintros]
          \<open>s' ''a'' = s\<close>
        by (auto intro!: terminates_in_state_intro[OF Big_StepT.WhileTrue
              [OF _ max_constant_iteration_correct Big_StepT.WhileFalse]])
    next
      case (Suc nat)
      hence "s \<noteq> 0" "?c > 6"
        using \<open>\<not> (s \<noteq> 0 \<and> ?c < 7)\<close>
        by auto
      thus ?thesis
        using
          \<open>0 < s' ''max_constant''\<close>
          max_constant_loop_time.psimps[OF max_constant_loop_time.domintros]
          max_constant_stack_nat.psimps[OF max_constant_stack_nat.domintros]
          \<open>s' ''a'' = s\<close>
        by (auto intro!: terminates_in_state_intro[OF Big_StepT.WhileTrue
              [OF _ max_constant_iteration_correct Big_StepT.WhileFalse]])
    qed
  qed
qed

definition max_constant_IMP_Minus where "max_constant_IMP_Minus \<equiv>
  ''max_constant'' ::= (A (N 1)) ;;
  WHILE ''max_constant''\<noteq>0 DO max_constant_iteration ;;
  ''max_constant'' ::= (A (V ''a'')) ;;
  ''a'' ::= (A (N 0))"

definition max_constant_time where "max_constant_time s \<equiv>
  6 + max_constant_loop_time s"

lemma max_constant_IMP_Minus_correct:
"max_constant_stack_nat_dom (s ''a'') \<Longrightarrow>
    0 < s' ''max_constant'' \<Longrightarrow>
(max_constant_IMP_Minus, s)
    \<Rightarrow>\<^bsup>max_constant_time (s ''a'')\<^esup>
       s(''a'' := 0,
         ''b'' := 0,
         ''c'' := 0,
         ''d'' := 0,
         ''e'' := 0,
         ''f'' := 0,
         ''g'' := 0,
         ''h'' := 0,
         ''i'' := 0,
         ''j'' := 0,
         ''k'' := 0,
         ''l'' := 0,
         ''m'' := 0,
         ''n'' := 0,
         ''max_constant'' := max_constant_stack_nat (s ''a''),
         ''fst_nat'' := 0,
         ''snd_nat'' := 0,
         ''nth_nat'' := 0,
         ''cons'' := 0,
         ''triangle'' := 0,
         ''prod_encode'' := 0,
         ''aexp_max_constant'' := 0,
         ''atomExp_to_constant'' := 0,
         ''add_res'' := 0,
         ''push_con'' := 0)"
  unfolding max_constant_IMP_Minus_def max_constant_time_def
  by(fastforce intro!: terminates_in_state_intro[OF Seq] max_constant_loop_correct)

end