(*
    File:        SndLBeta.thy
    Time-stamp:  <2016-01-06T17:03:46Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory SndLBeta imports LBeta begin

consts

  SndLBeta1 :: i

inductive
  domains "SndLBeta1" <= "LTerm * LTerm"

  intros
    baseI: "LFreeForIn(B, x, A) ==>
            <LApp(LLam(x, A), B), Lsubst(A, x, B)>: SndLBeta1"

    LLamI: "[| <M, M'>: SndLBeta1;  x: LVariable |] ==>
            <LLam(x, M), LLam(x, M')>: SndLBeta1"

    LAppI1: "[| <A, A'>: SndLBeta1;  B: LTerm |] ==>
             <LApp(A, B), LApp(A', B)>: SndLBeta1"

    LAppI2: "[| <B, B'>: SndLBeta1;  A: LTerm |] ==>
             <LApp(A, B), LApp(A, B')>: SndLBeta1"

  type_intros LTerm.intros SigmaI nat_0I Lsubst_type
  type_elims SigmaE2 LFreeForInE

lemma SndLBeta1_LBeta1:
  "<M, N>: SndLBeta1 ==> LBeta1(M, N)"
apply (erule SndLBeta1.induct)
apply (assumption | rule LBeta1_baseI LBeta1_LLamI
         LBeta1_LAppI1 LBeta1_LAppI2)+
done

lemma LBeta1_SndLBeta1:
  assumes prem: "LBeta1(M, N)"
  shows "<M, N>: SndLBeta1"
apply (rule prem [THEN rev_mp])
apply (rule prem [THEN LBeta1_type2, THEN [2] bspec])
apply (rule prem [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs LTerm_typeEs)
apply (drule_tac [4] bspec [THEN mp], erule_tac [4] asm_rl,
       erule_tac [4] asm_rl)
apply (drule_tac [3] bspec [THEN mp], erule_tac [3] asm_rl,
       erule_tac [3] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] asm_rl,
       erule_tac [1] asm_rl)
apply (assumption | erule SndLBeta1.intros)+
done

lemma SndLBeta1_iff_LBeta1:
  "<M, N> : SndLBeta1 <-> LBeta1(M, N)"
apply (rule iffI)
apply (erule SndLBeta1_LBeta1)
apply (erule LBeta1_SndLBeta1)
done

end


section \<open>Circular Singly Linked Lists\<close>
theory Circ_List
imports List_Seg Imp_List_Spec
begin

text \<open>
  Example of circular lists, with efficient append, prepend, pop, and rotate
  operations.
\<close>

subsection \<open>Datatype Definition\<close>

type_synonym 'a cs_list = "'a node ref option"

text \<open>A circular list is described by a list segment, with special
  cases for the empty list:\<close>
fun cs_list :: "'a::heap list \<Rightarrow> 'a node ref option \<Rightarrow> assn" where
  "cs_list [] None = emp"
| "cs_list (x#l) (Some p) = lseg (x#l) (Some p) (Some p)"
| "cs_list _ _ = false"

lemma [simp]:
  "cs_list l (Some p)
  = (\<exists>\<^sub>Ax ls. \<up>(l=x#ls) * lseg (x#ls) (Some p) (Some p))"
  apply (rule ent_iffI)
  apply (cases l)
  apply simp
  apply sep_auto
  apply (cases l)
  apply simp
  apply sep_auto
  done

subsection \<open>Precision\<close>
lemma cs_prec:
  "precise cs_list"
  apply rule
  apply (case_tac p)
  apply clarsimp

  apply clarsimp
  apply (subgoal_tac "x=xa \<and> n=na", simp)

  apply (erule prec_frame_expl[OF lseg_prec1])
  apply frame_inference
  apply frame_inference

  apply (drule prec_frame[OF sngr_prec])
  apply frame_inference
  apply frame_inference
  apply simp
  done

lemma cs_imp_list_impl: "imp_list cs_list"
  apply unfold_locales
  apply (rule cs_prec)
  done
interpretation cs: imp_list cs_list by (rule cs_imp_list_impl)

subsection \<open>Operations\<close>
subsubsection \<open>Allocate Empty List\<close>
definition cs_empty :: "'a::heap cs_list Heap" where
  "cs_empty \<equiv> return None"

lemma cs_empty_rule: "<emp> cs_empty <cs_list []>"
  unfolding cs_empty_def
  by sep_auto

lemma cs_empty_impl: "imp_list_empty cs_list cs_empty"
  by unfold_locales (sep_auto heap: cs_empty_rule)
interpretation cs: imp_list_empty cs_list cs_empty by (rule cs_empty_impl)

subsubsection \<open>Prepend Element\<close>
fun cs_prepend :: "'a \<Rightarrow> 'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_prepend x None = do {
    p \<leftarrow> ref (Node x None);
    p:=Node x (Some p);
    return (Some p)
  }"
| "cs_prepend x (Some p) = do {
    n \<leftarrow> !p;
    q \<leftarrow> ref (Node (val n) (next n));
    p := Node x (Some q);
    return (Some p)
  }"

declare cs_prepend.simps [simp del]

lemma cs_prepend_rule:
  "<cs_list l p> cs_prepend x p <cs_list (x#l)>"
  apply (cases p)
  apply simp_all
  apply (sep_auto simp: cs_prepend.simps)

  apply (sep_auto simp: cs_prepend.simps)
  done

lemma cs_prepend_impl: "imp_list_prepend cs_list cs_prepend"
  by unfold_locales (sep_auto heap: cs_prepend_rule)
interpretation cs: imp_list_prepend cs_list cs_prepend
  by (rule cs_prepend_impl)

subsubsection \<open>Append Element\<close>
fun cs_append :: "'a \<Rightarrow> 'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_append x None = do {
    p \<leftarrow> ref (Node x None);
    p:=Node x (Some p);
    return (Some p) }"
| "cs_append x (Some p) = do {
    n \<leftarrow> !p;
    q \<leftarrow> ref (Node (val n) (next n));
    p := Node x (Some q);
    return (Some q)
  }"

declare cs_append.simps [simp del]

lemma cs_append_rule:
  "<cs_list l p> cs_append x p <cs_list (l@[x])>"
  apply (cases p)
  apply simp_all
  apply (sep_auto simp: cs_append.simps)

  apply (sep_auto simp: cs_append.simps)
  apply (rule ent_frame_fwd)
  apply (rule_tac s=pp in lseg_append) (* frame_inference does no backtracking
    on instantiating schematics, hence we have to give it some help here. *)
  apply frame_inference
  apply (sep_auto)
  done

lemma cs_append_impl: "imp_list_append cs_list cs_append"
  by unfold_locales (sep_auto heap: cs_append_rule)
interpretation cs: imp_list_append cs_list cs_append
  by (rule cs_append_impl)

subsubsection \<open>Pop First Element\<close>
fun cs_pop :: "'a::heap cs_list \<Rightarrow> ('a\<times>'a cs_list) Heap" where
  "cs_pop None = raise STR ''Pop from empty list''"
| "cs_pop (Some p) = do {
    n1 \<leftarrow> !p;
    if next n1 = Some p then
      return (val n1,None) \<comment> \<open>Singleton list becomes empty list\<close>
    else do {
      let p2 = the (next n1);
      n2 \<leftarrow> !p2;
      p := Node (val n2) (next n2);
      return (val n1,Some p)
    }
  }"

declare cs_pop.simps[simp del]

lemma cs_pop_rule:
  "<cs_list (x#l) p> cs_pop p <\<lambda>(y,p'). cs_list l p' * true * \<up>(y=x)>"
  apply (cases p)
  apply (sep_auto simp: cs_pop.simps)

  apply (cases l)
  apply (sep_auto simp: cs_pop.simps dflt_simps: option.sel)

  apply (sep_auto
    simp: cs_pop.simps
    dflt_simps: option.sel
    eintros del: exI)
  (* Some unfortunate quantifier fiddling :( *)
  apply (rule_tac x=aa in exI)
  apply (rule_tac x=list in exI)
  apply (rule_tac x=pp in exI)
  apply clarsimp
  apply (rule exI)
  apply sep_auto
  done

lemma cs_pop_impl: "imp_list_pop cs_list cs_pop"
  apply unfold_locales
  apply (sep_auto heap: cs_pop_rule elim!: neq_NilE)
  done
interpretation cs: imp_list_pop cs_list cs_pop by (rule cs_pop_impl)

subsubsection \<open>Rotate\<close>
fun cs_rotate :: "'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_rotate None = return None"
| "cs_rotate (Some p) = do {
    n \<leftarrow> !p;
    return (next n)
  }"

declare cs_rotate.simps [simp del]

lemma cs_rotate_rule:
  "<cs_list l p> cs_rotate p <cs_list (rotate1 l)>"
  apply (cases p)
  apply (sep_auto simp: cs_rotate.simps)

  apply (cases l)
  apply simp

  apply (case_tac list)
  apply simp
  apply (sep_auto simp: cs_rotate.simps)

  apply (sep_auto simp: cs_rotate.simps)
  apply (rule ent_frame_fwd)
  apply (rule_tac s="pp" in lseg_append)
  apply frame_inference
  apply sep_auto
  done

lemma cs_rotate_impl: "imp_list_rotate cs_list cs_rotate"
  apply unfold_locales
  apply (sep_auto heap: cs_rotate_rule)
  done
interpretation cs: imp_list_rotate cs_list cs_rotate by (rule cs_rotate_impl)

subsection \<open>Test\<close>
definition "test \<equiv> do {
  l \<leftarrow> cs_empty;
  l \<leftarrow> cs_append ''a'' l;
  l \<leftarrow> cs_append ''b'' l;
  l \<leftarrow> cs_append ''c'' l;
  l \<leftarrow> cs_prepend ''0'' l;
  l \<leftarrow> cs_rotate l;
  (v1,l)\<leftarrow>cs_pop l;
  (v2,l)\<leftarrow>cs_pop l;
  (v3,l)\<leftarrow>cs_pop l;
  (v4,l)\<leftarrow>cs_pop l;
  return [v1,v2,v3,v4]
}"

definition "test_result \<equiv> [''a'', ''b'', ''c'', ''0'']"

lemma "<emp> test <\<lambda>r. \<up>(r=test_result) * true>"
  unfolding test_def test_result_def
  apply (sep_auto)
  done

export_code test checking SML_imp

ML_val \<open>
  val res = @{code test} ();
  if res = @{code test_result} then () else raise Match;
\<close>

hide_const (open) test test_result

end


text_raw \<open>\subsection[Identifiability, Isomorphical Uniqueness and Permutability]{Identifiability, Isomorphical Uniqueness and Permutability\isalabel{identifiability-iso-uniqueness}}\<close>

theory IdentifiabilityAndIsomorphicalUniqueness
  imports Identifiability
  "../ParticularStructures/StructuralPropertiesTheorems"
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  While we introduced, in the previous section, a definition for
  what consists the ``identity'' of a particular in terms of the
  existence of a suitable \emph{identifying predicate}, in this
  section we show that it is not necessary to refer to the existence
  of an
  element that is ontologically extraneous to the UFO particular
  structure (the identifying predicate), to characterize the concept
  of the ``identity'' of a particular.

  We achive this by proving the logical equivalence between the
  notion of identifiability, as described in the previous section,
  and the notions of isomorphical uniqueness and non-permutability,
  that were introduced in \autoref{subsec:isomorphical-uniqueness}
  and \autoref{subsec:permutability}.
\<close>

context ufo_particular_theory
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> ex1_intro_1:
  fixes A and P
  assumes \<open>f \<in> A\<close> \<open>\<And>g. g \<in> A \<Longrightarrow> g a = f a\<close>
  shows \<open>\<exists>!z. \<forall>g \<in> A. g a = z\<close>
  apply (intro ex1I[of _ \<open>f a\<close>] ballI)
  subgoal using assms by blast
  subgoal premises P for z
    using P[rule_format,OF assms(1)]
    by simp
  done

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The equivalence of the set of isomorphically-unique particulars
  and the set of identifiable particulars is shown by the following
  lemmas and theorem:
\<close>

lemma  im_uniques_are_identifiables: \<open>\<P>\<^sub>\<simeq>\<^sub>! \<subseteq> \<P>\<^sub>=\<close>
proof (intro subsetI)
  fix x
  assume as: \<open>x \<in> \<P>\<^sub>\<simeq>\<^sub>!\<close>
  obtain \<open>x \<in> \<E>\<close> using as by blast

  have A: \<open>\<sigma> x = \<phi> x\<close>
    if \<open>inj_on \<phi> \<E>\<close>
       \<open>particular_struct_morphism \<Gamma> (MorphImg \<phi> \<Gamma>) \<sigma>\<close>
    for \<phi>  \<sigma> :: \<open>'p \<Rightarrow> ZF\<close>
    apply (rule as[THEN isomorphically_unique_particulars_E])
    subgoal premises P
      apply (rule P(2)[simplified,OF conjI
                ,OF that(1)[simplified] _ that(2) \<open>x \<in> \<E>\<close>,
                THEN iffD2])
      using inj_on_id by blast+
    done

  have pick_ex: \<open>\<exists>!y. \<forall>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>. \<phi>' x = y\<close>
    if as1: \<open>\<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> for \<Gamma>'
  proof -
    obtain \<phi>\<^sub>1 where phi1:
        \<open>\<phi>\<^sub>1 \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
        \<open>\<Gamma>' = MorphImg \<phi>\<^sub>1 \<Gamma>\<close>
      using as1 by blast
    interpret phi1: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<^sub>1\<close> using phi1 by simp
    interpret phi1_inv: particular_struct_bijection_1 \<open>MorphImg \<phi>\<^sub>1 \<Gamma>\<close> \<open>phi1.inv_morph\<close>
      using particular_struct_bijection_iff_particular_struct_bijection_1 by blast

    have AA: \<open>\<phi>\<^sub>1 \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>\<close>
      apply (auto)
      using phi1(2) phi1.particular_struct_morphism_axioms
      by blast

    have BB: \<open>\<phi>' x = \<phi>\<^sub>1 x\<close> if as2: \<open>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>\<close> for \<phi>'
      apply (rule A)
      subgoal using phi1.morph_is_injective[simplified] .
      using phi1(2) as2 morphs_D by metis

    show \<open>?thesis\<close>
      apply (rule ex1_intro_1[of \<open>\<phi>\<^sub>1\<close>])
      subgoal using AA .
      subgoal premises P for \<phi>'
        using BB[OF P] .
      done
  qed

  show \<open>x \<in> \<P>\<^sub>=\<close>
  proof (clarsimp simp:  identifiables_def \<open>x \<in> \<E>\<close>)

    define P where \<open>P \<Gamma>' z \<longleftrightarrow> z = (THE y. \<forall>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>. \<phi>' x = y)\<close> for \<Gamma>' and z :: \<open>ZF\<close>

    have P1: \<open>P \<Gamma>' (\<phi>' x)\<close>
      if \<open>\<exists>\<phi>\<in>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>. \<Gamma>' = MorphImg \<phi> \<Gamma>\<close> \<open>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>\<close> for \<Gamma>' \<phi>'
      using pick_ex[THEN the1I2,of \<open>\<Gamma>'\<close> \<open>\<lambda>y. \<forall>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub>. \<phi>' x = y\<close>,
        simplified P_def[symmetric],simplified] that by metis
    have P2: \<open>P (MorphImg \<phi> \<Gamma>) (\<phi>' x)\<close>
      if \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> \<open>\<phi>' \<in> Morphs\<^bsub>\<Gamma>, MorphImg \<phi> \<Gamma>\<^esub>\<close> for \<phi> \<phi>'
      using P1 that by metis

    have P3: \<open>y = \<phi> x\<close>
      if as3: \<open>\<sigma> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> \<open>\<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<sigma> \<Gamma>\<^esub>\<close>
              \<open>P (MorphImg \<sigma> \<Gamma>) y\<close>  for \<sigma> \<phi> y
      apply (rule the1_equality[of \<open>\<lambda>y. \<forall>\<phi>' \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<sigma> \<Gamma>\<^esub>. \<phi>' x = y\<close>,of \<open>\<phi> x\<close>,
              simplified as3(3)[simplified P_def,symmetric],OF pick_ex]
              ; (intro ballI)?)
      subgoal G1 using that(1) by blast
      subgoal for \<phi>\<^sub>3
        apply auto
        by (metis G1 morphs_iff pick_ex that(2))
      done

    show \<open>\<exists>P. identity_pred \<Gamma> P x\<close>
      apply (intro exI[of _ \<open>P\<close>] identity_pred_I1 iffI )
      subgoal by (simp add: \<open>x \<in> \<E>\<close>)
      subgoal by (metis (full_types) P3 as isomorphic_models_E ufo_particular_theory_sig.isomorphically_unique_particulars_E)
      using P2 \<open>x \<in> \<E>\<close> by auto
  qed
qed

lemma identifiables_are_im_uniques: \<open>\<P>\<^sub>= \<subseteq> \<P>\<^sub>\<simeq>\<^sub>!\<close>
proof (intro subsetI)
  fix x
  assume \<open>x \<in> \<P>\<^sub>=\<close>
  then obtain P where P: \<open>x \<in> \<E>\<close> \<open>identity_pred \<Gamma> P x\<close> by blast
  show \<open>x \<in> \<P>\<^sub>\<simeq>\<^sub>!\<close>
  proof (rule)
    show \<open>x \<in> \<E>\<close> using P(1) .
    fix \<phi> \<sigma> y
    assume as: \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> \<open>\<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>\<close> \<open>y \<in> \<E>\<close>
    have P1: \<open>identity_pred (MorphImg \<phi> \<Gamma>) P (\<phi> x)\<close>
      using identity_respects_isomorphisms[OF P(2) as(1)] .
    interpret phi: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close>
      using as(1) by blast
    have A: \<open>phi.tgt.\<Gamma> = MorphImg \<phi> \<Gamma>\<close>
      using phi.tgt_Gamma_eq_Morph_img by auto
    have B: \<open>\<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>\<close>
      using as(1) by (meson bijections1_are_morphisms)
    note C = identity_pred_eqI[
               where \<phi> = \<open>\<phi>\<close> and x = \<open>x\<close> and P = \<open>P\<close> and \<sigma> = \<open>\<phi>\<close>,
                 OF P(2) as(1) B]
             identity_pred_eqI[
               where \<phi> = \<open>\<sigma>\<close> and x = \<open>x\<close> and P = \<open>P\<close> and \<sigma> = \<open>\<phi>\<close>,
                 OF P(2) as(1,2)]
    have D: \<open>P (MorphImg \<phi> \<Gamma>) (\<sigma> x) \<longleftrightarrow> P (MorphImg \<phi> \<Gamma>) (\<phi> x)\<close>
      by (metis C(1) C(2) P(1))
    have E: \<open>\<phi> x = \<sigma> x \<longleftrightarrow> P (MorphImg \<phi> \<Gamma>) (\<phi> x)\<close>
      using C(2)[of \<open>\<phi> x\<close>]
      using P(1) P(2) identity_pred phi.morph_is_injective by auto
    have E1: \<open>MorphImg \<phi> \<Gamma> \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
      using as(1) by blast
    obtain F: \<open>\<And>\<Gamma>' \<phi> y. \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> \<Longrightarrow> \<phi> \<in> Morphs\<^bsub>\<Gamma>,\<Gamma>'\<^esub> \<Longrightarrow> P \<Gamma>' y = (\<forall>z\<in>phi.src.endurants. (y = \<phi> z) = (z = x))\<close>
      using P(2)[THEN identity_pred_E] by metis
    note G = F[OF E1 as(2)]
    note H = C(1)[simplified C(2)]
    note J = H[THEN iffD1,simplified Ball_def,simplified,rule_format]
             H[THEN iffD2,simplified Ball_def,simplified,rule_format]
    show \<open>\<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close>
      apply (intro iffI)
      subgoal using G P(2) as(3) identity_pred phi.particular_struct_bijection_1_axioms by auto
      subgoal using J by (metis E P(2) identity_pred phi.morph_is_injective ufo_particular_theory_sig.\<Gamma>_simps(2))
      done
  qed
qed

theorem identifiables_are_the_im_uniques: \<open>\<P>\<^sub>= = \<P>\<^sub>\<simeq>\<^sub>!\<close>
  using im_uniques_are_identifiables
      identifiables_are_im_uniques
  by blast

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Since the set of isomorphically unique particulars is
  equivalent to the set of non-permutable particulars,
  then we can also say that the identifiable particulars
  are exactly those that are non-permutable:\<close>

theorem identifiables_are_the_non_permutables: \<open>\<P>\<^sub>= = \<P>\<^sub>1\<^sub>!\<close>
  using identifiables_are_the_im_uniques
  by (simp add: non_permutable_particulars_are_the_unique_particulars)

end

end


section\<open>The Axiom of Separation in $M[G]$\<close>
theory Separation_Axiom
  imports Forcing_Theorems Separation_Rename
begin

context G_generic1
begin

lemma map_val :
  assumes "env\<in>list(M[G])"
  shows "\<exists>nenv\<in>list(M). env = map(val(G),nenv)"
  using assms
proof(induct env)
  case Nil
  have "map(val(G),Nil) = Nil" by simp
  then show ?case by force
next
  case (Cons a l)
  then obtain a' l' where
    "l' \<in> list(M)" "l=map(val(G),l')" "a = val(G,a')"
    "Cons(a,l) = map(val(G),Cons(a',l'))" "Cons(a',l') \<in> list(M)"
    using GenExtD
    by force
  then show ?case by force
qed

lemma Collect_sats_in_MG :
  assumes
    "A\<in>M[G]"
    "\<phi> \<in> formula" "env\<in>list(M[G])" "arity(\<phi>) \<le> 1 +\<^sub>\<omega> length(env)"
  shows
    "{x \<in> A . (M[G], [x] @ env \<Turnstile> \<phi>)} \<in> M[G]"
proof -
  from \<open>A\<in>M[G]\<close>
  obtain \<pi> where "\<pi> \<in> M" "val(G, \<pi>) = A"
    using GenExt_def by auto
  then
  have "domain(\<pi>)\<in>M" "domain(\<pi>) \<times> \<bbbP> \<in> M"
    using cartprod_closed[of _ \<bbbP>,simplified]
    by (simp_all flip:setclass_iff)
  let ?\<chi>="\<cdot>\<cdot> 0 \<in> (1 +\<^sub>\<omega> length(env)) \<cdot> \<and> \<phi> \<cdot>"
  let ?new_form="sep_ren(length(env),forces(?\<chi>))"
  let ?\<psi>="(\<cdot>\<exists>(\<cdot>\<exists>\<cdot>\<cdot>\<langle>0,1\<rangle> is 2 \<cdot> \<and> ?new_form \<cdot> \<cdot>)\<cdot>)"
  note phi = \<open>\<phi>\<in>formula\<close> \<open>arity(\<phi>) \<le> 1 +\<^sub>\<omega> length(env)\<close>
  then
  have "?\<chi>\<in>formula" "forces(?\<chi>) \<in> formula" "arity(\<phi>) \<le> 2+\<^sub>\<omega> length(env)"
    using definability le_trans[OF \<open>arity(\<phi>)\<le>_\<close>] add_le_mono[of 1 2,OF _ le_refl]
    by simp_all
  with \<open>env\<in>_\<close> phi
  have "arity(?\<chi>) \<le> 2+\<^sub>\<omega>length(env)"
    using ord_simp_union leI FOL_arities by simp
  with \<open>env\<in>list(_)\<close> phi
  have "arity(forces(?\<chi>)) \<le> 6 +\<^sub>\<omega> length(env)"
    using  arity_forces_le by simp
  then
  have "arity(forces(?\<chi>)) \<le> 7 +\<^sub>\<omega> length(env)"
    using ord_simp_union arity_forces leI by simp
  with \<open>arity(forces(?\<chi>)) \<le>7 +\<^sub>\<omega> _\<close> \<open>env \<in> _\<close> \<open>\<phi> \<in> formula\<close>
  have "arity(?new_form) \<le> 7 +\<^sub>\<omega> length(env)" "?new_form \<in> formula" "?\<psi>\<in>formula"
    using arity_rensep[OF definability[of "?\<chi>"]]
    by auto
  then
  have "arity(?\<psi>) \<le> 5 +\<^sub>\<omega> length(env)"
    using ord_simp_union arity_forces pred_mono[OF _ pred_mono[OF _ \<open>arity(?new_form) \<le> _\<close>]]
    by (auto simp:arity)
  from \<open>env \<in> _\<close>
  obtain nenv where "nenv\<in>list(M)" "env = map(val(G),nenv)" "length(nenv) = length(env)"
    using map_val by auto
  from phi \<open>nenv\<in>_\<close> \<open>env\<in>_\<close> \<open>\<pi>\<in>M\<close> \<open>\<phi>\<in>_\<close> \<open>length(nenv) = length(env)\<close>
  have "arity(?\<chi>) \<le> length([\<theta>] @ nenv @ [\<pi>])" for \<theta>
    using union_abs2[OF \<open>arity(\<phi>) \<le> 2+\<^sub>\<omega> _\<close>] ord_simp_union FOL_arities
    by simp
  note in_M = \<open>\<pi>\<in>M\<close> \<open>domain(\<pi>) \<times> \<bbbP> \<in> M\<close>
  have Equivalence: "
       (M, [u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>) \<longleftrightarrow>
         (\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u =\<langle>\<theta>,p\<rangle> \<and>
          (\<forall>F. M_generic(F) \<and> p \<in> F \<longrightarrow> M[F],  map(val(F), [\<theta>] @ nenv @[\<pi>]) \<Turnstile>  ?\<chi>))"
    if "u \<in> domain(\<pi>) \<times> \<bbbP>"
    for u
  proof -
    from \<open>u \<in> domain(\<pi>) \<times> \<bbbP>\<close> \<open>domain(\<pi>) \<times> \<bbbP> \<in> M\<close>
    have "u\<in>M" by (simp add:transitivity)
    have "(M, [\<theta>,p,u,\<bbbP>,leq,\<one>,\<pi>]@nenv \<Turnstile> ?new_form) \<longleftrightarrow>
          (\<forall>F. M_generic(F) \<and> p \<in> F \<longrightarrow> (M[F],  map(val(F), [\<theta>] @ nenv@[\<pi>]) \<Turnstile>  ?\<chi>))"
      if "\<theta>\<in>M" "p\<in>\<bbbP>"
      for \<theta> p
    proof -
      from \<open>p\<in>\<bbbP>\<close>
      have "p\<in>M" by (simp add: transitivity)
      let ?env="[p,\<bbbP>,leq,\<one>,\<theta>] @ nenv @ [\<pi>,u]"
      let ?new_env=" [\<theta>,p,u,\<bbbP>,leq,\<one>,\<pi>] @ nenv"
      note types = in_M \<open>\<theta> \<in> M\<close> \<open>p\<in>M\<close> \<open>u \<in> domain(\<pi>) \<times> \<bbbP>\<close> \<open>u \<in> M\<close> \<open>nenv\<in>_\<close>
      then
      have tyenv:"?env \<in> list(M)" "?new_env \<in> list(M)"
        by simp_all
      from types
      have eq_env:"[p, \<bbbP>, leq, \<one>] @ ([\<theta>] @ nenv @ [\<pi>,u]) =
                  ([p, \<bbbP>, leq, \<one>] @ ([\<theta>] @ nenv @ [\<pi>])) @ [u]"
        using app_assoc by simp
      then
      have "(M, [\<theta>,p,u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?new_form) \<longleftrightarrow> (M, ?new_env \<Turnstile> ?new_form)"
        by simp
      from tyenv \<open>length(nenv) = length(env)\<close> \<open>arity(forces(?\<chi>)) \<le> 7 +\<^sub>\<omega> length(env)\<close> \<open>forces(?\<chi>) \<in> formula\<close>
      have "... \<longleftrightarrow> p \<tturnstile> ?\<chi> ([\<theta>] @ nenv @ [\<pi>,u])"
        using sepren_action[of "forces(?\<chi>)"  "nenv",OF _ _ \<open>nenv\<in>list(M)\<close>]
        by simp
      also from types phi \<open>env\<in>_\<close> \<open>length(nenv) = length(env)\<close> \<open>arity(forces(?\<chi>)) \<le> 6 +\<^sub>\<omega> length(env)\<close>
      have "... \<longleftrightarrow> p \<tturnstile> ?\<chi>  ([\<theta>] @ nenv @ [\<pi>])"
        by (subst eq_env,rule_tac arity_sats_iff,auto)
      also from types phi \<open>p\<in>\<bbbP>\<close> \<open>arity(forces(?\<chi>)) \<le> 6 +\<^sub>\<omega> length(env)\<close> \<open>arity(?\<chi>) \<le> length([\<theta>] @ nenv @ [\<pi>])\<close>
      have " ... \<longleftrightarrow> (\<forall>F . M_generic(F) \<and> p \<in> F \<longrightarrow>
                           M[F],  map(val(F), [\<theta>] @ nenv @ [\<pi>]) \<Turnstile>  ?\<chi>)"
        using definition_of_forcing[where \<phi>="\<cdot>\<cdot> 0 \<in> (1 +\<^sub>\<omega> length(env)) \<cdot> \<and> \<phi> \<cdot>"]
        by auto
      finally
      show ?thesis
        by simp
    qed
    with in_M \<open>?new_form \<in> formula\<close> \<open>?\<psi>\<in>formula\<close> \<open>nenv \<in> _\<close> \<open>u \<in> domain(\<pi>)\<times>\<bbbP>\<close>
    show ?thesis
      by (auto simp add: transitivity)
  qed
  moreover from \<open>env = _\<close> \<open>\<pi>\<in>M\<close> \<open>nenv\<in>list(M)\<close>
  have map_nenv:"map(val(G), nenv @ [\<pi>]) = env @ [val(G,\<pi>)]"
    using map_app_distrib append1_eq_iff by auto
  ultimately
  have aux:"(\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u =\<langle>\<theta>,p\<rangle> \<and> (p\<in>G \<longrightarrow> M[G], [val(G,\<theta>)] @ env @ [val(G,\<pi>)] \<Turnstile> ?\<chi>))"
    (is "(\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. _ ( _ \<longrightarrow> M[G] , ?vals(\<theta>) \<Turnstile> _))")
    if "u \<in> domain(\<pi>) \<times> \<bbbP>" "M, [u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>" for u
    using Equivalence[THEN iffD1, OF that] generic by force
  moreover
  have "[val(G, \<theta>)] @ env @ [val(G, \<pi>)] \<in> list(M[G])" if "\<theta>\<in>M" for \<theta>
    using \<open>\<pi>\<in>M\<close> \<open>env \<in> list(M[G])\<close> GenExtI that by force
  ultimately
  have "(\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u=\<langle>\<theta>,p\<rangle> \<and> (p\<in>G \<longrightarrow> val(G,\<theta>)\<in>nth(1 +\<^sub>\<omega> length(env),[val(G, \<theta>)] @ env @ [val(G, \<pi>)])
        \<and> (M[G], ?vals(\<theta>) \<Turnstile> \<phi>)))"
    if "u \<in> domain(\<pi>) \<times> \<bbbP>" "M, [u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>" for u
    using aux[OF that] by simp
  moreover from \<open>env \<in> _\<close> \<open>\<pi>\<in>M\<close>
  have nth:"nth(1 +\<^sub>\<omega> length(env),[val(G, \<theta>)] @ env @ [val(G, \<pi>)]) = val(G,\<pi>)"
    if "\<theta>\<in>M" for \<theta>
    using nth_concat[of "val(G,\<theta>)" "val(G,\<pi>)" "M[G]"] that GenExtI by simp
  ultimately
  have "(\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u=\<langle>\<theta>,p\<rangle> \<and> (p\<in>G \<longrightarrow> val(G,\<theta>)\<in>val(G,\<pi>) \<and> (M[G],?vals(\<theta>) \<Turnstile>  \<phi>)))"
    if "u \<in> domain(\<pi>) \<times> \<bbbP>" "M, [u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>" for u
    using that \<open>\<pi>\<in>M\<close> \<open>env \<in> _\<close> by simp
  with \<open>domain(\<pi>)\<times>\<bbbP>\<in>M\<close>
  have "\<forall>u\<in>domain(\<pi>)\<times>\<bbbP> . (M, [u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>) \<longrightarrow> (\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u =\<langle>\<theta>,p\<rangle> \<and>
        (p \<in> G \<longrightarrow> val(G, \<theta>)\<in>val(G, \<pi>) \<and> (M[G],?vals(\<theta>) \<Turnstile>  \<phi>)))"
    by (simp add:transitivity)
  then
  have "{u\<in>domain(\<pi>)\<times>\<bbbP> . (M,[u,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>) } \<subseteq>
     {u\<in>domain(\<pi>)\<times>\<bbbP> . \<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. u =\<langle>\<theta>,p\<rangle> \<and>
       (p \<in> G \<longrightarrow> val(G, \<theta>)\<in>val(G, \<pi>) \<and> (M[G], ?vals(\<theta>) \<Turnstile> \<phi>))}"
    (is "?n\<subseteq>?m")
    by auto
  then
  have first_incl: "val(G,?n) \<subseteq> val(G,?m)"
    using val_mono by simp
  note  \<open>val(G,\<pi>) = A\<close> (* from the assumptions *)
  with \<open>?\<psi>\<in>formula\<close>  \<open>arity(?\<psi>) \<le> _\<close> in_M \<open>nenv \<in> _\<close> \<open>env \<in> _\<close> \<open>length(nenv) = _\<close>
  have "?n\<in>M"
    using separation_ax leI separation_iff by auto
  from generic
  have "filter(G)" "G\<subseteq>\<bbbP>"
    by auto
  from \<open>val(G,\<pi>) = A\<close>
  have "val(G,?m) =
               {z . t\<in>domain(\<pi>) , (\<exists>q\<in>\<bbbP> .
                    (\<exists>\<theta>\<in>M. \<exists>p\<in>\<bbbP>. \<langle>t,q\<rangle> = \<langle>\<theta>, p\<rangle> \<and>
            (p \<in> G \<longrightarrow> val(G, \<theta>) \<in> A \<and> (M[G],  [val(G, \<theta>)] @ env @ [A] \<Turnstile>  \<phi>)) \<and> q \<in> G)) \<and>
           z=val(G,t)}"
    using val_of_name by auto
  also
  have "... =  {z . t\<in>domain(\<pi>) , (\<exists>q\<in>\<bbbP>.
                   val(G, t) \<in> A \<and> (M[G],  [val(G, t)] @ env @ [A] \<Turnstile>  \<phi>) \<and> q \<in> G) \<and> z=val(G,t)}"
    using \<open>domain(\<pi>)\<in>M\<close> by (auto simp add:transitivity)
  also
  have "... =  {x\<in>A . \<exists>q\<in>\<bbbP>. x \<in> A \<and> (M[G],  [x] @ env @ [A] \<Turnstile>  \<phi>) \<and> q \<in> G}"
  proof(intro equalityI, auto)
    (* Now we show the other inclusion:
      {x .. x \<in> A , \<exists>q\<in>\<bbbP>. x \<in> A \<and> (M[G],  [x, w, c] \<Turnstile>  \<phi>) \<and> q \<in> G}
      \<subseteq>
      {val(G,t)..t\<in>domain(\<pi>),\<exists>q\<in>\<bbbP>.val(G,t)\<in> A\<and>(M[G], [val(G,t),w] \<Turnstile> \<phi>)\<and>q\<in>G}
    *)
    {
      fix x q
      assume "M[G], Cons(x, env @ [A]) \<Turnstile> \<phi>" "x\<in>A" "q \<in> \<bbbP>" "q \<in> G"
      from this \<open>val(G,\<pi>) = A\<close>
      show "x \<in> {y . x \<in> domain(\<pi>), val(G, x) \<in> A \<and> (M[G], Cons(val(G, x), env @ [A]) \<Turnstile> \<phi>) \<and> (\<exists>q\<in>\<bbbP>. q \<in> G) \<and> y = val(G, x)}"
        using elem_of_val by force
    }
  qed
  also
  have " ... = {x \<in> A. (M[G], [x] @ env @ [A] \<Turnstile> \<phi>)}"
    using \<open>G\<subseteq>\<bbbP>\<close> G_nonempty by force
  finally
  have val_m: "val(G,?m) = {x \<in> A. (M[G], [x] @ env @ [A] \<Turnstile> \<phi>)}" by simp
  have "val(G,?m) \<subseteq> val(G,?n)"
  proof
    fix x
    assume "x \<in> val(G,?m)"
    with val_m
    have "x \<in> {x \<in> A. (M[G], [x] @ env @ [A] \<Turnstile> \<phi>)}" by simp
    with \<open>val(G,\<pi>) = A\<close>
    have "x \<in> val(G,\<pi>)" by simp
    then
    obtain \<theta> q where "\<langle>\<theta>,q\<rangle>\<in>\<pi>" "q\<in>G" "val(G,\<theta>)=x" "\<theta>\<in>M"
      using elem_of_val_pair domain_trans[OF trans_M \<open>\<pi>\<in>_\<close>]
      by force
    with \<open>\<pi>\<in>M\<close> \<open>nenv \<in> _\<close> \<open>env = _\<close>
    have "[val(G,\<theta>), val(G,\<pi>)] @ env \<in> list(M[G])" "[\<theta>] @ nenv @ [\<pi>]\<in>list(M)"
      using GenExt_def by auto
    with \<open>val(G,\<theta>)=x\<close> \<open>val(G,\<pi>) = A\<close> \<open>x \<in> val(G,\<pi>)\<close> nth \<open>\<theta>\<in>M\<close> \<open>x\<in> {x \<in> A . _}\<close>
    have "M[G],  [val(G,\<theta>)] @ env @ [val(G,\<pi>)] \<Turnstile> \<cdot>\<cdot> 0 \<in> (1 +\<^sub>\<omega> length(env)) \<cdot> \<and> \<phi> \<cdot>"
      by auto
        \<comment> \<open>Recall \<^term>\<open>?\<chi> = And(Member(0,1 +\<^sub>\<omega> length(env)),\<phi>)\<close>\<close>
    with \<open>[_] @ nenv @ [_] \<in> _ \<close> map_nenv \<open>arity(?\<chi>) \<le> length(_)\<close> \<open>length(nenv) = _\<close>
    obtain r where "r\<in>G" "r \<tturnstile> ?\<chi> ([\<theta>] @ nenv @ [\<pi>])"
      using truth_lemma[OF \<open>?\<chi>\<in>_\<close>,of "[\<theta>] @ nenv @ [\<pi>]"]
      by auto
    with \<open>filter(G)\<close> and \<open>q\<in>G\<close>
    obtain p where "p\<in>G" "p\<preceq>q" "p\<preceq>r"
      unfolding filter_def compat_in_def by force
    with \<open>r\<in>G\<close> \<open>q\<in>G\<close> \<open>G\<subseteq>\<bbbP>\<close>
    have "p\<in>\<bbbP>" "r\<in>\<bbbP>" "q\<in>\<bbbP>" "p\<in>M"
      using transitivity[OF _ P_in_M] subsetD
      by simp_all
    with \<open>\<phi>\<in>formula\<close> \<open>\<theta>\<in>M\<close> \<open>\<pi>\<in>M\<close> \<open>p\<preceq>r\<close> \<open>nenv \<in> _\<close> \<open>arity(?\<chi>) \<le> length(_)\<close> \<open>r \<tturnstile> ?\<chi> _\<close> \<open>env\<in>_\<close>
    have "p \<tturnstile> ?\<chi> ([\<theta>] @ nenv @ [\<pi>])"
      using strengthening_lemma
      by simp
    with \<open>p\<in>\<bbbP>\<close> \<open>\<phi>\<in>formula\<close> \<open>\<theta>\<in>M\<close> \<open>\<pi>\<in>M\<close> \<open>nenv \<in> _\<close> \<open>arity(?\<chi>) \<le> length(_)\<close>
    have "\<forall>F. M_generic(F) \<and> p \<in> F \<longrightarrow>
                 M[F],   map(val(F), [\<theta>] @ nenv @ [\<pi>]) \<Turnstile>  ?\<chi>"
      using definition_of_forcing[where \<phi>="\<cdot>\<cdot> 0 \<in> (1 +\<^sub>\<omega> length(env)) \<cdot> \<and> \<phi> \<cdot>"]
      by simp
    with \<open>p\<in>\<bbbP>\<close> \<open>\<theta>\<in>M\<close>
    have Eq6: "\<exists>\<theta>'\<in>M. \<exists>p'\<in>\<bbbP>.  \<langle>\<theta>,p\<rangle> = \<langle>\<theta>',p'\<rangle> \<and> (\<forall>F. M_generic(F) \<and> p' \<in> F \<longrightarrow>
                 M[F],   map(val(F), [\<theta>'] @ nenv @ [\<pi>]) \<Turnstile>  ?\<chi>)" by auto
    from \<open>\<pi>\<in>M\<close> \<open>\<langle>\<theta>,q\<rangle>\<in>\<pi>\<close> \<open>\<theta>\<in>M\<close> \<open>p\<in>\<bbbP>\<close> \<open>p\<in>M\<close>
    have "\<langle>\<theta>,q\<rangle> \<in> M" "\<langle>\<theta>,p\<rangle>\<in>M" "\<langle>\<theta>,p\<rangle>\<in>domain(\<pi>)\<times>\<bbbP>"
      using pair_in_M_iff transitivity
      by auto
    with \<open>\<theta>\<in>M\<close> Eq6 \<open>p\<in>\<bbbP>\<close>
    have "M, [\<langle>\<theta>,p\<rangle>,\<bbbP>,leq,\<one>,\<pi>] @ nenv \<Turnstile> ?\<psi>"
      using Equivalence by auto
    with \<open>\<langle>\<theta>,p\<rangle>\<in>domain(\<pi>)\<times>\<bbbP>\<close>
    have "\<langle>\<theta>,p\<rangle>\<in>?n" by simp
    with \<open>p\<in>G\<close> \<open>p\<in>\<bbbP>\<close>
    have "val(G,\<theta>)\<in>val(G,?n)"
      using val_of_elem[of \<theta> p] by simp
    with \<open>val(G,\<theta>)=x\<close>
    show "x\<in>val(G,?n)" by simp
  qed (* proof of "val(G,?m) \<subseteq> val(G,?n)" *)
  with val_m first_incl
  have "val(G,?n) = {x \<in> A. (M[G], [x] @ env @ [A] \<Turnstile> \<phi>)}" by auto
  also from \<open>A\<in>_\<close> phi \<open>env \<in> _\<close>
  have " ... = {x \<in> A. (M[G], [x] @ env \<Turnstile> \<phi>)}"
    using arity_sats_iff[where env="[_]@env"] transitivity_MG
    by auto
  finally
  show "{x \<in> A. (M[G], [x] @ env \<Turnstile> \<phi>)}\<in> M[G]"
    using \<open>?n\<in>M\<close> GenExt_def by force
qed

theorem separation_in_MG:
  assumes
    "\<phi>\<in>formula" and "arity(\<phi>) \<le> 1 +\<^sub>\<omega> length(env)" and "env\<in>list(M[G])"
  shows
    "separation(##M[G],\<lambda>x. (M[G], [x] @ env \<Turnstile> \<phi>))"
proof -
  {
    fix A
    assume "A\<in>M[G]"
    moreover from \<open>env \<in> _\<close>
    obtain nenv where "nenv\<in>list(M)""env = map(val(G),nenv)" "length(env) = length(nenv)"
      using GenExt_def map_val[of env] by auto
    moreover note \<open>\<phi> \<in> _\<close> \<open>arity(\<phi>) \<le> _\<close> \<open>env \<in> _\<close>
    ultimately
    have "{x \<in> A . (M[G], [x] @ env \<Turnstile> \<phi>)} \<in> M[G]"
      using Collect_sats_in_MG by auto
  }
  then
  show ?thesis
    using separation_iff rev_bexI unfolding is_Collect_def by force
qed

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

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory L4vBucket
imports
  "Word_Lib.Word_Lemmas"
  "CogentShallow.ShallowUtil"
begin

no_notation fun_app (infixr "$" 10)

(* Copied from HaskellLemmaBucket.thy *)
lemma is_aligned_alignUp[simp]:
  "is_aligned (alignUp p n) n"
  by (simp add: alignUp_def complement_def
                is_aligned_mask mask_def
                word_bw_assocs)

lemma alignUp_le[simp]:
  "alignUp p n \<le> p + 2 ^ n - 1"
  unfolding alignUp_def
  by (rule word_and_le2)

lemma complement_mask:
  "complement (2 ^ n - 1) = ~~ mask n"
  unfolding complement_def mask_def
  by simp

lemma alignUp_idem:
  fixes a :: "'a::len word"
  assumes al: "is_aligned a n"
  and   sz: "n < len_of TYPE('a)"
  shows "alignUp a n = a"
  using sz al unfolding alignUp_def
  apply (simp add: complement_mask)
  apply (subst x_power_minus_1)
  apply (subst neg_mask_is_div)
  apply (simp only: word_arith_nat_div  unat_word_ariths)
  apply (simp only: unat_power_lower)
  apply (subst power_mod_div)
  apply (erule is_alignedE)
  apply simp
  apply (subst unat_mult_power_lem)
   apply simp
  apply (subst unat_sub)
   apply (subst unat_arith_simps)
   apply (simp add: word_size)
  apply (simp add: word_size del: unat_1)
  apply simp
  done

lemma alignUp_not_aligned_eq:
  fixes a :: "'a :: len word"
  assumes al: "\<not> is_aligned a n"
    and   sz: "n < len_of TYPE('a)"
  shows "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
  using assms
  by (metis alignUp_not_aligned_eq)

lemma alignUp_ge:
  fixes a :: "'a :: len word"
  assumes sz: "n < len_of TYPE('a)"
  and nowrap: "alignUp a n \<noteq> 0"
  shows "a \<le> alignUp a n"
proof (cases "is_aligned a n")
  case True
  thus ?thesis using sz
    by (subst alignUp_idem, simp_all)
next
  case False

  have lt0: "unat a div 2 ^ n < 2 ^ (len_of TYPE('a) - n)" using sz
    apply -
    apply (subst td_gal_lt [symmetric])
     apply simp
    apply (simp add: power_add [symmetric])
    done

  have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ len_of TYPE('a)" using sz
    apply -
    apply (rule nat_le_power_trans)
    apply simp
    apply (rule Suc_leI [OF lt0])
    apply simp
    done
  moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ len_of TYPE('a)" using nowrap sz
    apply -
    apply (erule contrapos_nn)
    apply (subst alignUp_not_aligned_eq [OF False sz])
    apply (subst unat_arith_simps)
    apply (subst unat_word_ariths)
    apply (subst unat_word_ariths)
    apply simp
    apply (subst mult_mod_left)
    apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power
                     min.absorb2 unat_power_lower)
    done
  ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ len_of TYPE('a)" by simp

  have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
  also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
    apply (simp add: field_simps)
    apply (rule word_add_less_mono1)
    apply (rule word_mod_less_divisor)
    apply (simp add: word_less_nat_alt unat_power_lower)
    apply (subst unat_word_ariths)
    apply (simp add: unat_div unat_power_lower)
    done
  also have "\<dots> =  alignUp a n"
    by (rule alignUp_not_aligned_eq [symmetric]) fact+
  finally show ?thesis by (rule order_less_imp_le)
qed

lemma alignUp_le_greater_al:
  fixes x :: "'a :: len word"
  assumes le: "a \<le> x"
  and     sz: "n < len_of TYPE('a)"
  and     al: "is_aligned x n"
  shows   "alignUp a n \<le> x"
proof (cases "is_aligned a n")
  case True
  thus ?thesis using sz le by (simp add: alignUp_idem)
next
  case False

  hence anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (len_of TYPE('a) - n)"
    by (auto elim!: is_alignedE)

  hence kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ len_of TYPE('a)"
    using sz
    apply (subst unat_of_nat_eq)
     apply (erule order_less_le_trans)
     apply simp
    apply (subst mult.commute)
    apply (simp add: unat_power_lower)
    apply (rule nat_less_power_trans)
     apply simp
    apply simp
    done

  have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
    by (rule alignUp_not_aligned_eq) fact+
  also have "\<dots> \<le> of_nat k * 2 ^ n"
  proof (rule word_mult_le_mono1 [OF inc_le _ kn])
    show "a div 2 ^ n < of_nat k" using kv xk le sz anz
      by (simp add: alignUp_div_helper)

    show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
  qed

  finally show ?thesis using xk by (simp add: field_simps)
qed

lemma alignUp_is_aligned_nz:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < len_of TYPE('a)"
  and     ax: "a \<le> x"
  and     az: "a \<noteq> 0"
  shows   "alignUp (a::'a :: len word) n \<noteq> 0"
proof (cases "is_aligned a n")
  case True
  hence "alignUp a n = a" using sz by (simp add: alignUp_idem)
  thus ?thesis using az by simp
next
  case False
  hence anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  {
    assume asm: "alignUp a n = 0"

    have lt0: "unat a div 2 ^ n < 2 ^ (len_of TYPE('a) - n)" using sz
      apply -
      apply (subst td_gal_lt [symmetric])
      apply simp
      apply (simp add: power_add [symmetric])
      done

    have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ len_of TYPE('a)" using sz
      apply -
      apply (rule nat_le_power_trans)
      apply simp
      apply (rule Suc_leI [OF lt0])
      apply simp
      done

    from al obtain k where  kv: "k < 2 ^ (len_of TYPE('a) - n)" and xk: "x = 2 ^ n * of_nat k"
      by (auto elim!: is_alignedE)

    hence "a div 2 ^ n < of_nat k" using ax sz anz
      by (rule alignUp_div_helper)

    hence r: "unat a div 2 ^ n < k" using sz
      apply (simp add: unat_div word_less_nat_alt)
      apply (subst (asm) unat_of_nat)
      apply (subst (asm) mod_less)
      apply (rule order_less_le_trans [OF kv])
      apply (simp add: unat_power_lower)+
      done

    have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
      by (rule alignUp_not_aligned_eq) fact+

    hence "\<dots> = 0" using asm by simp
    hence "unat a div 2 ^ n = 2 ^ (len_of TYPE('a) - n) - 1" using sz leq
      apply -
      apply (rule nat_diff_add)
      apply simp
      apply (subst nat_mult_eq_cancel1 [where k = "2 ^ n", symmetric])
      apply simp
      apply (subst power_add [symmetric])
      apply simp
      apply (drule unat_cong)
      apply simp
      apply (subst (asm) unat_word_ariths)
      apply (subst (asm) unat_word_ariths)
      apply (simp add: unat_div mult_mod_left power_add [symmetric] mod_mod_power
                       min.absorb2)
      apply (clarsimp simp: field_simps)
      apply (rule ccontr)
      apply (drule (1) order_le_neq_trans)
      apply (force simp add: unat_power_lower)
      done

    hence "2 ^ (len_of TYPE('a) - n) - 1 < k" using r
      by simp
    hence False using kv by simp
  } thus ?thesis by (clarsimp simp del: word_neq_0_conv)
qed

lemma alignUp_ar_helper:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < len_of TYPE('a)"
  and    sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
  and    anz: "a \<noteq> 0"
  shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
proof
  from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)

  from xl sub have ax: "a \<le> x"
    by (clarsimp elim!: range_subset_lower [where x = x])

  show "a \<le> alignUp a n"
  proof (rule alignUp_ge)
    show "alignUp a n \<noteq> 0" using al sz ax anz
      by (rule alignUp_is_aligned_nz)
  qed fact+

  show "alignUp a n + 2 ^ n - 1 \<le> b"
  proof (rule order_trans)
    from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
      by (clarsimp elim!: range_subset_upper [where x = x])

    from ax have "alignUp a n \<le> x"
      by (rule alignUp_le_greater_al) fact+
    hence "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)" using xl
      apply -
      apply (erule word_plus_mono_left)
      apply (subst olen_add_eqv)
      apply (simp add: field_simps)
      done
    thus "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
      by (simp add: field_simps)
  qed
qed

end


section \<open>Matrix Interface\<close>
theory IICF_Matrix
imports "../../Sepref"
begin

subsection \<open>Relator and Interface\<close>
definition [to_relAPP]: "mtx_rel A \<equiv> nat_rel \<times>\<^sub>r nat_rel \<rightarrow> A"

lemma mtx_rel_id[simp]: "\<langle>Id\<rangle>mtx_rel = Id" unfolding mtx_rel_def by auto

type_synonym 'a mtx = "nat\<times>nat \<Rightarrow> 'a"
sepref_decl_intf 'a i_mtx is "nat\<times>nat \<Rightarrow> 'a"

subsection \<open>Operations\<close>

definition op_mtx_new :: "'a mtx \<Rightarrow> 'a mtx" where [simp]: "op_mtx_new c \<equiv> c"

sepref_decl_op (no_def) mtx_new: "op_mtx_new" :: "(nat_rel\<times>\<^sub>rnat_rel \<rightarrow> A) \<rightarrow> \<langle>A\<rangle>mtx_rel"
  apply (rule fref_ncI) unfolding op_mtx_new_def[abs_def] mtx_rel_def
  by parametricity

(* TODO: Ad-hoc rule *)
lemma mtx_init_adhoc_frame_match_rule[sepref_frame_match_rules]:
  "hn_val (nat_rel\<times>\<^sub>rnat_rel \<rightarrow> A) x y \<Longrightarrow>\<^sub>t hn_val (nat_rel\<times>\<^sub>rnat_rel \<rightarrow> the_pure (pure A)) x y"
  by simp

context
  fixes t ::  "('a mtx * (nat*nat)) => nat"
begin
  definition "mop_matrix_get (m::_ mtx) e = SPECT [m e \<mapsto> enat (t (m,e))]"

  lemma matrix_get: "\<And>tt. tt \<le> lst (SPECT [ m e \<mapsto> t (m,e)]) Q \<Longrightarrow> tt
           \<le> lst (mop_matrix_get m e) Q" unfolding mop_matrix_get_def by simp

  lemma progress_mop_matrix_get[progress_rules]: "t (m,e) > 0 \<Longrightarrow> progress (mop_matrix_get m e)"
    unfolding mop_matrix_get_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  sepref_register "mop_matrix_get"
end

context
  fixes t ::  "(('b mtx * (nat*nat)) * 'b) \<Rightarrow> nat"
begin
  definition "mop_matrix_set (m::'b mtx) e v = SPECT [m(e:=v) \<mapsto> enat (t ((m,e),v))]"

  lemma matrix_set: "\<And>tt. tt \<le> lst (SPECT [ m(e:=v) \<mapsto> t ((m,e),v)]) Q \<Longrightarrow> tt
           \<le> lst (mop_matrix_set m e v) Q" unfolding mop_matrix_set_def by simp

  sepref_register "mop_matrix_set"
  print_theorems
end

definition mtx_nonzero :: "_ mtx \<Rightarrow> (nat\<times>nat) set" where "mtx_nonzero m \<equiv> {(i,j). m (i,j)\<noteq>0}"

lemma mtx_nonzeroD:
  "\<lbrakk>\<not>i<N; mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}\<rbrakk> \<Longrightarrow> m(i,j) = 0"
  "\<lbrakk>\<not>j<M; mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}\<rbrakk> \<Longrightarrow> m(i,j) = 0"
  by (auto simp: mtx_nonzero_def)

  subsubsection \<open>Square Matrix\<close>

  definition [simp]: "op_amtx_new (N::nat) (M::nat) \<equiv> op_mtx_new"

context fixes N M :: nat
    and t :: "nat \<Rightarrow> nat \<Rightarrow> nat"
    begin

    definition "mop_amtx_new c =  SPECT [op_amtx_new N M c \<mapsto> t N M] "

    sepref_register "mop_amtx_new"
end

end


(*  Title:      Code_Target_Bits_Int.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Implementation of bit operations on int by target language operations\<close>

theory Code_Target_Bits_Int
imports
  Bits_Integer
  "HOL-Library.Code_Target_Int"
begin

declare [[code drop:
  "bitAND :: int \<Rightarrow> _" "bitOR :: int \<Rightarrow> _" "bitXOR :: int \<Rightarrow> _" "bitNOT :: int \<Rightarrow> _"
  "lsb :: int \<Rightarrow> _" "set_bit :: int \<Rightarrow> _" "test_bit :: int \<Rightarrow> _"
  "shiftl :: int \<Rightarrow> _" "shiftr :: int \<Rightarrow> _"
  bin_last bin_rest bin_nth Bit
  int_of_integer_symbolic
  ]]

context
includes integer.lifting
begin

lemma bitAND_int_code [code]:
  "int_of_integer i AND int_of_integer j = int_of_integer (i AND j)"
by transfer simp

lemma bitOR_int_code [code]:
  "int_of_integer i OR int_of_integer j = int_of_integer (i OR j)"
by transfer simp

lemma bitXOR_int_code [code]:
  "int_of_integer i XOR int_of_integer j = int_of_integer (i XOR j)"
by transfer simp

lemma bitNOT_int_code [code]:
  "NOT (int_of_integer i) = int_of_integer (NOT i)"
by transfer simp

declare bin_last_conv_AND [code]

lemma bin_rest_code [code]:
   "bin_rest (int_of_integer i) = int_of_integer (bin_rest_integer i)"
by transfer simp

declare bitval_bin_last [code_unfold]

declare bin_nth_conv_AND [code]

lemma Bit_code [code]: "int_of_integer i BIT b = int_of_integer (Bit_integer i b)"
by transfer simp

lemma test_bit_int_code [code]: "int_of_integer x !! n = x !! n"
by transfer simp

lemma lsb_int_code [code]: "lsb (int_of_integer x) = lsb x"
by transfer simp

lemma set_bit_int_code [code]: "set_bit (int_of_integer x) n b = int_of_integer (set_bit x n b)"
by transfer simp

lemma shiftl_int_code [code]: "int_of_integer x << n = int_of_integer (x << n)"
by transfer simp

lemma shiftr_int_code [code]: "int_of_integer x >> n = int_of_integer (x >> n)"
by transfer simp

lemma int_of_integer_symbolic_code [code]:
  "int_of_integer_symbolic = int_of_integer"
by(simp add: int_of_integer_symbolic_def)

end

end