(*
This theory is not used currently. I fear this is also the missing polynomial triangular root.
As this was implemented again now in Primitives, I suggest deprecating this file.

*)

theory Prod_Poly
  imports "HOL-Library.Nat_Bijection" "Recursion-Theory-I.CPair"
begin
(*

Commented out to avoid errors in proofs

fun mult_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"mult_acc acc c  b  = (if b = 0 then acc else if b mod 2 = 0 then
 mult_acc acc (c*2) (b div 2) else mult_acc (acc+c) (c*2) (b div 2)
 )"

lemma mult_acc_correct:"mult_acc acc c b = acc + c*b"
  apply(induct acc c b  rule:mult_acc.induct)
  apply auto
  by (metis
One_nat_def mod_mult_div_eq mult.assoc
mult_Suc_right plus_1_eq_Suc)

definition mult:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"mult a b = mult_acc 0 a b"

lemma mult_correct: "mult a b = a * b"
  using mult_def mult_acc_correct by auto

definition triangle' :: "nat \<Rightarrow> nat" where
"triangle' n = mult n (Suc n) div 2"

lemma sub_triangle : "triangle' n = triangle n"
  using triangle_def triangle'_def mult_correct by auto

definition pair :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"pair a b = triangle' (a+b) + a"

lemma sub_pair:"pair a b = prod_encode (a,b)"
  using pair_def  sub_triangle
  by (simp add: prod_encode_def)

lemma triangle_sf:"triangle x = sf x "
  by (simp add: sf_def triangle_def)

lemma  "prod_encode(a,b) = c_pair a b"
  by (auto simp add:  c_pair_def prod_encode_def triangle_sf)

lemma prod_c_pair: "prod_decode n = (c_fst n , c_snd n)"
  by (metis (no_types) c_fst_le_c_sum c_snd_def prod_decode_aux.simps prod_encode_inverse
prod_encode_prod_decode_aux sf_c_sum_plus_c_fst triangle_sf)

function find_triangle_search :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"find_triangle_search  a b n = (let m = ((a+b) div 2); t = triangle' m  in
if b\<le>a  then a else if n-t \<le> m then find_triangle_search a m n else find_triangle_search (m+1) b n
)"
  by pat_completeness auto
termination by (relation "measure (\<lambda>(a,b,n).b-a)") (auto simp add: sub_triangle)

lemma mean_in_the_interval:"\<not> b \<le> a \<Longrightarrow> ((a::nat) + b ) div 2 \<ge> a \<and> b \<ge> Suc ((a::nat) + b ) div 2 "
  by auto
lemma "\<not> b \<le> a \<Longrightarrow> b = Suc ((a + b) div 2) \<Longrightarrow> b = a \<or> b = Suc a \<or> b = Suc(Suc a)"
  apply auto
  done

lemma find_triangle_search_inv:"\<lbrakk> a \<le> c_sum n ; c_sum n \<le> b\<rbrakk> \<Longrightarrow> find_triangle_search a b n = c_sum n "
  apply(induct a b n rule:find_triangle_search.induct)
  apply(subst find_triangle_search.simps)
  apply (auto simp add: Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps c_sum_def)
   apply(subst find_triangle_search.simps)
   apply (auto simp add:   Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps c_sum_def)
proof  (goal_cases)
  case (1 a b n)
  have "a = (a + b) div 2" using mean_in_the_interval 1(6) 1(8) by auto
  hence "b = Suc a" using 1(6) by force
  thus ?case using 1
    by (smt le_add_diff_inverse le_trans nat_less_le not_less sf_aux2 sf_c_sum_le_arg sf_mono)
next
  case (2 a b n)
  then have "c_sum n \<le> (a+b) div 2 "
    by (metis arg_less_sf_imp_c_sum_less_arg
le_add_diff_inverse not_less order_less_imp_le sf_aux2)
  moreover have "find_triangle_search a ((a + b) div 2) n = find_triangle_search a ((a + (a + b) div 2) div 2) n"
    using 2 apply(subst find_triangle_search.simps)
    by (auto simp add: Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps)
  ultimately show  ?case using 2(1) by auto
next
  case (3 a b n)
 have "a = (a + b) div 2" using mean_in_the_interval 3(6) 3(8) by auto
  hence "b = Suc a" using 3(6) by force
  thus ?case using 3
    by (smt le_add_diff_inverse le_trans nat_less_le not_less sf_aux2 sf_c_sum_le_arg sf_mono)
next
  case (4 a b n)
   then have "c_sum n \<le> (a+b) div 2 "
    by (metis arg_less_sf_imp_c_sum_less_arg
le_add_diff_inverse not_less order_less_imp_le sf_aux2)
  moreover have "find_triangle_search a ((a + b) div 2) n = find_triangle_search (Suc ((a + (a + b) div 2) div 2)) ((a + b) div 2) n"
    using 4 apply(subst find_triangle_search.simps)
    by (auto simp add: Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps)
  ultimately show  ?case using 4(1) by auto
next
  case (5 a b n)
  then show ?case
    apply(subst find_triangle_search.simps)
    apply (auto simp add:   Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps c_sum_def)
  proof (goal_cases)
case 1
  have "b = Suc ((a + b) div 2)" using mean_in_the_interval 1(6) 1(8) by auto
  moreover then have  " b = a \<or> b = Suc a \<or> b = Suc(Suc a)" using 1(6)  by auto
  ultimately show ?case using 1
    by (smt add_diff_cancel_left' c_sum_is_sum le_SucE le_add1 le_add_same_cancel1 linorder_not_less
 nat_less_le sf_aux2 sf_c_sum_plus_c_fst zero_less_diff)
next
  case 2
   then have " Suc ((a + b) div 2) \<le> c_sum n"
     by (smt Suc_leI add_diff_cancel_left' c_sum_is_sum le_add1 le_add_same_cancel1 le_trans
 linorder_not_less nat_less_le sf_aux2 sf_c_sum_plus_c_fst zero_less_diff)
  moreover have "find_triangle_search (Suc ((a + b) div 2)) b n  = find_triangle_search (Suc ((a + b) div 2)) (Suc ((a + b) div 2 + b) div 2) n"
    using 2 apply(subst find_triangle_search.simps)
    by (auto simp add: Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps)
  ultimately show  ?case using 2(2) by auto
next
  case 3
  have "b = Suc ((a + b) div 2)" using mean_in_the_interval 3(6) 3(8) by auto
  moreover then have  " b = a \<or> b = Suc a \<or> b = Suc(Suc a)" using 3(6)  by auto
  ultimately show ?case using 3
    by (smt add_diff_cancel_left' c_sum_is_sum le_SucE le_add1 le_add_same_cancel1 linorder_not_less
 nat_less_le sf_aux2 sf_c_sum_plus_c_fst zero_less_diff)
next
  case 4
   then have " Suc ((a + b) div 2) \<le> c_sum n"
     by (smt Suc_leI add_diff_cancel_left' c_sum_is_sum le_add1 le_add_same_cancel1 le_trans
 linorder_not_less nat_less_le sf_aux2 sf_c_sum_plus_c_fst zero_less_diff)
  moreover have "find_triangle_search (Suc ((a + b) div 2)) b n = find_triangle_search (Suc (Suc ((a + b) div 2 + b) div 2)) b n"
    using 4 apply(subst find_triangle_search.simps)
    by (auto simp add: Let_def sub_triangle triangle_sf simp del: find_triangle_search.simps)
  ultimately show  ?case using 4(2) by auto
qed

qed

definition find_triangle :: "nat \<Rightarrow> nat" where
"find_triangle n = find_triangle_search 0 n n"

lemma sub_find_triangle: "find_triangle n = c_sum n"
  apply(auto simp add: find_triangle_def  simp del: find_triangle_search.simps)
  using find_triangle_search_inv[of 0 n n]
  using c_sum_le_arg by blast

definition fst_nat' :: "nat \<Rightarrow> nat" where
"fst_nat' n = n - triangle' (find_triangle n)"

lemma fst_nat'_correct:"fst_nat' n = c_fst n"
  by(auto simp add: fst_nat'_def c_fst_def sub_triangle triangle_sf sub_find_triangle)

lemma sub_fst':
"fst_nat' n  = fst (prod_decode n)"
  using prod_c_pair fst_nat'_correct by simp

definition snd_nat' :: "nat \<Rightarrow> nat" where
"snd_nat' n = find_triangle n - fst_nat' n"

lemma snd_nat'_correct:"snd_nat' n = c_snd n"
  by(auto simp add: snd_nat'_def c_snd_def sub_triangle triangle_sf sub_find_triangle fst_nat'_correct)

lemma sub_snd':
"snd_nat' n  = snd (prod_decode n)"
  using prod_c_pair snd_nat'_correct  by simp
 *)
end


(*  Title:      HOL/HOLCF/Sprod.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of strict products\<close>

theory Sprod
imports Cfun
begin

default_sort pcpo

subsection \<open>Definition of strict product type\<close>

definition "sprod = {p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"

pcpodef ('a, 'b) sprod  ("(_ \<otimes>/ _)" [21,20] 20) = "sprod :: ('a \<times> 'b) set"
  unfolding sprod_def by simp_all

instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])

type_notation (ASCII)
  sprod  (infixr "**" 20)

subsection \<open>Definitions of constants\<close>

definition
  sfst :: "('a ** 'b) \<rightarrow> 'a" where
  "sfst = (\<Lambda> p. fst (Rep_sprod p))"

definition
  ssnd :: "('a ** 'b) \<rightarrow> 'b" where
  "ssnd = (\<Lambda> p. snd (Rep_sprod p))"

definition
  spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
  "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"

definition
  ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
  "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"

syntax
  "_stuple" :: "[logic, args] \<Rightarrow> logic"  ("(1'(:_,/ _:'))")

translations
  "(:x, y, z:)" == "(:x, (:y, z:):)"
  "(:x, y:)"    == "CONST spair\<cdot>x\<cdot>y"

translations
  "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"

subsection \<open>Case analysis\<close>

lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
by (simp add: sprod_def seq_conv_if)

lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)

lemmas Rep_sprod_simps =
  Rep_sprod_inject [symmetric] below_sprod_def
  prod_eq_iff below_prod_def
  Rep_sprod_strict Rep_sprod_spair

lemma sprodE [case_names bottom spair, cases type: sprod]:
  obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)

lemma sprod_induct [case_names bottom spair, induct type: sprod]:
  "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)

subsection \<open>Properties of \emph{spair}\<close>

lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
by (simp add: Rep_sprod_simps)

lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
by (simp add: Rep_sprod_simps)

lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_below_iff:
  "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_eq_iff:
  "((:a, b:) = (:c, d:)) =
    (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
by simp

lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
by simp

lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
by simp

lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
by simp

lemma spair_below:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
by (simp add: spair_below_iff)

lemma spair_eq:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
by (simp add: spair_eq_iff)

lemma spair_inject:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
by (rule spair_eq [THEN iffD1])

lemma inst_sprod_pcpo2: "\<bottom> = (:\<bottom>, \<bottom>:)"
by simp

lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
by (cases p, simp only: inst_sprod_pcpo2, simp)

subsection \<open>Properties of \emph{sfst} and \emph{ssnd}\<close>

lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)

lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)

lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)

lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)

lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
by (cases p, simp_all)

lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
by (cases p, simp_all)

lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
by simp

lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
by simp

lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
by (cases p, simp_all)

lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)

lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
by (auto simp add: po_eq_conv below_sprod)

lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
apply (simp add: below_sprod)
done

lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
apply (simp add: below_sprod)
done

subsection \<open>Compactness\<close>

lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
by (rule compactI, simp add: sfst_below_iff)

lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
by (rule compactI, simp add: ssnd_below_iff)

lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)

lemma compact_spair_iff:
  "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
apply (safe elim!: compact_spair)
apply (drule compact_sfst, simp)
apply (drule compact_ssnd, simp)
apply simp
apply simp
done

subsection \<open>Properties of \emph{ssplit}\<close>

lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (simp add: ssplit_def)

lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
by (simp add: ssplit_def)

lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
by (cases z, simp_all)

subsection \<open>Strict product preserves flatness\<close>

instance sprod :: (flat, flat) flat
proof
  fix x y :: "'a \<otimes> 'b"
  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
    apply (induct x, simp)
    apply (induct y, simp)
    apply (simp add: spair_below_iff flat_below_iff)
    done
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

chapter "List Manipulation Functions"

theory List_Lib
imports Main
begin

definition list_replace :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_replace list a b \<equiv> map (\<lambda>x. if x = a then b else x) list"

primrec list_replace_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_replace_list [] a list' = []" |
  "list_replace_list (x # xs) a list' = (if x = a then list' @ xs
                           else x # list_replace_list xs a list')"

definition list_swap :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_swap list a b \<equiv> map (\<lambda>x. if x = a then b else if x = b then a else x) list"

primrec list_insert_after :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_insert_after [] a b = []" |
  "list_insert_after (x # xs) a b = (if x = a then x # b # xs
                                     else x # list_insert_after xs a b)"

primrec list_remove :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_remove [] a = []" |
  "list_remove (x # xs) a = (if x = a then (list_remove xs a)
                             else x # (list_remove xs a))"

fun after_in_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a option" where
  "after_in_list [] a = None" |
  "after_in_list [x] a = None" |
  "after_in_list (x # y # xs) a = (if a = x then Some y else after_in_list (y # xs) a)"

lemma zip_take1:
  "zip (take n xs) ys = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemma zip_take2:
  "zip xs (take n ys) = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemmas zip_take = zip_take1 zip_take2

lemma replicate_append: "replicate n x @ (x # xs) = replicate (n + 1) x @ xs"
  by (induct n, simp+)

end


(*  Title:      HOL/Typedef.thy
    Author:     Markus Wenzel, TU Munich
*)

section \<open>HOL type definitions\<close>

theory Typedef
imports Set
keywords
  "typedef" :: thy_goal and
  "morphisms" :: quasi_command
begin

locale type_definition =
  fixes Rep and Abs and A
  assumes Rep: "Rep x \<in> A"
    and Rep_inverse: "Abs (Rep x) = x"
    and Abs_inverse: "y \<in> A \<Longrightarrow> Rep (Abs y) = y"
  \<comment> \<open>This will be axiomatized for each typedef!\<close>
begin

lemma Rep_inject: "Rep x = Rep y \<longleftrightarrow> x = y"
proof
  assume "Rep x = Rep y"
  then have "Abs (Rep x) = Abs (Rep y)" by (simp only:)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  moreover have "Abs (Rep y) = y" by (rule Rep_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  then show "Rep x = Rep y" by (simp only:)
qed

lemma Abs_inject:
  assumes "x \<in> A" and "y \<in> A"
  shows "Abs x = Abs y \<longleftrightarrow> x = y"
proof
  assume "Abs x = Abs y"
  then have "Rep (Abs x) = Rep (Abs y)" by (simp only:)
  moreover from \<open>x \<in> A\<close> have "Rep (Abs x) = x" by (rule Abs_inverse)
  moreover from \<open>y \<in> A\<close> have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  then show "Abs x = Abs y" by (simp only:)
qed

lemma Rep_cases [cases set]:
  assumes "y \<in> A"
    and hyp: "\<And>x. y = Rep x \<Longrightarrow> P"
  shows P
proof (rule hyp)
  from \<open>y \<in> A\<close> have "Rep (Abs y) = y" by (rule Abs_inverse)
  then show "y = Rep (Abs y)" ..
qed

lemma Abs_cases [cases type]:
  assumes r: "\<And>y. x = Abs y \<Longrightarrow> y \<in> A \<Longrightarrow> P"
  shows P
proof (rule r)
  have "Abs (Rep x) = x" by (rule Rep_inverse)
  then show "x = Abs (Rep x)" ..
  show "Rep x \<in> A" by (rule Rep)
qed

lemma Rep_induct [induct set]:
  assumes y: "y \<in> A"
    and hyp: "\<And>x. P (Rep x)"
  shows "P y"
proof -
  have "P (Rep (Abs y))" by (rule hyp)
  moreover from y have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "P y" by simp
qed

lemma Abs_induct [induct type]:
  assumes r: "\<And>y. y \<in> A \<Longrightarrow> P (Abs y)"
  shows "P x"
proof -
  have "Rep x \<in> A" by (rule Rep)
  then have "P (Abs (Rep x))" by (rule r)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  ultimately show "P x" by simp
qed

lemma Rep_range: "range Rep = A"
proof
  show "range Rep \<subseteq> A" using Rep by (auto simp add: image_def)
  show "A \<subseteq> range Rep"
  proof
    fix x assume "x \<in> A"
    then have "x = Rep (Abs x)" by (rule Abs_inverse [symmetric])
    then show "x \<in> range Rep" by (rule range_eqI)
  qed
qed

lemma Abs_image: "Abs ` A = UNIV"
proof
  show "Abs ` A \<subseteq> UNIV" by (rule subset_UNIV)
  show "UNIV \<subseteq> Abs ` A"
  proof
    fix x
    have "x = Abs (Rep x)" by (rule Rep_inverse [symmetric])
    moreover have "Rep x \<in> A" by (rule Rep)
    ultimately show "x \<in> Abs ` A" by (rule image_eqI)
  qed
qed

end

ML_file "Tools/typedef.ML"

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Sim_Pres
  imports Weak_Sim
begin

lemma actPres:
  fixes P    :: ccs
  and   Q    :: ccs
  and   Rel  :: "(ccs \<times> ccs) set"
  and   a    :: name
  and   Rel' :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> Rel"

  shows "\<alpha>.(P) \<leadsto>\<^sup>^<Rel> \<alpha>.(Q)"
using assms
by(fastforce simp add: weakSimulation_def elim: actCases intro: weakAction)

lemma sumPres:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>\<^sup>^<Rel> Q"
  and     "Rel \<subseteq> Rel'"
  and     "Id \<subseteq> Rel'"
  and     C1: "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<oplus> U, T) \<in> Rel'"

  shows "P \<oplus> R \<leadsto>\<^sup>^<Rel'> Q \<oplus> R"
proof(induct rule: weakSimI)
  case(Sim \<alpha> QR)
  from \<open>Q \<oplus> R \<longmapsto>\<alpha> \<prec> QR\<close> show ?case
  proof(induct rule: sumCases)
    case(cSum1 Q')
    from \<open>P \<leadsto>\<^sup>^<Rel> Q\<close> \<open>Q \<longmapsto>\<alpha> \<prec> Q'\<close>
    obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(blast dest: weakSimE)
    thus ?case
    proof(induct rule: weakTransCases)
      case Base
      have "P \<oplus> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P \<oplus> R" by simp
      moreover from \<open>(P, Q') \<in> Rel\<close> have "(P \<oplus> R, Q') \<in> Rel'" by(rule C1)
      ultimately show ?case by blast
    next
      case Step
      from \<open>P \<Longrightarrow>\<alpha> \<prec> P'\<close> have "P \<oplus> R \<Longrightarrow>\<alpha> \<prec> P'" by(rule weakCongSum1)
      hence "P \<oplus> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" by(simp add: weakTrans_def)
      thus ?case using \<open>(P', Q') \<in> Rel\<close> \<open>Rel \<subseteq> Rel'\<close> by blast
    qed
  next
    case(cSum2 R')
    from \<open>R \<longmapsto>\<alpha> \<prec> R'\<close> have "R \<Longrightarrow>\<alpha> \<prec> R'" by(rule transitionWeakCongTransition)
    hence "P \<oplus> R \<Longrightarrow>\<alpha> \<prec> R'" by(rule weakCongSum2)
    hence "P \<oplus> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'" by(simp add: weakTrans_def)
    thus ?case using \<open>Id \<subseteq> Rel'\<close> by blast
  qed
qed

lemma parPresAux:
  fixes P     :: ccs
  and   Q     :: ccs
  and   R     :: ccs
  and   T     :: ccs
  and   Rel   :: "(ccs \<times> ccs) set"
  and   Rel'  :: "(ccs \<times> ccs) set"
  and   Rel'' :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>\<^sup>^<Rel> Q"
  and     "(P, Q) \<in> Rel"
  and     "R \<leadsto>\<^sup>^<Rel'> T"
  and     "(R, T) \<in> Rel'"
  and     C1: "\<And>P' Q' R' T'. \<lbrakk>(P', Q') \<in> Rel; (R', T') \<in> Rel'\<rbrakk> \<Longrightarrow> (P' \<parallel> R', Q' \<parallel> T') \<in> Rel''"

  shows "P \<parallel> R \<leadsto>\<^sup>^<Rel''> Q \<parallel> T"
proof(induct rule: weakSimI)
  case(Sim \<alpha> QT)
  from \<open>Q \<parallel> T \<longmapsto>\<alpha> \<prec> QT\<close>
  show ?case
  proof(induct rule: parCases)
    case(cPar1 Q')
    from \<open>P \<leadsto>\<^sup>^<Rel> Q\<close> \<open>Q \<longmapsto>\<alpha> \<prec> Q'\<close> obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule weakSimE)
    from \<open>P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'\<close> have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<parallel> R" by(rule weakPar1)
    moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R, T) \<in> Rel'\<close> have "(P' \<parallel> R, Q' \<parallel> T) \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cPar2 T')
    from \<open>R \<leadsto>\<^sup>^<Rel'> T\<close> \<open>T \<longmapsto>\<alpha> \<prec> T'\<close> obtain R' where "R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule weakSimE)
    from \<open>R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'\<close> have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P \<parallel> R'" by(rule weakPar2)
    moreover from \<open>(P, Q) \<in> Rel\<close> \<open>(R', T') \<in> Rel'\<close> have "(P \<parallel> R', Q \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cComm Q' T' \<alpha>)
    from \<open>P \<leadsto>\<^sup>^<Rel> Q\<close> \<open>Q \<longmapsto>\<alpha> \<prec> Q'\<close> obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule weakSimE)
    from \<open>R \<leadsto>\<^sup>^<Rel'> T\<close> \<open>T \<longmapsto>(coAction \<alpha>) \<prec> T'\<close> obtain R' where "R \<Longrightarrow>\<^sup>^(coAction \<alpha>) \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule weakSimE)
    from \<open>P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'\<close> \<open>R \<Longrightarrow>\<^sup>^(coAction \<alpha>) \<prec> R'\<close> \<open>\<alpha> \<noteq> \<tau>\<close> have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'"
      by(auto intro: weakCongSync simp add: weakTrans_def)
    hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'" by(simp add: weakTrans_def)
    moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R', T') \<in> Rel'\<close> have "(P' \<parallel> R', Q' \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  qed
qed

lemma parPres:
  fixes P    :: ccs
  and   Q    :: ccs
  and   R    :: ccs
  and   Rel  :: "(ccs \<times> ccs) set"
  and   Rel' :: "(ccs \<times> ccs) set"
  assumes "P \<leadsto>\<^sup>^<Rel> Q"
  and     "(P, Q) \<in> Rel"
  and     C1: "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<parallel> U, T \<parallel> U) \<in> Rel'"

  shows "P \<parallel> R \<leadsto>\<^sup>^<Rel'> Q \<parallel> R"
using assms
by(rule_tac parPresAux[where Rel'=Id and Rel''=Rel']) (auto intro: reflexive)

  assumes "P \<leadsto>\<^sup>^<Rel> Q"
  and     "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (\<lparr>\<nu>y\<rparr>R, \<lparr>\<nu>y\<rparr>S) \<in> Rel'"

  shows "\<lparr>\<nu>x\<rparr>P \<leadsto>\<^sup>^<Rel'> \<lparr>\<nu>x\<rparr>Q"
using assms
by(fastforce simp add: weakSimulation_def elim: resCases intro: weakRes)

  assumes "(P, Q) \<in> Rel"
  and     C1: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto>\<^sup>^<Rel> S"
  and     Par: "\<And>R S T U. \<lbrakk>(R, S) \<in> Rel; (T, U) \<in> Rel'\<rbrakk> \<Longrightarrow> (R \<parallel> T, S \<parallel> U) \<in> Rel'"
  and     C2: "bangRel Rel \<subseteq> Rel'"
  and     C3: "\<And>R S. (R \<parallel> !R, S) \<in> Rel' \<Longrightarrow> (!R, S) \<in> Rel'"

  shows "!P \<leadsto>\<^sup>^<Rel'> !Q"
proof(induct rule: weakSimI)
  case(Sim \<alpha> Q')
  {
    fix Pa \<alpha> Q'
    assume "!Q \<longmapsto>\<alpha> \<prec> Q'" and "(Pa, !Q) \<in> bangRel Rel"
    hence "\<exists>P'. Pa \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
    proof(nominal_induct arbitrary: Pa rule: bangInduct)
      case(cPar1 \<alpha> Q')
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(P, Q) \<in> Rel\<close> have "P \<leadsto>\<^sup>^<Rel> Q" by(rule C1)
        with \<open>Q \<longmapsto>\<alpha> \<prec> Q'\<close> obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: weakSimE)
        from \<open>P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'\<close> have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<parallel> R" by(rule weakPar1)
        moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R, !Q) \<in> bangRel Rel\<close> C2 have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> Rel'"
          by(blast intro: Par)
        ultimately show ?case by blast
      qed
    next
      case(cPar2 \<alpha> Q')
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(R, !Q) \<in> bangRel Rel\<close> obtain R' where "R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'" and "(R', Q') \<in> Rel'" using cPar2
          by blast
        from \<open>R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'\<close> have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P \<parallel> R'" by(rule weakPar2)
        moreover from \<open>(P, Q) \<in> Rel\<close> \<open>(R', Q') \<in> Rel'\<close> have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'" by(rule Par)
        ultimately show ?case by blast
      qed
    next
      case(cComm a Q' Q'' Pa)
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(P, Q) \<in> Rel\<close> have "P \<leadsto>\<^sup>^<Rel> Q" by(rule C1)
        with \<open>Q \<longmapsto>a \<prec> Q'\<close> obtain P' where "P \<Longrightarrow>\<^sup>^a \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: weakSimE)
        from \<open>(R, !Q) \<in> bangRel Rel\<close> obtain R' where "R \<Longrightarrow>\<^sup>^(coAction a) \<prec> R'" and "(R', Q'') \<in> Rel'" using cComm
          by blast
        from \<open>P \<Longrightarrow>\<^sup>^a \<prec> P'\<close> \<open>R \<Longrightarrow>\<^sup>^(coAction a) \<prec> R'\<close> \<open>a \<noteq> \<tau>\<close> have "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'"
          by(auto intro: weakCongSync simp add: weakTrans_def)
        moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R', Q'') \<in> Rel'\<close> have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> Rel'" by(rule Par)
        ultimately show ?case by blast
      qed
    next
      case(cBang \<alpha> Q' Pa)
      from \<open>(Pa, !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        from \<open>(P, Q) \<in> Rel\<close> have "(!P, !Q) \<in> bangRel Rel" by(rule bangRel.BRBang)
        with \<open>(P, Q) \<in> Rel\<close> have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule bangRel.BRPar)
        then obtain P' where "P \<parallel> !P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel'" using cBang
          by blast
        from \<open>P \<parallel> !P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'\<close>
        show ?case
        proof(induct rule: weakTransCases)
          case Base
          have "!P \<Longrightarrow>\<^sup>^\<tau> \<prec> !P" by simp
          moreover from \<open>(P', Q') \<in> Rel'\<close> \<open>P \<parallel> !P = P'\<close> have "(!P, Q') \<in> Rel'" by(blast intro: C3)
          ultimately show ?case by blast
        next
          case Step
          from \<open>P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P'\<close> have "!P \<Longrightarrow>\<alpha> \<prec> P'" by(rule weakCongRepl)
          hence "!P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" by(simp add: weakTrans_def)
          with \<open>(P', Q') \<in> Rel'\<close> show ?case by blast
        qed
      qed
    qed
  }

  moreover from \<open>(P, Q) \<in> Rel\<close> have "(!P, !Q) \<in> bangRel Rel" by(rule BRBang)
  ultimately show ?case using \<open>!Q \<longmapsto> \<alpha> \<prec> Q'\<close> by blast
qed

end