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

theory ArchUserOp_IF
imports UserOp_IF
begin

context Arch begin global_naming RISCV64

definition ptable_lift_s where
  "ptable_lift_s s \<equiv> ptable_lift (cur_thread s) s"

definition ptable_rights_s where
  "ptable_rights_s s \<equiv> ptable_rights (cur_thread s) s"

(* FIXME: move to ADT_AI.thy *)
definition ptable_attrs :: "obj_ref \<Rightarrow> 's :: state_ext state \<Rightarrow> obj_ref \<Rightarrow> vm_attributes" where
 "ptable_attrs tcb s \<equiv>
    \<lambda>addr. case_option {} (fst o snd o snd)
             (get_page_info (aobjs_of s) (get_vspace_of_thread (kheap s) (arch_state s) tcb) addr)"

definition ptable_attrs_s :: "'s :: state_ext state \<Rightarrow> obj_ref \<Rightarrow> vm_attributes" where
 "ptable_attrs_s s \<equiv> ptable_attrs (cur_thread s) s"

definition ptable_xn_s where
  "ptable_xn_s s \<equiv> \<lambda>addr. Execute \<notin> ptable_attrs_s s addr"

type_synonym user_state_if = "user_context \<times> user_mem \<times> device_state"

text \<open>
  A user transition gives back a possible event that is the next
  event the user wants to perform
\<close>
type_synonym user_transition_if =
  "obj_ref \<Rightarrow> vm_mapping \<Rightarrow> mem_rights \<Rightarrow> (obj_ref \<Rightarrow> bool) \<Rightarrow>
   user_state_if \<Rightarrow> (event option \<times> user_state_if) set"

definition do_user_op_if ::
  "user_transition_if \<Rightarrow> user_context \<Rightarrow> (event option \<times> user_context,'z::state_ext) s_monad" where
  "do_user_op_if uop tc =
   do
      \<comment> \<open>Get the page rights of each address (ReadOnly, ReadWrite, None, etc).\<close>
      pr \<leftarrow> gets ptable_rights_s;

      \<comment> \<open>Fetch the execute bits of the current thread's page mappings.\<close>
      pxn \<leftarrow> gets (\<lambda>s x. pr x \<noteq> {} \<and> ptable_xn_s s x);

      \<comment> \<open>Get the mapping from virtual to physical addresses.\<close>
      pl \<leftarrow> gets (\<lambda>s. restrict_map (ptable_lift_s s) {x. pr x \<noteq> {}});

      allow_read \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowRead \<in> pr x};
      allow_write \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowWrite \<in> pr x};

      \<comment> \<open>Get the current thread.\<close>
      t \<leftarrow> gets cur_thread;

      \<comment> \<open>Generate user memory by throwing away anything from global
         memory that the user doesn't have access to. (The user must
         have both (1) a mapping to the page; (2) that mapping has the
         AllowRead right.\<close>
      um \<leftarrow> gets (\<lambda>s. (user_mem s) \<circ> ptrFromPAddr);
      dm \<leftarrow> gets (\<lambda>s. (device_mem s) \<circ> ptrFromPAddr);
      ds \<leftarrow> gets (device_state \<circ> machine_state);

      \<comment> \<open>Non-deterministically execute one of the user's operations.\<close>
      u \<leftarrow> return (uop t pl pr pxn (tc, um|`allow_read, (ds \<circ> ptrFromPAddr)|` allow_read));
      assert (u \<noteq> {});
      (e,(tc',um',ds')) \<leftarrow> select u;

      \<comment> \<open>Update the changes the user made to memory into our model.
         We ignore changes that took place where they didn't have
         write permissions. (uop shouldn't be doing that --- if it is,
         uop isn't correctly modelling real hardware.)\<close>
      do_machine_op (user_memory_update (((um' |` allow_write) \<circ> addrFromPPtr) |` (-(dom ds))));

      do_machine_op (device_memory_update (((ds' |` allow_write) \<circ> addrFromPPtr) |` (dom ds)));

      return (e,tc')
   od"

named_theorems UserOp_IF_assms

lemma arch_globals_equiv_underlying_memory_update[UserOp_IF_assms, simp]:
  "arch_globals_equiv ct it kh kh' as as' (underlying_memory_update f ms) ms' =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  "arch_globals_equiv ct it kh kh' as as' ms (underlying_memory_update f ms') =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  by auto

lemma arch_globals_equiv_device_state_update[UserOp_IF_assms, simp]:
  "arch_globals_equiv ct it kh kh' as as' (device_state_update f ms) ms' =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  "arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  by auto

end

requalify_types RISCV64.user_transition_if

global_interpretation UserOp_IF_1?: UserOp_IF_1
proof goal_cases
  interpret Arch .
  case 1 show ?case
    by (unfold_locales; (fact UserOp_IF_assms)?)
qed

context Arch begin global_naming RISCV64

lemma requiv_get_pt_of_thread_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s);
     pt_ref \<noteq> riscv_global_pt (arch_state s); pt_ref' \<noteq> riscv_global_pt (arch_state s');
     get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = pt_ref;
     get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = pt_ref' \<rbrakk>
     \<Longrightarrow> pt_ref = pt_ref'"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag (cur_thread s)")
   apply (clarsimp simp: get_vspace_of_thread_eq)
  apply simp
  done

lemma requiv_get_pt_entry_eq:
  "\<lbrakk> reads_equiv aag s t; invs s; pas_refined aag s; is_subject aag pt; vref \<in> user_region;
     \<exists>asid vref. vs_lookup_table max_pt_level asid vref s = Some (max_pt_level, pt) \<rbrakk>
     \<Longrightarrow> pt_lookup_slot pt vref (ptes_of s) = pt_lookup_slot pt vref (ptes_of t)"
  apply (clarsimp simp: pt_lookup_slot_def)
  apply (clarsimp simp: pt_lookup_slot_from_level_def)
  apply (frule_tac pt=pt and vptr=vref in pt_walk_reads_equiv[where bot_level=0])
          apply clarsimp+
    apply (fastforce simp: reads_equiv_f_def)
   apply (fastforce elim: vs_lookup_table_vref_independent)
  apply (clarsimp simp: obind_def split: option.splits)
  done

lemma requiv_get_page_info_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; invs s; is_subject aag pt; x \<notin> kernel_mappings;
     \<exists>asid. vs_lookup_table max_pt_level asid x s = Some (max_pt_level, pt) \<rbrakk>
     \<Longrightarrow> get_page_info (aobjs_of s) pt x = get_page_info (aobjs_of s') pt x"
  apply (clarsimp simp: get_page_info_def obind_def)
  apply (subgoal_tac "pt_lookup_slot pt x (ptes_of s) = pt_lookup_slot pt x (ptes_of s')")
   apply (clarsimp split: option.splits)
   apply (case_tac "pt_lookup_slot pt x (ptes_of s') = Some (a, b)"; clarsimp)
   apply (frule_tac ptr=b in ptes_of_reads_equiv[rotated])
    apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def)
    apply (prop_tac "ba = bb", clarsimp simp: pt_slot_offset_def)
    apply (frule pt_walk_is_aligned)
     apply (erule vs_lookup_table_is_aligned; clarsimp simp: canonical_not_kernel_is_user)
    apply (erule pt_walk_is_subject, (fastforce simp: canonical_not_kernel_is_user)+)
  apply (rule requiv_get_pt_entry_eq; fastforce simp: canonical_not_kernel_is_user)
  done

lemma requiv_vspace_of_thread_global_pt:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag (cur_thread s); invs s; pas_refined aag s;
     get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = global_pt s \<rbrakk>
     \<Longrightarrow> get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = global_pt s'"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (prop_tac "aag_can_read aag (cur_thread s)", simp)
  apply (clarsimp simp: get_vspace_of_thread_def
                 split: option.split kernel_object.splits cap.splits arch_cap.splits)
  apply (rename_tac tcb word word' word'')
  apply (subgoal_tac "aag_can_read_asid aag word'")
   apply (subgoal_tac "s \<turnstile> ArchObjectCap (PageTableCap word (Some (word',word'')))")
    apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def obind_def
                          vspace_for_asid_def vspace_for_pool_def pool_for_asid_def)
    apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj)
    apply (drule_tac x=word' in spec)
    apply (case_tac "word' = 0"; clarsimp)
    apply (clarsimp simp: asid_pools_of_ko_at obj_at_def asid_low_bits_of_def opt_map_def
                   split: option.splits)
    apply (frule valid_global_arch_objs_global_ptD[OF invs_valid_global_arch_objs])
    apply (drule invs_valid_global_refs)
    apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated])
     apply (subst caps_of_state_tcb_cap_cases)
       apply (simp add: get_tcb_def)
      apply (simp add: dom_tcb_cap_cases[simplified])
     apply simp
    apply (simp add: cap_range_def global_refs_def)
   apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable)
     apply (fastforce simp: invs_valid_objs get_tcb_def)+
  apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag word')
                        \<in> state_asids_to_policy aag s")
   apply (frule pas_refined_Control_into_is_subject_asid)
    apply (fastforce simp: pas_refined_def)
   apply simp
  apply (cut_tac aag=aag and ptr="(cur_thread s, tcb_cnode_index 1)" in sata_asid)
    prefer 3
    apply (simp add: caps_of_state_tcb_cap_cases get_tcb_def dom_tcb_cap_cases[simplified])+
  done

lemma vspace_for_asid_get_vspace_of_thread:
  "get_vspace_of_thread (kheap s) (arch_state s) ct \<noteq> global_pt s
   \<Longrightarrow> \<exists>asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) ct)"
  by (fastforce simp: get_vspace_of_thread_def
               split: option.splits kernel_object.splits cap.splits arch_cap.splits)

lemma pt_of_thread_same_agent:
  "\<lbrakk> pas_refined aag s; is_subject aag tcb_ptr;
     get_vspace_of_thread (kheap s) (arch_state s) tcb_ptr = pt; pt \<noteq> global_pt s \<rbrakk>
     \<Longrightarrow> pasObjectAbs aag tcb_ptr = pasObjectAbs aag pt"
  apply (rule_tac aag="pasPolicy aag" in aag_wellformed_Control[rotated])
   apply (fastforce simp: pas_refined_def)
  apply (rule pas_refined_mem[rotated], simp)
  apply (clarsimp simp: get_vspace_of_thread_eq)
  apply (cut_tac ptr="(tcb_ptr, tcb_cnode_index 1)" in sbta_caps)
     prefer 4
     apply (simp add: state_objs_to_policy_def)
    apply (subst caps_of_state_tcb_cap_cases)
      apply (simp add: get_tcb_def)
     apply (simp add: dom_tcb_cap_cases[simplified])
    apply simp
   apply (simp add: obj_refs_def)
  apply (simp add: cap_auth_conferred_def arch_cap_auth_conferred_def)
  done

lemma requiv_ptable_rights_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s' \<rbrakk>
     \<Longrightarrow> ptable_rights_s s = ptable_rights_s s'"
  apply (simp add: ptable_rights_s_def)
  apply (rule ext)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_rights_def split: option.splits)
   apply (rule conjI; clarsimp)
    apply (frule some_get_page_info_kmapsD;
           fastforce dest: invs_arch_state vspace_for_asid_get_vspace_of_thread
                     simp: valid_arch_state_def kernel_mappings_canonical)
   apply (frule some_get_page_info_kmapsD)
              apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread
                          simp: valid_arch_state_def kernel_mappings_canonical)[12]
   apply (frule_tac r=b in some_get_page_info_kmapsD)
              apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread
                          simp: valid_arch_state_def kernel_mappings_canonical)[12]
  apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   riscv_global_pt (arch_state s)")
   apply (frule requiv_vspace_of_thread_global_pt)
       apply (auto)[4]
   apply (fastforce dest: get_page_info_gpd_kmaps[rotated, rotated]
                    simp: ptable_rights_def invs_valid_global_objs invs_arch_state
                   split: option.splits)+
  apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   riscv_global_pt (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_vspace_of_thread_global_pt; fastforce simp: reads_equiv_def)
  apply (simp add: ptable_rights_def)
  apply (frule requiv_get_pt_of_thread_eq)
        apply (auto)[6]
  apply (frule pt_of_thread_same_agent, simp+)
  apply (subst requiv_get_page_info_eq, simp+)
   apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp)
   apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+
  done

lemma requiv_ptable_attrs_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_attrs_s s x = ptable_attrs_s s' x"
  apply (simp add: ptable_attrs_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
               apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
              apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread
                          simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12]
  apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   riscv_global_pt (arch_state s)")
   apply (frule requiv_vspace_of_thread_global_pt)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
  apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   riscv_global_pt (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_vspace_of_thread_global_pt)
       apply ((fastforce simp: reads_equiv_def)+)[5]
  apply (simp add: ptable_attrs_def)
  apply (frule requiv_get_pt_of_thread_eq, simp+)[1]
  apply (frule pt_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)
   apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp)
   apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+
  done

lemma requiv_ptable_lift_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; invs s;
     invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_lift_s s x = ptable_lift_s s' x"
  apply (simp add: ptable_lift_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
               apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
              apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread
                          simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12]
  apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   riscv_global_pt (arch_state s)")
   apply (frule requiv_vspace_of_thread_global_pt)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
  apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   riscv_global_pt (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_vspace_of_thread_global_pt)
       apply ((fastforce simp: reads_equiv_def)+)[5]
  apply (simp add: ptable_lift_def)
  apply (frule requiv_get_pt_of_thread_eq, simp+)[1]
  apply (frule pt_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)
   apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp)
   apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+
  done

lemma requiv_ptable_xn_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_xn_s s x = ptable_xn_s s' x"
  by (simp add: ptable_xn_s_def requiv_ptable_attrs_eq)

lemma data_at_obj_range:
  "\<lbrakk> data_at sz ptr s; pspace_aligned s; valid_objs s \<rbrakk>
     \<Longrightarrow> ptr + (offset && mask (pageBitsForSize sz)) \<in> obj_range ptr (ArchObj (DataPage dev sz))"
  apply (clarsimp simp: data_at_def)
  apply (elim disjE)
   apply (clarsimp simp: obj_at_def)
   apply (drule (2) ptr_in_obj_range)
   apply (clarsimp simp: obj_bits_def obj_range_def)
   apply fastforce
  apply (clarsimp simp: obj_at_def)
  apply (drule (2) ptr_in_obj_range)
  apply (clarsimp simp: obj_bits_def obj_range_def)
  apply fastforce
  done

lemma obj_range_data_for_cong:
  "obj_range ptr (ArchObj (DataPage dev sz')) = obj_range ptr (ArchObj (DataPage False sz'))"
  by (simp add: obj_range_def)

lemma pspace_distinct_def':
  "pspace_distinct \<equiv>
     \<lambda>s. \<forall>x y ko ko'. kheap s x = Some ko \<and> kheap s y = Some ko' \<and> x \<noteq> y
                      \<longrightarrow> obj_range x ko \<inter> obj_range y ko' = {}"
  by (auto simp: pspace_distinct_def obj_range_def field_simps)

lemma data_at_disjoint_equiv:
  "\<lbrakk> ptr' \<noteq> ptr;data_at sz' ptr' s; data_at sz ptr s; valid_objs s; pspace_aligned s;
     pspace_distinct s; ptr' \<in> obj_range ptr (ArchObj (DataPage dev sz)) \<rbrakk>
     \<Longrightarrow> False"
  apply (frule (2) data_at_obj_range[where offset = 0,simplified])
  apply (clarsimp simp: data_at_def obj_at_def)
  apply (elim disjE)
  by (clarsimp dest!: spec simp: obj_at_def pspace_distinct_def'
      , erule impE, erule conjI2[OF conjI2], (fastforce+)[2]
      , fastforce cong: obj_range_data_for_cong)+

lemma is_aligned_pptrBaseOffset:
  "is_aligned pptrBaseOffset (pageBitsForSize sz)"
  by (case_tac sz, simp_all add: pptrBaseOffset_def paddrBase_def pageBits_def canonical_bit_def
                                 ptTranslationBits_def pptrBase_def is_aligned_def)

lemma ptrFromPAddr_mask_simp:
  "ptrFromPAddr z && ~~ mask (pageBitsForSize l) =
   ptrFromPAddr (z && ~~ mask (pageBitsForSize l))"
  apply (simp add: ptrFromPAddr_def field_simps)
  apply (subst mask_out_add_aligned[OF is_aligned_pptrBaseOffset])
  apply simp
  done

lemma pageBitsForSize_le_canonical_bit:
  "pageBitsForSize sz \<le> canonical_bit"
  by (cases sz, simp_all add: pageBits_def ptTranslationBits_def canonical_bit_def)

lemma data_at_same_size:
  assumes dat_sz':
    "data_at sz' (ptrFromPAddr base) s"
  and dat_sz:
    "data_at sz
       (ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz)) s"
  and vs:
    "pspace_distinct s" "pspace_aligned s" "valid_objs s"
  shows "sz' = sz"
proof -
  from dat_sz' and dat_sz
  have trivial:
    "sz' \<noteq> sz
     \<Longrightarrow> ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz) \<noteq>
         ptrFromPAddr base"
    by (auto simp: data_at_def obj_at_def)
  have sz_equiv: "(pageBitsForSize sz = pageBitsForSize sz') = (sz' = sz)"
    by (clarsimp simp: pageBitsForSize_def ptTranslationBits_def split: vmpage_size.splits)
  show ?thesis
    apply (rule sz_equiv[THEN iffD1])
    apply (rule ccontr)
    apply (drule neq_iff[THEN iffD1])
    using dat_sz' dat_sz vs
    apply (cut_tac trivial) prefer 2
     apply (fastforce simp: sz_equiv)
    apply (frule(1) data_at_aligned)
    apply (elim disjE)
     apply (erule(5) data_at_disjoint_equiv)
     apply (unfold obj_range_def)
     apply (rule mask_in_range[THEN iffD1])
      apply (simp add: obj_bits_def)+
     apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
     apply (rule arg_cong[where f = ptrFromPAddr])
     apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit])
     apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
       apply simp
      apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified])
     apply (simp add: is_aligned_neg_mask_eq)
    apply (drule not_sym)
    apply (erule(5) data_at_disjoint_equiv)
    apply (unfold obj_range_def)
    apply (rule mask_in_range[THEN iffD1])
     apply (simp add: obj_bits_def is_aligned_neg_mask)+
    apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
    apply (rule arg_cong[where f = ptrFromPAddr])
    apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit])
    apply (rule sym)
    apply (subst mask_lower_twice[symmetric])
     apply (erule less_imp_le_nat)
    apply (rule arg_cong[where f = "\<lambda>x. x && ~~ mask z" for z])
    apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
      apply simp
     apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified])
    apply simp
    done
qed

lemma level_le_2_cases:
  "(level :: vm_level) \<le> 2 \<Longrightarrow> level = 0 \<or> level = 1 \<or> level = 2"
  apply clarsimp
  apply (erule_tac P="level=2" in swap)
  apply (subst (asm) order.order_iff_strict)
  apply (erule disjE_R)
   apply (clarsimp simp: order.strict_implies_not_eq)
   apply (induct level; clarsimp)
   apply (drule meta_mp)
    apply (erule order.strict_implies_not_eq)
   apply (drule meta_mp)
    apply (rule bit0.minus_one_leq_less)
     apply (erule order.strict_implies_order)
    apply (erule bit0.zero_least)
   apply clarsimp
  apply clarsimp
  done

lemma ptable_lift_data_consistant:
  assumes vs: "valid_state s"
  and pt_lift: "ptable_lift t s x = Some ptr"
  and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
  and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \<noteq> riscv_global_pt (arch_state s)"
            "x \<notin> kernel_mappings"
  shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) =
         Some (ptr && ~~ mask (pageBitsForSize sz))"
proof -
  have vs': "valid_objs s \<and> valid_arch_state s \<and> valid_vspace_objs s
                          \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs by (simp add: valid_state_def valid_pspace_def)
  thus ?thesis
    using pt_lift dat vs'
    apply (clarsimp simp: ptable_lift_def split: option.splits)
    apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits)
    apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]])
    apply (rename_tac level pt pde asid)
    apply (case_tac pde; clarsimp simp: pte_info_def)
    apply (frule pt_lookup_slot_max_pt_level)
    apply (frule vspace_for_asid_vs_lookup)
    apply (frule canonical_not_kernel_is_user[OF misc(2)])
    apply (frule_tac level=level in valid_vspace_objs_pte)
      apply clarsimp
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def)
     apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]
                      dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI
                     intro: vs_lookup_level)
    apply (erule disjE[OF _  _ FalseE])
     prefer 2
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps)
     apply (clarsimp split: if_splits)
      apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2)
     apply (subst (asm) table_index_max_level_slots; clarsimp?)
     apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table)
    apply (clarsimp simp: valid_pte_def)
    apply (frule data_at_same_size; simp?)
    apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t)
                                    (vref_for_level x level) (ptes_of s) = Some (level, pt)")
     apply (case_tac "level = max_pt_level"; clarsimp)
      apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad)
      apply (subst (asm) pt_lookup_vs_lookup_eq)
        apply clarsimp
       apply (clarsimp simp: vspace_for_asid_def)
      apply (clarsimp simp: pt_walk.simps)
      apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad)
     apply (fold vref_for_level_def)
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad)
     apply (rule exI)
     apply (subst pt_walk_vref_for_level_eq[where vref'=x])
       apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def)
      apply clarsimp
     apply fastforce
    apply (fastforce simp: vref_for_level_def is_aligned_mask_out_add_eq mask_AND_NOT_mask
                           pt_bits_left_le_canonical is_aligned_ptrFromPAddr_n_eq
                     elim: canonical_vref_for_levelI[unfolded vref_for_level_def]
                     dest: data_at_aligned)
    done
qed

lemma ptable_rights_data_consistant:
  assumes vs: "valid_state s"
  and pt_lift: "ptable_lift t s x = Some ptr"
  and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
  and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \<noteq>
             riscv_global_pt (arch_state s)" "x \<notin> kernel_mappings"
  shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x"
proof -
  have vs': "valid_objs s \<and> valid_arch_state s \<and> valid_vspace_objs s
                          \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs by (simp add: valid_state_def valid_pspace_def)
  thus ?thesis
    using pt_lift dat vs'
    apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits)
    apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits)
    apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]])
    apply (rename_tac level pt pde asid)
    apply (case_tac pde; clarsimp simp: pte_info_def)
    apply (frule pt_lookup_slot_max_pt_level)
    apply (frule vspace_for_asid_vs_lookup)
    apply (frule canonical_not_kernel_is_user[OF misc(2)])
    apply (frule_tac level=level in valid_vspace_objs_pte)
      apply clarsimp
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def)
     apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]
                      dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI
                     intro: vs_lookup_level)
    apply (erule disjE[OF _  _ FalseE])
     prefer 2
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps)
     apply (clarsimp split: if_splits)
      apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2)
     apply (subst (asm) table_index_max_level_slots; clarsimp?)
     apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table)
    apply (clarsimp simp: valid_pte_def)
    apply (frule data_at_same_size; simp?)
    apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t)
                                    (vref_for_level x level) (ptes_of s) = Some (level, pt)")
     apply (case_tac "level = max_pt_level"; clarsimp)
      apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad)
      apply (subst (asm) pt_lookup_vs_lookup_eq)
        apply clarsimp
       apply (clarsimp simp: vspace_for_asid_def)
      apply (clarsimp simp: pt_walk.simps)
      apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad)
     apply (fold vref_for_level_def)
     apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad)
     apply (rule exI)
     apply (subst pt_walk_vref_for_level_eq[where vref'=x])
       apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def)
      apply clarsimp
     apply fastforce
    apply (clarsimp simp: vref_for_level_def)
    apply (fastforce dest: canonical_vref_for_levelI[unfolded vref_for_level_def]
                     simp: pt_bits_left_le_canonical )
    done
qed

lemma user_op_access_data_at:
  "\<lbrakk> invs s; pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr;
     data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s;
     auth \<in> vspace_cap_rights_to_auth (ptable_rights tcb s x) \<rbrakk>
     \<Longrightarrow> (pasObjectAbs aag tcb, auth,
          pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \<in> pasPolicy aag"
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule some_get_page_info_kmapsD)
              apply (fastforce dest: invs_arch_state invs_equal_kernel_mappings
                               simp: valid_arch_state_def vspace_for_asid_get_vspace_of_thread
                                     kernel_mappings_canonical vspace_cap_rights_to_auth_def)+
  apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) tcb = riscv_global_pt (arch_state s)")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply (fastforce simp: invs_valid_global_objs invs_arch_state)+
  apply (frule (2) ptable_lift_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (frule (2) ptable_rights_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (erule (3) user_op_access)
  apply simp
  done

lemma user_frame_at_equiv:
  "\<lbrakk> typ_at (AArch (AUserData sz)) p s; equiv_for P kheap s s'; P p \<rbrakk>
     \<Longrightarrow> typ_at (AArch (AUserData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma device_frame_at_equiv:
  "\<lbrakk> typ_at (AArch (ADeviceData sz)) p s; equiv_for P kheap s s'; P p \<rbrakk>
     \<Longrightarrow> typ_at (AArch (ADeviceData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma typ_at_user_data_at:
  "typ_at (AArch (AUserData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma typ_at_device_data_at:
  "typ_at (AArch (ADeviceData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma requiv_device_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> device_mem s (ptrFromPAddr y) = device_mem s' (ptrFromPAddr y)"
  apply (simp add: device_mem_def)
  apply (rule conjI)
   apply (erule reads_equivE)
   apply (clarsimp simp: in_device_frame_def)
   apply (rule exI)
   apply (rule device_frame_at_equiv)
     apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (frule_tac auth=Read in user_op_access_data_at[where s=s])
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
               | intro typ_at_device_data_at)+
   apply (rule reads_read)
   apply (fastforce simp: ptrFromPAddr_mask_simp)
  apply clarsimp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
  apply (erule reads_equivE)
  apply (clarsimp simp: in_device_frame_def)
  apply (rule exI)
  apply (rule device_frame_at_equiv)
    apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (erule equiv_symmetric[THEN iffD1])
  apply (frule_tac auth=Read in user_op_access_data_at[where s=s'])
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
              | intro typ_at_device_data_at)+
  apply (rule reads_read)
  apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma requiv_user_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> user_mem s (ptrFromPAddr y) = user_mem s' (ptrFromPAddr y)"
  apply (simp add: user_mem_def)
  apply (rule conjI)
   apply clarsimp
   apply (rule context_conjI')
    apply (erule reads_equivE)
    apply (clarsimp simp: in_user_frame_def)
    apply (rule exI)
    apply (rule user_frame_at_equiv)
      apply assumption+
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
         apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
                | intro typ_at_user_data_at)+
    apply (rule reads_read)
    apply (fastforce simp: ptrFromPAddr_mask_simp)
   apply clarsimp
   apply (subgoal_tac "aag_can_read aag (ptrFromPAddr y)")
    apply (erule reads_equivE)
    apply clarsimp
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply simp
   apply (frule_tac auth=Read in user_op_access)
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+
   apply (rule reads_read)
   apply simp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
  apply (erule reads_equivE)
  apply (clarsimp simp: in_user_frame_def)
  apply (rule exI)
  apply (rule user_frame_at_equiv)
    apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (erule equiv_symmetric[THEN iffD1])
  apply (frule_tac auth=Read in user_op_access_data_at[where s=s'])
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
              | intro typ_at_user_data_at)+
  apply (rule reads_read)
  apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma ptable_rights_imp_frameD:
  "\<lbrakk> ptable_lift t s x = Some y;valid_state s;ptable_rights t s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> \<exists>sz. data_at sz (ptrFromPAddr y && ~~ mask (pageBitsForSize sz)) s"
  apply (subst (asm) addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (drule ptable_rights_imp_frame)
    apply simp+
   apply (rule addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (auto simp: in_user_frame_def in_device_frame_def
             dest!: spec typ_at_user_data_at typ_at_device_data_at)
  done

lemma requiv_user_device_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> device_state (machine_state s) (ptrFromPAddr y) =
         device_state (machine_state s') (ptrFromPAddr y)"
  apply (simp add: ptable_lift_s_def)
  apply (frule ptable_rights_imp_frameD)
    apply fastforce
   apply (fastforce simp: ptable_rights_s_def)
  apply (erule reads_equivE)
  apply clarsimp
  apply (erule_tac f="device_state" in equiv_forD)
  apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
       apply ((fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
               | intro typ_at_user_data_at)+)[6]
  apply (rule reads_read)
  apply (frule_tac auth=Read in user_op_access)
      apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+
  done

definition context_matches_state where
  "context_matches_state pl pr pxn ms s \<equiv> case ms of (um, ds) \<Rightarrow>
     pl = ptable_lift_s s |` {x. pr x \<noteq> {}} \<and>
     pr = ptable_rights_s s \<and>
     pxn = (\<lambda>x. pr x \<noteq> {} \<and> ptable_xn_s s x) \<and>
     um = (user_mem s \<circ> ptrFromPAddr) |` {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x} \<and>
     ds = (device_state (machine_state s) \<circ> ptrFromPAddr) |`
          {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x}"

lemma do_user_op_reads_respects_g:
  notes split_paired_All[simp del]
  shows
    "(\<forall>pl pr pxn tc ms s. P tc s \<and> context_matches_state pl pr pxn ms s
                          \<longrightarrow> (\<exists>x. uop (cur_thread s) pl pr pxn (tc, ms) = {x}))
     \<Longrightarrow> reads_respects_g aag l (pas_refined aag and invs and is_subject aag \<circ> cur_thread
                                                 and (\<lambda>s. cur_thread s \<noteq> idle_thread s) and P tc)
                          (do_user_op_if uop tc)"
  apply (simp add: do_user_op_if_def)
  apply (rule use_spec_ev)
  apply (rule spec_equiv_valid_add_asm)
  apply (rule spec_equiv_valid_add_rel[OF _ reads_equiv_g_refl])
  apply (rule spec_equiv_valid_add_rel'[OF _ affects_equiv_refl])
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_ptable_rights_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (rule ext)
   apply (clarsimp simp: reads_equiv_g_def)
   apply (case_tac "ptable_rights_s st x = {}", simp)
   apply simp
   apply (rule requiv_ptable_xn_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (subst expand_restrict_map_eq,clarsimp)
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_ptable_lift_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_cur_thread_eq,fastforce)
  apply (rule spec_equiv_valid_inv_gets_more[where proj="\<lambda>m. dom m \<inter> cw"
                                               and projsnd="\<lambda>m. m |` cr" for cr and cw])
   apply (rule context_conjI')
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: reads_equiv_g_def restrict_map_def)
    apply (rule requiv_user_mem_eq)
            apply simp+
   apply fastforce
  apply (rule spec_equiv_valid_inv_gets[where proj = "\<lambda>x. ()", simplified])
  apply (rule spec_equiv_valid_inv_gets_more[where proj = "\<lambda>m. (m \<circ> ptrFromPAddr) |` cr" for cr])
   apply (rule conjI)
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: restrict_map_def reads_equiv_g_def)
    apply (rule requiv_user_device_eq)
            apply simp+
   apply (clarsimp simp: globals_equiv_def reads_equiv_g_def)
  apply (rule spec_equiv_valid_guard_imp)
   apply (wpsimp wp: dmo_user_memory_update_reads_respects_g dmo_device_state_update_reads_respects_g
                     dmo_device_state_update_reads_respects_g select_ev select_wp dmo_wp)
  apply clarsimp
  apply (rule conjI)
   apply clarsimp
   apply (drule spec)+
   apply (erule impE)
    prefer 2
    apply assumption
   apply (clarsimp simp: context_matches_state_def comp_def  reads_equiv_g_def globals_equiv_def)
  apply (clarsimp simp: reads_equiv_g_def globals_equiv_def)
  done

definition valid_vspace_objs_if where
  "valid_vspace_objs_if \<equiv> \<top>"

declare valid_vspace_objs_if_def[simp]

end

requalify_consts
  RISCV64.do_user_op_if
  RISCV64.valid_vspace_objs_if
  RISCV64.context_matches_state

requalify_facts
  RISCV64.do_user_op_reads_respects_g

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory MachineExports
imports MachineOps
begin

context begin interpretation Arch .

(* Check consistency of machine_word and machine_word_len. *)
term "id :: machine_word \<Rightarrow> machine_word_len word"

requalify_types
  machine_word
  machine_word_len
  vmfault_type
  hyp_fault_type
  irq

requalify_consts
  getActiveIRQ
  maskInterrupt
  freeMemory
  loadWord
  storeWord
  storeWordVM
  setNextPC
  getRestartPC
  setRegister
  getRegister
  initContext
  exceptionMessage
  syscallMessage
  gpRegisters
  frameRegisters
  ackInterrupt
  resetTimer
  maxIRQ
  minIRQ
  word_size_bits
  clearMemory
  non_kernel_IRQs
  tlsBaseRegister

(* HERE IS THE PLACE FOR GENERIC WORD LEMMAS FOR ALL ARCHITECTURES *)

lemma Suc_unat_mask_div_obfuscated:
  "Suc (unat (mask sz div (word_size::machine_word))) = 2 ^ (min sz word_bits - word_size_bits)"
  by (rule Suc_unat_mask_div)

lemma word_size_size_bits_nat:
  "2^word_size_bits = (word_size :: nat)"
  by (simp add: word_size_bits_def word_size_def)

lemma word_size_size_bits_word:
  "2^word_size_bits = (word_size :: 'a :: len word)"
  by (simp add: word_size_bits_def word_size_def)

end

end


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

theory Proof_SI
imports
  CreateObjects_SI
  CreateIRQCaps_SI
  DuplicateCaps_SI
  InitVSpace_SI
  InitTCB_SI
  InitCSpace_SI
  InitIRQ_SI
  StartThreads_SI
begin

lemma parse_bootinfo_sep:
  "\<lbrace>\<guillemotleft>((\<And>* (cptr, cap) \<in> set (zip [ustart .e. uend - 1] untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
      (\<And>* cptr \<in> set [fstart .e. fend - 1]. (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
      (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>* R)
     and K (bi_untypes bootinfo = (ustart, uend) \<and>
            bi_free_slots bootinfo = (fstart, fend) \<and>
            unat ustart < 2 ^ si_cnode_size \<and>
            unat (uend - 1) < 2 ^ si_cnode_size \<and>
            unat fstart < 2 ^ si_cnode_size \<and>
            unat (fend - 1) < 2 ^ si_cnode_size \<and>
            uend \<noteq> 0 \<and>
            fend \<noteq> 0 \<and>
            list_all is_full_untyped_cap untyped_caps \<and>
            length untyped_caps = unat uend - unat ustart) \<guillemotright>\<rbrace>
    parse_bootinfo bootinfo
   \<lbrace>\<lambda>rv.
    \<guillemotleft>((\<And>* (cptr, cap) \<in> set (zip (fst rv) untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
      (\<And>* cptr \<in> set (snd rv). (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
      (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>* R) and
     K (rv = ([fst (bi_untypes bootinfo) .e. snd (bi_untypes bootinfo) - 1],
              [fst (bi_free_slots bootinfo) .e. snd (bi_free_slots bootinfo) - 1]))\<guillemotright> \<rbrace>"
  apply (clarsimp simp: parse_bootinfo_def)
  apply (cases bootinfo, clarsimp)
  apply wp
  apply (clarsimp simp: zip_map1 comp_def split_beta')
  done

(* This isn't actually all the combinations, but enough of them for what I needed. *)
lemma object_types_distinct:
 "tcb_at x s     \<Longrightarrow> \<not> cnode_at x s"
 "table_at x s   \<Longrightarrow> \<not> cnode_at x s"
 "table_at x s   \<Longrightarrow> \<not> tcb_at x s"
 "capless_at x s \<Longrightarrow> \<not> cnode_at x s"
 "capless_at x s \<Longrightarrow> \<not> tcb_at x s"
 "capless_at x s \<Longrightarrow> \<not> table_at x s"
 "capless_at x s \<Longrightarrow> \<not> pt_at x s"
 "capless_at x s \<Longrightarrow> \<not> pd_at x s"
 "capless_at x s \<Longrightarrow> \<not> asidpool_at x s"
  by (clarsimp simp: object_at_def is_tcb_def is_cnode_def is_pd_def is_pt_def
                     is_ep_def is_ntfn_def is_asidpool_def is_frame_def
                     is_untyped_def | rule conjI |
      clarsimp split: cdl_object.splits)+

lemma real_objects_some_type:
  "well_formed spec \<Longrightarrow>
   {obj_id. real_object_at obj_id spec \<and>
       \<not> cnode_at obj_id spec \<and>
       \<not> tcb_at obj_id spec \<and>
       \<not> pt_at obj_id spec \<and>
       \<not> pd_at obj_id spec \<and>
       \<not> untyped_at obj_id spec \<and>
       \<not> ep_at obj_id spec \<and>
       \<not> ntfn_at obj_id spec \<and>
       \<not> frame_at obj_id spec} = {}"
  apply (clarsimp simp: object_at_def is_tcb_def is_cnode_def is_pd_def is_pt_def
                        is_ep_def is_ntfn_def is_asidpool_def is_frame_def is_untyped_def)
  apply (clarsimp split: cdl_object.splits)
  apply (drule_tac obj_id=x in well_formed_asidpool_at)
  apply (clarsimp simp: real_object_at_def object_at_def is_asidpool_def irq_nodes_def is_irq_node_def
                 split: cdl_object.splits)
  by metis

lemma capdl_objects_by_parts:
  "well_formed spec \<Longrightarrow>
   (sep_map_set_conj P {obj_id. real_object_at obj_id spec}) =
   (sep_map_set_conj P {obj_id. cnode_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. tcb_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. table_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. capless_at obj_id spec})"
  apply (rule sym)
  apply (subst (5) sep_map_set_conj_restrict [where t = "(\<lambda>obj. cnode_at obj spec)"], simp)
  apply (subst (6) sep_map_set_conj_restrict [where t = "(\<lambda>obj. tcb_at obj spec)"], simp)
  apply (subst (7) sep_map_set_conj_restrict [where t = "(\<lambda>obj. table_at obj spec)"], simp)
  apply (subst (8) sep_map_set_conj_restrict [where t = "(\<lambda>obj. capless_at obj spec)"], simp)
  apply (clarsimp simp: object_types_distinct real_object_not_irq_node real_objects_some_type
                  cong: rev_conj_cong)
  done

lemma objects_empty_by_parts:
  "well_formed spec \<Longrightarrow>
   (objects_empty spec t {obj_id. real_object_at obj_id spec}) =
   (objects_empty spec t {obj_id. cnode_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. tcb_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. table_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. capless_at obj_id spec})"
  by (clarsimp simp: objects_empty_def capdl_objects_by_parts)

lemma objects_initialised_by_parts:
  "well_formed spec \<Longrightarrow>
   (objects_initialised spec t {obj_id. real_object_at obj_id spec}) =
   (objects_initialised spec t {obj_id. cnode_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. tcb_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. table_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. capless_at obj_id spec})"
  by (clarsimp simp: objects_initialised_def capdl_objects_by_parts)

lemma object_empty_object_initialised_capless:
  "capless_at obj_id spec \<Longrightarrow>
   object_empty spec t obj_id = object_initialised spec t obj_id"
  apply (rule ext)
  apply (clarsimp simp: object_empty_def object_initialised_def)
  apply (clarsimp simp: object_initialised_general_def object_default_state_def2)
  apply (fastforce simp: object_at_def update_slots_def
                         object_default_state_def2 spec2s_def
                         is_ep_def is_ntfn_def is_asidpool_def
                         is_frame_def is_untyped_def cdl_frame.splits
                  split: cdl_object.splits)
  done

lemma objects_empty_objects_initialised_capless:
  "objects_empty spec t {obj_id. capless_at obj_id spec} =
   objects_initialised spec t {obj_id. capless_at obj_id spec}"
  apply (clarsimp simp: objects_empty_def objects_initialised_def)
  apply (rule sep.prod.cong, simp)
  apply (clarsimp simp: object_empty_object_initialised_capless)
  done

lemma valid_case_prod':
  "(\<And>x y. \<lbrace>P x y\<rbrace> f x y \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P (fst v) (snd v)\<rbrace> case v of (x, y) \<Rightarrow> f x y \<lbrace>Q\<rbrace>"
  by (clarsimp split: prod.splits)

lemma le_list_all:
  "\<lbrakk>unat start < 2 ^ si_cnode_size; unat (end - 1) < 2 ^ si_cnode_size\<rbrakk>
   \<Longrightarrow> list_all (\<lambda>n. (n::32 word) < 2 ^ si_cnode_size) [start .e. end - 1]"
  apply (clarsimp simp: list_all_iff)
  apply (subst word_arith_power_alt)
  apply simp
  by (metis (no_types) dual_order.strict_trans2 unat_less_2_si_cnode_size)

lemma list_all_drop:
  "list_all P xs \<Longrightarrow> list_all P (drop n xs)"
  by (fastforce simp: list_all_iff dest: in_set_dropD)

lemma dom_map_of_zip':
  "length xs \<le> length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
  apply (subst zip_take_length [symmetric])
  apply (subst dom_map_of_zip, simp+)
  done

(* FIXME: MOVE (Lib) *)
lemma in_zip_map: "p \<in> set xs \<Longrightarrow> length xs \<le> length ys \<Longrightarrow> map_of (zip xs ys) p \<noteq> None"
  using dom_map_of_zip' by blast

lemma map_of_list_allE:
  "map_of (zip ys xs) p = Some v \<Longrightarrow> distinct ys \<Longrightarrow> list_all P xs \<Longrightarrow> P v"
  apply (induct ys arbitrary: xs; clarsimp)
  by (meson in_set_zipE list_all_spec map_of_SomeD)

lemma card_eq_lengthI:
  "set xs = ys \<Longrightarrow> distinct xs \<Longrightarrow> length xs = card ys"
  by (induct xs arbitrary: ys; fastforce)

lemma length_filter_card:
  "\<lbrakk>s_list = sorted_list_of_set s; finite s\<rbrakk>
   \<Longrightarrow> length (filter P s_list) = card {x \<in> s. P x}"
  by (fastforce intro: card_eq_lengthI)

lemma sys_init_explicit:
  "\<lbrakk>well_formed spec;
   set obj_ids = dom (cdl_objects spec); distinct obj_ids;
   real_ids = [obj_id \<leftarrow> obj_ids. real_object_at obj_id spec];
   length obj_ids + length [obj\<leftarrow>obj_ids. cnode_or_tcb_at obj spec] +
   card (\<Union>(set ` get_frame_caps spec ` {obj. pd_at obj spec})) \<le> unat fend - unat fstart;
   length untyped_caps = unat uend - unat ustart;
   distinct_sets (map cap_free_ids untyped_caps);
   list_all is_full_untyped_cap untyped_caps;
   list_all well_formed_untyped_cap untyped_caps;
   list_all (\<lambda>c. \<not> is_device_cap c) untyped_caps;
   bi_untypes bootinfo = (ustart, uend);
   bi_free_slots bootinfo = (fstart, fend);
   unat ustart < 2 ^ si_cnode_size;
   unat (uend - 1) < 2 ^ si_cnode_size;
   unat fstart < 2 ^ si_cnode_size;
   unat (fend - 1) < 2 ^ si_cnode_size;
   uend \<noteq> 0; fend \<noteq> 0;
   [ustart .e. uend - 1] = untyped_cptrs;
   [fstart .e. fend - 1] = free_cptrs;
   (map_of (zip [obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec] (drop (length obj_ids) [fstart .e. fend - 1]))) = dup_caps
   \<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>(\<And>* (cptr, cap) \<in> set (zip untyped_cptrs untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
     (\<And>* cptr \<in> set free_cptrs. (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
     (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>*
    si_objects \<and>*
    si_irq_nodes spec \<and>*
    (SETSEPCONJ pd_id | pd_at pd_id spec.
      frame_duplicates_empty (make_frame_cap_map obj_ids (drop (length obj_ids) free_cptrs) spec)
                             pd_id spec) \<and>*
    R\<guillemotright>\<rbrace>
   init_system spec bootinfo obj_ids
  \<lbrace>\<lambda>_ s. \<exists>t.
    \<guillemotleft>objects_initialised spec t {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec t (used_irqs spec) \<and>*
    (\<And>* cptr\<in>set (take (card (dom (cdl_objects spec))) free_cptrs). (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     si_caps_at t dup_caps spec False {obj_id. cnode_or_tcb_at obj_id spec} \<and>*
     si_objects \<and>*
     si_objects_extra_caps (dom (cdl_objects spec))
                            (free_cptrs :: 32 word list)
                            (untyped_cptrs :: 32 word list) spec \<and>*
    (SETSEPCONJ pd_id | pd_at pd_id spec.
      frame_duplicates_copied (make_frame_cap_map obj_ids (drop (length obj_ids) free_cptrs) spec)
                              pd_id spec t) \<and>*
    R\<guillemotright> s \<and>
    inj_on t (dom (cdl_objects spec)) \<and> dom t = set obj_ids\<rbrace>"
  supply [[unify_search_bound = 1000]]
  apply clarsimp
  apply (frule (1) le_list_all [where start = ustart])
  apply (frule (1) le_list_all [where start = fstart])
  apply (frule well_formed_objects_card)
  apply (insert distinct_card [symmetric, where xs ="[obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec]"], simp)
  apply (frule distinct_card [symmetric])
  apply (clarsimp simp: init_system_def, wp valid_case_prod')
            apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in start_threads_sep [sep_wandise], simp)
           apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and
                                                  free_cptrs="[fstart .e. fend - 1]" in init_cspace_sep [sep_wandise])
          apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_tcbs_sep [sep_wandise])
         apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_vspace_sep [sep_wandise])
        apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_pd_asids_sep [sep_wandise])
       apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and dev=False in init_irqs_sep [sep_wandise])
      apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and dev=False and
                                             untyped_cptrs = "[ustart .e. uend - 1]" and
                                             free_cptrs_orig = "[fstart .e. fend - 1]" in duplicate_caps_sep [sep_wandise])
     apply (rule create_irq_caps_sep [where dev = False,sep_wandise,
            where free_cptrs_orig = "[fstart .e. fend - 1]"
              and untyped_cptrs = "[ustart .e. uend - 1]"
              and orig_caps = "map_of (zip [obj\<leftarrow>obj_ids. real_object_at obj spec]
                                           [fstart .e. fend - 1])"
              and spec = spec])
    apply (wp sep_wp: create_objects_sep [where untyped_caps = untyped_caps and dev = False])
   apply (wp sep_wp: parse_bootinfo_sep [where fstart = fstart
                                           and fend = fend
                                           and ustart = ustart
                                           and uend = uend
                                           and untyped_caps = untyped_caps])
  apply (subst objects_initialised_by_parts, assumption)
  apply (subst objects_empty_by_parts, assumption)+
  apply (subst objects_empty_objects_initialised_capless)+
  apply (clarsimp simp: linorder_not_le)
  apply (intro conjI allI impI pred_conjI | sep_cancel+)+
         apply fastforce
        apply (clarsimp simp: less_diff_conv)
        apply (rule list_all_drop, erule (1) le_list_all)
       apply clarsimp
       apply (subgoal_tac "map_of (zip (filter (\<lambda>obj. real_object_at obj spec) obj_ids) free_cptrs)
                                  p \<noteq> None")
        apply clarsimp
        apply (erule map_of_list_allE)
         apply (fastforce intro!: List.distinct_filter)
        apply (fastforce intro!: le_list_all)
       apply (rule in_zip_map)
        apply clarsimp
        apply (fastforce dest!: real_object_not_irq_node(3))
       apply (insert length_filter_le[where xs = obj_ids and P="\<lambda>obj. real_object_at obj spec"],
              fastforce)[1]
      apply (erule (1) le_list_all)
     apply (rule list_all_drop, erule (1) le_list_all)
    apply simp
   apply (subst dom_map_of_zip')
    apply (insert length_filter_le [where xs = obj_ids and P="\<lambda>obj. real_object_at obj spec"],
           fastforce)[1]
   apply simp
  apply (erule (1) le_list_all)
  done

(**************************************************
 * The top level lemma for system initialisation. *
 **************************************************)
(* FIXME, make the acquiring of the object_ids part of sys_init, not a parameter. *)

lemma sys_init:
  "\<lbrakk>well_formed spec; obj_ids = sorted_list_of_set (dom (cdl_objects spec))\<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>valid_boot_info bootinfo spec \<and>* R\<guillemotright>\<rbrace>
    init_system spec bootinfo obj_ids
   \<lbrace>\<lambda>_ s. \<exists>t.
    \<guillemotleft>objects_initialised spec t {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec t (used_irqs spec) \<and>*
     si_final_objects spec t \<and>*
     (EXS map. (SETSEPCONJ pd_id | pd_at pd_id spec. frame_duplicates_copied map pd_id spec t)) \<and>*
     R\<guillemotright> s \<and>
     inj_on t (set obj_ids) \<and> dom t = set obj_ids\<rbrace>"
  apply (insert distinct_card [where xs = "[obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec]"], simp)
  apply (clarsimp simp: valid_boot_info_def si_final_objects_def
                        sep_conj_exists sep_conj_assoc)
  apply (subst ex_conj_increase)+
  apply (rule hoare_ex_pre)+
  apply (rule hoare_grab_asm)+
  apply (rule hoare_chain)
    apply (rule sys_init_explicit[where obj_ids="sorted_list_of_set (dom (cdl_objects spec))" and R=R],
          (assumption|simp add: unat_less_2_si_cnode_size' length_filter_card)+)
   apply sep_solve
  apply clarsimp
  apply (rule_tac x=t in exI)
  apply (clarsimp)
  apply (clarsimp simp: si_objects_extra_caps_def si_caps_at_def
                        sep_conj_exists sep_conj_assoc)
  apply (rule_tac x="(map_of (zip [obj \<leftarrow> obj_ids. cnode_or_tcb_at obj spec]
                                  (drop (length obj_ids) [fstart .e. fend - 1])))" in exI)
  apply (rule_tac x="[x .e. xa - 1]" in exI)
  apply (rule_tac x="[fstart .e. fend - 1]" in exI)
  apply (rule_tac x=untyped_capsa in exI)
  apply (rule_tac x=all_available_ids in exI)
  apply (rule_tac x="make_frame_cap_map obj_ids (drop (card (dom (cdl_objects spec)))
                                                      [fstart .e. fend - 1]) spec" in exI)
  apply (clarsimp simp: sep_conj_ac)
  done

definition injective :: "('a \<Rightarrow> 'b option) \<Rightarrow> bool"
where "injective f \<equiv> inj_on f (dom f)"

lemma sys_init_paper:
  "\<lbrakk>well_formed spec; obj_ids = sorted_list_of_set (dom (cdl_objects spec))\<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>valid_boot_info bootinfo spec \<and>* R\<guillemotright>\<rbrace>
   init_system spec bootinfo obj_ids
   \<lbrace>\<lambda>_ s. \<exists>\<phi>.
    \<guillemotleft>objects_initialised spec \<phi> {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec \<phi> (used_irqs spec) \<and>*
     si_final_objects spec \<phi> \<and>*
     (EXS map. (SETSEPCONJ pd_id | pd_at pd_id spec. frame_duplicates_copied map pd_id spec \<phi>)) \<and>*
     R\<guillemotright> s \<and>
     injective \<phi> \<and> dom \<phi> = set obj_ids\<rbrace>"
  apply (rule hoare_strengthen_post)
   apply (fact sys_init)
  apply (fastforce simp: injective_def)
  done

end


(*<*)
theory Cheatsheet
  imports Main  "HOL-Library.LaTeXsugar"
(* "HOL-Library.OptionalSugar" *)
begin
(*>*)

chapter \<open>Isabelle documentation cheatsheet \label{sec:cheatsheet}\<close>

text \<open>
Isabelle allows you to mix computer verified proofs with human readable text. It has quite extensive
capabilities to modify the exported documentation, and this Theory/Module can be used as a
cheatsheet to guide a developer write maintanable documentation. It is recommended to read this
both in the JEdit editor and in the generated pdf to understand how different commands affects
the output.
\<close>

section \<open>Text basics\<close>

subsection "Text, comments and commands"

text "This is normal text between quotes."

text
"
Each text command creates a paragraph.
And it can be multiline.

An empty line does not create a new paragraph, it just creates a newline.
"

\<comment> \<open>This is a comment, it doesn't appear in the final document\<close>

(* This is another way to express a comment *)

text
"
Text blocks are commands to Isabelle, just like defining a datatype
"

datatype 'a tree
  = Tip
  | Node "'a tree" 'a "'a tree"

text
"
By default all commands appear in the generated documentation, unless you enclose them
between (*<*) a particular comment block(*>*).
"

(*<*)
datatype 'a perhaps
  = Nope
  | Yeap 'a

(*>*)

subsection "Unicode characters"

text
\<open>
Isabelle uses a lot of Unicode characters, for example the one used to define this "text block" is
called a cartouche, and it is used in several places to delimit a string.
\<close>

text
\<open>
Inside the JEdit editor you can use the "Symbols" panel to insert a character, or you can use the
autocomplete feature. To insert a cartouche start by typing a double quote ", and when the modal
appears, select cartouche template. Most unicode characters can be fuzzy searched starting with a
backslash and with the name of the character. Searching for @{verbatim \<open>\forall\<close>} will yield the
"\forall" character. If you are reading this from JEdit, you will note that the actual unicode
character is not display here, in order to see it, it needs to be inside a proposition or an
antiquote that expects it (E.g: @{prop "\<forall> x. x"}).
\<close>

subsection "Antiquotations"

text
\<open>
Antiquotations  are a way to export constructs to the document. The basic syntax is to write the
at symbol (@)  followed by the antiquotation body inside curly braces (\{\}).
\<close>

text
\<open>
For example we can use the verbatim antiquote to escape text that would otherwise be interpreted
by Isabelle: @{verbatim \<open>@verbatim{"The outer verbatim escapes the inner one. So meta"}\<close>}
\<close>

text
\<open>
The basic syntax for an antiquote is @{verbatim \<open>@{ antiquotation_body }\<close>}.
The full syntax and a list of commands is available in chapter 4.2
of the isar\_ref pdf available at this link
@{url "https://isabelle.in.tum.de/doc/isar-ref.pdf#page=84"}. Note the use of the
@{verbatim "@{url}"} antiquote.
\<close>

text
\<open>
Not all antiquotes are listed in the chapter 4.2, for example the @{verbatim "datatype"} and
@{verbatim "code_stmts"} antiquotes are missing. To see a list of all the antiquotes available in a
context and the options you can click on the following command and inspect the output pane:
\<close>

print_antiquotations

text
\<open>
You can read the \<^emph>\<open>ML\<close> code to see what arguments can be passed by entering the definition
with @{verbatim "CMD+click"} on the antiquote.
\<close>

text
\<open>
Sidenote:
\<^item> To avoid adding a url in the body of the text, you can use a footnote using the
@{verbatim \<open>\footnote\<close>} unicode char \<^footnote>\<open>Url by antiquote: @{url "www.google.com"}\<close>.
\<^item> Instead of the @{verbatim "@{url}"} antiquote, you can also use the unicode char @{verbatim \<open>\url\<close>}
 \<^footnote>\<open>Url by unicode char: \<^url>\<open>http://www.google.com\<close> \<close>.
\<^item> Instead of the @{verbatim "@{verbatim}"} antiquote you can use the \<^verbatim>\<open>\verbatim\<close> char.
\<close>

subsection \<open>Formatting text\<close>

text

\<open>
You can use the @{verbatim \<open>\emph\<close>} char to \<^emph>\<open>emphasize text\<close>, or the
@{verbatim \<open>\bold\<close>} to \<^bold>\<open>bold it\<close>.

\begin{center}
You can also write centered text.
\end{center}

Use the @{verbatim \<open>\item\<close>} char
\<^item> to
\<^item> create
\<^item> bullets

\<close>
text
\<open>
Or the @{verbatim \<open>\enum\<close>} char
\<^enum> to
\<^enum> create
\<^enum> numbered bullets

\<close>

subsection \<open>References\<close>

text
\<open>
Inside \<^emph>\<open>root.tex\<close> there is a command definition for \<^verbatim>\<open>\secref{sec:cheatsheet}\<close>, which allow us to reference
sections labeled using \<^verbatim>\<open>\label{sec:cheatsheet}\<close> (E.g: \secref{sec:cheatsheet}).
\<close>

text
\<open>
To produce hyperlinks like in HTML we can use the \<^verbatim>\<open>\hyperref[sec:cheatsheet]{some link}\<close> command.
(E.g: \hyperref[sec:cheatsheet]{link to cheatsheet})
\<close>
section \<open>Definitions \label{sec:definitions}\<close>
subsection \<open>Terms, types and values\<close>

text \<open>
You can print terms, types and values.  Note that in some cases we need to specify the type
of a number using \<^verbatim>\<open>::\<close> as addition is polymorphic.

\<^item> Term: @{term "2 + 2"}
\<^item> Type of a polymorphic term: @{typeof "2 + 2"}
\<^item> Type of a concrete term: @{typeof "2 + 2 :: nat"}
\<^item> The evaluation of a term @{value "2 + 2 :: nat"}
\<^item> The evaluation of a term with its type @{value [show_types] "2 + 2 :: nat"}
\<close>

subsection \<open>Data types  \label{sec:definitions-datatypes}\<close>

text \<open>To print a datatype we can use the @{verbatim "@{datatype <type>}"} antiquote.\<close>

text \<open>@{datatype tree}\<close>

(*
text \<open>
Isabelle will try to print it as a one-liner, but if its too big, you can use the
 @{verbatim "[display]"} option to span in multiple lines.\<close>

text \<open>@{datatype[display] tree}\<close>

text \<open>
By default, if the name collides Isabelle will use the full specified name. We can
use @{verbatim "[names_short]"} option to solve that.\<close>

text \<open>@{datatype[display,names_short] tree}\<close>
*)

text  \<open>We can also use the @{verbatim "code_stmts"} antiquote to print a datatype in Haskell\<close>

text \<open>@{code_stmts tree.case_tree type_constructor: tree (Haskell)}\<close>

text \<open>By default @{verbatim "code_stmts"} will print all the code needed to export the constants. We
can control what gets printed with the
 @{verbatim "type_constructor, constant, type_class and class_instance"} modifiers.\<close>

subsection \<open>Functions \label{sec:definitions-functions}\<close>

text \<open>The following is the syntax for defining a function:\<close>

fun isNope :: "'a perhaps \<Rightarrow> bool" where
  "isNope Nope = True" |
  "isNope (Yeap _) = False"

fun isYeap :: "'a perhaps \<Rightarrow> bool" where
  isYeap_Nope: "isYeap Nope = False" |
  isYeap_Yeap: "isYeap (Yeap _) = True"

text \<open>Note that the second
definition gives a label to each pattern match. This enable us to reference a case using the
\<^verbatim>\<open>@{thm isYeap_Nope}\<close> and \<^verbatim>\<open>@{thm isYeap_Yeap}\<close> antiquotes.
\<close>

text \<open>
\begin{center}
@{thm isYeap_Nope} \\
@{thm isYeap_Yeap }
\end{center}
\<close>

text
\<open>
If the function cases doesn't have a label we can still reference them using the
\<^verbatim>\<open>@{thm isNope.simps(n)}\<close> constant.
Whenever we define a datatype, function or theorem, different constants are created. Use the \<^emph>\<open>Query\<close>
panel to inspect them.
\<close>

text
\<open>
\begin{center}
@{thm isNope.simps(1)} \\
@{thm isNope.simps(2)}
\end{center}
\<close>

text
\<open>
Using the \<^verbatim>\<open>[display]\<close> option we can print all terms at once (with a slightly smaller font, and for
some reason the center does not work).
 \<^verbatim>\<open>@{thm [display]isNope.simps}\<close>
\<close>

text
\<open>
\begin{center}
@{thm [display]isNope.simps}
\end{center}
\<close>

text \<open>
We can print the type of a function using the \<^verbatim>\<open>@{typeof ...}\<close> antiquote, or a term with it's
type using \<^verbatim>\<open>@{term_type ...}\<close>.

\<^item> Tyepof a function isNope :: @{typeof isNope}
\<^item> Term and its type: @{term_type isNope}
\<close>

text \<open>
In the section \<^emph>\<open>Latex Sugar\<close> \secref{sec:latex-sugar} there are links to a pdf that shows how to
align equations.
\<close>

text
\<open>
\begin{center}
\begin{tabular}{l@ {~~@{text "="}~~}l}
@{thm (lhs) isYeap_Nope} & @{thm (rhs) isYeap_Nope}\\
@{thm (lhs) isYeap_Yeap} & @{thm (rhs) isYeap_Yeap}
\end{tabular}
\end{center}
\<close>

text \<open>And how to rename \<^verbatim>\<open>DUMMY\<close> variables\<close>

text
\<open>
\begin{center}
\begin{tabular}{l@ {~~@{text "="}~~}l}
@{thm (lhs) isYeap_Nope} & @{thm (rhs) isYeap_Nope}\\
@{thm (dummy_pats,lhs) isYeap_Yeap} & @{thm (rhs) isYeap_Yeap}
\end{tabular}
\end{center}

\<close>

text
\<open>
Similar to the Datatype definition \secref{sec:definitions-datatypes}, we can use the \<^verbatim>\<open>@code_stmts{...}\<close>
antiquote to print the Haskell version of a function.
\<close>

text \<open>@{code_stmts isNope constant: isNope (Haskell)}\<close>

section \<open>Proofs\<close>

text
\<open>
For a proposition that has been already proven, and that is available in the current context, we
can use the \<^verbatim>\<open>@{thm map_append}\<close> antiquote to print it.
\<close>

text \<open>@{thm map_append}\<close>

text
\<open>
When we need to prove a proposition, Isabelle provide us two different ways: an imperative and a
declarative way. When the proof is trivial, it is recommended to use the imperative way
\<close>

(*<*)
fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum [] = 0" |
  "listsum (x#xs) = x + listsum xs"

(*>*)

lemma listsum_app: "listsum (xs @ ys) = listsum xs + listsum ys"
  apply (induction xs)
  apply (simp_all)
  done

text "or even shorter"

lemma listsum_app2: "listsum (xs @ ys) = listsum xs + listsum ys"
  by (induction xs) simp_all

text
\<open>
When the theorem is more complex, the authors of Isabelle recommend to write them as structured proofs
with Isar \<^footnote>\<open>\<^url>\<open>http://concrete-semantics.org/concrete-semantics.pdf#page=63\<close>\<close>. Those type of test
are easier to read and to maintain.
\<close>

text "For example, given the definition for a reverse function that can be optimized with TCO"

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev [] ys = ys" |
  "itrev (x # xs) ys = itrev xs (x # ys)"

text \<open>We would like to prove that @{prop "itrev xs ys =  rev xs @ ys" }. The lemma is easy
enough to write it in an imperative way\<close>

lemma itrev_app: "itrev xs ys =  rev xs @ ys"
  by (induction xs arbitrary: ys) simp_all

text "But we can use this as an example to showcase Isar. If you write the \<^verbatim>\<open>proof\<close> command and give
a method like induction, Isabelle will suggest you the pattern match to divide the proof by its case.
In the simplest example we could write the proof like this:"

lemma itrev_app2: "itrev xs ys =  rev xs @ ys"
proof (induction xs arbitrary: ys)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by simp
qed

text "The \<^verbatim>\<open>?case\<close> keyword is the current goal for each case. We can also use other constructs
to refine the goal and to make the proof more explicit"

lemma itrev_app3: "itrev xs ys =  rev xs @ ys"
proof (induction xs arbitrary: ys)
  case Nil
  hence "itrev [] ys = ys" by simp
  hence "...  = [] @ ys" by (simp only: append_Nil)
  hence "...  = rev [] @ ys"  by (simp only: rev.simps)
  thus "itrev [] ys = rev [] @ ys" by simp
next
  case (Cons x xs)
  hence 0: "itrev (x # xs) ys = itrev xs (x # ys) " by (simp only: itrev.simps)
  hence 1: "... = rev xs @ (x # ys)" using Cons.IH by (simp only:  Cons.IH)
  hence 2: "... = rev xs @ [x] @ ys" by simp
  hence 3: "... = rev xs @ rev [x] @ ys" by simp
  hence 4: "... = rev ([x] @ xs) @ ys"  by (simp flip: rev_append)
  from 1 4 show "itrev (x # xs) ys = rev (x # xs) @ ys" by simp
qed

text "We can also play with \<^verbatim>\<open>(*<*) ... (*>*)\<close> and antiquotes to focus on the english version of
the proof."

text_raw \<open>\fbox{\parbox{\textwidth}{\<close>
(*<*)
lemma itrev_app4 [simp]: "itrev xs ys =  rev xs @ ys"
(*>*)
  text \<open>
  \<^bold>\<open>Lemma\<close> @{term ?thesis}. \\ \\
  We can use induction on @{verbatim "xs"} for an arbitrary @{verbatim "ys"}
\<close>

(*<*)
proof (induction xs arbitrary: ys)
  case Nil
(*>*)
  text_raw
  \<open>\begin{enumerate}
  \item For the Base case: \\
  \begin{tabular}{l@ {~~@{text "="}~~}l l}
  \<close>
  (*<*)hence "itrev [] ys = ys" by simp(*>*)
  text_raw \<open>@{thm (lhs) this} & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of \<^verbatim>\<open>itrev\<close>\\\<close>

  (*<*)hence "...  = [] @ ys" by (simp only: append_Nil) (*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of \<^verbatim>\<open>append\<close>\\\<close>

  (*<*)hence "...  = rev [] @ ys" by (simp only: rev.simps) (*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of \<^verbatim>\<open>rev\<close>\\\<close>

  text_raw
  \<open>\end{tabular} \\\<close>
  (*<*)thus "itrev [] ys = rev [] @ ys" by simp (*>*)

(*<*)
next
  case (Cons x xs)
(*>*)
  text_raw
  \<open>\item For the Inductive case: \\
   We assume the \<^emph>\<open>I.H.\<close> as: \forall ys. @{thm Cons.IH}, then \\
   \begin{tabular}{l@ {~~@{text "="}~~}l l}
  \<close>

  (*<*)hence 0: "itrev (x # xs) ys = itrev xs (x # ys) " by (simp only: itrev.simps)(*>*)
  text_raw \<open>@{thm (lhs) this} & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of \<^verbatim>\<open>itrev\<close>\\\<close>

  (*<*)hence 1: "... = rev xs @ (x # ys)" using Cons.IH by (simp only: Cons.IH)(*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the induction hypotesis \\\<close>

  (*<*)hence 2: "... = rev xs @ [x] @ ys" by simp (*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of \<^verbatim>\<open>append\<close>\\\<close>

  (*<*)hence 3: "... = rev xs @ rev [x] @ ys" by simp (*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the singleton\_rev lemma \\\<close>

  (*<*)hence 4: "... = rev ([x] @ xs) @ ys"  by (simp flip: rev_append)(*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the rev\_append lemma \\\<close>

  (*<*)from 1 4 show "itrev (x # xs) ys = rev (x # xs) @ ys" by simp(*>*)
  text_raw \<open> & @{thm (rhs) this} & \<^bold>\<open>by\<close> the definition of append \\\<close>

  text_raw \<open>
  \end{tabular}
  \end{enumerate}
  }}
  \<close>
(*<*)qed(*>*)

subsection "Parenthesis problem"

text \<open>Isabelle has some translation rule that gets rid of "unnecesary parenthesis".
This makes some theorems a little bit awkward \<^verbatim>\<open>@{thm append_assoc}\<close>:\<close>

text \<open>@{thm append_assoc}\<close>

text \<open>
This happens even if we write it manually.

\<close>
text \<open>\<^prop>\<open>(a @ b) @ c = a @ (b @ c)\<close>\<close>

text "So far I wasn't able to solve this problem"

section \<open>Latex sugar \label{sec:latex-sugar}\<close>
text
\<open>
The Latex sugar pdf \<^footnote>\<open>Latex sugar: \<^url>\<open>https://isabelle.in.tum.de/doc/sugar.pdf\<close> \<close> explains some
advanced commands, like printing Inference Rules.

\begin{center}
  @{thm[mode=Rule] conjI} {\sc conjI}
\end{center}

For this to work, @{verbatim \<open>"HOL-Library.LaTeXsugar"\<close>} needs to be imported and the
@{verbatim \<open>\usepackage{mathpartir}\<close>} used in \<^emph>\<open>root.tex\<close>
\<close>

text
\<open>In the \<^verbatim>\<open>"HOL-Library.OptionalSugar\<close> package there are some translation rules that we can copy,
paste and modify into a "formmating" package to modify the notation of some constructs. For example,
with the following code, list notation looks more closely to Haskell notation\<close>

notation (latex)
  Cons  ("_ :/ _" [66,65] 65)

syntax (latex output)
  "_appendL" :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<^latex>\<open>++\<close>" 65)

translations
  "_appendL xs ys" <= "xs @ ys"
  "_appendL (_appendL xs ys) zs" <= "_appendL xs (_appendL ys zs)"

text
\<open>
@{thm [display]rev.simps}
\<close>

(*<*)
end
(*>*)