header {* Execution rules for groups *}

theory KPL_execution_group imports
  KPL_execution_thread
begin

text {* Intra-group race detection *}
definition group_race
  :: "lid set \<Rightarrow> (lid \<rightharpoonup> thread_state) \<Rightarrow> bool"
where "group_race T \<gamma> \<equiv>
  \<exists>j \<in> T. \<exists>k \<in> T. j \<noteq> k \<and>
  W (the (\<gamma> j)) \<inter> (R (the (\<gamma> k)) \<union> W (the (\<gamma> k))) \<noteq> {}"

text {* The constraints for the @{term "merge"} map *}
inductive pre_merge
  :: "lid set \<Rightarrow> (lid \<rightharpoonup> thread_state) \<Rightarrow> nat \<Rightarrow> word \<Rightarrow> bool"
where
  "\<lbrakk> j \<in> T ; z \<in> W (the (\<gamma> j)) ; dom \<gamma> = T \<rbrakk> \<Longrightarrow>
  pre_merge T \<gamma> z (sh (the (\<gamma> j)) z)"
| "\<lbrakk> \<forall>j \<in> T. z \<notin> W (the (\<gamma> j)) ; dom \<gamma> = T \<rbrakk> \<Longrightarrow>
  pre_merge T \<gamma> z (sh (the (\<gamma> 0)) z)"

inductive_cases pre_merge_inv [elim!]: "pre_merge P \<gamma> z z'"

text {* The @{term "merge"} map maps each nat to the word that
   satisfies the above constaints. The @{text "merge_is_unique"}
   lemma shows that there exists exactly one such word
   per nat, provided there are no group races. *}
definition merge :: "lid set \<Rightarrow> (lid \<rightharpoonup> thread_state) \<Rightarrow> nat \<Rightarrow> word"
where "merge T \<gamma> \<equiv> \<lambda>z. The (pre_merge T \<gamma> z)"

lemma no_races_imp_no_write_overlap:
  "\<not> (group_race T \<gamma>) \<Longrightarrow>
  \<forall>i \<in> T. \<forall>j \<in> T.
  i \<noteq> j \<longrightarrow> W (the (\<gamma> i)) \<inter> W (the (\<gamma> j)) = {}"
unfolding group_race_def
by blast

lemma merge_is_unique:
  assumes "dom \<gamma> = T"
  assumes "\<not> (group_race T \<gamma>)"
  shows "\<exists>!z'. pre_merge T \<gamma> z z'"
apply (insert assms)
apply (drule no_races_imp_no_write_overlap)
apply (intro allI ex_ex1I)
apply (metis pre_merge.intros)
apply clarify
proof -
  fix z1 z2
  assume a: "\<forall>i\<in>dom \<gamma>. \<forall>j\<in>dom \<gamma>. i \<noteq> j \<longrightarrow> W (the (\<gamma> i)) \<inter> W (the (\<gamma> j)) = {}"
  assume "pre_merge (dom \<gamma>) \<gamma> z z1"
  and "pre_merge (dom \<gamma>) \<gamma> z z2"
  thus "z1 = z2"
  apply (elim pre_merge_inv)
  apply (rename_tac j1 j2)
  apply (case_tac "j1 = j2")
  apply auto[1]
  apply simp
  apply (subgoal_tac "W (the (\<gamma> j1)) \<inter> W (the (\<gamma> j2)) = {}")
  apply auto[1]
  apply (auto simp add: a)
  done
qed

text {* The rules of Figure 5, plus an additional rule for
  equality abstraction (Fig 7a), plus an additional rule for
  adversarial abstraction (Fig 7b)  *}
inductive step_g
  :: "abs_level \<Rightarrow> gid \<Rightarrow> (gid \<rightharpoonup> lid set) \<Rightarrow> (group_state \<times> pred_stmt) \<Rightarrow> group_state option \<Rightarrow> bool"
where
  G_Race:
  "\<lbrakk> \<forall>j \<in> the (T i). step_t a (the (\<gamma> \<^sub>t\<^sub>s j), (s, p)) (the (\<gamma>' \<^sub>t\<^sub>s j)) ;
    group_race (the (T i)) ((\<gamma>' :: group_state)\<^sub>t\<^sub>s) \<rbrakk>
  \<Longrightarrow> step_g a i T (\<gamma>, (Basic s, p)) None"
| G_Basic:
  "\<lbrakk> \<forall>j \<in> the (T i). step_t a (the (\<gamma> \<^sub>t\<^sub>s j), (s, p)) (the (\<gamma>' \<^sub>t\<^sub>s j)) ;
    \<not> (group_race (the (T i)) (\<gamma>' \<^sub>t\<^sub>s)) ;
    R_group \<gamma>' = R_group \<gamma> \<union> (\<Union>j \<in> the (T i). ({j} \<times> R (the (\<gamma>' \<^sub>t\<^sub>s j)))) ;
    W_group \<gamma>' = W_group \<gamma> \<union> (\<Union>j \<in> the (T i). ({j} \<times> W (the (\<gamma>' \<^sub>t\<^sub>s j)))) \<rbrakk>
  \<Longrightarrow> step_g a i T (\<gamma>, (Basic s, p)) (Some \<gamma>')"
| G_No_Op:
  "\<forall>j \<in> the (T i). \<not> (eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j)))
  \<Longrightarrow> step_g a i T (\<gamma>, (Barrier, p)) (Some \<gamma>)"
| G_Divergence:
  "\<lbrakk> j \<noteq> k ; j \<in> the (T i) ; k \<in> the (T i) ;
   eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j)) ; \<not> (eval_bool p (the (\<gamma> \<^sub>t\<^sub>s k))) \<rbrakk>
  \<Longrightarrow> step_g a i T (\<gamma>, (Barrier, p)) None"
| G_Sync:
  "\<lbrakk> \<forall>j \<in> the (T i). eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j)) ;
    \<forall>j \<in> the (T i). the (\<gamma>' \<^sub>t\<^sub>s j) = (the (\<gamma> \<^sub>t\<^sub>s j)) (|
    sh := merge P (\<gamma> \<^sub>t\<^sub>s), R := {}, W := {} |) \<rbrakk>
  \<Longrightarrow> step_g No_Abst i T (\<gamma>, (Barrier, p)) (Some \<gamma>')"
| G_Sync_Eq:
  "\<lbrakk> \<forall>j \<in> the (T i). eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j)) ;
    \<forall>j \<in> the (T i). the (\<gamma>' \<^sub>t\<^sub>s j) = (the (\<gamma> \<^sub>t\<^sub>s j)) (|
    sh := sh', R := {}, W := {} |) \<rbrakk>
  \<Longrightarrow> step_g Eq_Abst i T (\<gamma>, (Barrier, p)) (Some \<gamma>')"
| G_Sync_Adv:
  "\<lbrakk> \<forall>j \<in> the (T i). eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j)) ;
    \<forall>j \<in> the (T i). \<exists>sh'. the (\<gamma>' \<^sub>t\<^sub>s j) = (the (\<gamma> \<^sub>t\<^sub>s j)) (|
    sh := sh', R := {}, W := {} |) \<rbrakk>
  \<Longrightarrow> step_g Adv_Abst i T (\<gamma>, (Barrier, p)) (Some \<gamma>')"

text {* Rephrasing @{text G_No_Op} to make it more usable *}
lemma G_No_Op_helper:
  "\<lbrakk> \<forall>j \<in> the (T i). \<not> (eval_bool p (the (\<gamma> \<^sub>t\<^sub>s j))) ; \<gamma> = \<gamma>' \<rbrakk>
  \<Longrightarrow> step_g a i T (\<gamma>, (Barrier, p)) (Some \<gamma>')"
by (simp add: step_g.G_No_Op)

end


theory Seq_Atomic
imports Seq_Obs
begin

datatype labels = Pgm | Env

locale seq_atomic = test_seq +
  fixes step :: "labels \<Rightarrow> ('b \<times> 'b) \<Rightarrow> 'a"
  assumes step_test: "range (step l) \<inter> range test = {}"
  assumes step_last: "x \<le> step l (a,b) \<Longrightarrow> last x \<le> test b"
  assumes test_step: "test a ; step l (a, b) \<ge>  step l (a, b)"
  assumes first_step': "first (step l (a, b); x) \<ge> test a"
  assumes last_step': "last (step l (a,b)) \<ge> test b"
  assumes test_step': " step l (a, b); test b \<ge>  step l (a, b)"
  assumes bot_not_step: "\<bottom> \<notin> range (step l)"
  assumes step_le: "step l s \<ge> (step l' s' ; x) \<Longrightarrow> l = l' \<and> s = s'"
  assumes step_meet_seq: "\<And>a b.  a \<le> step l s \<Longrightarrow> b \<le> step l' s' \<Longrightarrow>  x \<le> a ; c \<Longrightarrow> x \<le> b ; d \<Longrightarrow>
                                  \<exists>y y'. y \<le> a \<and> y \<le> b \<and> y' \<le> c \<and> y' \<le> d \<and> x \<le> y ; y'"
  assumes ref_tail: "step l s ; c \<ge> step l s ; d \<Longrightarrow> (test (snd s) ; c) \<ge> (test (snd s) ; d)"
  assumes step_atomic: "x \<le> step l (a, b)  \<Longrightarrow>
      ((x \<le> \<bottom>) \<or> ((x \<le> step l (a, b) ; \<bottom>) \<and> (x \<ge>  step l (a, b) ; \<bottom>) ) \<or> (x \<ge> step l (a, b)))"
begin

lemma last_step: "last (step l (a,b)) \<le> test b"
  apply (subst unit_of_unit)
  using test_step' by blast

lemma step_first: "x \<le> step l (a, b) \<Longrightarrow> first x \<le> test a"
  by (metis first_le first_step order_trans unit_of_apply)

lemma first_stepD: "first (step l (a, b) ; x) \<ge> test a' \<Longrightarrow> a = a'"
  by (metis dual_order.trans first_step test_le)

lemma  step_meet: "x \<le> step l (a, b) \<Longrightarrow> x \<le> step l' (c, d) \<Longrightarrow> x \<le> \<bottom> \<or> (c = a \<and> d = b)"
  apply (case_tac "x \<le> \<bottom>"; clarsimp)
  apply (case_tac "c = a"; clarsimp?)
   defer
   apply (frule step_first)
   apply (frule step_first) back
  apply (metis bot_annihilate_seq dual_order.trans flip.unit_of_apply mono_f test_atom test_le)
  apply (subgoal_tac "last x \<le> test b \<and> last x \<le> test d")
   apply (clarsimp)
   apply (subst (asm) unit_of_unit)
   apply (subst (asm) unit_of_unit)
   apply (frule (3) step_meet_seq) back
   apply (clarsimp)
  apply (case_tac "y' = \<bottom>")
    apply (smt (verit, del_insts) Pair_inject le_test order_trans step_atomic step_le)

   apply (smt (verit, del_insts) Pair_inject le_test order_trans preorder_bot_class.bot_least step_atomic step_le)
  using step_last by blast

lemma  step_meet': "x \<le> step l (a, b) \<Longrightarrow> x \<le> step l' (c, d) \<Longrightarrow> x \<le> \<bottom> \<or> (c = a \<and> d = b \<and> l = l')"
  apply (case_tac "x \<le> \<bottom>"; clarsimp)
  apply (case_tac "c = a"; clarsimp?)
   defer
   apply (frule step_first)
   apply (frule step_first) back
  apply (metis bot_annihilate_seq dual_order.trans flip.unit_of_apply mono_f test_atom test_le)
  apply (subgoal_tac "last x \<le> test b \<and> last x \<le> test d")
   apply (clarsimp)
   apply (subst (asm) unit_of_unit)
   apply (subst (asm) unit_of_unit)
   apply (frule (3) step_meet_seq) back
   apply (clarsimp)
  apply (case_tac "y' = \<bottom>")
    apply (smt (verit, del_insts) Pair_inject le_test order_trans step_atomic step_le)

   apply (smt (verit, del_insts) Pair_inject le_test order_trans preorder_bot_class.bot_least step_atomic step_le)
  using step_last by blast

lemma step_le_first: "step l (a, b) \<le> step l' (x, y) \<Longrightarrow> a = x"
  apply (frule first_le)
  by (metis dual_order.trans le_test prod.inject seq_atomic.step_le seq_atomic_axioms)

lemma step_le_last: "step l (a,b) \<le> step l' (x,y) \<Longrightarrow> b = y"
  apply (drule step_last)
  by (meson last_step' order_trans test_le)

lemma step_not_bot [simp]: " step l (a, b) \<notin> \<down> \<bottom>"
  apply (clarsimp simp: in_down_iff)
  by (metis dual_order.trans labels.distinct(1) le_test preorder_bot_class.bot_least step_le)

lift_definition datomic :: "(labels \<times> 'b \<times> 'b) set \<Rightarrow> 'a downset"  is
                           "\<lambda>S. \<Down>((\<lambda>x. step (fst x) (snd x)) ` S) \<union> \<down>\<bottom> "
  by (clarsimp simp: down_sup_distrib down_union_distrib)

lemma step_le_bex[simp, elim!]: "(a, aa, b) \<in> p \<Longrightarrow> c \<le> step a (aa, b) \<Longrightarrow> (\<exists>x\<in>p. c \<le> step (fst x) (snd x))"

  by (metis fst_conv snd_conv)

sublocale step_atomic: abstract_atomic_commands datomic
  apply (standard)
      apply (clarsimp simp: inj_def)
  apply (transfer)
                 apply (intro set_eqI iffI; clarsimp)
                  apply (drule_tac x="step a (aa,b)" in set_eqD1[rotated]; clarsimp?)
        apply (clarsimp simp: downset_set_def'  )
       apply (clarsimp simp: in_Down_iff)
  apply (metis dual_order.trans le_test seq_atomic.step_le seq_atomic_axioms)
                 apply (drule sym, drule_tac x="step a (aa,b)" in set_eqD1[rotated]; clarsimp?)
       apply (clarsimp simp: downset_set_def')

      apply (clarsimp simp: in_Down_iff)
  apply (metis dual_order.trans le_test seq_atomic.step_le seq_atomic_axioms)

     apply (clarsimp simp: sup_downset_def, transfer)
                apply (safe; clarsimp?)[1]
                  apply (clarsimp simp: downset_set_def' in_down_iff)
                  apply (elim disjE; clarsimp?)
        apply (metis fst_conv order_refl snd_conv)

      apply (clarsimp simp: downset_set_def')+
  apply (metis Un_iff fst_conv snd_conv)
  apply (simp add: down_union_distrib image_Un)+
    apply (clarsimp simp: inf_downset_def, transfer)
 apply (safe; clarsimp?)[1]
      apply (clarsimp simp: downset_set_def')

          apply (fastforce simp: down_union_distrib image_Un down_image_iff )+
    apply (clarsimp simp: down_image_iff)
    apply (clarsimp simp: in_down_iff)
    apply (frule (1) step_meet') back
  apply (elim disjE; clarsimp?)

              apply (transfer; clarsimp)
             apply (clarsimp simp: less_eq_downset_def, transfer, clarsimp)
  apply (safe; clarsimp simp: downset_set_def')[1]
  apply (metis fst_eqD snd_eqD subsetD)
  apply (drule_tac c="step a (aa,b)" in subsetD)
   apply (clarsimp)+
  by (metis in_down_iff order_refl step_meet' step_not_bot)

sublocale seq_elem_fiter: iteration_finite_distrib convolute conv_test_pre.nil
  apply (standard)
  using conv_seq_distrib.seq_nondet_distrib by presburger

sublocale seq_elem_iter: iteration_infinite_distrib convolute conv_test_pre.nil
  apply (standard)
  using conv_seq_Distrib.seq_Nondet_distrib by presburger

end

end


theory CorrectnessResourced
  imports ResourcedDenotational Launchbury
begin

theorem correctness:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and     "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>"
  shows   "\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<N>\<lbrakk>z\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>" and "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>"
  using assms
proof(nominal_induct arbitrary: \<rho> rule:reds.strong_induct)
case Lambda
  case 1 show ?case..
  case 2 show ?case..
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e')
  have Gamma_subset: "domA \<Gamma> \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF Application.hyps(8)])

  case 1
  hence prem1: "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>" and  "x \<in> set L \<union> domA \<Gamma>" by auto
  moreover
  note reds_pres_closed[OF Application.hyps(8) prem1]
  moreover
  note reds_doesnt_forget[OF Application.hyps(8)]
  moreover
  have "fv (e'[y::=x]) \<subseteq> fv (Lam [y]. e') \<union> {x}"
    by (auto simp add: fv_subst_eq)
  ultimately
  have prem2: "fv (\<Delta>, e'[y::=x]) \<subseteq> set L \<union> domA \<Delta>" by auto

  have *: "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) x \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) x"
  proof(cases "x \<in> domA \<Gamma>")
    case True
    thus ?thesis
      using fun_belowD[OF Application.hyps(10)[OF prem1], where \<rho>1 = \<rho> and x = x]
      by simp
  next
    case False
    from False \<open>x \<in> set L \<union> domA \<Gamma>\<close> reds_avoids_live[OF Application.hyps(8)]
    show ?thesis by (auto simp add: lookup_HSem_other)
  qed

  {
  fix r
  have "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> ((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r \<down>CFn (\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) x)\<cdot>r"
    by (rule CEApp_no_restr)
  also have "((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)) \<sqsubseteq> ((\<N>\<lbrakk> Lam [y]. e' \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>))"
    using Application.hyps(9)[OF prem1].
  also note \<open>((\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) x) \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) x\<close>
  also have "(\<N>\<lbrakk> Lam [y]. e' \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> (CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e' \<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>\<rho>)(y := v)\<^esub>)))"
    by (rule CELam_no_restr)
  also have "CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e' \<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>\<rho>)(y := v)\<^esub>)) \<down>CFn ((\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) x) = (\<N>\<lbrakk> e' \<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>\<rho>)(y := (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) x)\<^esub>)"
    by simp
  also have "\<dots> = (\<N>\<lbrakk> e'[y ::= x] \<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>\<rho>)\<^esub>)"
    unfolding ESem_subst..
  also have "\<dots> \<sqsubseteq> \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>"
    using Application.hyps(12)[OF prem2].
  finally
  have "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> (\<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>)\<cdot>r" by this (intro cont2cont)+
  }
  thus ?case by (rule cfun_belowI)

  show "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` (domA \<Gamma>) \<sqsubseteq> (\<N>\<lbrace>\<Theta>\<rbrace>\<rho>)  f|` (domA \<Gamma>)"
    using Application.hyps(10)[OF prem1]
          env_restr_below_subset[OF Gamma_subset Application.hyps(13)[OF prem2]]
    by (rule below_trans)
next
case (Variable \<Gamma> x e L \<Delta> z)
  hence [simp]:"x \<in> domA \<Gamma>"
    by (metis domA_from_set map_of_SomeD)

  case 2

  have "x \<notin> domA \<Delta>"
    by (rule reds_avoids_live[OF Variable.hyps(2)], simp_all)

  have subset: "domA (delete x \<Gamma>) \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF Variable.hyps(2)])

  let "?new" = "domA \<Delta> - domA \<Gamma>"
  have "fv (delete x \<Gamma>, e) \<union> {x} \<subseteq> fv (\<Gamma>, Var x)"
    by (rule fv_delete_heap[OF \<open>map_of \<Gamma> x = Some e\<close>])
  hence prem: "fv (delete x \<Gamma>, e) \<subseteq> set (x # L) \<union> domA (delete x \<Gamma>)" using 2 by auto
  hence fv_subset: "fv (delete x \<Gamma>, e) - domA (delete x \<Gamma>) \<subseteq> - ?new"
    using reds_avoids_live'[OF Variable.hyps(2)] by auto

  have "domA \<Gamma> \<subseteq> (-?new)" by auto

  have "\<N>\<lbrace>\<Gamma>\<rbrace>\<rho> = \<N>\<lbrace>(x,e) # delete x \<Gamma>\<rbrace>\<rho>"
    by (rule HSem_reorder[OF map_of_delete_insert[symmetric, OF Variable(1)]])
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>(domA (delete x \<Gamma>))\<^esub> (\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<rho>'))( x := \<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>'\<^esub>))"
    by (rule iterative_HSem, simp)
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>(domA (delete x \<Gamma>))\<^esub> (\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<rho>'))( x := \<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<rho>'\<^esub>))"
    by (rule iterative_HSem', simp)
  finally
  have "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>)f|` (- ?new) \<sqsubseteq> (...) f|` (- ?new)" by (rule ssubst) (rule below_refl)
  also have "\<dots> \<sqsubseteq> (\<mu> \<rho>'. (\<rho> ++\<^bsub>domA \<Delta>\<^esub> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>'))( x := \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>'\<^esub>)) f|` (- ?new)"
  proof (induction rule: parallel_fix_ind[where P ="\<lambda> x y. x f|` (- ?new) \<sqsubseteq> y f|` (- ?new)"])
    case 1 show ?case by simp
  next
    case 2 show ?case ..
  next
    case (3 \<sigma> \<sigma>')
    hence "\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>\<^esub> \<sqsubseteq> \<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>'\<^esub>"
      and "(\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>) f|` domA (delete x \<Gamma>) \<sqsubseteq> (\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>') f|` domA (delete x \<Gamma>)"
      using fv_subset by (auto intro: ESem_fresh_cong_below HSem_fresh_cong_below  env_restr_below_subset[OF _ 3])
    from below_trans[OF this(1) Variable(3)[OF prem]] below_trans[OF this(2) Variable(4)[OF prem]]
    have  "\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>\<^esub> \<sqsubseteq> \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<sigma>'\<^esub>"
       and "(\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<sigma>) f|` domA (delete x \<Gamma>) \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<sigma>') f|` domA (delete x \<Gamma>)".
    thus ?case
      using subset
      by (auto intro!: fun_belowI simp add: lookup_override_on_eq  lookup_env_restr_eq elim: env_restr_belowD)
  qed
  also have "\<dots> = (\<mu> \<rho>'. (\<rho> ++\<^bsub>domA \<Delta>\<^esub> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>'))( x := \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<rho>'\<^esub>)) f|` (-?new)"
    by (rule arg_cong[OF iterative_HSem'[symmetric], OF \<open>x \<notin> domA \<Delta>\<close>])
  also have "\<dots> = (\<N>\<lbrace>(x,z) # \<Delta>\<rbrace>\<rho>)  f|` (-?new)"
    by (rule arg_cong[OF iterative_HSem[symmetric], OF \<open>x \<notin> domA \<Delta>\<close>])
  finally
  show le: ?case by (rule env_restr_below_subset[OF \<open>domA \<Gamma> \<subseteq> (-?new)\<close>]) (intro cont2cont)+

  have "\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> (\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) x" by (rule CESem_simps_no_tick)
  also have "\<dots> \<sqsubseteq> (\<N>\<lbrace>(x, z) # \<Delta>\<rbrace>\<rho>) x"
    using fun_belowD[OF le, where x = x] by simp
  also have "\<dots> = \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>(x, z) # \<Delta>\<rbrace>\<rho>\<^esub>"
    by (simp add: lookup_HSem_heap)
  finally
  show "\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>(x, z) # \<Delta>\<rbrace>\<rho>\<^esub>"  by this (intro cont2cont)+
next
case (Bool b)
  case 1
  show ?case by simp
  case 2
  show ?case by simp
next
case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> z)
  have Gamma_subset: "domA \<Gamma> \<subseteq> domA \<Delta>"
    by (rule reds_doesnt_forget[OF IfThenElse.hyps(1)])

  let ?e = "if b then e\<^sub>1 else e\<^sub>2"

  case 1

  hence prem1: "fv (\<Gamma>, scrut) \<subseteq> set L \<union> domA \<Gamma>"
    and prem2: "fv (\<Delta>, ?e) \<subseteq> set L \<union> domA \<Delta>"
    and "fv ?e \<subseteq> domA \<Gamma> \<union> set L"
    using new_free_vars_on_heap[OF IfThenElse.hyps(1)] Gamma_subset by auto

  {
  fix r
  have "(\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> CB_project\<cdot>((\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r)"
    by (rule CESem_simps_no_tick)
  also have "\<dots> \<sqsubseteq> CB_project\<cdot>((\<N>\<lbrakk> Bool b \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r)"
    by (intro monofun_cfun_fun monofun_cfun_arg  IfThenElse.hyps(2)[OF prem1])
  also have "\<dots> = (\<N>\<lbrakk> ?e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r" by (cases r) simp_all
  also have "\<dots> \<sqsubseteq> (\<N>\<lbrakk> ?e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>)\<cdot>r"
    proof(rule monofun_cfun_fun[OF ESem_fresh_cong_below_subset[OF  \<open>fv ?e \<subseteq> domA \<Gamma> \<union> set L\<close> Env.env_restr_belowI]])
      fix x
      assume "x \<in> domA \<Gamma> \<union> set L"
      thus "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) x \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) x"
      proof(cases "x \<in> domA \<Gamma>")
        assume "x \<in> domA \<Gamma>"
        from IfThenElse.hyps(3)[OF prem1]
        have "((\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma>) x \<sqsubseteq> ((\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>) x" by (rule fun_belowD)
        with \<open>x \<in> domA \<Gamma>\<close> show ?thesis by simp
      next
        assume "x \<notin> domA \<Gamma>"
        from this \<open>x \<in> domA \<Gamma> \<union> set L\<close> reds_avoids_live[OF IfThenElse.hyps(1)]
        show ?thesis
          by (simp add: lookup_HSem_other)
      qed
    qed
  also have "\<dots> \<sqsubseteq> (\<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>)\<cdot>r"
    by (intro monofun_cfun_fun monofun_cfun_arg IfThenElse.hyps(5)[OF prem2])
  finally
  have "(\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> (\<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Theta>\<rbrace>\<rho>\<^esub>)\<cdot>r" by this (intro cont2cont)+
  }
  thus ?case  by (rule cfun_belowI)

  show "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` (domA \<Gamma>) \<sqsubseteq> (\<N>\<lbrace>\<Theta>\<rbrace>\<rho>)  f|` (domA \<Gamma>)"
    using IfThenElse.hyps(3)[OF prem1]
          env_restr_below_subset[OF Gamma_subset IfThenElse.hyps(6)[OF prem2]]
    by (rule below_trans)
next
case (Let as \<Gamma> L body \<Delta> z)
  case 1
  have *: "domA as \<inter> domA \<Gamma> = {}" by (metis Let.hyps(1) fresh_distinct)

  have "fv (as @ \<Gamma>, body) - domA (as @ \<Gamma>) \<subseteq> fv (\<Gamma>, Let as body) - domA \<Gamma>"
    by auto
  with 1 have prem: "fv (as @ \<Gamma>, body)  \<subseteq> set L \<union>  domA (as @ \<Gamma>)" by auto

  have f1: "atom ` domA as \<sharp>* \<Gamma>"
    using Let(1) by (simp add: set_bn_to_atom_domA)

  have "\<N>\<lbrakk> Let as body \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<N>\<lbrakk> body \<rbrakk>\<^bsub>\<N>\<lbrace>as\<rbrace>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>"
     by (rule CESem_simps_no_tick)
  also have "\<dots> =  \<N>\<lbrakk> body \<rbrakk>\<^bsub>\<N>\<lbrace>as @ \<Gamma>\<rbrace>\<rho>\<^esub>"
    by (rule arg_cong[OF HSem_merge[OF f1]])
  also have "\<dots> \<sqsubseteq>  \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
    by (rule Let.hyps(4)[OF prem])
  finally
  show ?case  by this (intro cont2cont)+

  have "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` (domA \<Gamma>) = (\<N>\<lbrace>as\<rbrace>(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>)) f|` (domA \<Gamma>)"
    unfolding env_restr_HSem[OF *]..
  also have "\<N>\<lbrace>as\<rbrace>(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) = (\<N>\<lbrace>as @ \<Gamma>\<rbrace>\<rho>)"
    by (rule HSem_merge[OF f1])
  also have "\<dots> f|` domA \<Gamma> \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>"
    by (rule env_restr_below_subset[OF _ Let.hyps(5)[OF prem]]) simp
  finally
  show "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>) f|` domA \<Gamma> \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>\<rho>) f|` domA \<Gamma>".
qed

corollary correctness_empty_env:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and     "fv (\<Gamma>, e) \<subseteq> set L"
  shows   "\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<sqsubseteq> \<N>\<lbrakk>z\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>" and "\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>"
proof-
  from assms(2) have "fv (\<Gamma>, e) \<subseteq> set L \<union>  domA \<Gamma>" by auto
  note corr = correctness[OF assms(1) this, where \<rho> = "\<bottom>"]

  show "\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<sqsubseteq> \<N>\<lbrakk> z \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>" using corr(1).

  have "\<N>\<lbrace>\<Gamma>\<rbrace> = (\<N>\<lbrace>\<Gamma>\<rbrace>) f|` domA \<Gamma> "
    using env_restr_useless[OF HSem_edom_subset, where \<rho>1 = "\<bottom>"] by simp
  also have "\<dots> \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>) f|` domA \<Gamma>" using corr(2).
  also have "\<dots> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>" by (rule env_restr_below_itself)
  finally show "\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>" by this (intro cont2cont)+
qed

end


subsection \<open>Arithmetizing equations are Diophantine\<close>

theory Equation_Setup imports "../Register_Machine/RegisterMachineSpecification"
          "../Diophantine/Diophantine_Relations"

begin

locale register_machine =
  fixes p :: program
    and n :: nat
  assumes p_nonempty: "length p > 0"
      and valid_program: "program_register_check p n"
  assumes n_gt_0: "n > 0"

begin

  definition m :: "nat" where
    "m \<equiv> length p - 1"

  lemma modifies_yields_valid_register:
    assumes "k < length p"
    shows "modifies (p!k) < n"
  proof -
    have "instruction_register_check n (p!k)"
      using valid_program assms list_all_length program_register_check.simps by auto

    thus ?thesis by (cases "p!k", auto simp: n_gt_0)
  qed

end

locale rm_eq_fixes = register_machine +
  fixes a b c d e f :: "nat"
    and q :: nat
    and r z :: "register \<Rightarrow> nat"
    and s :: "state \<Rightarrow> nat"

end


theory Iterator
imports
  It_to_It
  SetIteratorOperations
  SetIteratorGA
  Proper_Iterator
  Gen_Iterator
  Idx_Iterator
begin

  text \<open>Folding over a list created by a proper iterator can be replaced
    by a single iteration\<close>
  lemma proper_it_to_list_opt[refine_transfer_post_subst]:
    assumes PR: "proper_it' it it'"
    shows "foldli o it_to_list it \<equiv> it'"
  proof (rule eq_reflection, intro ext)
    fix s c f \<sigma>

    obtain l where "it s = foldli l" and "it' s = foldli l"
      by (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
    thus "(foldli o it_to_list it) s c f \<sigma> = it' s c f \<sigma>"
      by (simp add: comp_def it_to_list_def)
  qed

  lemma iterator_cnv_to_comp[refine_transfer_post_simp]:
    "foldli (it_to_list it x) = (foldli o it_to_list it) x"
    by auto

  declare idx_iteratei_eq_foldli[autoref_rules]

end


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

theory CreateIRQCaps_SI
imports
  "DSpecProofs.IRQ_DP"
  ObjectInitialised_SI
  RootTask_SI
  SysInit_SI
begin

(*****************
 * Helper lemmas *
 *****************)

lemma si_cnode_caps:
  "si_cnode_cap = si_cspace_cap"
  by (simp add: si_cnode_cap_def si_cspace_cap_def)

lemma hoare_grab_exs2:
  "(\<And>x. P x \<Longrightarrow> \<lbrace>P' x\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x \<and> P' x s\<rbrace> f \<lbrace>Q\<rbrace>"
  by (fastforce simp: valid_def)

lemma sep_map_irq_sep_irq_node:
  "(irq \<mapsto>irq k_irq_table irq \<and>* R) s
  \<Longrightarrow> sep_irq_node s irq = Some (k_irq_table irq)"
  by (fastforce simp: sep_map_irq_def sep_conj_def
                      sep_disj_sep_state_def sep_state_disj_def
                      plus_sep_state_def sep_state_add_def
                      map_disj_def map_add_Some_iff)

(*********************************************************************************
 * A new definition of si_irq_nodes that states that the mapping is injective. *
 *********************************************************************************)

lemma sep_map_o_distinct:
  "(obj_id \<mapsto>o obj \<and>* obj_id' \<mapsto>o obj') s \<Longrightarrow> obj_id \<noteq> obj_id'"
  by (fastforce simp: sep_map_o_def sep_map_general_def sep_conj_def object_to_sep_state_def
                      sep_disj_sep_state_def sep_state_disj_def
                      map_disj_def dom_def disjoint_iff_not_equal)

lemma sep_any_map_o_false_eq:
  "(obj_id \<mapsto>o - \<and>* obj_id \<mapsto>o -) = sep_false"
  by (fastforce simp: sep_any_def sep_map_o_def sep_map_general_def sep_conj_def
                      object_to_sep_state_def sep_disj_sep_state_def sep_state_disj_def
                      map_disj_def dom_def disjoint_iff_not_equal)

lemma sep_any_map_o_false:
  "(obj_id \<mapsto>o - \<and>* obj_id \<mapsto>o -) s \<Longrightarrow> False"
  by (simp add: sep_any_map_o_false_eq)

lemma sep_map_o_false:
  "(obj_id \<mapsto>o obj \<and>* obj_id \<mapsto>o obj') s \<Longrightarrow> False"
  by (metis sep_map_o_distinct)

lemma sep_map_o_any_distinct_list:
  "((f x) \<mapsto>o - \<and>* \<And>* map (\<lambda>x. (f x) \<mapsto>o -) xs) s
  \<Longrightarrow> x \<notin> set xs"
  apply clarsimp
  apply (subst (asm) sep_list_conj_map_remove1, assumption)
  apply (sep_drule sep_any_map_o_false)
  apply clarsimp
  done

lemma sep_any_map_o_inj_on:
  "(\<And>* map (\<lambda>x. (f x) \<mapsto>o -) xs) s
  \<Longrightarrow> inj_on f (set xs)"
  apply (induct xs arbitrary: s)
   apply clarsimp
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: sep_conj_def)
  apply clarsimp
  apply (frule sep_map_o_any_distinct_list)
  apply simp
  done

lemma sep_any_map_o_inj_on_set:
  "\<lbrakk>(\<And>* x \<in> A. (f x) \<mapsto>o -) s; finite A\<rbrakk>
  \<Longrightarrow> inj_on f A"
  apply (drule sep_map_set_conj_sep_list_conj [where P="\<lambda>x. (f x) \<mapsto>o -"])
  apply clarsimp
  apply (erule sep_any_map_o_inj_on)
  done

lemma sep_map_o_inj_on_set:
  "\<lbrakk>(\<And>* x \<in> A. (f x) \<mapsto>o obj) s; finite A\<rbrakk>
  \<Longrightarrow> inj_on f A"
  apply (rule sep_any_map_o_inj_on_set [rotated, where s=s], assumption)
  apply (erule sep_map_set_conj_impl)
   apply (fastforce simp: sep_any_def)
  apply simp
  done

lemma sep_conj_existL:
  "(P \<and>* Q) s \<Longrightarrow> \<exists>s. P s"
  by (auto simp: sep_conj_def)

lemma sep_conj_existR:
  "(P \<and>* Q) s \<Longrightarrow> \<exists>s. Q s"
  by (auto simp: sep_conj_def)

lemma si_irq_nodes_def2:
  "si_irq_nodes spec =
     (\<lambda>s. \<exists>k_irq_table. inj_on k_irq_table (used_irqs spec) \<and>
                        (\<And>* irq\<in>used_irqs spec. irq \<mapsto>irq k_irq_table irq \<and>*
                                                 k_irq_table irq \<mapsto>o IRQNode empty_irq_node) s)"
  apply (rule ext)
  apply (clarsimp simp: si_irq_nodes_def)
  apply (rule iffI)
   apply clarsimp
   apply (rule_tac x=k_irq_table in exI, simp)
   apply (subst (asm) sep.prod.distrib)
   apply (drule sep_conj_existR, clarsimp)
    apply (erule sep_map_o_inj_on_set) (* Why doesn't sep_rule work? *)
   apply simp
  apply blast
  done

(*******************************************
 * The actual proofs about create_irq_caps *
 *******************************************)

lemma well_formed_default_irq_node_empty:
  "\<lbrakk>well_formed spec; irq \<in> used_irqs spec\<rbrakk>
    \<Longrightarrow> object_at (\<lambda>obj. object_default_state obj = IRQNode empty_irq_node) (cdl_irq_node spec irq) spec"
  apply (frule (1) well_formed_used_irqs_have_irq_node, clarsimp)
  apply (frule (1) well_formed_irq_is_irq_node)
  apply (frule (1) well_formed_size_irq_node)
  apply (clarsimp simp: object_at_def empty_irq_node_def object_default_state_def2
                        is_irq_node_def object_size_bits_def
                 split: cdl_object.splits)
  done

lemma create_irq_cap_sep:
  "\<lbrace>\<guillemotleft>(si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
      irq \<mapsto>irq kernel_irq_id \<and>*
      kernel_irq_id \<mapsto>o (IRQNode empty_irq_node) \<and>*
      si_objects \<and>* R\<guillemotright> and
    K(well_formed spec \<and>
      irq \<in> used_irqs spec \<and>
      t' (cdl_irq_node spec irq) = Some kernel_irq_id \<and>
      irq_caps irq = Some free_cptr \<and>
      free_cptr < 2 ^ si_cnode_size)\<rbrace>
   create_irq_cap spec (irq, free_cptr)
   \<lbrace>\<lambda>_.
    \<guillemotleft>irq_empty spec t' irq \<and>*
     si_irq_cap_at irq_caps spec irq \<and>*
     si_objects \<and>*
     R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm, clarsimp)
  apply (frule (1) well_formed_used_irqs_have_irq_node, clarsimp)
  apply (frule (1) well_formed_default_irq_node_empty, clarsimp simp: object_at_def)
  apply (clarsimp simp: create_irq_cap_def si_objects_def si_cnode_caps
                        irq_empty_def irq_initialised_general_def
                        si_irq_cap_at_def sep_conj_assoc)
  apply (wp add: hoare_drop_imp sep_wp: seL4_IRQHandler_IRQControl_Get, simp)
  apply (rule conjI)
   apply sep_solve
  apply (simp add: offset_slot_si_cnode_size' guard_equal_si_cspace_cap word_bits_def)
  done

lemma word_upto_enum_sorted:
  "sorted [(x::('a::len) word) .e. y]"
proof (induct "fromEnumAlt y" arbitrary: x y)
  case 0
    then show ?case by (simp add: upto_enum_def)
  next case (Suc d)
    have d_prev: "d = fromEnumAlt (y - 1)"
      using Suc.hyps
      apply clarsimp
      apply (subst unat_minus_one; fastforce)
      done
    then show ?case
      using Suc.hyps(1)[where x=x and y="y-1"] Suc.hyps(2)
      apply (simp only: upto_enum_def)
      apply (clarsimp simp: sorted_append)
      by (metis le_def order_le_less_trans order_less_imp_le toEnum_of_nat unat_lt2p
                word_not_le word_unat_less_le)
qed

lemma sorted_list_of_set_eq_filter:
  fixes P::"('a::len) word \<Rightarrow> bool"
  shows "sorted_list_of_set {x. P x} = filter P [minBound .e. maxBound]"
        (is "_ = ?rhs")
proof -
  have rhs_sorted: "sorted ?rhs"
    by (intro sorted_imp_sorted_filter word_upto_enum_sorted)
  moreover have rhs_distinct: "distinct ?rhs"
    by (intro distinct_filter distinct_enum_upto')
  moreover have enum_UNIV: "set [(minBound::'a word) .e. maxBound] = UNIV"
   by (force simp: upto_enum_def minBound_word maxBound_word word_unat.univ unats_def
                   unat_minus_one_word
                   atLeastLessThan_def atLeast_def lessThan_def)
  moreover have rhs_set: "{x. P x} = set ?rhs"
    by (simp only: set_filter enum_UNIV, blast)
  ultimately show ?thesis
    by (metis sorted_list_of_set_already_sorted)
qed

lemma well_formed_spec_used_irqs_compute:
  assumes "well_formed spec"
  shows "used_irq_list_compute spec = used_irq_list spec"
  using assms
  unfolding used_irq_list_compute_def used_irq_list_def used_irqs_def
            sorted_list_of_set_eq_filter minBound_word
  apply (rule_tac filter_cong[OF refl, OF iffI])
   apply (clarsimp simp add: Option.is_none_def)
   apply (frule well_formed_cap_to_irq_object,assumption)
    apply (simp add: well_formed_cdl_irq_node_irq_nodes)
   apply (force dest: well_formed_inj_cdl_irq_node[THEN injD]
                      well_formed_cap_to_irq_object
                simp add: all_caps_def)
  apply (clarsimp simp add: Option.is_none_def well_formed_all_caps_cap_irq)
  done

lemma create_irq_caps_sep_helper:
  "\<lbrace>\<guillemotleft>((\<And>* cptr \<in> set (take (card (used_irqs spec)) free_cptrs).
           ((si_cnode_id, unat cptr) \<mapsto>c NullCap)) \<and>*
      si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* si_irq_nodes spec \<and>* R)  and
   K (well_formed spec \<and>
      list_all (\<lambda>n. n < 2 ^ si_cnode_size) free_cptrs \<and>
      distinct free_cptrs \<and>
      card (used_irqs spec) \<le> length free_cptrs)\<guillemotright> \<rbrace>
  create_irq_caps spec free_cptrs
   \<lbrace>\<lambda>rv s. \<exists>(t'::32 word \<Rightarrow> 32 word option).
    \<guillemotleft>(irqs_empty spec t' (used_irqs spec) \<and>*
      si_irq_caps_at (fst rv) spec (used_irqs spec) \<and>*
      si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* R)
    and K ((map_of (zip (used_irq_list spec) free_cptrs), drop (card (used_irqs spec)) free_cptrs) = rv \<and>
    inj_on t' (used_irq_nodes spec) \<and>
    dom t' = used_irq_nodes spec)\<guillemotright> s\<rbrace>"
  apply clarsimp
  apply (rule hoare_gen_asm_conj)
  apply (clarsimp simp: create_irq_caps_def si_irq_nodes_def2 sep_conj_exists
                        well_formed_spec_used_irqs_compute)
  apply (rule hoare_grab_exs2)
  apply wp
   apply simp
   apply (rule_tac x="(\<lambda>obj_id. Some ((k_irq_table \<circ> inv (cdl_irq_node spec)) obj_id))
                      |` used_irq_nodes spec" in hoare_exI)

   apply (rule_tac P1 = "\<lambda>(irq,free_cptr). (si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
                                           irq \<mapsto>irq k_irq_table irq \<and>*
                                           k_irq_table irq \<mapsto>o IRQNode empty_irq_node" and
                  Q1 = "\<lambda>(irq,free_cptr). irq_empty spec ((\<lambda>obj_id. Some ((k_irq_table \<circ> inv (cdl_irq_node spec)) obj_id))
                                                           |` used_irq_nodes spec) irq \<and>*
                                          si_irq_cap_at (map_of (zip (used_irq_list spec) free_cptrs)) spec irq" and
                  I1 = "si_objects" and
                  R1 = "si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
                        R" in hoare_chain [OF mapM_x_set_sep])
      apply (metis distinct_zipI2)
     apply (clarsimp split:prod.splits)
     apply (clarsimp simp: sep_conj_assoc)
     apply (wp sep_wp: create_irq_cap_sep, simp+)
     apply (rule conjI)
      apply (clarsimp simp: sep_conj_assoc sep_conj_exists)
      apply sep_solve
     apply (frule well_formed_inj_cdl_irq_node)
     apply (frule set_zip_leftD)
     apply (frule in_set_zip2)
     apply (simp add: map_of_zip_tuple_in list_all_iff unat_less_2_si_cnode_size
                      restrict_map_def used_irq_nodes_def)
    apply assumption
   defer
   apply (subst sep_list_conj_sep_map_set_conj [symmetric], erule distinct_zipI2)
   apply (subst (asm) sep_list_conj_sep_map_set_conj [symmetric, where xs = "used_irq_list spec", simplified])
   apply (subst split_beta')
   apply (subst sep_list_conj_map_add)
   apply (subst zip_take_length [symmetric])
   apply (subst split_beta' [symmetric])+
   apply (subst map_zip_snd', simp)

   apply (subst (asm) (3) append_take_drop_id [where n="card (used_irqs spec)" and xs=free_cptrs, symmetric])
   apply (subst map_zip_fst', simp)
   apply (subst sep_list_conj_sep_map_set_conj, fastforce simp: used_irq_list_def)
   apply (simp add: comp_def)
   apply sep_solve

  apply simp
  apply (subst (asm) sep_list_conj_sep_map_set_conj [symmetric], erule distinct_zipI2)
  apply (subst (asm) map_zip_fst', simp)
  apply (subst (asm) sep_list_conj_map_add)
  apply (subst (asm) sep_list_conj_sep_map_set_conj,
         metis used_irq_list_def distinct_sorted_list_of_set)
  apply (subst (asm) sep_list_conj_sep_map_set_conj,
         metis used_irq_list_def distinct_sorted_list_of_set)
  apply (clarsimp simp: irqs_empty_def si_irq_caps_at_def)
  apply (rule conjI)
   apply sep_solve
  apply (frule well_formed_inj_cdl_irq_node)
  apply (fastforce simp: inj_on_def used_irq_nodes_def)
  done

(*****************************************************************************
 * The above lemma has an injection on just the IRQs.                        *
 * We take the above proof, and join it with the result of CreateObjects     *
 * to produce an injection on all objects.                                   *
 *                                                                           *
 * The sum of the two injections "t_irqs" and "t_real" is injective because: *
 *  - Each individual relation is injective                                  *
 *  - The domains are separate                                               *
 *  - The ranges are separate                                                *
 *                                                                           *
 * The first two are easily true.                                            *
 * The last one is hard and only true because we have                        *
     obj_id \<mapsto>o Untyped \<and>* obj_id \<mapsto> IRQ, and so the obj_ids are distinct.   *
 *****************************************************************************)

lemma irq_empty_cong:
  "t (cdl_irq_node spec irq) = t' (cdl_irq_node spec irq)
  \<Longrightarrow> irq_empty spec t irq = irq_empty spec t' irq"
  by (clarsimp simp: irq_empty_def irq_initialised_general_def)

lemma object_empty_cong:
  "t obj_id = t' obj_id
  \<Longrightarrow> object_empty spec t obj_id = object_empty spec t' obj_id"
  by (clarsimp simp: object_empty_def object_initialised_general_def)

lemma si_cap_at_cong:
  "t obj_id = t' obj_id
  \<Longrightarrow> si_cap_at  t si_caps spec dev obj_id = si_cap_at  t' si_caps spec dev obj_id"
  by (clarsimp simp: si_cap_at_def)

lemma irq_empty_map_add:
  "\<lbrakk>dom t' = cdl_irq_node spec ` irqs\<rbrakk>
  \<Longrightarrow> irqs_empty spec t' irqs = irqs_empty spec (t++t') irqs"
  apply (clarsimp simp: irqs_empty_def)
  apply (rule sep.prod.cong, simp)
  apply (subst irq_empty_cong [where t'="t++t'" and t=t'], simp_all)
  by (metis imageI map_add_eval_right)

lemma object_empty_map_add:
  "\<lbrakk>dom t = obj_ids; map_disj t t'\<rbrakk>
  \<Longrightarrow> objects_empty spec t obj_ids = objects_empty spec (t++t') obj_ids"
  apply (clarsimp simp: objects_empty_def)
  apply (rule sep.prod.cong, simp)
  apply (subst object_empty_cong [where t'="t++t'" and t=t], simp_all)
  by (metis map_add_eval_left)

lemma si_caps_at_map_add:
  "\<lbrakk>dom t = obj_ids; map_disj t t'\<rbrakk>
  \<Longrightarrow> si_caps_at t si_caps spec dev obj_ids = si_caps_at (t++t') si_caps spec dev obj_ids"
  apply (clarsimp simp: si_caps_at_def)
  apply (rule sep.prod.cong, simp)
  apply (subst si_cap_at_cong [where t'="t++t'" and t=t], simp_all)
  by (metis map_add_eval_left)

lemma inj_on_map_add:
  "\<lbrakk>inj_on m (dom m); inj_on m' (dom m');
    dom m \<inter> dom m' = {}; ran m \<inter> ran m' = {}; A = dom m \<union> dom m'\<rbrakk>
  \<Longrightarrow> inj_on (m ++ m') A"
  apply (rule inj_onI)
  apply clarsimp
  apply (elim disjE)
     apply (metis inj_on_eq_iff inter_empty_not_both map_add_eval_left')
    apply (metis dom_ran map_add_comm map_add_eval_right orthD1)
   apply (metis dom_ran map_add_comm map_add_eval_right orthD1)
  apply (metis inj_on_def map_add_eval_right)
  done

lemma inter_emptyI:
  "\<lbrakk>\<And>x. x \<in> A \<and> x \<in> B \<Longrightarrow> False\<rbrakk>  \<Longrightarrow> A \<inter> B = {}"
  by auto

lemma ran_inter_emptyI:
  "\<lbrakk>\<And>x a b. f a = Some x \<and> g b = Some x \<Longrightarrow> False\<rbrakk> \<Longrightarrow> ran f \<inter> ran g = {}"
  apply (rule inter_emptyI)
  apply (auto simp: ran_def)
  done

lemma irq_empty_objects_empty_ran_distinct:
  "\<lbrakk>\<guillemotleft>irqs_empty spec t_irq (used_irqs spec) \<and>*
    objects_empty spec t_real {obj_id. real_object_at obj_id spec} \<and>* R\<guillemotright> s;
    well_formed spec;
    inj_on t_irq (cdl_irq_node spec ` used_irqs spec); dom t_irq = cdl_irq_node spec ` used_irqs spec;
    inj_on t_real {obj_id. real_object_at obj_id spec}; dom t_real = {obj_id. real_object_at obj_id spec}\<rbrakk>
  \<Longrightarrow> ran t_real \<inter> ran t_irq = {}"
  apply (frule well_formed_inj_cdl_irq_node)
  apply (clarsimp simp: irqs_empty_def irq_empty_def irq_initialised_general_def
                        objects_empty_def object_empty_def object_initialised_general_def)
  apply (rule ran_inter_emptyI)
  apply clarsimp
  apply (frule domI [where m=t_real])
  apply (frule domI [where m=t_irq])
  apply clarsimp
  apply (rename_tac irq_obj_id obj_id irq)
  apply (subst (asm) sep.prod.remove, simp, assumption)
  apply (subst (asm) sep.prod.remove, simp, fast)
  apply (clarsimp simp: sep_conj_exists sep_conj_assoc)
  apply (sep_drule sep_map_o_false, simp)
  done

lemma si_objects_extra_caps'_split:
  "\<lbrakk>well_formed spec; distinct free_cptrs';
   free_cptrs = drop (card {obj_id. real_object_at obj_id spec}) free_cptrs'\<rbrakk> \<Longrightarrow>
   si_objects_extra_caps' {obj_id. real_object_at obj_id spec} free_cptrs' untyped_cptrs
    =
  ((\<And>* cptr \<in> set (take (card (used_irqs spec)) free_cptrs). (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
   si_objects_extra_caps' (dom (cdl_objects spec)) free_cptrs' untyped_cptrs)"
  apply (frule well_formed_objects_card [symmetric])
  apply (subst (asm) add.commute)
  apply (clarsimp simp: si_objects_extra_caps'_def sep_conj_exists sep_conj_assoc)
  apply (subst take_drop_append [where a="card {obj_id. real_object_at obj_id spec}"
                                   and b="card (used_irqs spec)"])
  apply clarsimp
  apply (subst sep.prod.union_disjoint, (simp add: distinct_take_drop_append)+)
  apply (clarsimp simp: sep_conj_ac)
  done

lemma create_irq_caps_sep:
  "\<lbrace>\<lambda>s. \<exists>t_real.
    \<guillemotleft>(objects_empty spec t_real {obj_id. real_object_at obj_id spec} \<and>*
      si_caps_at t_real orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>*
      si_objects_extra_caps' {obj_id. real_object_at obj_id spec} free_cptrs_orig untyped_cptrs \<and>*
      si_irq_nodes spec \<and>* R)  and
   K (well_formed spec \<and>
      distinct free_cptrs_orig \<and>
      list_all (\<lambda>n. n < 2 ^ si_cnode_size) free_cptrs \<and>
      card (used_irqs spec) \<le> length free_cptrs \<and>
      inj_on t_real {obj_id. real_object_at obj_id spec} \<and>
      dom t_real = {obj_id. real_object_at obj_id spec} \<and>
      dom orig_caps = {obj_id. real_object_at obj_id spec} \<and>
      free_cptrs = drop (card {obj_id. real_object_at obj_id spec}) free_cptrs_orig)\<guillemotright> s\<rbrace>
  create_irq_caps spec free_cptrs
   \<lbrace>\<lambda>rv s. \<exists>(t::32 word \<Rightarrow> 32 word option).
    \<guillemotleft>(objects_empty spec t {obj_id. real_object_at obj_id spec} \<and>*
      irqs_empty spec t (used_irqs spec) \<and>*
      si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_irq_caps_at (fst rv) spec (used_irqs spec) \<and>*
      si_objects \<and>*
      si_objects_extra_caps' (dom (cdl_objects spec)) free_cptrs_orig untyped_cptrs \<and>*
      R) and
    K ((map_of (zip (used_irq_list spec) free_cptrs), drop (card (used_irqs spec)) free_cptrs) = rv \<and>
       inj_on t (dom (cdl_objects spec)) \<and> dom t = dom (cdl_objects spec))\<guillemotright> s\<rbrace>"
  apply (rule hoare_ex_pre)
  apply (rule hoare_gen_lifted_asm)
  apply (elim conjE)
  apply (subst si_objects_extra_caps'_split, assumption+)
  apply (rule hoare_chain [OF create_irq_caps_sep_helper, where orig_caps1=orig_caps])
   apply (rule pred_conjI)
    apply sep_solve
   apply clarsimp
  apply clarsimp
  apply (rule_tac x="t_real ++ t'" in exI)
  apply clarsimp
  apply (frule well_formed_objects_real_or_irq)
  apply (frule well_formed_objects_only_real_or_irq)
  apply (clarsimp simp: used_irq_nodes_def)
  apply (subgoal_tac "map_disj t_real t'")
   apply (rule conjI)
    apply (subst object_empty_map_add [symmetric], assumption+)
    apply (subst irq_empty_map_add [symmetric],simp add: used_irq_nodes_def)
    apply (subst si_caps_at_map_add [symmetric], assumption+)
    apply (clarsimp simp: si_objects_extra_caps'_def sep_conj_exists sep_conj_assoc)
    apply (rule_tac x=untyped_caps in exI)
    apply (rule_tac x=all_available_ids in exI)
    apply sep_solve
   apply (rule conjI)
    apply (rule inj_on_map_add, simp+)
     apply (rule irq_empty_objects_empty_ran_distinct, sep_solve, simp+)
   apply (metis sup_commute)
  apply (clarsimp simp: map_disjI)
  done

end


(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Lifting with applicative functors\<close>

theory Applicative
imports Main
keywords "applicative" :: thy_goal and "print_applicative" :: diag
begin

subsection \<open>Equality restricted to a set\<close>

definition eq_on :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where [simp]: "eq_on A = (\<lambda>x y. x \<in> A \<and> x = y)"

lemma rel_fun_eq_onI: "(\<And>x. x \<in> A \<Longrightarrow> R (f x) (g x)) \<Longrightarrow> rel_fun (eq_on A) R f g"
by auto

lemma rel_fun_map_fun2: "rel_fun (eq_on (range h)) A f g \<Longrightarrow> rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> A f (map_fun h id g)"
  by(auto simp add: rel_fun_def Grp_def eq_onp_def)

lemma rel_fun_refl_eq_onp:
  "(\<And>z. z \<in> f ` X \<Longrightarrow> A z z) \<Longrightarrow> rel_fun (eq_on X) A f f"
  by(auto simp add: rel_fun_def eq_onp_def)

lemma eq_onE: "\<lbrakk> eq_on X a b; \<lbrakk> b \<in> X; a = b \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis" by auto

lemma Domainp_eq_on [simp]: "Domainp (eq_on X) = (\<lambda>x. x \<in> X)"
  by auto

subsection \<open>Proof automation\<close>

lemma arg1_cong: "x = y \<Longrightarrow> f x z = f y z"
by (rule arg_cong)

lemma UNIV_E: "x \<in> UNIV \<Longrightarrow> P \<Longrightarrow> P" .

context begin

private named_theorems combinator_unfold
private named_theorems combinator_repr

private definition "B g f x \<equiv> g (f x)"
private definition "C f x y \<equiv> f y x"
private definition "I x \<equiv> x"
private definition "K x y \<equiv> x"
private definition "S f g x \<equiv> (f x) (g x)"
private definition "T x f \<equiv> f x"
private definition "W f x \<equiv> f x x"

lemmas [abs_def, combinator_unfold] = B_def C_def I_def K_def S_def T_def W_def
lemmas [combinator_repr] = combinator_unfold

private definition "cpair \<equiv> Pair"
private definition "cuncurry \<equiv> case_prod"

private lemma uncurry_pair: "cuncurry f (cpair x y) = f x y"
unfolding cpair_def cuncurry_def by simp

ML_file "applicative.ML"

local_setup \<open>Applicative.setup_combinators
 [("B", @{thm B_def}),
  ("C", @{thm C_def}),
  ("I", @{thm I_def}),
  ("K", @{thm K_def}),
  ("S", @{thm S_def}),
  ("T", @{thm T_def}),
  ("W", @{thm W_def})]\<close>

private attribute_setup combinator_eq =
  \<open>Scan.lift (Scan.option (Args.$$$ "weak" |--
    Scan.optional (Args.colon |-- Scan.repeat1 Args.name) []) >>
    Applicative.combinator_rule_attrib)\<close>

lemma [combinator_eq]: "B \<equiv> S (K S) K" unfolding combinator_unfold .
lemma [combinator_eq]: "C \<equiv> S (S (K (S (K S) K)) S) (K K)" unfolding combinator_unfold .
lemma [combinator_eq]: "I \<equiv> W K" unfolding combinator_unfold .
lemma [combinator_eq]: "I \<equiv> C K ()" unfolding combinator_unfold .
lemma [combinator_eq]: "S \<equiv> B (B W) (B B C)" unfolding combinator_unfold .
lemma [combinator_eq]: "T \<equiv> C I" unfolding combinator_unfold .
lemma [combinator_eq]: "W \<equiv> S S (S K)" unfolding combinator_unfold .

lemma [combinator_eq weak: C]:
  "C \<equiv> C (B B (B B (B W (C (B C (B (B B) (C B (cuncurry (K I))))) (cuncurry K))))) cpair"
unfolding combinator_unfold uncurry_pair .

end (* context *)

method_setup applicative_unfold =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.unfold_wrapper_tac ctxt opt_af))\<close>
  "unfold into an applicative expression"

method_setup applicative_fold =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.fold_wrapper_tac ctxt opt_af))\<close>
  "fold an applicative expression"

method_setup applicative_nf =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.normalize_wrapper_tac ctxt opt_af))\<close>
  "prove an equation that has been lifted to an applicative functor, using normal forms"

method_setup applicative_lifting =
  \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
    SIMPLE_METHOD' (Applicative.lifting_wrapper_tac ctxt opt_af))\<close>
  "prove an equation that has been lifted to an applicative functor"

ML \<open>Outer_Syntax.local_theory_to_proof @{command_keyword "applicative"}
  "register applicative functors"
  (Parse.binding --
    Scan.optional (@{keyword "("} |-- Parse.list Parse.short_ident --| @{keyword ")"}) [] --
    (@{keyword "for"} |-- Parse.reserved "pure" |-- @{keyword ":"} |-- Parse.term) --
    (Parse.reserved "ap" |-- @{keyword ":"} |-- Parse.term) --
    Scan.option (Parse.reserved "rel" |-- @{keyword ":"} |-- Parse.term) --
    Scan.option (Parse.reserved "set" |-- @{keyword ":"} |-- Parse.term) >>
    Applicative.applicative_cmd)\<close>

ML \<open>Outer_Syntax.command @{command_keyword "print_applicative"}
  "print registered applicative functors"
  (Scan.succeed (Toplevel.keep (Applicative.print_afuns o Toplevel.context_of)))\<close>

attribute_setup applicative_unfold =
  \<open>Scan.lift (Scan.option Parse.name >> Applicative.add_unfold_attrib)\<close>
  "register rules for unfolding into applicative expressions"

attribute_setup applicative_lifted =
  \<open>Scan.lift (Parse.name >> Applicative.forward_lift_attrib)\<close>
  "lift an equation to an applicative functor"

subsection \<open>Overloaded applicative operators\<close>

consts
  pure :: "'a \<Rightarrow> 'b"
  ap :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"

bundle applicative_syntax
begin
  notation ap (infixl "\<diamondop>" 70)
end

hide_const (open) ap

end


theory basicprime
  imports
    HHLProver.ContinuousInv
    HHLProver.BigStepParallel
    HHLProver.Complementlemma
begin

text \<open>Variables\<close>

definition T :: char where "T = CHR ''t''"
definition X :: char where "X = CHR ''x''"
definition Y :: char where "Y = CHR ''y''"
definition Z :: char where "Z = CHR ''z''"
definition J :: char where "J = CHR ''j''"
definition L :: char where "L = CHR ''l''"
definition M :: char where "M = CHR ''m''"
definition N :: char where "N = CHR ''n''"

lemma vars_distinct [simp]: "T \<noteq> X" "T \<noteq> Y" "T \<noteq> Z" "T \<noteq> J" "T \<noteq> L" "T \<noteq> M" "T \<noteq> N"
                            "X \<noteq> T" "X \<noteq> Y" "X \<noteq> Z" "X \<noteq> J" "X \<noteq> L" "X \<noteq> M" "X \<noteq> N"
                            "Y \<noteq> T" "Y \<noteq> X" "Y \<noteq> Z" "Y \<noteq> J" "Y \<noteq> L" "Y \<noteq> M" "Y \<noteq> N"
                            "Z \<noteq> T" "Z \<noteq> X" "Z \<noteq> Y" "Z \<noteq> J" "Z \<noteq> L" "Z \<noteq> M" "Z \<noteq> N"
                            "J \<noteq> T" "J \<noteq> X" "J \<noteq> Y" "J \<noteq> Z" "J \<noteq> L" "J \<noteq> M" "J \<noteq> N"
                            "L \<noteq> T" "L \<noteq> X" "L \<noteq> Y" "L \<noteq> Z" "L \<noteq> J" "L \<noteq> M" "L \<noteq> N"
                            "M \<noteq> T" "M \<noteq> X" "M \<noteq> Y" "M \<noteq> Z" "M \<noteq> J" "M \<noteq> L" "M \<noteq> N"
                            "N \<noteq> T" "N \<noteq> X" "N \<noteq> Y" "N \<noteq> Z" "N \<noteq> J" "N \<noteq> L" "N \<noteq> M"
  unfolding T_def X_def Y_def Z_def J_def  L_def M_def N_def by auto

text \<open>
  Analysis of <x' = -x, t' = 1> by explicit solution.
\<close>
lemma exp_1_subst:
  "(state2vec
     (\<lambda>a. (if a = T then \<lambda>s. 1 else ((\<lambda>_ _. 0)(X := \<lambda>s. - s X)) a)
          (vec2state v))) = (\<chi> a. if a = T then 1 else if a = X then -v $ X else 0)" for v
  apply(auto simp add: state2vec_def)
  using vec2state_def by auto

lemma exp_1_deriv_bounded:
  "bounded_linear (\<lambda>v. \<chi> a. if a = T then 0 else if a = X then - v $ X else 0)"
  apply (rule Real_Vector_Spaces.bounded_linear_intro[where K=1])
    apply (auto simp add: plus_vec_def scaleR_vec_def)
  by (simp add: norm_le_componentwise_cart)

lemma exp_1_deriv:
  "((\<lambda>v. \<chi> a. if a = T then 1 else if a = X then - v $ X else 0) has_derivative
      (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then - v $ X else 0)))
     (at x)"
proof -
  have a: "((\<chi> a. if a = T then 1 else if a = X then - y $ X else 0) -
            (\<chi> a. if a = T then 1 else if a = X then - x $ X else 0) -
            (\<chi> a. if a = T then 0 else if a = X then - (y - x) $ X else 0)) = (\<chi> a. 0)" for y
    by (auto simp add: minus_vec_def)
  show ?thesis
    apply (rule has_derivativeI)
     prefer 2
    apply (rule tendstoI)
     apply auto
    subgoal for e
      apply (subst a)
      by (metis (mono_tags, lifting) eventuallyI mult.commute norm_zero
          vector_space_over_itself.scale_zero_left zero_vec_def)
    by (rule exp_1_deriv_bounded)
qed

lemma exp_1_1:
  "\<Turnstile> {\<lambda>s tr. s X > 0 \<and> s T < P}
       Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. - s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
      {\<lambda>s tr. s X > 0}"
  apply (rule Valid_strengthen_post)
  prefer 2
   apply (rule Valid_ode_unique_solution_s_sp[where
              d="\<lambda>s. P - s T" and
              p = "\<lambda>s. (\<lambda>t. s(X := s X * exp (-1 * t), T := s T + t))" ] )
     apply auto
  subgoal for s
    unfolding ODEsol_def has_vderiv_on_def
    apply auto
    apply (rule exI[where x="1"])
    apply auto
     apply (rule has_vector_derivative_projI)
    apply (auto simp add: state2vec_def)
     prefer 2
     apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     apply (auto simp add: has_vector_derivative_def)
    apply (rule has_derivative_eq_rhs)
     apply (fast intro!: derivative_intros)[1]
    by auto
   apply(rule c1_implies_local_lipschitz[where
            f'="(\<lambda>_. Blinfun (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then -v $ X else 0)))"])
       apply (subst exp_1_subst)
      apply (rule has_derivative_eq_rhs)
        apply (rule exp_1_deriv)
       apply (auto simp add: bounded_linear_Blinfun_apply exp_1_deriv_bounded)
  apply(auto simp add: entails_def)
  done

lemma exp_1:
 "\<Turnstile> {\<lambda>s tr. s X > 0}
      Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. - s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
     {\<lambda>s tr. s X > 0}"
  apply(rule Valid_pre_cases)
   apply(rule exp_1_1)
  apply (rule Valid_ode_not) by auto

text \<open>
  Analysis of <x' = x, t' = 1> by explicit solution
\<close>
lemma exp_2_subst:
  "(state2vec
     (\<lambda>a. (if a = T then \<lambda>s. 1 else ((\<lambda>_ _. 0)(X := \<lambda>s. s X)) a)
          (vec2state v))) = ( \<chi> a. if a = T then 1 else if a = X then v $ X else 0)" for v
  apply(auto simp add: state2vec_def)
  using vec2state_def by auto

lemma exp_2_deriv_bounded:
  "bounded_linear (\<lambda>v. \<chi> a. if a = T then 0 else if a = X then v $ X else 0)"
  apply (rule Real_Vector_Spaces.bounded_linear_intro[where K=1])
    apply (auto simp add: plus_vec_def scaleR_vec_def)
  by (simp add: norm_le_componentwise_cart)

lemma exp_2_deriv:
  "((\<lambda>v. \<chi> a. if a = T then 1 else if a = X then v $ X else 0) has_derivative
      (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then v $ X else 0)))
     (at x)"
proof -
  have a: "((\<chi> a. if a = T then 1 else if a = X then y $ X else 0) -
            (\<chi> a. if a = T then 1 else if a = X then x $ X else 0) -
            (\<chi> a. if a = T then 0 else if a = X then (y - x) $ X else 0)) = (\<chi> a. 0)" for y
    by (auto simp add: minus_vec_def)
  show ?thesis
    apply (rule has_derivativeI)
     prefer 2
    apply (rule tendstoI)
     apply auto
    subgoal for e
      apply (subst a)
      by (metis (mono_tags, lifting) eventuallyI mult.commute norm_zero
          vector_space_over_itself.scale_zero_left zero_vec_def)
    by (rule exp_2_deriv_bounded)
qed

lemma exp_2_1:
  "\<Turnstile> {\<lambda>s tr. s X > 0 \<and> s T < P}
       Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
      {\<lambda>s tr. s X > 0}"
  apply (rule Valid_strengthen_post)
  prefer 2
  apply (rule Valid_ode_unique_solution_s_sp[where
            d="\<lambda>s. P - s T" and
            p = "\<lambda>s. (\<lambda>t. s(X := s X * exp t, T := s T + t))" ] )
     apply auto
  subgoal for s
    unfolding ODEsol_def has_vderiv_on_def
    apply auto
    apply (rule exI[where x="1"])
    apply auto
     apply (rule has_vector_derivative_projI)
    apply (auto simp add: state2vec_def)
    prefer 2
    apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     apply (auto simp add: has_vector_derivative_def)
    apply (rule has_derivative_eq_rhs)
     apply (fast intro!: derivative_intros)[1]
    by auto
  apply(rule c1_implies_local_lipschitz[where
            f'="(\<lambda>_. Blinfun (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then v $ X else 0)))"])
       apply (subst exp_2_subst)
      apply (rule has_derivative_eq_rhs)
        apply (rule exp_2_deriv)
       apply (auto simp add: bounded_linear_Blinfun_apply exp_2_deriv_bounded)
  apply (auto simp add: entails_def)
  done

lemma exp_2:
  "\<Turnstile> {\<lambda>s tr. s X > 0}
       Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
     {\<lambda>s tr. s X > 0}"
  apply(rule Valid_pre_cases)
   apply(rule exp_2_1)
  apply(rule Valid_ode_not) by auto

text \<open>
  Analysis of <x' = -x + 1, t' = 1> by explicit solution.
\<close>
lemma exp_3_subst:
  "(state2vec
      (\<lambda>a. (if a = T then \<lambda>s. 1 else ((\<lambda>_ _. 0)(X := \<lambda>s. 1 - s X)) a)
      (vec2state v))) = (\<chi> a. if a = T then 1 else if a = X then 1 - v $ X else 0)" for v
  apply(auto simp add: state2vec_def)
  using vec2state_def by auto

lemma exp_3_deriv_bounded:
  "bounded_linear (\<lambda>v. \<chi> a. if a = T then 0 else if a = X then -v $ X else 0)"
  apply (rule Real_Vector_Spaces.bounded_linear_intro[where K=1])
    apply (auto simp add: plus_vec_def scaleR_vec_def)
  by (simp add: norm_le_componentwise_cart)

lemma exp_3_deriv:
  "((\<lambda>v. \<chi> a. if a = T then 1 else if a = X then 1 - v $ X else 0) has_derivative
      (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then -v $ X else 0)))
     (at x)"
proof -
  have a: "((\<chi> a. if a = T then 1 else if a = X then 1 - y $ X else 0) -
            (\<chi> a. if a = T then 1 else if a = X then 1 - x $ X else 0) -
            (\<chi> a. if a = T then 0 else if a = X then -(y - x) $ X else 0)) = (\<chi> a. 0)" for y
    by (auto simp add: minus_vec_def)
  show ?thesis
    apply (rule has_derivativeI)
     prefer 2
    apply (rule tendstoI)
     apply auto
    subgoal for e
      apply (subst a)
      by (metis (mono_tags, lifting) eventuallyI mult.commute norm_zero
          vector_space_over_itself.scale_zero_left zero_vec_def)
    by (rule exp_3_deriv_bounded)
qed

lemma exp_3_1:
  "\<Turnstile> {\<lambda>s tr. s X > 0 \<and> s T < P}
     Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. - s X + 1, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
 {\<lambda>s tr. s X > 0}"
  apply (rule Valid_strengthen_post)
  prefer 2
   apply (rule Valid_ode_unique_solution_s_sp[where
             d="\<lambda>s. P - s T" and
             p = "\<lambda>s. (\<lambda>t. s(X := (s X - 1) * exp (-t) + 1, T := s T + t))" ] )
     apply auto
  subgoal for s
    unfolding ODEsol_def has_vderiv_on_def
    apply auto
    apply (rule exI[where x="1"])
    apply auto
     apply (rule has_vector_derivative_projI)
    apply (auto simp add: state2vec_def)
    prefer 2
apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     apply (auto simp add: has_vector_derivative_def)
    apply (rule has_derivative_eq_rhs)
     apply (fast intro!: derivative_intros)[1]
    by auto
    apply(rule c1_implies_local_lipschitz[where f'="(\<lambda>_. Blinfun (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then -v $ X else 0)))"])
       apply (subst exp_3_subst)
      apply (rule has_derivative_eq_rhs)
       apply (rule exp_3_deriv)
       apply (auto simp add: bounded_linear_Blinfun_apply exp_3_deriv_bounded)
  apply(auto simp add: entails_def)
  subgoal premises pre for s
  proof(cases "s X \<ge> 1")
    case True
    then show ?thesis
      using exp_ge_zero
      by (smt mult_nonneg_nonneg)
  next
    case False
    then have 1:"s X - 1 < 0" by auto
    have 2:"exp (s T - P) > 0" by auto
    have 3:"exp (s T - P) < 1" using pre by auto
    have 4:"(s X - 1) * exp (s T - P) > (s X - 1)"
      using 1 2 3 by auto
    then show ?thesis using pre by auto
  qed
 done

lemma exp_3:
  "\<Turnstile> {\<lambda>s tr. s X > 0}
     Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. -s X + 1, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
 {\<lambda>s tr. s X > 0}"
  apply(rule Valid_pre_cases)
   apply(rule exp_3_1)
  apply(rule Valid_ode_not) by auto

text \<open>
  Analysis of <x' = -y * x, t = 1> by Darboux invariants (with g = -y).
\<close>
lemma exp_4:
  "\<Turnstile> {\<lambda>s tr. s X > 0}
       Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. - s Y * s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
     {\<lambda>s tr. s X > 0}"
  apply (rule Valid_dbx_s_g[where g="\<lambda> s . - s Y"])
    apply clarify
  unfolding vec2state_def
    apply (fast intro!: derivative_intros)[1]
   apply(auto simp add: state2vec_def)
  apply(auto simp add: continuous_on_eq_continuous_within)
  done

text \<open>
  Analysis of <x' = x, t' = 1>, to show x remains non-negative.
\<close>
lemma exp_5_1:
  "\<Turnstile> {\<lambda>s tr. s X \<ge> 0 \<and> s T < P}
       Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
      {\<lambda>s tr. s X \<ge> 0}"
  apply (rule Valid_strengthen_post)
  prefer 2
   apply (rule Valid_ode_unique_solution_s_sp[where
             d="\<lambda>s. P - s T" and
             p = "\<lambda>s. (\<lambda>t. s(X := s X * exp t, T := s T + t))" ] )
     apply auto
  subgoal for s
    unfolding ODEsol_def has_vderiv_on_def
    apply auto
    apply (rule exI[where x="1"])
    apply auto
     apply (rule has_vector_derivative_projI)
    apply (auto simp add: state2vec_def)
    prefer 2
apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     apply (auto simp add: has_vector_derivative_def)
    apply (rule has_derivative_eq_rhs)
     apply (fast intro!: derivative_intros)[1]
    by auto
    apply(rule c1_implies_local_lipschitz[where f'="(\<lambda>_. Blinfun (\<lambda>v. (\<chi> a. if a = T then 0 else if a = X then  v $ X else 0)))"])
       apply (subst exp_2_subst)
      apply (rule has_derivative_eq_rhs)
        apply (rule exp_2_deriv)
       apply (auto simp add: bounded_linear_Blinfun_apply exp_2_deriv_bounded)
  apply(auto simp add: entails_def)
  done

lemma exp_5:
 "\<Turnstile> {\<lambda>s tr. s X \<ge> 0}
      Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s X, T := \<lambda>s. 1))) (\<lambda>s. s T < P)
     {\<lambda>s tr. s X \<ge> 0}"
  apply(rule Valid_pre_cases)
   apply (rule exp_5_1)
   apply (rule Valid_ode_not) by auto

end


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

theory HaskellLemmaBucket
imports
  HaskellLib_H
  NonDetMonadLemmaBucket
begin

lemma map_bits_to_bl:
  "map ((!!) x) [0..<size x] = reverse (to_bl x)"
  by (simp add: map_bits_rev_to_bl)

lemma not_orList_is_replicate:
  "\<not> orList ls \<Longrightarrow> ls = replicate (length ls) False"
proof (induct ls rule: rev_induct)
  case Nil thus ?case unfolding orList_def by simp
next
  case (snoc l ls)

  from snoc.prems have ol: "\<not> orList ls" and nl: "\<not> l" unfolding orList_def by auto
  have "ls = replicate (length ls) False" by (rule snoc.hyps [OF ol])
  thus ?case
    by (rule ssubst) (simp add: nl replicate_app_Cons_same [where xs = "[]", simplified])
qed

lemma andList_Cons:
  assumes al: "andList $ map P (y # ys)"
  shows   "P y"
  using al unfolding andList_def
  by simp (induct rule: rev_induct, simp+)

lemma andList_mapE:
  assumes al: "andList $ map P xs"
  and     xv: "x \<in> set xs"
  shows   "P x"
  using al xv
proof (induct xs arbitrary: x rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc y ys)

  show ?case
  proof (cases "x = y")
    case True
    with snoc.prems show ?thesis by (simp add: andList_def)
  next
    case False
    with snoc.prems show ?thesis
      by (auto simp: andList_def intro!: snoc.hyps)
  qed
qed

lemma andList_to_aligned:
  assumes al: "andList $ map (\<lambda>x. x && mask pageBits = 0) xs"
  and     xv: "x \<in> set xs"
  shows   "is_aligned x pageBits"
proof (subst is_aligned_mask)
  from al show "x && mask pageBits = 0" by (rule andList_mapE) fact
qed

(* minimum/maximum *)

lemma maximum_ge: "x \<in> set b \<Longrightarrow> x \<le> maximum b"
  unfolding maximum_def by (auto intro: Max_ge)

lemma less_minimum_not_in:
  "\<lbrakk> ls \<noteq> []; x < minimum ls \<rbrakk> \<Longrightarrow> x \<notin> set ls"
  unfolding minimum_def by auto

lemma minimum_le_member:
  "\<lbrakk> x \<in> set ls; ls \<noteq> []\<rbrakk> \<Longrightarrow> minimum ls \<le> x"
  unfolding minimum_def
  apply (rule Min_le)
    apply simp
   apply simp
  done

lemma minimum_map_distrib:
  fixes f :: "('a :: linorder) \<Rightarrow> 'a" and ls :: "'a list"
  assumes minf: "\<And>x y. \<lbrakk>x \<in> set ls; y \<in> set ls\<rbrakk> \<Longrightarrow> min (f x) (f y) = f (min x y)"
  and      lsn: "ls \<noteq> []"
  shows "minimum (map f ls) = f (minimum ls)"
  unfolding minimum_def
  apply simp
  apply (rule Min_image_distrib)
    apply (erule (1) minf)
   apply simp
  apply (simp add: lsn)
  done

lemma minimum_enum_upto:
  fixes x :: "'a::len word"
  assumes le: "x \<le> y"
  shows   "minimum [x .e. y] = x"
  unfolding minimum_def using le by (auto intro!: MinI)

lemma break_subsetsD:
  "break f xs = (ys, zs) \<Longrightarrow> set ys \<subseteq> set xs \<and> set zs \<subseteq> set xs"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (fastforce simp: split_def split: if_split_asm)
  done

lemma distinct_prop_breakD:
  "\<lbrakk> distinct_prop P xs; break f xs = (ys, zs) \<rbrakk>
    \<Longrightarrow> \<forall>y \<in> set ys. \<forall>z \<in> set zs. P y z"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (simp add: split_def split: if_split_asm)
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (frule break_subsetsD)
  apply fastforce
  done

lemma stateAssert_wp:
  "\<lbrace>\<lambda>s. P s \<longrightarrow> Q () s\<rbrace> stateAssert P e \<lbrace>Q\<rbrace>"
  by (clarsimp simp: stateAssert_def) wp

lemma haskell_assert_wp:
  "\<lbrace>\<lambda>s. Q \<longrightarrow> P s\<rbrace> haskell_assert Q xs \<lbrace>\<lambda>_. P\<rbrace>"
  by simp wp

lemma init_append_last:
  "xs \<noteq> [] \<Longrightarrow> init xs @ [last xs] = xs"
  apply (induct xs rule: rev_induct)
   apply simp
  apply (simp add: init_def)
  done

lemma init_Snoc[simp]:
  "init (xs @ [x]) = xs"
  by (induct xs) (auto simp: init_def)

lemma init_upto_enum_upt[simp]:
  "init [0.e.n] = [0..<n]"
  by (induct n) (auto simp: init_def)

lemma no_fail_stateAssert:
  "no_fail P (stateAssert P xs)"
  apply (simp add: stateAssert_def)
  apply (rule no_fail_pre, wp no_fail_bind)
  apply simp
  done

lemma empty_fail_stateAssert:
  "empty_fail (stateAssert P s)"
  by (simp add: stateAssert_def assert_def empty_fail_get)

lemma haskell_fail_wp:
  "\<lbrace>\<top>\<rbrace> haskell_fail x \<lbrace>P\<rbrace>"
  by simp

lemma no_fail_haskell_fail [simp, wp]:
  "no_fail \<bottom> (haskell_fail xs)"
  by simp

lemma in_assocs_is_fun:
  "(x \<in> set (assocs f)) = (f (fst x) = snd x)"
  by (cases x) (auto simp add: assocs_def)

lemma fun_is_in_assocs:
  "(f x = y) = ((x,y) \<in> set (assocs f))"
  by (simp add: in_assocs_is_fun)

lemma empty_set_is_null:
  "(set xs = {}) = null xs"
  by (clarsimp simp: null_def)

lemma assert_into_when:
  "(assert P) = (when (\<not> P) (haskell_fail []))"
  by (simp add: assert_def when_def)

lemma const_apply:
  "const x y = x"
  by (simp add: const_def)

lemma const_None_empty:
  "const None = Map.empty"
  by (rule ext, simp add: const_apply)

lemma headM_tailM_Cons:
  "headM (x # xs) = return x"
  "tailM (x # xs) = return xs"
  by (simp add: headM_def tailM_def)+

lemma replicateM_mapM:
  "replicateM n f = mapM (\<lambda>x. f) (replicate n ())"
  by (simp add: replicateM_def mapM_def)

lemma orList_False:
  "(\<not> orList bs) = (set bs \<subseteq> {False})"
  apply (induct bs)
  apply (simp_all add: orList_def foldl_True)
  apply (case_tac a)
  apply (simp_all add: orList_def foldl_True)
  done

lemma Cons_eq_tails:
  "((xs # xxs) = tails ys) = (ys = xs \<and> xxs = tl (tails ys))"
  by (case_tac ys, auto)

lemma findM_on_outcome':
  assumes x: "\<And>x xs. \<lbrace>\<lambda>s. Q None s \<and> x \<in> fn s \<and> set xs \<subseteq> fn s\<rbrace> f x
                     \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> set xs \<subseteq> fn s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. Q None s \<and> set xs \<subseteq> fn s\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (induct xs)
   apply (simp, wp)
  apply (simp, wp)
   apply (rule x)
  apply simp
  done

lemma findM_on_outcome:
  assumes x: "\<And>x ys. x \<in> set xs \<Longrightarrow> \<lbrace>Q None and I\<rbrace> f x \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> I s)\<rbrace>"
  shows      "\<lbrace>Q None and I\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (rule hoare_vcg_precond_imp)
   apply (rule findM_on_outcome' [where fn="\<lambda>s. if I s then set xs else {}"])
   apply (case_tac "x \<notin> set xs")
    apply simp
   apply (simp cong: rev_conj_cong)
   apply (case_tac "\<not> set xsa \<subseteq> set xs")
    apply simp
   apply simp
   apply (rule hoare_vcg_precond_imp)
    apply (rule hoare_post_imp [OF _ x])
     apply clarsimp
    apply assumption
   apply simp
  apply simp
  done

lemma in_set_tailsD: "xs \<in> set (tails ys) \<Longrightarrow> set xs \<subseteq> set ys"
  apply (induct ys)
   apply simp
  apply simp
  apply (erule disjE)
   apply simp
  apply simp
  apply blast
  done

lemma notin_set_tails_set:
  "x \<notin> set xs \<Longrightarrow> \<forall>xs' \<in> set (tails xs). \<forall>x' \<in> set xs'. x \<noteq> x'"
  by (fastforce dest!: in_set_tailsD)

lemma set_tails_set: "(set (tails v) \<subseteq> {x. set x \<subseteq> S}) = (set v \<subseteq> S)"
  apply (induct v, simp_all)
  done

lemma filter_assocs_Cons:
  fixes v :: "('a :: len) word" shows
  "\<lbrakk> f (v, g v); \<forall>x < v. \<not> f (x, g x) \<rbrakk> \<Longrightarrow>
     filter f (assocs g) = (v, g v) # tl (filter f (assocs g))"
  apply (simp add: assocs_def)
  apply (cut_tac v=v in enum_word_div)
  apply clarsimp
  apply (subst map_cong [OF _ refl], assumption)+
  apply (simp(no_asm))
  apply simp
  done

lemma snd_stateAssert_after:
  "\<not> snd ((do _ \<leftarrow> f; stateAssert R vs od) s) \<Longrightarrow>
  \<not>snd (f s) \<and> (\<forall>(rv, s') \<in> fst (f s). R s')"
  apply (clarsimp simp: bind_def stateAssert_def get_def assert_def
      return_def fail_def split_def split: if_split_asm)
  done

lemma oblivious_stateAssert [simp]:
  "oblivious f (stateAssert g xs) = (\<forall>s. g (f s) = g s)"
  apply (simp add: oblivious_def stateAssert_def exec_get
                   assert_def return_def fail_def split: if_split)
  apply auto
  done

lemma stateAssert_def2:
  "stateAssert f xs = do v \<leftarrow> gets f; if v then return () else fail od"
  by (simp add: stateAssert_def gets_def assert_def)

lemma findM_is_mapME:
  "(findM f xs >>= g)
   = liftM (\<lambda>_. ())
      (doE ys \<leftarrow> mapME_x (\<lambda>x. do v \<leftarrow> f x;
                             if v then do g (Some x); throwError () od
                             else returnOk () od) xs;
              liftE (g None) odE)"
  apply (induct xs)
   apply (simp add: mapME_x_def sequenceE_x_def liftM_def returnOk_bind)
   apply (simp add: liftE_def)
  apply (simp add: mapME_x_Cons bindE_assoc liftE_bindE[symmetric]
                   liftM_def cong: if_cong)
  apply (simp add: liftE_bindE bind_assoc)
  apply (rule bind_cong[OF refl])
  apply (simp add: bindE_assoc split: if_split)
  apply (simp add: liftE_bindE bind_assoc throwError_bind)
  done

text \<open>Some word equalities can be solved by considering the
problem bitwise.

This is proven for all n < len_of TYPE ('a), which is different to
running word_bitwise and expanding into an explicit list of bits.
\<close>

lemmas word_eqI_solve_simps = word_and_le1 word_or_zero le_word_or2
  shiftL_nat word_FF_is_mask word_1FF_is_mask neg_mask_bang nth_ucast
  linorder_not_less word_size minus_one_norm word_ops_nth_size
  is_aligned_nth nth_w2p nth_shiftl nth_shiftr conj_comms
  less_2p_is_upper_bits_unset

method word_eqI_solve = solves \<open>rule word_eqI;
  clarsimp simp: word_eqI_solve_simps;
  (eval_int_nat; clarsimp simp: word_eqI_solve_simps)?;
  fastforce simp: mask_def
\<close>

add_try_method word_eqI_solve

end


section \<open>Shallow Embedding of LLVM Semantics\<close>
theory LLVM_Shallow
imports Main
  "LLVM_Memory"
begin
  text \<open>We define a type synonym for the LLVM monad\<close>
  type_synonym 'a llM = "('a,unit,llvm_memory,err) M"
  translations
    (type) "'a llM" \<leftharpoondown> (type) "('a, unit, llvm_memory, err) M"

  subsection \<open>Shallow Embedding of Values\<close>

  text \<open>We use a type class to characterize types that can be injected into the value type.
    We will instantiate this type class to obtain injections from types of shape
    \<open>T = T\<times>T | _ word | _ ptr\<close>

    Although, this type class can be instantiated by other types, those will not be accepted
    by the code generator.

    We also define a class \<open>llvm_repv\<close>, which additionally contains \<open>unit\<close>.
    This is required for void functions, and if-the-else statements that produce no result.

    Again, while this class might be instantiated for other types, those will be rejected
    by the code generator.
  \<close>

  class llvm_repv

  class llvm_rep = llvm_repv +
    fixes to_val :: "'a \<Rightarrow> llvm_val"
      and from_val :: "llvm_val \<Rightarrow> 'a"
      and struct_of :: "'a itself \<Rightarrow> llvm_vstruct"
      and init :: 'a
    assumes from_to_id[simp]: "from_val o to_val = id"
    assumes to_from_id[simp]: "llvm_vstruct v = struct_of TYPE('a) \<Longrightarrow> to_val (from_val v) = v"
    assumes struct_of_matches[simp]: "llvm_vstruct (to_val x) = (struct_of TYPE('a))"
    assumes init_zero: "to_val init = llvm_zero_initializer (struct_of TYPE('a))"

  begin

    lemma from_to_id'[simp]: "from_val (to_val x) = x"
      using pointfree_idE[OF from_to_id] .

    lemma "to_val x = to_val y \<longleftrightarrow> x=y"
      by (metis from_to_id')

  end

  text \<open>We use a phantom type to attach the type of the pointed to value to a pointer.\<close>
  datatype 'a::llvm_rep ptr = PTR (the_raw_ptr: llvm_ptr)
  definition null :: "'a::llvm_rep ptr" where "null = PTR llvm_null"

  text \<open>We instantiate the type classes for the supported types,
    i.e., unit, word, ptr, and prod.\<close>

  instance unit :: llvm_repv by standard

  instantiation word :: (len) llvm_rep begin
    definition "to_val w \<equiv> llvm_int (lconst (len_of TYPE('a)) (uint w))"
    definition "from_val v \<equiv> word_of_int (lint_to_uint (llvm_the_int v))"
    definition [simp]: "struct_of_word (_::'a word itself) \<equiv> llvm_s_int (len_of TYPE('a))"
    definition [simp]: "init_word \<equiv> 0::'a word"

    lemma int_inv_aux: "width i = LENGTH('a) \<Longrightarrow> lconst LENGTH('a) (uint (word_of_int (lint_to_uint i) :: 'a word)) = i"
      by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_word_def to_val_word_def)
      apply (auto simp: llvm_s_int_def llvm_zero_initializer_def llvm_int_def)
      subgoal for v apply (cases v)
        apply (auto simp: llvm_int_def llvm_the_int_def llvm_s_ptr_def llvm_s_pair_def)
        apply (simp add: llvm_vstruct_def int_inv_aux)
      done
      done

  end

  instantiation ptr :: (llvm_rep) llvm_rep begin
    definition "to_val \<equiv> llvm_ptr o ptr.the_raw_ptr"
    definition "from_val v \<equiv> PTR (llvm_the_ptr v)"
    definition [simp]: "struct_of_ptr (_::'a ptr itself) \<equiv> llvm_s_ptr"
    definition [simp]: "init_ptr::'a ptr \<equiv> null"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_ptr_def to_val_ptr_def)
      apply (auto simp: llvm_zero_initializer_def llvm_ptr_def llvm_s_ptr_def null_def llvm_null_def)
      subgoal for v apply (cases v)
        by (auto simp: llvm_s_int_def llvm_s_pair_def llvm_ptr_def llvm_the_ptr_def)
      done

  end

  instantiation prod :: (llvm_rep, llvm_rep) llvm_rep begin
    definition "to_val_prod \<equiv> \<lambda>(a,b). llvm_pair (to_val a) (to_val b)"
    definition "from_val_prod p \<equiv> case llvm_the_pair p of (a,b) \<Rightarrow> (from_val a, from_val b)"
    definition [simp]: "struct_of_prod (_::('a\<times>'b) itself) \<equiv> llvm_s_pair (struct_of TYPE('a)) (struct_of TYPE('b))"
    definition [simp]: "init_prod ::'a\<times>'b \<equiv> (init,init)"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_prod_def to_val_prod_def)
      apply (auto simp: llvm_pair_def llvm_s_pair_def init_zero llvm_zero_initializer_def)
      subgoal for v
        apply (cases v)
        apply (auto simp: llvm_s_int_def llvm_s_ptr_def llvm_pair_def llvm_the_pair_def
          llvm_val.the_val_def llvm_vstruct_def split: prod.splits llvm_val.splits val.split)
        done
      done

  end

  lemma to_val_prod_conv[simp]: "to_val (a,b) = llvm_pair (to_val a) (to_val b)"
    unfolding to_val_prod_def by auto

  text \<open>Checked conversion from value\<close>
  definition checked_from_val :: "llvm_val \<Rightarrow> 'a::llvm_rep llM" where
    "checked_from_val v \<equiv> doM {
      fcheck (STATIC_ERROR ''Type mismatch'') (llvm_vstruct v = struct_of TYPE('a));
      return (from_val v)
    }"

  subsection \<open>Instructions\<close>

  text \<open>The instructions are arranged in the order as they are described in the
    LLVM Language Reference Manual \<^url>\<open>https://llvm.org/docs/LangRef.html\<close>.\<close>

  subsubsection \<open>Binary Operations\<close>
  text \<open>We define a generic lifter for binary arithmetic operations.
    It is parameterized by an error condition.
  \<close> (* TODO: Use precondition instead of negated precondition! *)

  definition op_lift_arith2 :: "_ \<Rightarrow> _ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word llM"
    where "op_lift_arith2 ovf f a b \<equiv> doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    fcheck (OVERFLOW_ERROR) (\<not>ovf a b);
    return (lint_to_word (f a b))
  }"

  definition "op_lift_arith2' \<equiv> op_lift_arith2 (\<lambda>_ _. False)"

  definition udivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "udivrem_is_undef a b \<equiv> lint_to_uint b=0"
  definition sdivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "sdivrem_is_undef a b \<equiv> lint_to_sint b=0 \<or> sdivrem_ovf a b"

  definition "ll_add \<equiv> op_lift_arith2' (+)"
  definition "ll_sub \<equiv> op_lift_arith2' (-)"
  definition "ll_mul \<equiv> op_lift_arith2' ( * )"
  definition "ll_udiv \<equiv> op_lift_arith2 udivrem_is_undef (div)"
  definition "ll_urem \<equiv> op_lift_arith2 udivrem_is_undef (mod)"
  definition "ll_sdiv \<equiv> op_lift_arith2 sdivrem_is_undef (sdiv)"
  definition "ll_srem \<equiv> op_lift_arith2 sdivrem_is_undef (smod)"

  subsubsection \<open>Compare Operations\<close>
  definition op_lift_cmp :: "_ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 1 word llM"
    where "op_lift_cmp f a b \<equiv> doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition op_lift_ptr_cmp :: "_ \<Rightarrow> 'a::llvm_rep ptr \<Rightarrow> 'a ptr \<Rightarrow> 1 word llM"
    where "op_lift_ptr_cmp f a b \<equiv> doM {
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition "ll_icmp_eq \<equiv>  op_lift_cmp (=)"
  definition "ll_icmp_ne \<equiv>  op_lift_cmp (\<noteq>)"
  definition "ll_icmp_sle \<equiv> op_lift_cmp (\<le>\<^sub>s)"
  definition "ll_icmp_slt \<equiv> op_lift_cmp (<\<^sub>s)"
  definition "ll_icmp_ule \<equiv> op_lift_cmp (\<le>)"
  definition "ll_icmp_ult \<equiv> op_lift_cmp (<)"

  text \<open>Note: There are no pointer compare instructions in LLVM.
    To compare pointers in LLVM, they have to be casted to integers first.
    However, our abstract memory model cannot assign a bit-width to pointers.

    Thus, we model pointer comparison instructions in our semantics, and let the
    code generator translate them to integer comparisons.

    Up to now, we only model pointer equality.
    For less-than, suitable preconditions are required, which are consistent with the
    actual memory layout of LLVM. We could, e.g., adopt the rules from the C standard here.
  \<close>
  definition "ll_ptrcmp_eq \<equiv> op_lift_ptr_cmp (=)"
  definition "ll_ptrcmp_ne \<equiv> op_lift_ptr_cmp (\<noteq>)"

  subsubsection \<open>Bitwise Binary Operations\<close>
  definition "shift_ovf a n \<equiv> nat (lint_to_uint n) \<ge> width a"
  definition "bitSHL' a n \<equiv> bitSHL a (nat (lint_to_uint n))"
  definition "bitASHR' a n \<equiv> bitASHR a (nat (lint_to_uint n))"
  definition "bitLSHR' a n \<equiv> bitLSHR a (nat (lint_to_uint n))"

  definition "ll_shl \<equiv> op_lift_arith2 shift_ovf bitSHL'"
  definition "ll_lshr \<equiv> op_lift_arith2 shift_ovf bitLSHR'"
  definition "ll_ashr \<equiv> op_lift_arith2 shift_ovf bitASHR'"

  definition "ll_and \<equiv> op_lift_arith2' (AND)"
  definition "ll_or \<equiv> op_lift_arith2' (OR)"
  definition "ll_xor \<equiv> op_lift_arith2' (XOR)"

  subsubsection \<open>Aggregate Operations\<close>
  text \<open>In LLVM, there is an \<open>extractvalue\<close> and \<open>insertvalue\<close> operation.
    In our shallow embedding, these get instantiated for \<open>fst\<close> and \<open>snd\<close>.\<close>

  definition "checked_split_pair v \<equiv> doM {
    fcheck (STATIC_ERROR ''Expected pair'') (llvm_is_pair v);
    return (llvm_the_pair v)
  }"

  definition ll_extract_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep llM" where "ll_extract_fst p = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val a }"
  definition ll_extract_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep llM" where "ll_extract_snd p = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val b }"
  definition ll_insert_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep \<Rightarrow> 't llM" where "ll_insert_fst p x = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair (to_val x) b) }"
  definition ll_insert_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep \<Rightarrow> 't llM" where "ll_insert_snd p x = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair a (to_val x)) }"

  (*
  definition ll_extract_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a llM" where "ll_extract_fst ab \<equiv> return (fst ab)"
  definition ll_extract_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b llM" where "ll_extract_snd ab \<equiv> return (snd ab)"
  definition ll_insert_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_fst ab a \<equiv> return (a,snd ab)"
  definition ll_insert_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_snd ab b \<equiv> return (fst ab,b)"
  *)

  subsubsection \<open>Memory Access and Addressing Operations\<close>

  definition ll_load :: "'a::llvm_rep ptr \<Rightarrow> 'a llM" where
    "ll_load p \<equiv> doM {
      r \<leftarrow> llvm_load (the_raw_ptr p);
      checked_from_val r
    }"

  definition ll_store :: "'a::llvm_rep \<Rightarrow> 'a ptr \<Rightarrow> unit llM" where
    "ll_store v p \<equiv> llvm_store (to_val v) (the_raw_ptr p)"

  text \<open>Note that LLVM itself does not have malloc and free instructions.
    However, these are primitive instructions in our abstract memory model,
    such that we have to model them in our semantics.

    The code generator will map them to the C standard library
    functions \<open>calloc\<close> and \<open>free\<close>.
  \<close>

  definition ll_malloc :: "'a::llvm_rep itself \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where
    "ll_malloc TYPE('a) n = doM {
      fcheck MEM_ERROR (unat n > 0); \<comment> \<open>Disallow empty malloc\<close>
      r \<leftarrow> llvm_allocn (to_val (init::'a)) (unat n);
      return (PTR r)
    }"

  definition ll_free :: "'a::llvm_rep ptr \<Rightarrow> unit llM"
    where "ll_free p \<equiv> llvm_free (the_raw_ptr p)"

  text \<open>As for the aggregate operations, the \<open>getelementptr\<close> instruction is instantiated
    for pointer indexing, fst, and snd. \<close>

  definition ll_ofs_ptr :: "'a::llvm_rep ptr \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where "ll_ofs_ptr p ofs = doM {
    r \<leftarrow> llvm_checked_idx_ptr (the_raw_ptr p) (sint ofs);
    return (PTR r)
  }"

  definition ll_gep_fst :: "'p::llvm_rep ptr \<Rightarrow> 'a::llvm_rep ptr llM" where "ll_gep_fst p = doM {
    fcheck (STATIC_ERROR ''gep_fst: Expected pair type'') (llvm_is_s_pair (struct_of TYPE('p)));
    r \<leftarrow> llvm_checked_gep (the_raw_ptr p) PFST;
    return (PTR r)
  }"

  definition ll_gep_snd :: "'p::llvm_rep ptr \<Rightarrow> 'b::llvm_rep ptr llM" where "ll_gep_snd p = doM {
    fcheck (STATIC_ERROR ''gep_snd: Expected pair type'') (llvm_is_s_pair (struct_of TYPE('p)));
    r \<leftarrow> llvm_checked_gep (the_raw_ptr p) PSND;
    return (PTR r)
  }"

  subsubsection \<open>Conversion Operations\<close>
  definition "llb_trunc i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Trunc must go to smaller type'') (width i > w);
    return (trunc w i)
  }"

  definition "llb_sext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Sext must go to greater type'') (width i < w);
    return (sext w i)
  }"

  definition "llb_zext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Zext must go to greater type'') (width i < w);
    return (zext w i)
  }"

  definition op_lift_iconv :: "_ \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word itself  \<Rightarrow> 'b word llM"
    where "op_lift_iconv f a _ \<equiv> doM {
    let a = word_to_lint a;
    let w = LENGTH('b);
    r \<leftarrow> f a w;
    return (lint_to_word r)
  }"

  definition "ll_trunc \<equiv> op_lift_iconv llb_trunc"
  definition "ll_sext \<equiv> op_lift_iconv llb_sext"
  definition "ll_zext \<equiv> op_lift_iconv llb_zext"

  subsection \<open>Control Flow\<close>

  text \<open>Our shallow embedding uses a structured control flow, which allows
    only sequential composition, if-then-else, and function calls.

    The code generator then maps sequential composition to basic blocks,
    and if-then-else to a control flow graph with conditional branching.
    Function calls are mapped to LLVM function calls.
   \<close>

  text \<open>We use the to Boolean conversion from word-lib. We re-state its semantics here.\<close>

  lemma to_bool_as_lint_to_bool:
    "to_bool (w::1 word) = lint_to_bool (word_to_lint w)"
    unfolding to_bool_def word_to_lint_def
    apply (clarsimp simp: ltrue_def lfalse_def lint_to_bool_def)
    apply transfer
    apply auto
    by (metis bin_rest_BIT bin_rest_x2)

  lemma to_bool_eq[simp]: "to_bool (w::1 word) \<longleftrightarrow> w\<noteq>0"
    by (rule to_bool_neq_0)

  definition llc_if :: "1 word \<Rightarrow> 'a::llvm_repv llM \<Rightarrow> 'a llM \<Rightarrow> 'a llM" where
    "llc_if b t e \<equiv> doM {
      if to_bool b then t else e
    }"

  lemma llc_if_mono[partial_function_mono]:
    "\<lbrakk>monotone orda ordb F; monotone orda ordb G\<rbrakk> \<Longrightarrow> monotone orda ordb (\<lambda>f. llc_if b (F f) (G f))"
    unfolding llc_if_def by pf_mono_prover

  subsubsection \<open>While-Combinator\<close>
  text \<open>
    Note that we also include the while combinator at this point, as we plan
    to add direct translation of while to a control flow graph as an optional
    feature of the code generator.

    In the current state, the code generator will recognize the while combinator,
    but refuse to translate it.

    Note that the standard way of using a while combinator is to translate it to
    a tail recursive function call, which the preprocessor can do automatically.
  \<close>

  definition llc_while :: "('a::llvm_repv \<Rightarrow> 1 word llM) \<Rightarrow> ('a \<Rightarrow> 'a llM) \<Rightarrow> 'a \<Rightarrow> 'a llM" where
    "llc_while b f s\<^sub>0 \<equiv> mwhile (\<lambda>s. b s \<bind> return o to_bool) f s\<^sub>0"

  lemma gen_code_thm_llc_while:
    assumes "f \<equiv> llc_while b body"
    shows "f s = doM { ctd \<leftarrow> b s; llc_if ctd (doM { s\<leftarrow>body s; f s}) (return s)}"
    unfolding assms
    unfolding llc_while_def llc_if_def
    apply (rewrite mwhile_unfold)
    by simp

  (* 'Definition' of llc_while for presentation in paper: *)
  lemma "llc_while b c s \<equiv> doM { x \<leftarrow> b s; llc_if x (doM {s\<leftarrow>c s; llc_while b c s}) (return s) }"
    unfolding llc_while_def llc_if_def
    apply (rewrite mwhile_unfold)
    by simp

end