header {* \isaheader{Relators} *}
theory Relators
imports "../Lib/Refine_Lib"
begin

text {*
  We define the concept of relators. The relation between a concrete type and
  an abstract type is expressed by a relation of type @{text "('c\<times>'a) set"}.
  For each composed type, say @{text "'a list"}, we can define a {\em relator},
  that takes as argument a relation for the element type, and returns a relation
  for the list type. For most datatypes, there exists a {\em natural relator}.
  For algebraic datatypes, this is the relator that preserves the structure
  of the datatype, and changes the components. For example,
  @{text "list_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a list) set"} is the natural
  relator for lists.

  However, relators can also be used to change the representation, and thus
  relate an implementation with an abstract type. For example, the relator
  @{text "list_set_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a set) set"} relates lists
  with the set of their elements.

  In this theory, we define some basic notions for relators, and
  then define natural relators for all HOL-types, including the function type.
  For each relator, we also show a single-valuedness property, and initialize a
  solver for single-valued properties.
*}

subsection {* Basic Definitions *}

text {*
  For smoother handling of relator unification, we require relator arguments to
  be applied by a special operator, such that we avoid higher-order
  unification problems. We try to set up some syntax to make this more
  transparent, and give relators a type-like prefix-syntax.
*}

definition relAPP
  :: "(('c1\<times>'a1) set \<Rightarrow> _) \<Rightarrow> ('c1\<times>'a1) set \<Rightarrow> _"
  where "relAPP f x \<equiv> f x"

syntax "_rel_APP" :: "args \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>_\<rangle>_" [0,900] 900)

translations
  "\<langle>x,xs\<rangle>R" == "\<langle>xs\<rangle>(CONST relAPP R x)"
  "\<langle>x\<rangle>R" == "CONST relAPP R x"

ML {*
  structure Refine_Relators_Thms = struct
    structure rel_comb_def_rules = Named_Thms (
      val name = @{binding refine_rel_defs}
      val description = "Refinement Framework: " ^
          "Relator definitions"
    );
  end
*}

setup Refine_Relators_Thms.rel_comb_def_rules.setup

subsection {* Basic HOL Relators *}
subsubsection {* Function *}
definition fun_rel where
  fun_rel_def_internal: "fun_rel A B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
abbreviation fun_rel_syn (infixr "\<rightarrow>" 60) where "A\<rightarrow>B \<equiv> \<langle>A,B\<rangle>fun_rel"

lemma fun_rel_def[refine_rel_defs]:
  "A\<rightarrow>B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
  by (simp add: relAPP_def fun_rel_def_internal)

lemma fun_relI[intro!]: "\<lbrakk>\<And>a a'. (a,a')\<in>A \<Longrightarrow> (f a,f' a')\<in>B\<rbrakk> \<Longrightarrow> (f,f')\<in>A\<rightarrow>B"
  by (auto simp: fun_rel_def)

lemma fun_relD:
  shows " ((f,f')\<in>(A\<rightarrow>B)) \<Longrightarrow>
  (\<And>x x'. \<lbrakk> (x,x')\<in>A \<rbrakk> \<Longrightarrow> (f x, f' x')\<in>B)"
  apply rule
  by (auto simp: fun_rel_def)

lemma fun_relD1:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f x = r"
  shows "\<forall>x'. (x,x')\<in>Ra \<longrightarrow> (r,f' x')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relD2:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f' x' = r'"
  shows "\<forall>x. (x,x')\<in>Ra \<longrightarrow> (f x,r')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relE1:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t' = f' x"
  shows "(f x,t')\<in>Rv" using assms
  by (auto elim: fun_relD)

lemma fun_relE2:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t = f x"
  shows "(t,f' x)\<in>Rv" using assms
  by (auto elim: fun_relD)

subsubsection {* Terminal Types *}
abbreviation unit_rel :: "(unit\<times>unit) set" where "unit_rel == Id"

abbreviation "nat_rel \<equiv> Id::(nat\<times>_) set"
abbreviation "int_rel \<equiv> Id::(int\<times>_) set"
abbreviation "bool_rel \<equiv> Id::(bool\<times>_) set"

subsubsection {* Product *}
definition prod_rel where
  prod_rel_def_internal: "prod_rel R1 R2
    \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"

abbreviation prod_rel_syn (infixr "\<times>\<^sub>r" 70) where "a\<times>\<^sub>rb \<equiv> \<langle>a,b\<rangle>prod_rel"

lemma prod_rel_def[refine_rel_defs]:
  "(\<langle>R1,R2\<rangle>prod_rel) \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"
  by (simp add: prod_rel_def_internal relAPP_def)

lemma prod_relI: "\<lbrakk>(a,a')\<in>R1; (b,b')\<in>R2\<rbrakk> \<Longrightarrow> ((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel"
  by (auto simp: prod_rel_def)
lemma prod_relE:
  assumes "(p,p')\<in>\<langle>R1,R2\<rangle>prod_rel"
  obtains a b a' b' where "p=(a,b)" and "p'=(a',b')"
  and "(a,a')\<in>R1" and "(b,b')\<in>R2"
  using assms
  by (auto simp: prod_rel_def)

lemma prod_rel_simp[simp]:
  "((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel \<longleftrightarrow> (a,a')\<in>R1 \<and> (b,b')\<in>R2"
  by (auto intro: prod_relI elim: prod_relE)

subsubsection {*Option*}
definition option_rel where
  option_rel_def_internal:
  "option_rel R \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"

lemma option_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>option_rel \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"
  by (simp add: option_rel_def_internal relAPP_def)

lemma option_relI:
  "(None,None)\<in>\<langle>R\<rangle> option_rel"
  "\<lbrakk> (a,a')\<in>R \<rbrakk> \<Longrightarrow> (Some a, Some a')\<in>\<langle>R\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_relE:
  assumes "(x,x')\<in>\<langle>R\<rangle>option_rel"
  obtains "x=None" and "x'=None"
  | a a' where "x=Some a" and "x'=Some a'" and "(a,a')\<in>R"
  using assms by (auto simp: option_rel_def)

lemma option_rel_simp[simp]:
  "(None,a)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> a=None"
  "(c,None)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> c=None"
  "(Some x,Some y)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> (x,y)\<in>R"
  by (auto intro: option_relI elim: option_relE)

subsubsection {* Sum *}
definition sum_rel where sum_rel_def_internal:
  "sum_rel Rl Rr
   \<equiv> { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"

lemma sum_rel_def[refine_rel_defs]:
  "\<langle>Rl,Rr\<rangle>sum_rel \<equiv>
     { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"
  by (simp add: sum_rel_def_internal relAPP_def)

lemma sum_rel_simp[simp]:
  "\<And>a a'. (Inl a, Inl a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rl"
  "\<And>a a'. (Inr a, Inr a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rr"
  "\<And>a a'. (Inl a, Inr a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  "\<And>a a'. (Inr a, Inl a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  unfolding sum_rel_def by auto

lemma sum_relI:
  "(a,a')\<in>Rl \<Longrightarrow> (Inl a, Inl a') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  "(a,a')\<in>Rr \<Longrightarrow> (Inr a, Inr a') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  by simp_all

lemma sum_relE:
  assumes "(x,x')\<in>\<langle>Rl,Rr\<rangle>sum_rel"
  obtains
    l l' where "x=Inl l" and "x'=Inl l'" and "(l,l')\<in>Rl"
  | r r' where "x=Inr r" and "x'=Inr r'" and "(r,r')\<in>Rr"
  using assms by (auto simp: sum_rel_def)

subsubsection {* Lists *}
definition list_rel where list_rel_def_internal:
  "list_rel R \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"

lemma list_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>list_rel \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"
  by (simp add: list_rel_def_internal relAPP_def)

lemma list_rel_induct[induct set,consumes 1, case_names Nil Cons]:
  assumes "(l,l')\<in>\<langle>R\<rangle> list_rel"
  assumes "P [] []"
  assumes "\<And>x x' l l'. \<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel; P l l' \<rbrakk>
    \<Longrightarrow> P (x#l) (x'#l')"
  shows "P l l'"
  using assms unfolding list_rel_def
  apply simp
  by (rule list_all2_induct)

lemma list_rel_eq_listrel: "list_rel = listrel"
  apply (rule ext)
proof safe
  case goal1 thus ?case
    unfolding list_rel_def_internal
    apply simp
    apply (induct a b rule: list_all2_induct)
    apply (auto intro: listrel.intros)
    done
next
  case goal2 thus ?case
    apply (induct)
    apply (auto simp: list_rel_def_internal)
    done
qed

lemma list_relI:
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "\<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel \<rbrakk> \<Longrightarrow> (x#l,x'#l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_rel_simp[simp]:
  "([],l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l'=[]"
  "(l,[])\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l=[]"
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "(x#l,x'#l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> (x,x')\<in>R \<and> (l,l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_relE1:
  assumes "(l,[])\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE2:
  assumes "([],l)\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE3:
  assumes "(x#xs,l')\<in>\<langle>R\<rangle>list_rel" obtains x' xs' where
  "l'=x'#xs'" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l')
  apply auto
  done

lemma list_relE4:
  assumes "(l,x'#xs')\<in>\<langle>R\<rangle>list_rel" obtains x xs where
  "l=x#xs" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l)
  apply auto
  done

lemmas list_relE = list_relE1 list_relE2 list_relE3 list_relE4

lemma list_rel_imp_same_length:
    "(l, l') \<in> \<langle>R\<rangle>list_rel \<Longrightarrow> length l = length l'"
  unfolding list_rel_eq_listrel relAPP_def
  by (rule listrel_eq_len)

subsubsection {* Sets *}
text {* Pointwise refinement: The abstract set is the image of
  the concrete set, and the concrete set only contains elements that
  have an abstract counterpart *}
definition set_rel where set_rel_def_internal:
  "set_rel R \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"

lemma set_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>set_rel \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"
  by (simp add: set_rel_def_internal relAPP_def)

lemma set_rel_simp[simp]:
  "({},{})\<in>\<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

subsection {* Automation *}
subsubsection {* A solver for relator properties *}
lemma relprop_triggers:
  "\<And>R. single_valued R \<Longrightarrow> single_valued R"
  "\<And>R. R=Id \<Longrightarrow> R=Id"
  "\<And>R. R=Id \<Longrightarrow> Id=R"
  "\<And>R. Range R = UNIV \<Longrightarrow> Range R = UNIV"
  "\<And>R. Range R = UNIV \<Longrightarrow> UNIV = Range R"
  "\<And>R R'. R\<subseteq>R' \<Longrightarrow> R\<subseteq>R'"
  by auto

ML {*
  structure relator_props = Named_Thms (
    val name = @{binding relator_props}
    val description = "Additional relator properties"
  )
*}
setup relator_props.setup

declaration {*
  Tagged_Solver.declare_solver
    @{thms relprop_triggers}
    @{binding relator_props_solver}
    "Additional relator peoperties solver"
    (fn ctxt => (REPEAT_ALL_NEW (match_tac (relator_props.get ctxt))))
*}

declaration {*
  Tagged_Solver.declare_solver
    []
    @{binding force_relator_props_solver}
    "Additional relator properties solver (instantiate schematics)"
    (fn ctxt => (REPEAT_ALL_NEW (resolve_tac (relator_props.get ctxt))))
*}

lemma relprop_id_orient[relator_props]:
  "R=Id \<Longrightarrow> Id=R"
  "Id = Id"
  by auto

lemma relprop_UNIV_orient[relator_props]:
  "R=UNIV \<Longrightarrow> UNIV=R"
  "UNIV = UNIV"
  by auto

subsubsection {* ML-Level utilities *}

ML {*
  signature RELATORS = sig
    val mk_relT: typ * typ -> typ
    val dest_relT: typ -> typ * typ

    val mk_relAPP: term -> term -> term
    val list_relAPP: term list -> term -> term
    val strip_relAPP: term -> term list * term

    val declare_natural_relator:
      (string*string) -> Context.generic -> Context.generic
    val remove_natural_relator: string -> Context.generic -> Context.generic
    val natural_relator_of: Proof.context -> string -> string option

    val mk_natural_relator: Proof.context -> term list -> string -> term option
    val mk_fun_rel: term -> term -> term

    val setup: theory -> theory
  end

  structure Relators :RELATORS = struct
    val mk_relT = HOLogic.mk_prodT #> HOLogic.mk_setT

    fun dest_relT (Type (@{type_name set},[Type (@{type_name prod},[cT,aT])]))
      = (cT,aT)
      | dest_relT ty = raise TYPE ("dest_relT",[ty],[])

    fun mk_relAPP x f = let
      val xT = fastype_of x
      val fT = fastype_of f
      val rT = range_type fT
    in
      Const (@{const_name relAPP},fT-->xT-->rT)$f$x
    end

    val list_relAPP = fold mk_relAPP

    fun strip_relAPP R = let
      fun aux @{mpat "\<langle>?R\<rangle>?S"} l = aux S (R::l)
        | aux R l = (l,R)
    in aux R [] end

    structure natural_relators = Generic_Data (
      type T = string Symtab.table
      val empty = Symtab.empty
      val extend = I
      val merge = Symtab.join (fn _ => fn (_,cn) => cn)
    )

    fun declare_natural_relator tcp =
      natural_relators.map (Symtab.update tcp)

    fun remove_natural_relator tname =
      natural_relators.map (Symtab.delete_safe tname)

    fun natural_relator_of ctxt =
      Symtab.lookup (natural_relators.get (Context.Proof ctxt))

    (* [R1,\<dots>,Rn] T is mapped to \<langle>R1,\<dots>,Rn\<rangle> Trel *)
    fun mk_natural_relator ctxt args Tname =
      case natural_relator_of ctxt Tname of
        NONE => NONE
      | SOME Cname => SOME let
          val argsT = map fastype_of args
          val (cTs, aTs) = map dest_relT argsT |> split_list
          val aT = Type (Tname,aTs)
          val cT = Type (Tname,cTs)
          val rT = mk_relT (cT,aT)
        in
          list_relAPP args (Const (Cname,argsT--->rT))
        end

    fun
      natural_relator_from_term (t as Const (name,T)) = let
        fun err msg = raise TERM (msg,[t])

        val (argTs,bodyT) = strip_type T
        val (conTs,absTs) = argTs |> map (HOLogic.dest_setT #> HOLogic.dest_prodT) |> split_list
        val (bconT,babsT) = bodyT |> HOLogic.dest_setT |> HOLogic.dest_prodT
        val (Tcon,bconTs) = dest_Type bconT
        val (Tcon',babsTs) = dest_Type babsT

        val _ = Tcon = Tcon' orelse err "Type constructors do not match"
        val _ = conTs = bconTs orelse err "Concrete types do not match"
        val _ = absTs = babsTs orelse err "Abstract types do not match"

      in
        (Tcon,name)
      end
    | natural_relator_from_term t =
        raise TERM ("Expected constant",[t]) (* TODO: Localize this! *)

    local
      fun decl_natrel_aux t context = let
        fun warn msg = let
          val tP =
            Context.cases Syntax.pretty_term_global Syntax.pretty_term
              context t
          val m = Pretty.block [
            Pretty.str "Ignoring invalid natural_relator declaration:",
            Pretty.brk 1,
            Pretty.str msg,
            Pretty.brk 1,
            tP
          ] |> Pretty.string_of
          val _ = warning m
        in context end
      in
        declare_natural_relator (natural_relator_from_term t) context
        handle
          TERM (msg,_) => warn msg
        | exn => if Exn.is_interrupt exn then reraise exn else warn ""
      end
    in
      val natural_relator_attr = Scan.repeat1 Args.term >> (fn ts =>
        Thm.declaration_attribute ( fn _ => fold decl_natrel_aux ts)
      )
    end

    fun mk_fun_rel r1 r2 = let
      val (r1T,r2T) = (fastype_of r1,fastype_of r2)
      val (c1T,a1T) = dest_relT r1T
      val (c2T,a2T) = dest_relT r2T
      val (cT,aT) = (c1T --> c2T, a1T --> a2T)
      val rT = mk_relT (cT,aT)
    in
      list_relAPP [r1,r2] (Const (@{const_name fun_rel},r1T-->r2T-->rT))
    end

    val setup = I
      #> Attrib.setup
        @{binding natural_relator} natural_relator_attr "Declare natural relator"

  end
*}

setup Relators.setup

subsection {* Setup *}
subsubsection "Natural Relators"

declare [[natural_relator
  unit_rel int_rel nat_rel bool_rel
  fun_rel prod_rel option_rel sum_rel list_rel
  ]]

(*declaration {* let open Relators in
  fn _ =>
     declare_natural_relator (@{type_name unit},@{const_name unit_rel})
  #> declare_natural_relator (@{type_name fun},@{const_name fun_rel})
  #> declare_natural_relator (@{type_name prod},@{const_name prod_rel})
  #> declare_natural_relator (@{type_name option},@{const_name option_rel})
  #> declare_natural_relator (@{type_name sum},@{const_name sum_rel})
  #> declare_natural_relator (@{type_name list},@{const_name list_rel})

end
*}*)

ML_val {*
  Relators.mk_natural_relator
    @{context}
    [@{term "Ra::('c\<times>'a) set"},@{term "\<langle>Rb\<rangle>option_rel"}]
    @{type_name prod}
  |> the
  |> cterm_of @{theory}
;
  Relators.mk_fun_rel @{term "\<langle>Id\<rangle>option_rel"} @{term "\<langle>Id\<rangle>list_rel"}
  |> cterm_of @{theory}
*}

subsubsection "Additional Properties"
lemmas [relator_props] =
  single_valued_Id
  subset_refl
  refl

(* TODO: Move *)
lemma eq_UNIV_iff: "S=UNIV \<longleftrightarrow> (\<forall>x. x\<in>S)" by auto

lemma fun_rel_sv[relator_props]:
  assumes RAN: "Range Ra = UNIV"
  assumes SV: "single_valued Rv"
  shows "single_valued (Ra \<rightarrow> Rv)"
proof (intro single_valuedI ext impI allI)
  fix f g h x'
  assume R1: "(f,g)\<in>Ra\<rightarrow>Rv"
  and R2: "(f,h)\<in>Ra\<rightarrow>Rv"

  from RAN obtain x where AR: "(x,x')\<in>Ra" by auto
  from fun_relD[OF R1 AR] have "(f x,g x') \<in> Rv" .
  moreover from fun_relD[OF R2 AR] have "(f x,h x') \<in> Rv" .
  ultimately show "g x' = h x'" using SV by (auto dest: single_valuedD)
qed

lemmas [relator_props] = Range_Id

lemma fun_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> R1 \<rightarrow> R2 = Id"
  by (auto simp: fun_rel_def)

lemma fun_rel_id_simp[simp]: "Id\<rightarrow>Id = Id" by tagged_solver

lemma fun_rel_comp_dist[relator_props]:
  "(R1\<rightarrow>R2) O (R3\<rightarrow>R4) \<subseteq> ((R1 O R3) \<rightarrow> (R2 O R4))"
  by (auto simp: fun_rel_def)

lemma fun_rel_mono[relator_props]: "\<lbrakk> R1\<subseteq>R2; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> R2\<rightarrow>R3 \<subseteq> R1\<rightarrow>R4"
  by (force simp: fun_rel_def)

lemma prod_rel_sv[relator_props]:
  "\<lbrakk>single_valued R1; single_valued R2\<rbrakk> \<Longrightarrow> single_valued (\<langle>R1,R2\<rangle>prod_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: prod_rel_def)

lemma prod_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> \<langle>R1,R2\<rangle>prod_rel = Id"
  by (auto simp: prod_rel_def)

lemma prod_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>prod_rel = Id" by tagged_solver

lemma prod_rel_mono[relator_props]:
"\<lbrakk> R2\<subseteq>R1; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> \<langle>R2,R3\<rangle>prod_rel \<subseteq> \<langle>R1,R4\<rangle>prod_rel"
  by (auto simp: prod_rel_def)

lemma prod_rel_range[relator_props]: "\<lbrakk>Range Ra=UNIV; Range Rb=UNIV\<rbrakk>
  \<Longrightarrow> Range (\<langle>Ra,Rb\<rangle>prod_rel) = UNIV"
  apply (auto simp: prod_rel_def)
  by (metis Range_iff UNIV_I)+

lemma option_rel_sv[relator_props]:
  "\<lbrakk>single_valued R\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>option_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: option_rel_def)

lemma option_rel_id[relator_props]:
  "R=Id \<Longrightarrow> \<langle>R\<rangle>option_rel = Id" by (auto simp: option_rel_def)

lemma option_rel_id_simp[simp]: "\<langle>Id\<rangle>option_rel = Id" by tagged_solver

lemma option_rel_mono[relator_props]: "R\<subseteq>R' \<Longrightarrow> \<langle>R\<rangle>option_rel \<subseteq> \<langle>R'\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_rel_range: "Range R = UNIV \<Longrightarrow> Range (\<langle>R\<rangle>option_rel) = UNIV"
  apply (auto simp: option_rel_def Range_iff)
  by (metis Range_iff UNIV_I option.exhaust)

lemma sum_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rl; single_valued Rr\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rl,Rr\<rangle>sum_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: sum_rel_def)

lemma sum_rel_id[relator_props]: "\<lbrakk>Rl=Id; Rr=Id\<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel = Id"
  apply (auto elim: sum_relE)
  apply (case_tac b)
  apply simp_all
  done

lemma sum_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>sum_rel = Id" by tagged_solver

lemma sum_rel_mono[relator_props]:
  "\<lbrakk> Rl\<subseteq>Rl'; Rr\<subseteq>Rr' \<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<subseteq> \<langle>Rl',Rr'\<rangle>sum_rel"
  by (auto simp: sum_rel_def)

lemma sum_rel_range[relator_props]:
  "\<lbrakk> Range Rl=UNIV; Range Rr=UNIV \<rbrakk> \<Longrightarrow> Range (\<langle>Rl,Rr\<rangle>sum_rel) = UNIV"
  apply (auto simp: sum_rel_def Range_iff)
  by (metis Range_iff UNIV_I sumE)

lemma list_rel_sv_iff:
  "single_valued (\<langle>R\<rangle>list_rel) \<longleftrightarrow> single_valued R"
  apply (intro iffI[rotated] single_valuedI allI impI)
  apply (clarsimp simp: list_rel_def)
proof -
  fix x y z
  assume SV: "single_valued R"
  assume "list_all2 (\<lambda>x x'. (x, x') \<in> R) x y" and
    "list_all2 (\<lambda>x x'. (x, x') \<in> R) x z"
  thus "y=z"
    apply (induct arbitrary: z rule: list_all2_induct)
    apply simp
    apply (case_tac z)
    apply force
    apply (force intro: single_valuedD[OF SV])
    done
next
  fix x y z
  assume SV: "single_valued (\<langle>R\<rangle>list_rel)"
  assume "(x,y)\<in>R" "(x,z)\<in>R"
  hence "([x],[y])\<in>\<langle>R\<rangle>list_rel" and "([x],[z])\<in>\<langle>R\<rangle>list_rel"
    by (auto simp: list_rel_def)
  with single_valuedD[OF SV] show "y=z" by blast
qed

lemma list_rel_sv[relator_props]:
  "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_rel)"
  by (simp add: list_rel_sv_iff)

lemma list_rel_id[relator_props]: "\<lbrakk>R=Id\<rbrakk> \<Longrightarrow> \<langle>R\<rangle>list_rel = Id"
  by (auto simp add: list_rel_def list_all2_eq[symmetric])

lemma list_rel_id_simp[simp]: "\<langle>Id\<rangle>list_rel = Id" by tagged_solver

lemma list_rel_mono[relator_props]:
  assumes A: "R\<subseteq>R'"
  shows "\<langle>R\<rangle>list_rel \<subseteq> \<langle>R'\<rangle>list_rel"
proof clarsimp
  fix l l'
  assume "(l,l')\<in>\<langle>R\<rangle>list_rel"
  thus "(l,l')\<in>\<langle>R'\<rangle>list_rel"
    apply induct
    using A
    by auto
qed

lemma list_rel_range[relator_props]:
  assumes A: "Range R = UNIV"
  shows "Range (\<langle>R\<rangle>list_rel) = UNIV"
proof (clarsimp simp: eq_UNIV_iff)
  fix l
  show "l\<in>Range (\<langle>R\<rangle>list_rel)"
    apply (induct l)
    using A[unfolded eq_UNIV_iff]
    by (auto simp: Range_iff intro: list_relI)
qed

text {* Pointwise refinement for set types: *}
lemma set_rel_sv[relator_props]:
  "single_valued (\<langle>R\<rangle>set_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: set_rel_def) []

lemma set_rel_id[relator_props]: "R=Id \<Longrightarrow> \<langle>R\<rangle>set_rel = Id"
  by (auto simp add: set_rel_def)

lemma set_rel_id_simp[simp]: "\<langle>Id\<rangle>set_rel = Id" by tagged_solver

lemma set_rel_csv[relator_props]:
  "\<lbrakk> single_valued (R\<inverse>) \<rbrakk>
  \<Longrightarrow> single_valued ((\<langle>R\<rangle>set_rel)\<inverse>)"
  apply (rule single_valuedI)
  apply (simp only: converse_iff)

  apply (simp add: single_valued_def Image_def set_rel_def)
  apply (intro allI impI equalityI)
    apply (clarsimp, blast) []
    apply (clarsimp, drule (1) set_mp, blast) []
  done

subsection {* Invariant and Abstraction *}

text {*
  Quite often, a relation can be described as combination of an
  abstraction function and an invariant, such that the invariant describes valid
  values on the concrete domain, and the abstraction function maps valid
  concrete values to its corresponding abstract value.
*}
definition build_rel where
  "build_rel \<alpha> I \<equiv> {(c,a) . a=\<alpha> c \<and> I c}"
abbreviation "br\<equiv>build_rel"
lemmas br_def[refine_rel_defs] = build_rel_def

lemma brI[intro?]: "\<lbrakk> a=\<alpha> c; I c \<rbrakk> \<Longrightarrow> (c,a)\<in>br \<alpha> I"
  by (simp add: br_def)

lemma br_id[simp]: "br id (\<lambda>_. True) = Id"
  unfolding build_rel_def by auto

lemma br_chain:
  "(build_rel \<beta> J) O (build_rel \<alpha> I) = build_rel (\<alpha>\<circ>\<beta>) (\<lambda>s. J s \<and> I (\<beta> s))"
  unfolding build_rel_def by auto

lemma br_sv[simp, intro!,relator_props]: "single_valued (br \<alpha> I)"
  unfolding build_rel_def
  apply (rule single_valuedI)
  apply auto
  done

lemma converse_br_sv_iff[simp]:
  "single_valued (converse (br \<alpha> I)) \<longleftrightarrow> inj_on \<alpha> (Collect I)"
  by (auto intro!: inj_onI single_valuedI dest: single_valuedD inj_onD
    simp: br_def) []

lemmas [relator_props] = single_valued_relcomp

lemma br_comp_alt: "br \<alpha> I O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by (auto simp add: br_def)

lemma br_comp_alt':
  "{(c,a) . a=\<alpha> c \<and> I c} O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by auto

lemma single_valued_as_brE:
  assumes "single_valued R"
  obtains \<alpha> invar where "R=br \<alpha> invar"
  apply (rule that[of "\<lambda>x. THE y. (x,y)\<in>R" "\<lambda>x. x\<in>Domain R"])
  using assms unfolding br_def
  by (auto dest: single_valuedD
    intro: the_equality[symmetric] theI)

lemma sv_add_invar:
  "single_valued R \<Longrightarrow> single_valued {(c, a). (c, a) \<in> R \<and> I c}"
  by (auto dest: single_valuedD intro: single_valuedI)

subsection {* Miscellanneous *}
lemma rel_cong: "(f,g)\<in>Id \<Longrightarrow> (x,y)\<in>Id \<Longrightarrow> (f x, g y)\<in>Id" by simp
lemma rel_fun_cong: "(f,g)\<in>Id \<Longrightarrow> (f x, g x)\<in>Id" by simp
lemma rel_arg_cong: "(x,y)\<in>Id \<Longrightarrow> (f x, f y)\<in>Id" by simp

end


theory Interface
  imports Graph Misc

begin

(* thought about partial function, but then I would have needed non-empty lists;
this one seems easier; empty list means no label of this kind in interface *)
(* lists make re-indexing easier *)

type_synonym ('n,'l) interface = "'l \<Rightarrow> 'n list"
definition inter_nodes :: "('n,'l) interface \<Rightarrow> 'n set" where
  "inter_nodes i \<equiv> \<Union>{set (i l)| l. True}"

(* index calculation is only for fun to make it compatible to the paper,
but is of no relevance for this development *)
primrec list_index_aux:: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat option" where
  "list_index_aux a [] n = None" |
  "list_index_aux a (x#xs) n = (if a=x then (Some n) else list_index_aux a xs (Suc n))"

abbreviation list_index :: "'a \<Rightarrow> 'a list \<Rightarrow> nat option" where
  "list_index a l \<equiv> list_index_aux a l 0"

definition index :: "('n,'l) interface \<Rightarrow> 'n \<Rightarrow> 'l \<Rightarrow> nat option" where
  "index i n l = list_index n (i l)"
(* end index calculation *)

abbreviation empty:: "'l \<Rightarrow> 'n list" ("\<lparr>\<rparr>") where
  "empty \<equiv> \<lambda>l. []"

lemma empty_inter_nodes:
  "inter_nodes \<lparr>\<rparr> = {}"
  by (simp add: inter_nodes_def)

subsection \<open>Matching Lists\<close>
(* could we allow the same node occur in the list multiple times? I guess not;
this will be ruled out by the definition of is_ComponentInterface *)
fun match_lists :: "'n list \<Rightarrow> 'n list \<Rightarrow> 'n \<rightharpoonup> 'n" where
  "match_lists [] ys = Map.empty" |
  "match_lists xs [] = Map.empty" |
  "match_lists (x#xs) (y#ys) = (match_lists xs ys)(x\<mapsto>y)"

lemma match_lists_empty[simp]:
  shows "match_lists [] ys = Map.empty"
  and "match_lists xs [] = Map.empty"
  using match_lists.elims by blast+

lemma match_lists_dom:
  "dom (match_lists xs ys) = set (take (length ys) xs)"
  apply(induct xs arbitrary: ys,simp)
  by (smt (verit) dom_fun_upd length_0_conv length_tl list.discI list.sel(3) list.simps(15)
                  match_lists.elims option.distinct(1) take_Cons' take_eq_Nil)

lemma match_lists_dom':
  "dom (match_lists xs ys) \<subseteq> set xs"
  by (simp add: match_lists_dom set_take_subset)

lemma distinct_dom:
  "distinct(x#xs) \<Longrightarrow> (x \<notin> dom (match_lists xs ys))"
  by (meson distinct.simps(2) match_lists_dom' subsetD)

lemma match_lists_restrict:
  "distinct xs \<Longrightarrow> match_lists xs ys |` set xs = match_lists xs ys"
proof(induct xs arbitrary: ys, simp)
  case (Cons x xs)
  thus ?case
  proof(cases "ys=[]", simp)
    case False
    then obtain y ys' where y: "ys=y#ys'"
      by (meson list.exhaust)
    thus "match_lists (x # xs) ys |` set (x # xs) = match_lists (x # xs) ys"
      using Cons by simp
  qed
qed

lemma match_list_added:
  assumes "(a, b) \<notin> map2set (match_lists xs ys)"
  and "(a, b) \<in> map2set (match_lists (x # xs) (y#ys))"
  shows "(a,b) = (x,y)"
  using assms
  by (smt (z3) dom_fun_upd fun_upd_other insertCI insertE map2set_def map_upd_Some_unfold
               match_lists.simps(3) mem_Collect_eq option.distinct(1) option.sel)

lemma distinct_match_lists_restrict:
  "distinct (x#xs) \<Longrightarrow> (match_lists (x#xs) (y#ys)) |` set xs = match_lists xs ys"
  by (simp add: match_lists_restrict)

lemma match_lists_minimum:
  "let n = min(length xs) (length ys)
   in match_lists xs ys = match_lists (take n xs) (take n ys)"
proof(induct xs arbitrary: ys, fastforce)
  case (Cons x xs)
  thus ?case
  proof(cases "ys = []", fastforce)
    case False
    then obtain y ys' where y: "ys=y#ys'"
      by (meson list.exhaust)
    thus ?thesis
      by (metis Cons.hyps length_Cons match_lists.simps(3) min_Suc_Suc take_Suc_Cons)
  qed
qed

lemma match_list_iso:
  "distinct (x#xs) \<Longrightarrow> map2set (match_lists xs ys) \<subseteq> map2set (match_lists (x#xs) (y#ys))"
  unfolding map2set_def
  using Suc_leI match_lists_dom' by fastforce

lemma match_lists_point1:
  "(a,b) \<in> map2set (match_lists xs ys)
     \<Longrightarrow> (\<exists>(n::nat) < min (length xs) (length ys). a = xs!n \<and> b = ys!n)"
unfolding map2set_def
proof(induct xs arbitrary: ys,fastforce)
  case (Cons x xs)
  thus ?case
  proof(cases "ys=[]", simp add: Cons.prems)
    case False
    then obtain y ys'
      where x1: "(a, b) \<in> map2set (match_lists (x # xs) (y#ys'))" and x2: "ys = y#ys'"
      unfolding map2set_def
      by (metis list.exhaust Cons.prems)
    thus ?thesis
      apply(cases "(a, b) \<in> map2set (match_lists xs ys')")
       apply (metis map2set_def Cons.hyps Suc_leI x2 length_Cons less_Suc_eq_le min_less_iff_conj
                    nth_Cons_Suc)
      using x1 x2 match_list_added by fastforce
  qed
qed

lemma match_lists_point2:
  "\<lbrakk>distinct xs; (\<exists>n < min (length xs) (length ys). a = xs!n \<and> b = ys!n)\<rbrakk>
      \<Longrightarrow> (a,b) \<in> map2set (match_lists xs ys)"
proof(induct xs arbitrary: ys, fastforce)
  case (Cons x xs)
  thus ?case
  proof-
    from Cons.prems(2)
    obtain n where a1: "n<min (length (x # xs)) (length ys)\<and> a = (x # xs) ! n \<and> b = ys ! n"
      by blast
    thus ?thesis
    proof(cases "ys=[]",simp add: Cons.prems)
      case False
      then obtain y ys' where a2: "ys = y#ys'"
        using list.exhaust by blast
      thus ?thesis
      proof(cases "n=0",(auto simp:  map2set_def a1 a2)[1])
        case False
        hence "(a, b) \<in> map2set (match_lists xs ys')"
          using a1 a2 gr0_conv_Suc Cons.hyps Cons.prems(1) by fastforce
        thus ?thesis
          by (metis Cons.prems(1) a2 match_list_iso subset_eq)
      qed
    qed
  qed
qed

lemma match_lists_point:
  assumes "distinct xs"
  shows "(a,b) \<in> map2set (match_lists xs ys)
         \<longleftrightarrow> (\<exists>(n::nat) < min (length xs) (length ys). a = xs!n \<and> b = ys!n)"
  by (metis assms match_lists_point1 match_lists_point2)

lemma match_lists_point':
  assumes "distinct xs"
  shows "a\<in>dom(match_lists xs ys)
         \<longleftrightarrow> (\<exists>(n::nat) < min(length xs)(length ys). a = xs!n \<and> the((match_lists xs ys) a) = ys!n)"
  using match_lists_point assms unfolding map2set_def
  by fastforce

lemma match_lists_assoc:
  "distinct (xs@ys) \<Longrightarrow> match_lists (xs@ys) zs = (match_lists xs zs) ++ (match_lists ys (drop (length xs) zs))"
proof(induct xs arbitrary:zs, simp)
  case (Cons x xs)
  show "match_lists ((x # xs) @ ys) zs = match_lists (x # xs) zs ++ match_lists ys (drop (length (x # xs)) zs)"
  proof(cases "zs=[]", simp)
    case False
    then obtain z zs' where z: "zs=z#zs'"
      by (meson list.exhaust)
    have "x\<notin>dom (match_lists ys (drop (length xs) zs'))"
      using Cons.prems
      by (metis Un_iff append_Cons distinct.simps(2) match_lists_dom' set_append subsetD)
    thus "match_lists ((x # xs) @ ys) zs = match_lists (x # xs) zs ++ match_lists ys (drop (length (x # xs)) zs)"
      by (metis z Cons.hyps Cons.prems append_Cons distinct.simps(2) drop_Suc_Cons length_Cons map_add_upd_left match_lists.simps(3))
  qed
qed

subsection \<open>Matching Interfaces\<close>
(* function makes it easier to have disjointness, as nodes are defined as pairs n,l *)
definition match_inter :: "('n,'l) interface \<Rightarrow> ('n,'l) interface \<Rightarrow> 'l \<Rightarrow> 'n \<rightharpoonup> 'n" where
  "match_inter i j = (\<lambda>l. match_lists (i l) (j l))"

lemma match_inter_point:
  assumes "distinct (i l)"
  shows "(a, b) \<in> map2set ((match_inter i j) l)
         \<longleftrightarrow> (\<exists>n < min (length (i l)) (length (j l)). a = (i l)!n \<and> b = (j l)!n)"
  unfolding match_inter_def
    using assms by (rule match_lists_point)

lemma match_inter_point':
  assumes "distinct (i l)"
  shows "a \<in> dom((match_inter i j) l)
         \<longleftrightarrow> (\<exists>n<min(length(i l)) (length(j l)). a=(i l)!n \<and> the(((match_inter i j) l) a)=(j l)!n)"
  using match_inter_point assms unfolding map2set_def
  by fastforce

lemma match_inter_empty[simp]:
  shows "match_inter \<lparr>\<rparr> i = (\<lambda>l. Map.empty)"
  and "match_inter i \<lparr>\<rparr> = (\<lambda>l. Map.empty)"
  unfolding match_inter_def
   apply simp
  by (metis list.discI match_lists.elims)

subsection \<open>Matching -- in preparation\<close>

definition inter_prune :: "('n,'l) interface \<Rightarrow> ('n,'l) interface \<Rightarrow> ('n,'l) interface" where
  "inter_prune i j = (\<lambda>l. drop (length (j l)) (i l))"

definition inter_comp :: "('n,'l) interface \<Rightarrow> ('n,'l) interface \<Rightarrow> ('n,'l) interface" (infixl "@@" 60) where
  "inter_comp  i j = (\<lambda>l. (i l)@(j l))"

lemma inter_comp_empty[simp]:
  shows "\<lparr>\<rparr> @@ i = i"
  and   "i @@ \<lparr>\<rparr> = i"
  unfolding inter_comp_def
  by force+

lemma inter_comp_assoc:
  "(i @@ j) @@ k = i @@ (j @@ k)"
  unfolding inter_comp_def
  by simp

lemma inter_prune_empty[simp]:
  "inter_prune i \<lparr>\<rparr> = i"
  "inter_prune \<lparr>\<rparr> i = \<lparr>\<rparr>"
  unfolding inter_prune_def
  by fastforce+

lemma map2set_extend:
  assumes "distinct (x#xs)"
  shows" map2set (match_lists (x # xs) (y#ys)) = {(x,y)} \<union> map2set (match_lists xs ys)"
proof-
  have "map2set (match_lists (x # xs) (y#ys)) = map2set (Map.empty(x\<mapsto>y) ++ (match_lists xs ys))"
    by (metis assms distinct_dom empty_map_add map_add_upd_left match_lists.simps(3))
  also have "... = map2set (Map.empty(x\<mapsto>y)) \<union> map2set ((match_lists xs ys))"
    apply(rule map2set_union)
    by (metis assms distinct_dom Int_empty_left Int_insert_left_if0 dom_eq_singleton_conv)
  ultimately show ?thesis
    by (simp add: map2set_single)
qed

lemma match_lists_set_zip:
  "distinct xs \<Longrightarrow> map2set(match_lists xs ys) = set (zip xs ys)"
proof(induct xs arbitrary:ys, simp add: map2set_def)
  case (Cons x xs)
  then show ?case
  proof(cases "ys = []", simp add: map2set_def)
  assume "distinct (x#xs)"
  case False
   then obtain y ys' where y: "ys=y#ys'"
      by (meson list.exhaust)
    thus " map2set (match_lists (x # xs) ys) = set (zip (x # xs) ys)"
      using Cons
      by (smt (z3) Collect_cong map2set_def match_lists_point mem_Collect_eq set_zip)
  qed
qed

end


theory State
  imports Main
begin

chapter \<open>Abstract State\<close>

text \<open>
To ensure the logic is sufficiently abstract,
we make no assumptions about its structure and represent it as a single type variable.
Therefore, rules that manipulate the state, such as removal of auxiliary variables
and local state require operators over the state to express the necessary transformations.
\<close>

type_synonym ('b) pred = "('b) set"
type_synonym ('b) rpred = "('b) rel"

section \<open>Definitions\<close>

text \<open>Stability of a predicate across an environment step\<close>
definition stable :: "('b) rpred \<Rightarrow> ('b) pred \<Rightarrow> bool"
  where "stable R P \<equiv> \<forall>m m'. m \<in> P \<longrightarrow> (m,m') \<in> R \<longrightarrow> m' \<in> P"

text \<open>Weakest precondition for a pre-condition and post-relation\<close>
definition wp :: "'b pred \<Rightarrow> 'b rpred \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "wp pre post Q \<equiv>
    pre \<inter> {m. (\<forall>m'. (m,m') \<in> post \<longrightarrow> m' \<in> Q) }"

text \<open>Equivalent definitions for stable and wp using relation operations.\<close>

lemma stable_rel:
  "stable R P = (R `` P \<subseteq> P)"
unfolding stable_def by auto

(*
lemma wp_rel_partial:
  "wp pre post Q = pre \<inter> Domain post \<inter> {m. (\<forall>m'. (m,m') \<in> post \<longrightarrow> m' \<in> Q)}"
unfolding wp_def by auto

lemma wp_rel:
  "wp pre post Q = pre \<inter> Domain post \<inter> -(post\<inverse> `` (-Q))"
unfolding wp_def by auto *)

text \<open>Guarantee check for a pre-condition and post-relation\<close>
definition guar :: "'b pred \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred \<Rightarrow> bool"
  where "guar pre post G \<equiv> {(m,m'). m \<in> pre \<and> (m,m') \<in> post} \<subseteq> G"

fun guar2 :: "'b pred \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred \<Rightarrow> bool" where
"guar2 pre post G = (pre \<subseteq> {m. (\<forall>m'. ((m,m') \<in> post \<longrightarrow> (m,m') \<in> G))})"

lemma "guar pre post G = guar2 pre post G"
by (auto simp add: guar_def)

text \<open>Shorthand for the weakest-precondition of an environment step\<close>
abbreviation wp\<^sub>e :: "'b rpred \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "wp\<^sub>e R Q \<equiv> wp UNIV (R\<^sup>* ) Q"

section \<open>Stability Properties\<close>

lemma stable_conseqI [intro]:
  assumes "stable R' P" "R \<subseteq> R'"
  shows "stable R P"
  using assms rtrancl_mono unfolding stable_def by blast

lemma stable_conjI [intro]:
  assumes "stable R P" "stable R' P'"
  shows "stable (R \<inter> R') (P \<inter> P')"
  using assms by (auto simp: stable_def)

lemma stable_transitive:
  assumes "(m,m') \<in> R\<^sup>*" "m \<in> P" "stable R P"
  shows "m' \<in> P"
  using assms by (induct rule: rtrancl.induct) (auto simp: stable_def)

lemma stable_wpI:
  "stable R P \<Longrightarrow> P \<subseteq> wp UNIV (R\<^sup>*) P"
  unfolding wp_def using stable_transitive by fast

lemma stable_falseI [intro]:
  "stable R {}"
  by (auto simp: stable_def)

lemma stable_wp: "stable R (wp UNIV (R\<^sup>*) P)"
unfolding stable_def wp_def
by (auto simp: converse_rtrancl_into_rtrancl)

lemma "P \<subseteq> (R\<^sup>*) `` P"
unfolding wp_def
by auto

lemma "stable R ((R\<^sup>*) `` P)"
unfolding stable_def
by (meson Image_iff rtrancl.rtrancl_into_rtrancl)

section \<open>Guarantee Properties\<close>

lemma guar_conseqI [intro]:
  assumes "guar pre post G" "G \<subseteq>  G'"
  shows "guar pre post G'"
  using assms by (auto simp: guar_def)

section \<open>Thread-Local State\<close>

text \<open>
To support thread-local state, we require an operation capable of merging two states, such
that the global component from the first is merged with the local component of the second.
We refer to this operation as op throughout the definitions.
\<close>

type_synonym 'b merge = "'b \<Rightarrow> 'b \<Rightarrow> 'b"

text \<open>Collect all states where their combination with the local state of l satisfies P\<close>
definition thr\<^sub>P :: "'b merge \<Rightarrow> 'b \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "thr\<^sub>P op l P \<equiv> {m. op m l \<in> P}"

text \<open>Collect all states where some local state satisfies Q\<close>
definition thr\<^sub>Q :: "'b merge \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "thr\<^sub>Q op Q \<equiv> {m. \<exists>l. op m l \<in> Q}"

text \<open>Collect all transitions in R that preserve the local state\<close>
definition thr\<^sub>R :: "'b merge \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred"
  where "thr\<^sub>R op R \<equiv> {(m,m') |m m'. \<forall>l. (op m l,op m' l) \<in> R}"

text \<open>Collect all transitions where their combinations with arbitrary local states satisfies G\<close>
definition thr\<^sub>G :: "'b merge \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred"
  where "thr\<^sub>G op G \<equiv> {(m,m') |m m' l l'. (op m l,op m' l') \<in> G}"

definition invthr\<^sub>G :: "'b merge \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred" where
  "invthr\<^sub>G op l l' G' \<equiv> {(op m l, op m' l') |m m'. (m,m') \<in> G'}"

text \<open>Collect all states where all local states satisfy P\<close>
definition thr\<^sub>A :: "'b merge \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "thr\<^sub>A op P \<equiv> {m. \<forall>l. op m l \<in> P}"

text \<open>Lift a local transition to a global transition given the pre and post local state\<close>
definition thr2glb :: "'b merge \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b rpred \<Rightarrow> 'b rpred"
  where "thr2glb op l l' r \<equiv> {(m,m'). (op m l,op m' l') \<in> r}"

text \<open>The predicate transformations preserve ordering\<close>
lemma thr_mono:
  "P \<subseteq> Q \<Longrightarrow> thr\<^sub>P op l P \<subseteq> thr\<^sub>P op l Q"
  unfolding thr\<^sub>P_def by auto

lemma thr_mono':
  "P \<subseteq> Q \<Longrightarrow> thr\<^sub>A op P \<subseteq> thr\<^sub>A op Q"
  unfolding thr\<^sub>A_def by auto

text \<open>The predicate transformations preserve stability\<close>
lemma thr_stable:
  "stable R P \<Longrightarrow> stable (thr\<^sub>R op R) (thr\<^sub>P op l P)"
  unfolding thr\<^sub>P_def thr\<^sub>R_def stable_def by auto

lemma thr_stable':
  "stable R P \<Longrightarrow> stable (thr\<^sub>R op R) (thr\<^sub>A op P)"
  unfolding thr\<^sub>A_def thr\<^sub>R_def stable_def by auto

lemma thr_stableQ:
  "stable R P \<Longrightarrow> stable (thr\<^sub>R op R) (thr\<^sub>Q op P)"
  unfolding thr\<^sub>Q_def thr\<^sub>R_def stable_def by auto

lemma thr_wp:
  "P \<subseteq> wp v r M \<Longrightarrow> thr\<^sub>P op l P \<subseteq> wp (thr\<^sub>P op l v) (thr2glb op l l' r) (thr\<^sub>P op l' M)"
  unfolding wp_def thr2glb_def thr\<^sub>P_def
  apply auto
  oops

lemma thr_guar:
  "guar v r G \<Longrightarrow> guar (thr\<^sub>P op l v) (thr2glb op l l' r) (thr\<^sub>G op G)"
  unfolding thr2glb_def thr\<^sub>P_def thr\<^sub>G_def guar_def by auto

section \<open>Auxiliary State\<close>

text \<open>
To support auxiliary state, we require a state relation the relates two states given their
real components are equivalent.
\<close>

definition aux\<^sub>P
  where "aux\<^sub>P r P \<equiv> {m. \<exists>m'. (m,m') \<in> r\<^sup>= \<and> m' \<in> P}"

definition aux\<^sub>R
  where "aux\<^sub>R r R \<equiv> {(m,m'). \<forall>n. (m,n) \<in> r\<^sup>= \<longrightarrow> (\<exists>n'. (m',n') \<in> r\<^sup>= \<and> (n,n') \<in> R)}"

definition aux\<^sub>G
  where "aux\<^sub>G r R \<equiv> {(m,m'). \<exists>n n'. (m,n) \<in> r\<^sup>= \<and> (m',n') \<in> r\<^sup>= \<and> (n,n') \<in> R}"

lemma aux\<^sub>P_mono [intro]:
  "P \<subseteq> Q \<Longrightarrow> aux\<^sub>P a P \<subseteq> aux\<^sub>P a Q"
  unfolding aux\<^sub>P_def by auto

lemma aux\<^sub>R_mono [intro]:
  "P \<subseteq> Q \<Longrightarrow> aux\<^sub>R a P \<subseteq> aux\<^sub>R a Q"
  unfolding aux\<^sub>R_def by fast

lemma aux\<^sub>P_self [intro]:
  "P \<subseteq> aux\<^sub>P r P"
  unfolding aux\<^sub>P_def by auto

lemma aux\<^sub>G_self [intro]:
  "R \<subseteq> aux\<^sub>G r R"
  unfolding aux\<^sub>G_def by auto

lemma aux_stable [intro]:
  assumes "stable R P"
  shows "stable (aux\<^sub>R r R) (aux\<^sub>P r P)"
  unfolding stable_def aux\<^sub>R_def aux\<^sub>P_def
proof (clarsimp, goal_cases)
  case (1 m n p)
  then obtain n' where a: "(p, n') \<in> r\<^sup>=" "(n, n') \<in> R" by auto
  hence "n' \<in> P" using 1 assms by (auto simp: stable_def)
  then show ?case using a(1) by auto
qed

(*
lemma aux_wp [intro]:
  assumes "P \<subseteq> wp v b Q"
  shows "aux\<^sub>P r P \<subseteq> wp (aux\<^sub>P r v) (aux\<^sub>R r b) (aux\<^sub>P r Q)"
  unfolding wp_def aux\<^sub>P_def
proof (clarsimp, (intro conjI; clarsimp), goal_cases)
  case (1 n m')
  then show ?case using assms by (auto simp: wp_def aux\<^sub>P_def)
next
  case (2 n m')
  then show ?case using assms
  proof (intro conjI, goal_cases)
    case 1
    then show ?case unfolding aux\<^sub>R_def wp_def by fast
  next
    case 2
    then show ?case
  qed
oops *)

lemma aux_guar [intro]:
  assumes "guar v b G"
  shows "guar (aux\<^sub>P r v) (aux\<^sub>R r b) (aux\<^sub>G r G)"
  unfolding wp_def aux\<^sub>G_def aux\<^sub>P_def aux\<^sub>R_def guar_def
proof (clarsimp, goal_cases)
  case (1 m m' n)
  then obtain n' where a: "(m', n') \<in> r\<^sup>=" "(n, n') \<in> b" by auto
  hence "(n,n') \<in> G" using assms 1 by (auto simp: guar_def)
  thus ?case using a(1) 1(2) by auto
qed

end


(*  Title:      HOL/Algebra/Sym_Groups.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Sym_Groups
  imports Cycles Solvable_Groups

begin

section \<open>Symmetric Groups\<close>

subsection \<open>Definitions\<close>

abbreviation inv' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "inv' f \<equiv> Hilbert_Choice.inv f"

definition sym_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "sym_group n = \<lparr> carrier = { p. p permutes {1..n} }, mult = (\<circ>), one = id \<rparr>"

definition alt_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "alt_group n = (sym_group n) \<lparr> carrier := { p. p permutes {1..n} \<and> evenperm p } \<rparr>"

definition sign_img :: "int monoid"
  where "sign_img = \<lparr> carrier = { -1, 1 }, mult = ( * ), one = 1 \<rparr>"

subsection \<open>Basic Properties\<close>

lemma sym_group_carrier: "p \<in> carrier (sym_group n) \<longleftrightarrow> p permutes {1..n}"
  unfolding sym_group_def by simp

lemma sym_group_mult: "mult (sym_group n) = (\<circ>)"
  unfolding sym_group_def by simp

lemma sym_group_one: "one (sym_group n) = id"
  unfolding sym_group_def by simp

lemma sym_group_carrier': "p \<in> carrier (sym_group n) \<Longrightarrow> permutation p"
  unfolding sym_group_carrier permutation_permutes by auto

lemma alt_group_carrier: "p \<in> carrier (alt_group n) \<longleftrightarrow> p permutes {1..n} \<and> evenperm p"
  unfolding alt_group_def by auto

lemma alt_group_mult: "mult (alt_group n) = (\<circ>)"
  unfolding alt_group_def using sym_group_mult by simp

lemma alt_group_one: "one (alt_group n) = id"
  unfolding alt_group_def using sym_group_one by simp

lemma alt_group_carrier': "p \<in> carrier (alt_group n) \<Longrightarrow> permutation p"
  unfolding alt_group_carrier permutation_permutes by auto

lemma sym_group_is_group: "group (sym_group n)"
  using permutes_inv permutes_inv_o(2)
  by (auto intro!: groupI
         simp add: sym_group_def permutes_compose
                   permutes_id comp_assoc, blast)

lemma sign_img_is_group: "group sign_img"
  unfolding sign_img_def by (unfold_locales, auto simp add: Units_def)

lemma sym_group_inv_closed:
  assumes "p \<in> carrier (sym_group n)" shows "inv' p \<in> carrier (sym_group n)"
  using assms permutes_inv sym_group_def by auto

lemma alt_group_inv_closed:
  assumes "p \<in> carrier (alt_group n)" shows "inv' p \<in> carrier (alt_group n)"
  using evenperm_inv[OF alt_group_carrier'] permutes_inv assms alt_group_carrier by auto

lemma sym_group_inv_equality [simp]:
  assumes "p \<in> carrier (sym_group n)" shows "inv\<^bsub>(sym_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) sym_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(sym_group n)\<^esub> p = one (sym_group n)"
    by (simp add: sym_group_def)
  thus ?thesis  using group.inv_equality[OF sym_group_is_group]
    by (simp add: assms sym_group_inv_closed)
qed

lemma sign_is_hom: "sign \<in> hom (sym_group n) sign_img"
  unfolding hom_def sign_img_def sym_group_mult using sym_group_carrier'[of _ n]
  by (auto simp add: sign_compose, meson sign_def)

lemma sign_group_hom: "group_hom (sym_group n) sign_img sign"
  using group_hom.intro[OF sym_group_is_group sign_img_is_group] sign_is_hom
  by (simp add: group_hom_axioms_def)

lemma sign_is_surj:
  assumes "n \<ge> 2" shows "sign ` (carrier (sym_group n)) = carrier sign_img"
proof -
  have "swapidseq (Suc 0) (Fun.swap (1 :: nat) 2 id)"
    using comp_Suc[OF id, of "1 :: nat" "2"] by auto
  hence "sign (Fun.swap (1 :: nat) 2 id) = (-1 :: int)"
    by (simp add: sign_swap_id)
  moreover have "Fun.swap (1 :: nat) 2 id \<in> carrier (sym_group n)" and "id \<in> carrier (sym_group n)"
    using assms permutes_swap_id[of "1 :: nat" "{1..n}" 2] permutes_id
    unfolding sym_group_carrier by auto
  ultimately have "carrier sign_img \<subseteq> sign ` (carrier (sym_group n))"
    using sign_id mk_disjoint_insert unfolding sign_img_def by fastforce
  moreover have "sign ` (carrier (sym_group n)) \<subseteq> carrier sign_img"
    using sign_is_hom unfolding hom_def by auto
  ultimately show ?thesis
    by blast
qed

lemma alt_group_is_sign_kernel:
  "carrier (alt_group n) = kernel (sym_group n) sign_img sign"
  unfolding alt_group_def sym_group_def sign_img_def kernel_def sign_def by auto

lemma alt_group_is_subgroup: "subgroup (carrier (alt_group n)) (sym_group n)"
  using group_hom.subgroup_kernel[OF sign_group_hom]
  unfolding alt_group_is_sign_kernel by blast

lemma alt_group_is_group: "group (alt_group n)"
  using group.subgroup_imp_group[OF sym_group_is_group alt_group_is_subgroup]
  by (simp add: alt_group_def)

lemma sign_iso:
  assumes "n \<ge> 2" shows "(sym_group n) Mod (carrier (alt_group n)) \<cong> sign_img"
  using group_hom.FactGroup_iso[OF sign_group_hom sign_is_surj[OF assms]]
  unfolding alt_group_is_sign_kernel .

lemma alt_group_inv_equality:
  assumes "p \<in> carrier (alt_group n)" shows "inv\<^bsub>(alt_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) alt_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(alt_group n)\<^esub> p = one (alt_group n)"
    by (simp add: alt_group_def sym_group_def)
  thus ?thesis  using group.inv_equality[OF alt_group_is_group]
    by (simp add: assms alt_group_inv_closed)
qed

lemma sym_group_card_carrier: "card (carrier (sym_group n)) = fact n"
  using card_permutations[of "{1..n}" n] unfolding sym_group_def by simp

lemma alt_group_card_carrier:
  assumes "n \<ge> 2" shows "2 * card (carrier (alt_group n)) = fact n"
proof -
  have "card (rcosets\<^bsub>sym_group n\<^esub> (carrier (alt_group n))) = 2"
    using iso_same_card[OF sign_iso[OF assms]] unfolding FactGroup_def sign_img_def by auto
  thus ?thesis
    using group.lagrange[OF sym_group_is_group alt_group_is_subgroup, of n]
    unfolding order_def sym_group_card_carrier by simp
qed

subsection \<open>Transposition Sequences\<close>

text \<open>In order to prove that the Alternating Group can be generated by 3-cycles, we need
      a stronger decomposition of permutations as transposition sequences than the one
      proposed at Permutations.thy. \<close>

inductive swapidseq_ext :: "'a set \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where
    empty:  "swapidseq_ext {} 0 id"
  | single: "\<lbrakk> swapidseq_ext S n p; a \<notin> S \<rbrakk> \<Longrightarrow> swapidseq_ext (insert a S) n p"
  | comp:   "\<lbrakk> swapidseq_ext S n p; a \<noteq> b \<rbrakk> \<Longrightarrow>
               swapidseq_ext (insert a (insert b S)) (Suc n) ((Fun.swap a b id) \<circ> p)"

lemma swapidseq_ext_finite:
  assumes "swapidseq_ext S n p" shows "finite S"
  using assms by (induction) (auto)

lemma swapidseq_ext_zero:
  assumes "finite S" shows "swapidseq_ext S 0 id"
  using assms empty by (induct set: "finite", fastforce, simp add: single)

lemma swapidseq_ext_imp_swapidseq:
  assumes "swapidseq_ext S n p" shows "swapidseq n p"
  using assms by (induction, simp, simp, meson comp_Suc)

lemma swapidseq_ext_zero_imp_id:
  assumes "swapidseq_ext S 0 p" shows "p = id"
proof -
  have "\<lbrakk> swapidseq_ext S n p; n = 0 \<rbrakk> \<Longrightarrow> p = id" for n
    by (induction rule: swapidseq_ext.induct, auto)
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_finite_expansion:
  assumes "finite B" and "swapidseq_ext A n p" shows "swapidseq_ext (A \<union> B) n p"
  using assms
proof (induct set: "finite", simp)
  case (insert b B) show ?case
    using insert single[OF insert(3), of b] by (metis Un_insert_right insert_absorb)
qed

lemma swapidseq_ext_backwards:
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                     swapidseq_ext A' n p' \<and> p = (Fun.swap a b id) \<circ> p'"
proof -
  { fix A n k and p :: "'a \<Rightarrow> 'a"
    assume "swapidseq_ext A n p" "n = Suc k"
    hence "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                       swapidseq_ext A' k p' \<and> p = (Fun.swap a b id) \<circ> p'"
    proof (induction, simp)
      case single thus ?case
        by (metis Un_insert_right insert_iff insert_is_Un swapidseq_ext.single)
    next
      case comp thus ?case
        by blast
    qed }
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_backwards':
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<in> A \<and> b \<in> A \<and> a \<noteq> b \<and> swapidseq_ext A n p' \<and> p = (Fun.swap a b id) \<circ> p'"
  using swapidseq_ext_backwards[OF assms] swapidseq_ext_finite_expansion
  by (metis Un_insert_left assms insertI1 sup.idem sup_commute swapidseq_ext_finite)

lemma swapidseq_ext_endswap:
  assumes "swapidseq_ext S n p" "a \<noteq> b"
  shows "swapidseq_ext (insert a (insert b S)) (Suc n) (p \<circ> (Fun.swap a b id))"
  using assms
proof (induction n arbitrary: S p a b)
  case 0 hence "p = id"
    using swapidseq_ext_zero_imp_id by blast
  thus ?case
    using 0 by (metis comp_id id_comp swapidseq_ext.comp)
next
  case (Suc n)
  then obtain c d S' and p' :: "'a \<Rightarrow> 'a"
    where cd: "c \<noteq> d" and S: "S = (insert c (insert d S'))" "swapidseq_ext S' n p'"
      and p: "p = (Fun.swap c d id) \<circ> p'"
    using swapidseq_ext_backwards[OF Suc(2)] by blast
  hence "swapidseq_ext (insert a (insert b S')) (Suc n) (p' \<circ> (Fun.swap a b id))"
    by (simp add: Suc.IH Suc.prems(2))
  hence "swapidseq_ext (insert c (insert d (insert a (insert b S')))) (Suc (Suc n))
                 ((Fun.swap c d id) \<circ> p' \<circ> (Fun.swap a b id))"
    by (metis cd fun.map_comp swapidseq_ext.comp)
  thus ?case
    by (metis S(1) p insert_commute)
qed

lemma swapidseq_ext_extension:
  assumes "swapidseq_ext A n p" and "swapidseq_ext B m q" and "A \<inter> B = {}"
  shows "swapidseq_ext (A \<union> B) (n + m) (p \<circ> q)"
  using assms(1,3)
proof (induction, simp add: assms(2))
  case single show ?case
    using swapidseq_ext.single[OF single(3)] single(2,4) by auto
next
  case comp show ?case
    using swapidseq_ext.comp[OF comp(3,2)] comp(4)
    by (metis Un_insert_left add_Suc insert_disjoint(1) o_assoc)
qed

lemma swapidseq_ext_of_cycles:
  assumes "cycle cs" shows "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
  using assms
proof (induct cs rule: cycle_of_list.induct)
  case (1 i j cs) show ?case
    using comp[OF 1(1), of i j] 1(2) by (simp add: o_def)
next
  case "2_1" show ?case
    by (simp, metis eq_id_iff empty)
next
  case ("2_2" v) show ?case
    using single[OF empty, of v] by (simp, metis eq_id_iff)
qed

lemma cycle_decomp_imp_swapidseq_ext:
  assumes "cycle_decomp S p" shows "\<exists>n. swapidseq_ext S n p"
  using assms
proof (induction)
  case empty show ?case
    using swapidseq_ext.empty by blast
next
  case (comp I p cs)
  then obtain m where m: "swapidseq_ext I m p" by blast
  hence "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
    using comp.hyps(2) swapidseq_ext_of_cycles by blast
  thus ?case using swapidseq_ext_extension m
    using comp.hyps(3) by blast
qed

lemma swapidseq_ext_of_permutation:
  assumes "p permutes S" and "finite S" shows "\<exists>n. swapidseq_ext S n p"
  using cycle_decomp_imp_swapidseq_ext[OF cycle_decomposition[OF assms]] .

lemma split_swapidseq_ext:
  assumes "k \<le> n" and "swapidseq_ext S n p"
  obtains q r U V where "swapidseq_ext U (n - k) q" and "swapidseq_ext V k r" and "p = q \<circ> r" and "U \<union> V = S"
proof -
  from assms
  have "\<exists>q r U V. swapidseq_ext U (n - k) q \<and> swapidseq_ext V k r \<and> p = q \<circ> r \<and> U \<union> V = S"
   (is "\<exists>q r U V. ?split k q r U V")
  proof (induct k rule: inc_induct)
    case base thus ?case
      by (metis diff_self_eq_0 id_o sup_bot.left_neutral empty)
  next
    case (step m)
    then obtain q r U V
      where q: "swapidseq_ext U (n - Suc m) q" and r: "swapidseq_ext V (Suc m) r"
        and p: "p = q \<circ> r" and S: "U \<union> V = S"
      by blast
    obtain a b r' V'
      where "a \<noteq> b" and r': "V = (insert a (insert b V'))" "swapidseq_ext V' m r'" "r = (Fun.swap a b id) \<circ> r'"
      using swapidseq_ext_backwards[OF r] by blast
    have "swapidseq_ext (insert a (insert b U)) (n - m) (q \<circ> (Fun.swap a b id))"
      using swapidseq_ext_endswap[OF q \<open>a \<noteq> b\<close>] step(2) by (metis Suc_diff_Suc)
    hence "?split m (q \<circ> (Fun.swap a b id)) r' (insert a (insert b U)) V'"
      using r' S unfolding p by fastforce
    thus ?case by blast
  qed
  thus ?thesis
    using that by blast
qed

subsection \<open>Unsolvability of Symmetric Groups\<close>

text \<open>We show that symetric groups (sym_group n) are unsolvable for n \<ge> 5.\<close>

abbreviation three_cycles :: "nat \<Rightarrow> (nat \<Rightarrow> nat) set"
  where "three_cycles n \<equiv>
           { cycle_of_list cs | cs. cycle cs \<and> length cs = 3 \<and> set cs \<subseteq> {1..n} }"

lemma stupid_lemma:
  assumes "length cs = 3" shows "cs = [ (cs ! 0), (cs ! 1), (cs ! 2) ]"
  using assms by (auto intro!: nth_equalityI)
    (metis Suc_lessI less_2_cases not_less_eq nth_Cons_0
           nth_Cons_Suc numeral_2_eq_2 numeral_3_eq_3)

lemma three_cycles_incl: "three_cycles n \<subseteq> carrier (alt_group n)"
proof
  fix p assume "p \<in> three_cycles n"
  then obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
    by auto
  obtain a b c where cs_def: "cs = [ a, b, c ]"
    using stupid_lemma[OF cs(3)] by auto
  have "swapidseq (Suc (Suc 0)) ((Fun.swap a b id) \<circ> (Fun.swap b c id))"
    using comp_Suc[OF comp_Suc[OF id], of b c a b] cs(2) unfolding cs_def by simp
  hence "evenperm p"
    using cs(1) unfolding cs_def by (simp add: evenperm_unique)
  thus "p \<in> carrier (alt_group n)"
    using permutes_subset[OF cycle_permutes cs(4)]
    unfolding alt_group_carrier cs(1) by simp
qed

lemma alt_group_carrier_as_three_cycles:
  "carrier (alt_group n) = generate (alt_group n) (three_cycles n)"
proof -
  interpret A: group "alt_group n"
    using alt_group_is_group by simp

  show ?thesis
  proof
    show "generate (alt_group n) (three_cycles n) \<subseteq> carrier (alt_group n)"
      using A.generate_subgroup_incl[OF three_cycles_incl A.subgroup_self] .
  next
    show "carrier (alt_group n) \<subseteq> generate (alt_group n) (three_cycles n)"
    proof
      { fix q :: "nat \<Rightarrow> nat" and a b c
        assume "a \<noteq> b" "b \<noteq> c" "{ a, b, c } \<subseteq> {1..n}"
        have "cycle_of_list [a, b, c] \<in> generate (alt_group n) (three_cycles n)"
        proof (cases)
          assume "c = a"
          hence "cycle_of_list [ a, b, c ] = id"
            by (simp add: swap_commute)
          thus "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            using one[of "alt_group n"] unfolding alt_group_one by simp
        next
          assume "c \<noteq> a"
          have "distinct [a, b, c]"
            using \<open>a \<noteq> b\<close> and \<open>b \<noteq> c\<close> and \<open>c \<noteq> a\<close> by auto
          with \<open>{ a, b, c } \<subseteq> {1..n}\<close>
          show "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            by (intro incl, fastforce)
        qed } note aux_lemma1 = this

      { fix S :: "nat set" and q :: "nat \<Rightarrow> nat"
        assume seq: "swapidseq_ext S (Suc (Suc 0)) q" and S: "S \<subseteq> {1..n}"
        have "q \<in> generate (alt_group n) (three_cycles n)"
        proof -
          obtain a b q' where ab: "a \<noteq> b" "a \<in> S" "b \<in> S"
            and q': "swapidseq_ext S (Suc 0) q'" "q = (Fun.swap a b id) \<circ> q'"
            using swapidseq_ext_backwards'[OF seq] by auto
          obtain c d where cd: "c \<noteq> d" "c \<in> S" "d \<in> S"
            and q: "q = (Fun.swap a b id) \<circ> (Fun.swap c d id)"
            using swapidseq_ext_backwards'[OF q'(1)]
                  swapidseq_ext_zero_imp_id
            unfolding q'(2)
            by fastforce

          consider (eq) "b = c" | (ineq) "b \<noteq> c" by auto
          thus ?thesis
          proof cases
            case eq then have "q = cycle_of_list [ a, b, d ]"
              unfolding q by simp
            moreover have "{ a, b, d } \<subseteq> {1..n}"
              using ab cd S by blast
            ultimately show ?thesis
              using aux_lemma1[OF ab(1)] cd(1) eq by simp
          next
            case ineq
            hence "q = cycle_of_list [ a, b, c ] \<circ> cycle_of_list [ b, c, d ]"
              unfolding q by (simp add: comp_swap)
            moreover have "{ a, b, c } \<subseteq> {1..n}" and "{ b, c, d } \<subseteq> {1..n}"
              using ab cd S by blast+
            ultimately show ?thesis
              using eng[OF aux_lemma1[OF ab(1) ineq] aux_lemma1[OF ineq cd(1)]]
              unfolding alt_group_mult by simp
          qed
        qed } note aux_lemma2 = this

      fix p assume "p \<in> carrier (alt_group n)" then have p: "p permutes {1..n}" "evenperm p"
        unfolding alt_group_carrier by auto
      obtain m where m: "swapidseq_ext {1..n} m p"
        using swapidseq_ext_of_permutation[OF p(1)] by auto
      have "even m"
        using swapidseq_ext_imp_swapidseq[OF m] p(2) evenperm_unique by blast
      then obtain k where k: "m = 2 * k"
        by auto
      show "p \<in> generate (alt_group n) (three_cycles n)"
        using m unfolding k
      proof (induct k arbitrary: p)
        case 0 then have "p = id"
          using swapidseq_ext_zero_imp_id by simp
        show ?case
          using generate.one[of "alt_group n" "three_cycles n"]
          unfolding alt_group_one \<open>p = id\<close> .
      next
        case (Suc m)
        have arith: "2 * (Suc m) - (Suc (Suc 0)) = 2 * m" and "Suc (Suc 0) \<le> 2 * Suc m"
          by auto
        then obtain q r U V
          where q: "swapidseq_ext U (2 * m) q" and r: "swapidseq_ext V (Suc (Suc 0)) r"
            and p: "p = q \<circ> r" and UV: "U \<union> V = {1..n}"
          using split_swapidseq_ext[OF _ Suc(2), of "Suc (Suc 0)"] unfolding arith by metis
        have "swapidseq_ext {1..n} (2 * m) q"
          using UV q swapidseq_ext_finite_expansion[OF swapidseq_ext_finite[OF r] q] by simp
        thus ?case
          using eng[OF Suc(1) aux_lemma2[OF r], of q] UV unfolding alt_group_mult p by blast
      qed
    qed
  qed
qed

theorem derived_alt_group_const:
  assumes "n \<ge> 5" shows "derived (alt_group n) (carrier (alt_group n)) = carrier (alt_group n)"
proof
  show "derived (alt_group n) (carrier (alt_group n)) \<subseteq> carrier (alt_group n)"
    using group.derived_in_carrier[OF alt_group_is_group] by simp
next
  { fix p assume "p \<in> three_cycles n" have "p \<in> derived (alt_group n) (carrier (alt_group n))"
    proof -
      obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
        using \<open>p \<in> three_cycles n\<close> by auto
      then obtain a b c where cs_def: "cs = [ a, b, c ]"
        using stupid_lemma[OF cs(3)] by blast
      have "card (set cs) = 3"
        using cs(2-3)
        by (simp add: distinct_card)

      have "set cs \<noteq> {1..n}"
        using assms cs(3) unfolding sym[OF distinct_card[OF cs(2)]] by auto
      then obtain d where d: "d \<notin> set cs" "d \<in> {1..n}"
        using cs(4) by blast

      hence "cycle (d # cs)" and "length (d # cs) = 4" and "card {1..n} = n"
        using cs(2-3) by auto
      hence "set (d # cs) \<noteq> {1..n}"
        using assms unfolding sym[OF distinct_card[OF \<open>cycle (d # cs)\<close>]]
        by (metis Suc_n_not_le_n eval_nat_numeral(3))
      then obtain e where e: "e \<notin> set (d # cs)" "e \<in> {1..n}"
        using d cs(4) by (metis insert_subset list.simps(15) subsetI subset_antisym)

      define q where "q = (Fun.swap d e id) \<circ> (Fun.swap b c id)"
      hence "bij q"
        by (simp add: bij_comp)
      moreover have "q b = c" and "q c = b"
        using d(1) e(1) unfolding q_def cs_def by simp+
      moreover have "q a = a"
        using d(1) e(1) cs(2) unfolding q_def cs_def by auto
      ultimately have "q \<circ> p \<circ> (inv' q) = cycle_of_list [ a, c, b ]"
        using conjugation_of_cycle[OF cs(2), of q]
        unfolding sym[OF cs(1)] unfolding cs_def by simp
      also have " ... = p \<circ> p"
        using cs(2) unfolding cs(1) cs_def
        by (auto, metis comp_id comp_swap swap_commute swap_triple)
      finally have "q \<circ> p \<circ> (inv' q) = p \<circ> p" .
      moreover have "bij p"
        unfolding cs(1) cs_def by (simp add: bij_comp)
      ultimately have p: "q \<circ> p \<circ> (inv' q) \<circ> (inv' p) = p"
        by (simp add: bijection.intro bijection.inv_comp_right comp_assoc)

      have "swapidseq (Suc (Suc 0)) q"
        using comp_Suc[OF comp_Suc[OF id], of b c d e] e(1) cs(2)  unfolding q_def cs_def by auto
      hence "evenperm q"
        using even_Suc_Suc_iff evenperm_unique by blast
      moreover have "q permutes { d, e, b, c }"
        unfolding q_def by (simp add: permutes_compose permutes_swap_id)
      hence "q permutes {1..n}"
        using cs(4) d(2) e(2) permutes_subset unfolding cs_def by fastforce
      ultimately have "q \<in> carrier (alt_group n)"
        unfolding alt_group_carrier by simp
      moreover have "p \<in> carrier (alt_group n)"
        using \<open>p \<in> three_cycles n\<close> three_cycles_incl by blast
      ultimately have "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
        using p alt_group_inv_equality unfolding alt_group_mult
        by (metis (no_types, lifting) UN_iff singletonI)
      thus "p \<in> derived (alt_group n) (carrier (alt_group n))"
        unfolding derived_def by (rule incl)
    qed } note aux_lemma = this

  interpret A: group "alt_group n"
    using alt_group_is_group .

  have "generate (alt_group n) (three_cycles n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using A.generate_subgroup_incl[OF _ A.derived_is_subgroup] aux_lemma by (meson subsetI)
  thus "carrier (alt_group n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using alt_group_carrier_as_three_cycles by simp
qed

corollary alt_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (alt_group n)"
proof (rule ccontr)
  assume "\<not> \<not> solvable (alt_group n)"
  then obtain m where "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = { id }"
    using group.solvable_iff_trivial_derived_seq[OF alt_group_is_group] unfolding alt_group_one by blast
  moreover have "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = carrier (alt_group n)"
    using derived_alt_group_const[OF assms] by (induct m) (auto)
  ultimately have card_eq_1: "card (carrier (alt_group n)) = 1"
    by simp
  have ge_2: "n \<ge> 2"
    using assms by simp
  have "2 = fact n"
    using alt_group_card_carrier[OF ge_2] unfolding card_eq_1
    by (metis fact_2 mult.right_neutral of_nat_fact)
  hence "n = 2"
    by (smt fact_ge_self ge_2 le_antisym)
  thus False
    using assms by simp
qed

corollary sym_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (sym_group n)"
proof -
  interpret Id: group_hom "alt_group n" "sym_group n" id
    using group.canonical_inj_is_hom[OF sym_group_is_group alt_group_is_subgroup] alt_group_def by simp
  show ?thesis
    using Id.inj_hom_imp_solvable alt_group_is_unsolvable[OF assms] by auto
qed

end


section\<open>Forcing notions\<close>
text\<open>This theory defines a locale for forcing notions, that is,
 preorders with a distinguished maximum element.\<close>

theory Forcing_Notions
  imports "ZF-Constructible.Relative"
begin

subsection\<open>Basic concepts\<close>
text\<open>We say that two elements $p,q$ are
  \<^emph>\<open>compatible\<close> if they have a lower bound in $P$\<close>
definition compat_in :: "i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "compat_in(A,r,p,q) \<equiv> \<exists>d\<in>A . \<langle>d,p\<rangle>\<in>r \<and> \<langle>d,q\<rangle>\<in>r"

definition
  is_compat_in :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
  "is_compat_in(M,A,r,p,q) \<equiv> \<exists>d[M]. d\<in>A \<and> (\<exists>dp[M]. pair(M,d,p,dp) \<and> dp\<in>r \<and>
                                   (\<exists>dq[M]. pair(M,d,q,dq) \<and> dq\<in>r))"

lemma compat_inI :
  "\<lbrakk> d\<in>A ; \<langle>d,p\<rangle>\<in>r ; \<langle>d,g\<rangle>\<in>r \<rbrakk> \<Longrightarrow> compat_in(A,r,p,g)"
  by (auto simp add: compat_in_def)

lemma refl_compat:
  "\<lbrakk> refl(A,r) ; \<langle>p,q\<rangle> \<in> r | p=q | \<langle>q,p\<rangle> \<in> r ; p\<in>A ; q\<in>A\<rbrakk> \<Longrightarrow> compat_in(A,r,p,q)"
  by (auto simp add: refl_def compat_inI)

lemma  chain_compat:
  "refl(A,r) \<Longrightarrow> linear(A,r) \<Longrightarrow>  (\<forall>p\<in>A.\<forall>q\<in>A. compat_in(A,r,p,q))"
  by (simp add: refl_compat linear_def)

lemma subset_fun_image: "f:N\<rightarrow>P \<Longrightarrow> f``N\<subseteq>P"
  by (auto simp add: image_fun apply_funtype)

lemma refl_monot_domain: "refl(B,r) \<Longrightarrow> A\<subseteq>B \<Longrightarrow> refl(A,r)"
  unfolding refl_def by blast

definition
  antichain :: "i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "antichain(P,leq,A) \<equiv> A\<subseteq>P \<and> (\<forall>p\<in>A.\<forall>q\<in>A.(\<not> compat_in(P,leq,p,q)))"

definition
  ccc :: "i \<Rightarrow> i \<Rightarrow> o" where
  "ccc(P,leq) \<equiv> \<forall>A. antichain(P,leq,A) \<longrightarrow> |A| \<le> nat"

locale forcing_notion =
  fixes P leq one
  assumes one_in_P:         "one \<in> P"
    and leq_preord:       "preorder_on(P,leq)"
    and one_max:          "\<forall>p\<in>P. \<langle>p,one\<rangle>\<in>leq"
begin

abbreviation Leq :: "[i, i] \<Rightarrow> o"  (infixl "\<preceq>" 50)
  where "x \<preceq> y \<equiv> \<langle>x,y\<rangle>\<in>leq"

lemma refl_leq:
  "r\<in>P \<Longrightarrow> r\<preceq>r"
  using leq_preord unfolding preorder_on_def refl_def by simp

text\<open>A set $D$ is \<^emph>\<open>dense\<close> if every element $p\in P$ has a lower
bound in $D$.\<close>
definition
  dense :: "i\<Rightarrow>o" where
  "dense(D) \<equiv> \<forall>p\<in>P. \<exists>d\<in>D . d\<preceq>p"

text\<open>There is also a weaker definition which asks for
a lower bound in $D$ only for the elements below some fixed
element $q$.\<close>
definition
  dense_below :: "i\<Rightarrow>i\<Rightarrow>o" where
  "dense_below(D,q) \<equiv> \<forall>p\<in>P. p\<preceq>q \<longrightarrow> (\<exists>d\<in>D. d\<in>P \<and> d\<preceq>p)"

lemma P_dense: "dense(P)"
  by (insert leq_preord, auto simp add: preorder_on_def refl_def dense_def)

definition
  increasing :: "i\<Rightarrow>o" where
  "increasing(F) \<equiv> \<forall>x\<in>F. \<forall> p \<in> P . x\<preceq>p \<longrightarrow> p\<in>F"

definition
  compat :: "i\<Rightarrow>i\<Rightarrow>o" where
  "compat(p,q) \<equiv> compat_in(P,leq,p,q)"

lemma leq_transD:  "a\<preceq>b \<Longrightarrow> b\<preceq>c \<Longrightarrow> a \<in> P\<Longrightarrow> b \<in> P\<Longrightarrow> c \<in> P\<Longrightarrow> a\<preceq>c"
  using leq_preord trans_onD unfolding preorder_on_def by blast

lemma leq_transD':  "A\<subseteq>P \<Longrightarrow> a\<preceq>b \<Longrightarrow> b\<preceq>c \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> P\<Longrightarrow> c \<in> P\<Longrightarrow> a\<preceq>c"
  using leq_preord trans_onD subsetD unfolding preorder_on_def by blast

lemma leq_reflI: "p\<in>P \<Longrightarrow> p\<preceq>p"
  using leq_preord unfolding preorder_on_def refl_def by blast

lemma compatD[dest!]: "compat(p,q) \<Longrightarrow> \<exists>d\<in>P. d\<preceq>p \<and> d\<preceq>q"
  unfolding compat_def compat_in_def .

abbreviation Incompatible :: "[i, i] \<Rightarrow> o"  (infixl "\<bottom>" 50)
  where "p \<bottom> q \<equiv> \<not> compat(p,q)"

lemma compatI[intro!]: "d\<in>P \<Longrightarrow> d\<preceq>p \<Longrightarrow> d\<preceq>q \<Longrightarrow> compat(p,q)"
  unfolding compat_def compat_in_def by blast

lemma denseD [dest]: "dense(D) \<Longrightarrow> p\<in>P \<Longrightarrow>  \<exists>d\<in>D. d\<preceq> p"
  unfolding dense_def by blast

lemma denseI [intro!]: "\<lbrakk> \<And>p. p\<in>P \<Longrightarrow> \<exists>d\<in>D. d\<preceq> p \<rbrakk> \<Longrightarrow> dense(D)"
  unfolding dense_def by blast

lemma dense_belowD [dest]:
  assumes "dense_below(D,p)" "q\<in>P" "q\<preceq>p"
  shows "\<exists>d\<in>D. d\<in>P \<and> d\<preceq>q"
  using assms unfolding dense_below_def by simp
    (*obtains d where "d\<in>D" "d\<in>P" "d\<preceq>q"
  using assms unfolding dense_below_def by blast *)

lemma dense_belowI [intro!]:
  assumes "\<And>q. q\<in>P \<Longrightarrow> q\<preceq>p \<Longrightarrow> \<exists>d\<in>D. d\<in>P \<and> d\<preceq>q"
  shows "dense_below(D,p)"
  using assms unfolding dense_below_def by simp

lemma dense_below_cong: "p\<in>P \<Longrightarrow> D = D' \<Longrightarrow> dense_below(D,p) \<longleftrightarrow> dense_below(D',p)"
  by blast

lemma dense_below_cong': "p\<in>P \<Longrightarrow> \<lbrakk>\<And>x. x\<in>P \<Longrightarrow> Q(x) \<longleftrightarrow> Q'(x)\<rbrakk> \<Longrightarrow>
           dense_below({q\<in>P. Q(q)},p) \<longleftrightarrow> dense_below({q\<in>P. Q'(q)},p)"
  by blast

lemma dense_below_mono: "p\<in>P \<Longrightarrow> D \<subseteq> D' \<Longrightarrow> dense_below(D,p) \<Longrightarrow> dense_below(D',p)"
  by blast

lemma dense_below_under:
  assumes "dense_below(D,p)" "p\<in>P" "q\<in>P" "q\<preceq>p"
  shows "dense_below(D,q)"
  using assms leq_transD by blast

lemma ideal_dense_below:
  assumes "\<And>q. q\<in>P \<Longrightarrow> q\<preceq>p \<Longrightarrow> q\<in>D"
  shows "dense_below(D,p)"
  using assms leq_reflI by blast

lemma dense_below_dense_below:
  assumes "dense_below({q\<in>P. dense_below(D,q)},p)" "p\<in>P"
  shows "dense_below(D,p)"
  using assms leq_transD leq_reflI  by blast
    (* Long proof *)
    (*  unfolding dense_below_def
proof (intro ballI impI)
  fix r
  assume "r\<in>P" \<open>r\<preceq>p\<close>
  with assms
  obtain q where "q\<in>P" "q\<preceq>r" "dense_below(D,q)"
    using assms by auto
  moreover from this
  obtain d where "d\<in>P" "d\<preceq>q" "d\<in>D"
    using assms leq_preord unfolding preorder_on_def refl_def by blast
  moreover
  note \<open>r\<in>P\<close>
  ultimately
  show "\<exists>d\<in>D. d \<in> P \<and> d\<preceq> r"
    using leq_preord trans_onD unfolding preorder_on_def by blast
qed *)

definition
  antichain :: "i\<Rightarrow>o" where
  "antichain(A) \<equiv> A\<subseteq>P \<and> (\<forall>p\<in>A.\<forall>q\<in>A.(\<not>compat(p,q)))"

text\<open>A filter is an increasing set $G$ with all its elements
being compatible in $G$.\<close>
definition
  filter :: "i\<Rightarrow>o" where
  "filter(G) \<equiv> G\<subseteq>P \<and> increasing(G) \<and> (\<forall>p\<in>G. \<forall>q\<in>G. compat_in(G,leq,p,q))"

lemma filterD : "filter(G) \<Longrightarrow> x \<in> G \<Longrightarrow> x \<in> P"
  by (auto simp add : subsetD filter_def)

lemma filter_leqD : "filter(G) \<Longrightarrow> x \<in> G \<Longrightarrow> y \<in> P \<Longrightarrow> x\<preceq>y \<Longrightarrow> y \<in> G"
  by (simp add: filter_def increasing_def)

lemma filter_imp_compat: "filter(G) \<Longrightarrow> p\<in>G \<Longrightarrow> q\<in>G \<Longrightarrow> compat(p,q)"
  unfolding filter_def compat_in_def compat_def by blast

lemma low_bound_filter: \<comment> \<open>says the compatibility is attained inside G\<close>
  assumes "filter(G)" and "p\<in>G" and "q\<in>G"
  shows "\<exists>r\<in>G. r\<preceq>p \<and> r\<preceq>q"
  using assms
  unfolding compat_in_def filter_def by blast

text\<open>We finally introduce the upward closure of a set
and prove that the closure of $A$ is a filter if its elements are
compatible in $A$.\<close>
definition
  upclosure :: "i\<Rightarrow>i" where
  "upclosure(A) \<equiv> {p\<in>P.\<exists>a\<in>A. a\<preceq>p}"

lemma  upclosureI [intro] : "p\<in>P \<Longrightarrow> a\<in>A \<Longrightarrow> a\<preceq>p \<Longrightarrow> p\<in>upclosure(A)"
  by (simp add:upclosure_def, auto)

lemma  upclosureE [elim] :
  "p\<in>upclosure(A) \<Longrightarrow> (\<And>x a. x\<in>P \<Longrightarrow> a\<in>A \<Longrightarrow> a\<preceq>x \<Longrightarrow> R) \<Longrightarrow> R"
  by (auto simp add:upclosure_def)

lemma  upclosureD [dest] :
  "p\<in>upclosure(A) \<Longrightarrow> \<exists>a\<in>A.(a\<preceq>p) \<and> p\<in>P"
  by (simp add:upclosure_def)

lemma upclosure_increasing :
  assumes "A\<subseteq>P"
  shows "increasing(upclosure(A))"
  unfolding increasing_def upclosure_def
  using leq_transD'[OF \<open>A\<subseteq>P\<close>] by auto

lemma  upclosure_in_P: "A \<subseteq> P \<Longrightarrow> upclosure(A) \<subseteq> P"
  using subsetI upclosure_def by simp

lemma  A_sub_upclosure: "A \<subseteq> P \<Longrightarrow> A\<subseteq>upclosure(A)"
  using subsetI leq_preord
  unfolding upclosure_def preorder_on_def refl_def by auto

lemma  elem_upclosure: "A\<subseteq>P \<Longrightarrow> x\<in>A  \<Longrightarrow> x\<in>upclosure(A)"
  by (blast dest:A_sub_upclosure)

lemma  closure_compat_filter:
  assumes "A\<subseteq>P" "(\<forall>p\<in>A.\<forall>q\<in>A. compat_in(A,leq,p,q))"
  shows "filter(upclosure(A))"
  unfolding filter_def
proof(auto)
  show "increasing(upclosure(A))"
    using assms upclosure_increasing by simp
next
  let ?UA="upclosure(A)"
  show "compat_in(upclosure(A), leq, p, q)" if "p\<in>?UA" "q\<in>?UA" for p q
  proof -
    from that
    obtain a b where 1:"a\<in>A" "b\<in>A" "a\<preceq>p" "b\<preceq>q" "p\<in>P" "q\<in>P"
      using upclosureD[OF \<open>p\<in>?UA\<close>] upclosureD[OF \<open>q\<in>?UA\<close>] by auto
    with assms(2)
    obtain d where "d\<in>A" "d\<preceq>a" "d\<preceq>b"
      unfolding compat_in_def by auto
    with 1
    have 2:"d\<preceq>p" "d\<preceq>q" "d\<in>?UA"
      using A_sub_upclosure[THEN subsetD] \<open>A\<subseteq>P\<close>
        leq_transD'[of A d a] leq_transD'[of A d b] by auto
    then
    show ?thesis unfolding compat_in_def by auto
  qed
qed

lemma  aux_RS1:  "f \<in> N \<rightarrow> P \<Longrightarrow> n\<in>N \<Longrightarrow> f`n \<in> upclosure(f ``N)"
  using elem_upclosure[OF subset_fun_image] image_fun
  by (simp, blast)

lemma decr_succ_decr:
  assumes "f \<in> nat \<rightarrow> P" "preorder_on(P,leq)"
    "\<forall>n\<in>nat.  \<langle>f ` succ(n), f ` n\<rangle> \<in> leq"
    "m\<in>nat"
  shows "n\<in>nat \<Longrightarrow> n\<le>m \<Longrightarrow> \<langle>f ` m, f ` n\<rangle> \<in> leq"
  using \<open>m\<in>_\<close>
proof(induct m)
  case 0
  then show ?case using assms leq_reflI by simp
next
  case (succ x)
  then
  have 1:"f`succ(x) \<preceq> f`x" "f`n\<in>P" "f`x\<in>P" "f`succ(x)\<in>P"
    using assms by simp_all
  consider (lt) "n<succ(x)" | (eq) "n=succ(x)"
    using succ le_succ_iff by auto
  then
  show ?case
  proof(cases)
    case lt
    with 1 show ?thesis using leI succ leq_transD by auto
  next
    case eq
    with 1 show ?thesis using leq_reflI by simp
  qed
qed

lemma decr_seq_linear:
  assumes "refl(P,leq)" "f \<in> nat \<rightarrow> P"
    "\<forall>n\<in>nat.  \<langle>f ` succ(n), f ` n\<rangle> \<in> leq"
    "trans[P](leq)"
  shows "linear(f `` nat, leq)"
proof -
  have "preorder_on(P,leq)"
    unfolding preorder_on_def using assms by simp
  {
    fix n m
    assume "n\<in>nat" "m\<in>nat"
    then
    have "f`m \<preceq> f`n \<or> f`n \<preceq> f`m"
    proof(cases "m\<le>n")
      case True
      with \<open>n\<in>_\<close> \<open>m\<in>_\<close>
      show ?thesis
        using decr_succ_decr[of f n m] assms leI \<open>preorder_on(P,leq)\<close> by simp
    next
      case False
      with \<open>n\<in>_\<close> \<open>m\<in>_\<close>
      show ?thesis
        using decr_succ_decr[of f m n] assms leI not_le_iff_lt \<open>preorder_on(P,leq)\<close> by simp
    qed
  }
  then
  show ?thesis
    unfolding linear_def using ball_image_simp assms by auto
qed

end (* forcing_notion *)

subsection\<open>Towards Rasiowa-Sikorski Lemma (RSL)\<close>
locale countable_generic = forcing_notion +
  fixes \<D>
  assumes countable_subs_of_P:  "\<D> \<in> nat\<rightarrow>Pow(P)"
    and     seq_of_denses:        "\<forall>n \<in> nat. dense(\<D>`n)"

begin

definition
  D_generic :: "i\<Rightarrow>o" where
  "D_generic(G) \<equiv> filter(G) \<and> (\<forall>n\<in>nat.(\<D>`n)\<inter>G\<noteq>0)"

text\<open>The next lemma identifies a sufficient condition for obtaining
RSL.\<close>
lemma RS_sequence_imp_rasiowa_sikorski:
  assumes
    "p\<in>P" "f : nat\<rightarrow>P" "f ` 0 = p"
    "\<And>n. n\<in>nat \<Longrightarrow> f ` succ(n)\<preceq> f ` n \<and> f ` succ(n) \<in> \<D> ` n"
  shows
    "\<exists>G. p\<in>G \<and> D_generic(G)"
proof -
  note assms
  moreover from this
  have "f``nat  \<subseteq> P"
    by (simp add:subset_fun_image)
  moreover from calculation
  have "refl(f``nat, leq) \<and> trans[P](leq)"
    using leq_preord unfolding preorder_on_def by (blast intro:refl_monot_domain)
  moreover from calculation
  have "\<forall>n\<in>nat.  f ` succ(n)\<preceq> f ` n" by (simp)
  moreover from calculation
  have "linear(f``nat, leq)"
    using leq_preord and decr_seq_linear unfolding preorder_on_def by (blast)
  moreover from calculation
  have "(\<forall>p\<in>f``nat.\<forall>q\<in>f``nat. compat_in(f``nat,leq,p,q))"
    using chain_compat by (auto)
  ultimately
  have "filter(upclosure(f``nat))" (is "filter(?G)")
    using closure_compat_filter by simp
  moreover
  have "\<forall>n\<in>nat. \<D> ` n \<inter> ?G \<noteq> 0"
  proof
    fix n
    assume "n\<in>nat"
    with assms
    have "f`succ(n) \<in> ?G \<and> f`succ(n) \<in> \<D> ` n"
      using aux_RS1 by simp
    then
    show "\<D> ` n \<inter> ?G \<noteq> 0"  by blast
  qed
  moreover from assms
  have "p \<in> ?G"
    using aux_RS1 by auto
  ultimately
  show ?thesis unfolding D_generic_def by auto
qed

end (* countable_generic *)

text\<open>Now, the following recursive definition will fulfill the
requirements of lemma \<^term>\<open>RS_sequence_imp_rasiowa_sikorski\<close> \<close>

consts RS_seq :: "[i,i,i,i,i,i] \<Rightarrow> i"
primrec
  "RS_seq(0,P,leq,p,enum,\<D>) = p"
  "RS_seq(succ(n),P,leq,p,enum,\<D>) =
    enum`(\<mu> m. \<langle>enum`m, RS_seq(n,P,leq,p,enum,\<D>)\<rangle> \<in> leq \<and> enum`m \<in> \<D> ` n)"

context countable_generic
begin

lemma preimage_rangeD:
  assumes "f\<in>Pi(A,B)" "b \<in> range(f)"
  shows "\<exists>a\<in>A. f`a = b"
  using assms apply_equality[OF _ assms(1), of _ b] domain_type[OF _ assms(1)] by auto

lemma countable_RS_sequence_aux:
  fixes p enum
  defines "f(n) \<equiv> RS_seq(n,P,leq,p,enum,\<D>)"
    and   "Q(q,k,m) \<equiv> enum`m\<preceq> q \<and> enum`m \<in> \<D> ` k"
  assumes "n\<in>nat" "p\<in>P" "P \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
    "\<And>x k. x\<in>P \<Longrightarrow> k\<in>nat \<Longrightarrow>  \<exists>q\<in>P. q\<preceq> x \<and> q \<in> \<D> ` k"
  shows
    "f(succ(n)) \<in> P \<and> f(succ(n))\<preceq> f(n) \<and> f(succ(n)) \<in> \<D> ` n"
  using \<open>n\<in>nat\<close>
proof (induct)
  case 0
  from assms
  obtain q where "q\<in>P" "q\<preceq> p" "q \<in> \<D> ` 0" by blast
  moreover from this and \<open>P \<subseteq> range(enum)\<close>
  obtain m where "m\<in>nat" "enum`m = q"
    using preimage_rangeD[OF \<open>enum:nat\<rightarrow>M\<close>] by blast
  moreover
  have "\<D>`0 \<subseteq> P"
    using apply_funtype[OF countable_subs_of_P] by simp
  moreover note \<open>p\<in>P\<close>
  ultimately
  show ?case
    using LeastI[of "Q(p,0)" m] unfolding Q_def f_def by auto
next
  case (succ n)
  with assms
  obtain q where "q\<in>P" "q\<preceq> f(succ(n))" "q \<in> \<D> ` succ(n)" by blast
  moreover from this and \<open>P \<subseteq> range(enum)\<close>
  obtain m where "m\<in>nat" "enum`m\<preceq> f(succ(n))" "enum`m \<in> \<D> ` succ(n)"
    using preimage_rangeD[OF \<open>enum:nat\<rightarrow>M\<close>] by blast
  moreover note succ
  moreover from calculation
  have "\<D>`succ(n) \<subseteq> P"
    using apply_funtype[OF countable_subs_of_P] by auto
  ultimately
  show ?case
    using LeastI[of "Q(f(succ(n)),succ(n))" m] unfolding Q_def f_def by auto
qed

lemma countable_RS_sequence:
  fixes p enum
  defines "f \<equiv> \<lambda>n\<in>nat. RS_seq(n,P,leq,p,enum,\<D>)"
    and   "Q(q,k,m) \<equiv> enum`m\<preceq> q \<and> enum`m \<in> \<D> ` k"
  assumes "n\<in>nat" "p\<in>P" "P \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows
    "f`0 = p" "f`succ(n)\<preceq> f`n \<and> f`succ(n) \<in> \<D> ` n" "f`succ(n) \<in> P"
proof -
  from assms
  show "f`0 = p" by simp
  {
    fix x k
    assume "x\<in>P" "k\<in>nat"
    then
    have "\<exists>q\<in>P. q\<preceq> x \<and> q \<in> \<D> ` k"
      using seq_of_denses apply_funtype[OF countable_subs_of_P]
      unfolding dense_def by blast
  }
  with assms
  show "f`succ(n)\<preceq> f`n \<and> f`succ(n) \<in> \<D> ` n" "f`succ(n)\<in>P"
    unfolding f_def using countable_RS_sequence_aux by simp_all
qed

lemma RS_seq_type:
  assumes "n \<in> nat" "p\<in>P" "P \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows "RS_seq(n,P,leq,p,enum,\<D>) \<in> P"
  using assms countable_RS_sequence(1,3)
  by (induct;simp)

lemma RS_seq_funtype:
  assumes "p\<in>P" "P \<subseteq> range(enum)" "enum:nat\<rightarrow>M"
  shows "(\<lambda>n\<in>nat. RS_seq(n,P,leq,p,enum,\<D>)): nat \<rightarrow> P"
  using assms lam_type RS_seq_type by auto

lemmas countable_rasiowa_sikorski =
  RS_sequence_imp_rasiowa_sikorski[OF _ RS_seq_funtype countable_RS_sequence(1,2)]
end (* countable_generic *)

end


theory T39
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory Renegar_Algorithm
  imports  BKR_Algorithm
begin

(* There is significant overlap between Renegar's algorithm and BKR's.
  However, the RHS vector is constructed differently in Renegar. The base case is also different.
  In general, the _R's on definition and lemma names in this file are to emphasize that we are
  working with Renegar style.
*)

definition construct_NofI_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> real poly list \<Rightarrow> rat"
  where "construct_NofI_R p I1 I2 = (
    let new_p = sum_list (map (\<lambda>x. x^2) (p # I1)) in
    rat_of_int (changes_R_smods new_p ((pderiv new_p)*(prod_list I2))))"

(* Renegar's RHS vector will have type (nat list * nat list) list.
   Note the change from BKR, where the RHS vector had type nat list list*)
definition construct_rhs_vector_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> rat vec"
  where "construct_rhs_vector_R p qs Is =
  vec_of_list (map (\<lambda>(I1,I2).
    (construct_NofI_R p (retrieve_polys qs I1) (retrieve_polys qs I2))) Is)"

section "Base Case"

(* Renegar's matrix is 3x3 instead of 2x2 *)
definition base_case_info_R:: "(rat mat \<times> ((nat list * nat list) list \<times> rat list list))"
  where "base_case_info_R =
    ((mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]),([([], []),([0], []),([], [0])], [[1],[0],[-1]]))"

(* When p, q are coprime, this will actually be an int vec, which is why taking the floor is okay *)
definition base_case_solve_for_lhs:: "real poly \<Rightarrow> real poly \<Rightarrow> rat vec"
  where "base_case_solve_for_lhs p q = (mult_mat_vec (mat_of_rows_list 3 [[1/2, -1/2, 1/2], [0, 1, 0], [1/2, -1/2, -1/2]])  (construct_rhs_vector_R p [q] [([], []),([0], []),([], [0])]))"

(* Solve for LHS in general: mat_inverse returns an option type, and we pattern match on this.
  Notice that when we call this function in the algorithm, the matrix we pass will always be invertible,
  given how the construction works. *)
definition solve_for_lhs_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> rat mat \<Rightarrow> rat vec"
  where "solve_for_lhs_R p qs subsets matr =
     mult_mat_vec (matr_option (dim_row matr) (mat_inverse_var matr))  (construct_rhs_vector_R p qs subsets)"

section "Smashing"

definition subsets_smash_R::"nat \<Rightarrow> (nat list*nat list) list \<Rightarrow> (nat list*nat list) list \<Rightarrow> (nat list*nat list) list"
  where "subsets_smash_R n s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. (((fst l1) @ (map ((+) n) (fst l2))), (snd l1) @ (map ((+) n) (snd l2)))) s2) s1)"

definition smash_systems_R:: "('a::zero) poly \<Rightarrow> ('a::zero) poly list \<Rightarrow> ('a::zero) poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> (nat list * nat list) list \<Rightarrow>
  rat list list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> rat mat \<Rightarrow>
  ('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list))"
  where "smash_systems_R p qs1 qs2 subsets1 subsets2 signs1 signs2 mat1 mat2 =
    (qs1@qs2, (kronecker_product mat1 mat2, (subsets_smash_R (length qs1) subsets1 subsets2, signs_smash signs1 signs2)))"

fun combine_systems_R:: "('a::zero) poly \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list))) \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list)))
  \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list)))"
  where "combine_systems_R p (qs1, m1, sub1, sgn1) (qs2, m2, sub2, sgn2) =
    (smash_systems_R p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2)"

(* Overall:
  Start with a matrix equation.
  Input a matrix, subsets, and signs.
  Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
  Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
   and delete those rows.  Reduce subsets accordingly.
  End with a reduced system! *)
section "Reduction"

fun reduction_step_R:: "rat mat \<Rightarrow> rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat vec \<Rightarrow> rat mat \<times> ((nat list*nat list) list \<times> rat list list)"
  where "reduction_step_R A signs subsets lhs_vec =
    (let reduce_cols_A = (reduce_mat_cols A lhs_vec);
         rows_keep = rows_to_keep reduce_cols_A in
    (take_rows_from_matrix  reduce_cols_A rows_keep,
      (take_indices subsets rows_keep,
      take_indices signs (find_nonzeros_from_input_vec lhs_vec))))"

fun reduce_system_R:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> ((nat list*nat list) list \<times> rat list list))) \<Rightarrow> (rat mat \<times> ((nat list*nat list) list \<times> rat list list))"
  where "reduce_system_R p (qs,m,subs,signs) =
    reduction_step_R m signs subs (solve_for_lhs_R p qs subs m)"

section "Overall algorithm "
(* Find matrix, subsets, signs.
   The "rat mat" in the output is the matrix. The "(nat list*nat list) list" is the list of subsets.
   The "rat list list" is the list of signs.
*)
fun calculate_data_R:: "real poly \<Rightarrow> real poly list \<Rightarrow>  (rat mat \<times> ((nat list*nat list) list \<times> rat list list))"
  where
  "calculate_data_R p qs =
  ( let len = length qs in
    if len = 0 then
      (\<lambda>(a,b,c).(a,b,map (drop 1) c)) (reduce_system_R p ([1],base_case_info_R))
    else if len \<le> 1 then reduce_system_R p (qs,base_case_info_R)
    else
    (let q1 = take (len div 2) qs; left = calculate_data_R p q1;
         q2 = drop (len div 2) qs; right = calculate_data_R p q2;
         comb = combine_systems_R p (q1,left) (q2,right) in
         reduce_system_R p comb
    )
  )"

(* Extract the list of consistent sign assignments *)
definition find_consistent_signs_at_roots_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where [code]:
  "find_consistent_signs_at_roots_R p qs =
  ( let (M,S,\<Sigma>) = calculate_data_R p qs in \<Sigma> )"

lemma find_consistent_signs_at_roots_thm_R:
  shows "find_consistent_signs_at_roots_R p qs = snd (snd (calculate_data_R p qs))"
  by (simp add: case_prod_beta find_consistent_signs_at_roots_R_def)

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)

theory Myhill
  imports Myhill_2 "Regular-Sets.Derivatives"
begin

section \<open>The theorem\<close>

theorem Myhill_Nerode:
  fixes A::"('a::finite) lang"
  shows "(\<exists>r. A = lang r) \<longleftrightarrow> finite (UNIV // \<approx>A)"
using Myhill_Nerode1 Myhill_Nerode2 by auto

subsection \<open>Second direction proved using partial derivatives\<close>

text \<open>
  An alternaive proof using the notion of partial derivatives for regular
  expressions due to Antimirov \cite{Antimirov95}.
\<close>

lemma MN_Rel_Derivs:
  shows "x \<approx>A y \<longleftrightarrow> Derivs x A = Derivs y A"
unfolding Derivs_def str_eq_def
by auto

lemma Myhill_Nerode3:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
proof -
  have "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
  proof -
    have "range (\<lambda>x. pderivs x r) \<subseteq> Pow (pderivs_lang UNIV r)"
      unfolding pderivs_lang_def by auto
    moreover
    have "finite (Pow (pderivs_lang UNIV r))" by (simp add: finite_pderivs_lang)
    ultimately
    have "finite (range (\<lambda>x. pderivs x r))"
      by (simp add: finite_subset)
    then show "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
      by (rule finite_eq_tag_rel)
  qed
  moreover
  have "=(\<lambda>x. pderivs x r)= \<subseteq> \<approx>(lang r)"
    unfolding tag_eq_def
    by (auto simp add: MN_Rel_Derivs Derivs_pderivs)
  moreover
  have "equiv UNIV =(\<lambda>x. pderivs x r)="
  and  "equiv UNIV (\<approx>(lang r))"
    unfolding equiv_def refl_on_def sym_def trans_def
    unfolding tag_eq_def str_eq_def
    by auto
  ultimately show "finite (UNIV // \<approx>(lang r))"
    by (rule refined_partition_finite)
qed

end