theory NaNoCop imports Main
begin

primrec member (infix\<open>|\<in>|\<close> 200) where
  \<open>(_ |\<in>| []) = False\<close> |
  \<open>(x |\<in>| (x' # xs)) = ((x = x') \<or> (x |\<in>| xs))\<close>

lemma member_simp[simp]: \<open>x |\<in>| xs \<longleftrightarrow> x \<in> (set xs)\<close>
  by (induct xs) simp_all

abbreviation notmember (infix \<open>|\<notin>|\<close> 200) where \<open>x |\<notin>| xs \<equiv> \<not> x |\<in>| xs\<close>

definition \<open>linsert x xs \<equiv> (if (x |\<in>| xs) then xs else x # xs)\<close>

lemma linsert_is_insert: \<open>set (linsert x xs) = insert x (set xs)\<close>
  by (induct xs) (simp_all add: linsert_def insert_absorb)

primrec subseteq (infix \<open>|\<subseteq>|\<close> 120) where
  \<open>([] |\<subseteq>| _) = True\<close> |
  \<open>((x # xs) |\<subseteq>| ys) = ((x |\<in>| ys) \<and> (xs |\<subseteq>| ys))\<close>

lemma subseteq_simp[simp]: \<open>xs |\<subseteq>| ys \<longleftrightarrow> (set xs) \<subseteq> (set ys)\<close>
  by (induct xs) simp_all

primrec lremove where
  \<open>lremove _ [] = []\<close> |
  \<open>lremove x (y # ys) = (if y = x then lremove x ys else y # (lremove x ys))\<close>

lemma lremove_simp[simp]: \<open>set (lremove x xs) = (set xs) - {x}\<close>
  by (induct xs) (simp_all add: insert_Diff_if)

primrec lminus (infix \<open>|-|\<close> 210) where
  \<open>xs |-| [] = xs\<close> |
  \<open>xs |-| (y # ys) = (lremove y xs) |-| ys\<close>

lemma hoist_lremove:\<open>set ((lremove x xs) |-| ys) = set (lremove x (xs |-| ys))\<close>
  apply (induct ys arbitrary: x xs)
   apply simp
  by (metis Diff_insert Diff_insert2 lminus.simps(2) lremove_simp)

lemma lminus_simp[simp]: \<open>set (xs |-| ys) = (set xs) - (set ys)\<close>
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  have \<open>set (xs |-| (y # ys)) = set (xs |-| ys) - {y}\<close>
    by (simp add: hoist_lremove)
  then show ?case
    using Cons.hyps by force
qed

definition lequal (infix \<open>|=|\<close> 120) where \<open>xs |=| ys \<equiv> xs |\<subseteq>| ys \<and> ys |\<subseteq>| xs\<close>

lemma lequal_simp[simp]: \<open>xs |=| ys \<longleftrightarrow> (set xs) = (set ys)\<close>
  by (simp add: lequal_def set_eq_subset)

primrec lunion (infix \<open>|\<union>|\<close> 110) where
  \<open>lunion xs [] = xs\<close> |
  \<open>lunion xs (y # ys) = (if y |\<in>| xs then lunion xs ys else y # (lunion xs ys))\<close>

lemma lunion_simp[simp]: \<open>set (xs |\<union>| ys) = set xs \<union> set ys\<close>
  by (induct ys) auto

primrec isset where
  \<open>isset [] = True\<close> |
  \<open>isset (x # xs) = (x |\<notin>| xs \<and> isset xs)\<close>

lemma isset_length: \<open>isset xs \<Longrightarrow> size xs = size (sorted_list_of_set (set xs))\<close>
  by (induct xs) simp_all
(*-------------------------*)

datatype trm
  = Var nat
  | Const nat
  | Fun nat \<open>trm list\<close>

datatype mat
  = Lit bool nat \<open>trm list\<close>
  | Mat \<open>(nat \<times> mat list) list\<close>

fun exi_clause where
  \<open>exi_clause P (Lit _ _ _) = False\<close> |
  \<open>exi_clause P (Mat []) = False\<close> |
  \<open>exi_clause P (Mat ((n,ms) # cs)) =
  (P (n,ms) \<or> (\<exists> m \<in> set ms. exi_clause P m) \<or> exi_clause P (Mat cs))\<close>

definition \<open>exi_mat P m \<equiv> P m \<or> exi_clause (\<lambda> (_,ms). \<exists> m' \<in> set ms. P m') m\<close>

fun all_clause where
  \<open>all_clause P (Lit _ _ _) = True\<close> |
  \<open>all_clause P (Mat []) = True\<close> |
  \<open>all_clause P (Mat ((n,ms) # cs)) =
  (P (n,ms) \<and> (\<forall> m \<in> set ms. all_clause P m) \<and> all_clause P (Mat cs))\<close>

definition \<open>all_mat P m \<equiv> P m \<and> all_clause (\<lambda> (_,ms). \<forall> m' \<in> set ms. P m') m\<close>

definition \<open>id_exists idty m \<equiv> exi_clause (\<lambda> (n,_). n = idty) m\<close>

fun ids_unique where
  \<open>ids_unique (Lit b n ts) = True\<close> |
  \<open>ids_unique (Mat []) = True\<close> |
  \<open>ids_unique (Mat ((n,ms) # cs)) = (
    (\<forall> m \<in> set ms. ids_unique m \<and> \<not>id_exists n m) \<and>
    \<not>id_exists n (Mat cs) \<and>
    ids_unique (Mat cs))\<close>

primrec siblings where
  \<open>siblings c1 c2 (Lit _ _ _) = False\<close> |
  \<open>siblings c1 c2 (Mat cs) = (member c1 cs \<and> member c2 cs)\<close>

abbreviation \<open>
  alpha_top_level cid l m \<equiv> (\<exists> c cid' c'.
    cid \<noteq> cid' \<and>
    siblings (cid,c) (cid',c') m \<and>
    (\<exists> m' \<in> set c'. exi_mat (\<lambda> l'. l = l') m'))\<close>

definition \<open>
  alpha_related m cid l \<equiv>
    exi_mat (alpha_top_level cid l) m\<close>

primrec union_many where
  \<open>union_many [] = {}\<close> |
  \<open>union_many (xs # ys) = xs \<union> (union_many ys)\<close>

primrec vars_term where
  \<open>vars_term (Var i) = {i}\<close> |
  \<open>vars_term (Const i) = {}\<close> |
  \<open>vars_term (Fun i ts) = union_many (map vars_term ts)\<close>

primrec var_in_mat where
  \<open>var_in_mat v (Lit _ _ ts) = (\<exists> t \<in> set ts. v \<in> vars_term t)\<close> |
  \<open>var_in_mat v (Mat _) = False\<close>

abbreviation \<open>var_in_mats v ms \<equiv> (\<exists> m \<in> ms. exi_mat (var_in_mat v) m)\<close>

abbreviation \<open>var_in_clause v cid m \<close>

definition \<open>
  free_var v cid m \<equiv>
    exi_mat (\<lambda> m'. \<exists> c. (cid,c) \<in> set m') m\<close>

primrec substitute where
\<open>substitute \<sigma> (Var i) = Var (\<sigma> i)\<close> |
\<open>substitute \<sigma> (Const i) = Const i\<close> |
\<open>substitute \<sigma> (Fun i ts) = Fun i (map (substitute \<sigma>) ts)\<close>

definition
\<open>compliment \<sigma> pol pred trms pol' pred' trms' \<equiv>
  (pol \<longleftrightarrow> \<not>pol') \<and> pred = pred' \<and> (map (substitute \<sigma>) trms  = map (substitute \<sigma>) trms')\<close>

definition \<open>permutation xs ys \<equiv> length xs = length ys \<and> set xs \<inter> set ys = {}\<close>

inductive CC' (\<open>\<turnstile> _ _ _ _\<close> 0) where
Axiom: \<open>\<turnstile> _ [] _ _\<close> |
Reduction: \<open>
  (\<turnstile> \<sigma> C M ((pol,pred,trms) # P)) \<Longrightarrow>
  compliment \<sigma> pol pred trms pol' pred' trms' \<Longrightarrow>
  (\<turnstile> \<sigma> ((Lit pol' pred' trms') # C) M ((pol,pred,trms) # P))\<close> |
Permutation: \<open>
  (\<turnstile> \<sigma> C M P) \<Longrightarrow>
  permutation C C' \<Longrightarrow> permutation P P' \<Longrightarrow>
  (\<turnstile> \<sigma> C' M P')\<close>

(*
Extension: \<open>
  (\<turnstile> \<sigma> C M P) \<Longrightarrow>
  copy_clause \<delta> M C1 C2 \<Longrightarrow>
  (mat_replace C1 C2 (Mat M) (Mat M')) \<Longrightarrow>
  (\<turnstile> \<sigma> C3 M' (P |\<union>| \<lbrace>(pol,pred,trms)\<rbrace>)) \<Longrightarrow>
  b_clause (pol,pred,trms) C2 (_,C3) \<Longrightarrow>
  extension_clause M (P |\<union>| \<lbrace>(pol,pred,trms)\<rbrace>) C1 \<Longrightarrow>
  contains_mat_in_clause (Lit pol' pred' trms') C2 \<Longrightarrow>
  compliment \<sigma> pol pred trms pol' pred' trms' \<Longrightarrow>
  (\<turnstile> \<sigma> (C |\<union>| \<lbrace>Lit pol pred trms\<rbrace>) M P)\<close> |
Decomposition: \<open>
  (\<turnstile> \<sigma> (C |\<union>| C') M P) \<Longrightarrow>
  (_,C') |\<in>| M' \<Longrightarrow>
  (\<turnstile> \<sigma> (C |\<union>| \<lbrace>Mat M'\<rbrace>) M P)\<close>*)

function free_vars where
  \<open>free_vars M\<close>

function b_clause where
  \<open>b_clause pol pred trms \<lbrace>\<rbrace> = \<lbrace>\<rbrace>\<close> |
  \<open>b_clause pol pred trms (Insert (Lit pol' pred' trms') C) = (
    if pol = pol' \<and> pred = pred' \<and> trms = trms'
    then C
    else Insert (Lit pol' pred' trms') (b_clause pol pred trms C))\<close> |
  \<open>b_clause pol pred trms (Insert (Mat \<lbrace>\<rbrace>) C) = (Insert (Mat \<lbrace>\<rbrace>) C)\<close> |
  \<open>b_clause pol pred trms (Insert (Mat (Insert (Cls idC' C') Cs)) C) = (
    if mat_in_clause (Lit pol pred trms) (Cls idC' C')
    then (Insert (Mat (\<lbrace>(Cls idC' (b_clause pol pred trms C'))\<rbrace>)) C)
    else (Insert (Mat (Insert (Cls idC' C') Cs)) (b_clause pol pred trms C)))\<close>
  by pat_completeness auto
termination
  apply (relation \<open>measure (\<lambda> (_, _, _, C). mat_elem_size (Cls 0 C))\<close>)
  by simp_all (metis add.assoc ignore_id less_SucI less_add_Suc1)

inductive mat_replace where
\<open>\<not> contains_clause_in_mat C M \<Longrightarrow> mat_replace C C' (Mat M) (Mat M)\<close> |
\<open>mat_replace C C' (Lit pol pred trms) (Lit pol pred trms)\<close> |
\<open>C |\<in>| Cs \<Longrightarrow> mat_replace C C' (Mat Cs) (Mat (finsert C' (Cs |-| \<lbrace>C\<rbrace>)))\<close> |
\<open>
  contains_clause_in_mat C M \<Longrightarrow>
  (Mat M) |\<in>| C'' \<Longrightarrow> (idC'',C'') |\<in>| Cs \<Longrightarrow>
  mat_replace C C' (Mat M) M' \<Longrightarrow>
  mat_replace C C'
    (Mat Cs)
    (Mat (finsert (idC'',finsert M' (C'' |-| \<lbrace>Mat M\<rbrace>)) (Cs |-| \<lbrace>(idC'',C'')\<rbrace>)))\<close>

fun free_vars_trm where
  \<open>free_vars_trm (Var n) = \<lbrace>n\<rbrace>\<close> |
  \<open>free_vars_trm (Const n) = \<lbrace>n\<rbrace>\<close> |
  \<open>free_vars_trm (Fun n trms) = fold (\<lambda> t s. s |\<union>| free_vars_trm t) trms \<lbrace>\<rbrace>\<close>

definition \<open>free_vars_trms trms \<equiv> fold (\<lambda> t s. s |\<union>| free_vars_trm t) trms \<lbrace>\<rbrace>\<close>

abbreviation \<open>contains_var_in_lit_in_clause var pol pred trms C \<equiv>
  var |\<in>| free_vars_trms trms \<and>
  contains_mat_in_clause (Lit pol pred trms) C\<close>

abbreviation \<open>contains_mat_in_mat M M' \<equiv>
  (\<exists> C. contains_mat_in_clause (Mat M) C \<and> contains_clause_in_mat C M')\<close>

definition \<open>alpha_related M C pol pred trms \<equiv>
  (\<exists> M' C1 C2. (contains_mat_in_mat M' M \<or> M' = M) \<and>
  C1 |\<in>| M' \<and> C2 |\<in>| M' \<and> C1 \<noteq> C2 \<and>
  (C = C1 \<or> contains_clause_in_clause C C1) \<and>
  contains_mat_in_clause (Lit pol pred trms) C2)\<close>

definition free_vars_clause where
  \<open>free_vars_clause M C \<equiv>
  THE vars. \<forall> var. var |\<in>| vars \<longleftrightarrow> (
    \<exists> pol pred trms.
    contains_var_in_lit_in_clause var pol pred trms C) \<and>
    (\<forall> pol' pred' trms' C'.
      contains_var_in_lit_in_clause var pol' pred' trms' C' \<longrightarrow>
      contains_clause_in_mat C' M \<longrightarrow>
        (contains_clause_in_clause C' C \<or>
        C' = C \<or>
        alpha_related M C pol' pred' trms'))\<close>

definition \<open>vars_in_mat M \<equiv> THE nset. \<forall> var. var |\<in>| nset \<longleftrightarrow> (\<exists> pol pred trms C idC.
  var |\<in>| free_vars_trms trms \<and> Lit pol pred trms |\<in>| C \<and> contains_clause_in_mat (idC,C) M)\<close>

primrec copy_term where
\<open>copy_term \<delta> (Var i) = Var (\<delta> i)\<close> |
\<open>copy_term \<delta> (Const i) = Const i\<close> |
\<open>copy_term \<delta> (Fun i trms) = Fun i (map (copy_term \<delta>) trms)\<close>

inductive copy_clause_elem where
\<open>copy_clause_elem \<delta> (Lit pol pred trms) (Lit pol pred (map (copy_term \<delta>) trms))\<close> |
\<open>\<forall> C. C |\<in>| M \<longrightarrow>
  (\<exists> C'. C' |\<in>| M' \<and> C = (idC,C1) \<and> C' = (idC',C2) \<and> idC = idC' \<and>
    (\<forall> cm. cm |\<in>| C1 \<longrightarrow>
    (\<exists> cm'. cm' |\<in>| C2 \<and> copy_clause_elem \<delta> cm cm'
  ))) \<Longrightarrow>
\<forall> C'. C' |\<in>| M' \<longrightarrow>
 (\<exists> C. C |\<in>| M \<and> C = (idC,C1) \<and> C' = (idC',C2) \<and> idC = idC' \<and>
   (\<forall> cm'. cm' |\<in>| C2 \<longrightarrow>
     (\<exists> cm. cm |\<in>| C1 \<and> copy_clause_elem \<delta> cm cm'
  ))) \<Longrightarrow>
copy_clause_elem \<delta> (Mat M) (Mat M')\<close>

abbreviation \<open>copy_function \<delta> M C \<equiv> \<forall> var.
  var |\<in>| vars_in_mat \<lbrace>C\<rbrace> \<longrightarrow>
  (var |\<in>| free_vars_clause M C \<longrightarrow>
  \<delta> var |\<notin>| vars_in_mat M) \<and>
  (var |\<notin>| free_vars_clause M C \<longrightarrow>
  \<delta> var = var)\<close>

definition \<open>copy_clause \<delta> M C1 C2 \<equiv>
  copy_function \<delta> M C1 \<and>
  copy_clause_elem \<delta> (Mat \<lbrace>C1\<rbrace>) (Mat \<lbrace>C2\<rbrace>)\<close>

fun snd_fold where
  \<open>snd_fold f (fst',snd') = (fst', fold f snd')\<close>

definition \<open>parent_clause M C \<equiv> THE (idC',C').
  contains_clause_in_mat (idC',C') M \<and> (\<exists> M'. (Mat M') |\<in>| C' \<and> C |\<in>| M')\<close>

definition \<open>extension_clause M P C \<equiv>
  contains_clause_in_mat C M \<and>
  ((\<exists> pol pred trms.
    contains_mat_in_clause (Lit pol pred trms) C \<and>
    (pol,pred,trms) |\<in>| P) \<or>
  ((\<forall> pol pred trms C'.
    (pol,pred,trms) |\<in>| P \<longrightarrow>
    contains_mat_in_clause (Lit pol pred trms) C' \<longrightarrow>
    C' |\<in>| M \<longrightarrow>
    alpha_related M C pol pred trms) \<and>
  (C |\<notin>| M \<longrightarrow> (\<exists> pol pred trms.
    (pol,pred,trms) |\<in>| P \<and>
    contains_mat_in_clause (Lit pol pred trms) (parent_clause M C)))))\<close>

inductive CC' (\<open>\<turnstile> _ _ _ _\<close> 0) where
Axiom: \<open>\<turnstile> _ \<lbrace>\<rbrace> _ _\<close> |
Reduction: \<open>
  (\<turnstile> \<sigma> C M (finsert (pol,pred,trms) P)) \<Longrightarrow>
  compliment \<sigma> pol pred trms pol' pred' trms' \<Longrightarrow>
  (\<turnstile> \<sigma> (finsert (Lit pol pred trms) C) M (finsert (pol,pred,trms) P))\<close> |
Extension: \<open>
  (\<turnstile> \<sigma> C M P) \<Longrightarrow>
  copy_clause \<delta> M C1 C2 \<Longrightarrow>
  (mat_replace C1 C2 (Mat M) (Mat M')) \<Longrightarrow>
  (\<turnstile> \<sigma> C3 M' (P |\<union>| \<lbrace>(pol,pred,trms)\<rbrace>)) \<Longrightarrow>
  b_clause (pol,pred,trms) C2 (_,C3) \<Longrightarrow>
  extension_clause M (P |\<union>| \<lbrace>(pol,pred,trms)\<rbrace>) C1 \<Longrightarrow>
  contains_mat_in_clause (Lit pol' pred' trms') C2 \<Longrightarrow>
  compliment \<sigma> pol pred trms pol' pred' trms' \<Longrightarrow>
  (\<turnstile> \<sigma> (C |\<union>| \<lbrace>Lit pol pred trms\<rbrace>) M P)\<close> |
Decomposition: \<open>
  (\<turnstile> \<sigma> (C |\<union>| C') M P) \<Longrightarrow>
  (_,C') |\<in>| M' \<Longrightarrow>
  (\<turnstile> \<sigma> (C |\<union>| \<lbrace>Mat M'\<rbrace>) M P)\<close>

inductive CC where
Start:
\<open>\<turnstile> \<sigma> C2 M \<lbrace>\<rbrace> \<Longrightarrow> copy_clause \<delta> M C1 (_,C2) \<Longrightarrow> contains_clause_in_mat C1 M \<Longrightarrow>
  CC M\<close>

(*Examples*)
lemma \<open>CC \<lbrace>(0,\<lbrace>Lit True 1 []\<rbrace>),(1,\<lbrace>Lit False 1 []\<rbrace>)\<rbrace>\<close>
proof-
  let ?f = \<open>\<lambda> i. i\<close>
  let ?C0 = \<open>(0,\<lbrace>Lit True 1 []\<rbrace>)\<close>
  let ?C1 = \<open>(1,\<lbrace>Lit False 1 []\<rbrace>)\<close>
  let ?M = \<open>\<lbrace>?C0,?C1\<rbrace>\<close>
  have copy_fun: \<open>copy_function ?f ?M ?C0\<close>
  proof-
    have \<open>vars_in_mat \<lbrace>?C0\<rbrace> = \<lbrace>\<rbrace>\<close>
  have copy1: \<open>copy_clause ?f ?M (0,\<lbrace>Lit True 1 []\<rbrace>) (0,\<lbrace>Lit True 1 []\<rbrace>)\<close>
  from Start have ?thesis if
    \<open>\<turnstile> (\<lambda> i. i) \<lbrace>Lit True 1 []\<rbrace> \<lbrace>(0,\<lbrace>Lit True 1 []\<rbrace>),(1,\<lbrace>Lit False 1 []\<rbrace>)\<rbrace> \<lbrace>\<rbrace>\<close>
    using that

end


theory PartialOrderRelation3
  imports Main
begin

text "Partial order on relations that take three inputs"

definition rel_leq :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool)\<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
  where
"rel_leq f g = ({(n, a, b) | n a b. f n a b} \<subseteq> {(n, a, b) | n a b. g n a b})"

lemma rel_leqD:
  "\<lbrakk>rel_leq f g; f a b c\<rbrakk> \<Longrightarrow> g a b c"
  unfolding rel_leq_def
  apply (drule_tac c = "(a, b, c)" in subsetD; blast)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_nat_times
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus2 :: "Bin => Bin => Bin" where
"plus2 (One) y = s y"
| "plus2 (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus2 (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus2 z ys)"
| "plus2 (ZeroAnd z) (OneAnd xs) = OneAnd (plus2 z xs)"
| "plus2 (OneAnd x2) (One) = s (OneAnd x2)"
| "plus2 (OneAnd x2) (ZeroAnd zs) = OneAnd (plus2 x2 zs)"
| "plus2 (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus2 x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus2 (ZeroAnd (times xs12 y)) y"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times2 :: "Nat => Nat => Nat" where
"times2 (Z) y = Z"
| "times2 (S z) y = plus y (times2 z y)"

fun toNat :: "Bin => Nat" where
"toNat (One) = S Z"
| "toNat (ZeroAnd xs) = plus (toNat xs) (toNat xs)"
| "toNat (OneAnd ys) = plus (plus (S Z) (toNat ys)) (toNat ys)"

theorem property0 :
  "((toNat (times x y)) = (times2 (toNat x) (toNat y)))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_52
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 y2 xs) = y (rev xs) (cons2 y2 (nil2))"

fun count :: "Nat => Nat list => Nat" where
  "count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

theorem property0 :
  "((count n xs) = (count n (rev xs)))"
  oops

end


theory Uniform_Sampling imports
  CryptHOL.CryptHOL
  "HOL-Number_Theory.Cong"
begin

definition sample_uniform_units :: "nat \<Rightarrow> nat spmf"
  where "sample_uniform_units q = spmf_of_set ({..< q} - {0})"

lemma set_spmf_sample_uniform_units [simp]:
  "set_spmf (sample_uniform_units q) = {..< q} - {0}"
  by(simp add: sample_uniform_units_def)

lemma lossless_sample_uniform_units:
  assumes "(p::nat) > 1"
  shows "lossless_spmf (sample_uniform_units p)"
  unfolding sample_uniform_units_def
  using assms by auto

lemma weight_sample_uniform_units:
  assumes "(p::nat) > 1"
  shows "weight_spmf (sample_uniform_units p) = 1"
  using assms lossless_sample_uniform_units
  by (simp add: lossless_weight_spmfD)

(*General lemma for mapping using sample_uniform*)

lemma one_time_pad':
  assumes inj_on: "inj_on f ({..<q} - {0})"
    and sur: "f ` ({..<q} - {0}) = ({..<q} - {0})"
  shows "map_spmf f (sample_uniform_units q) = (sample_uniform_units q)"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set (({..<q} - {0}))"
    by(auto simp add: sample_uniform_units_def)
  also have "map_spmf(\<lambda>s. f s) (spmf_of_set ({..<q} - {0})) = spmf_of_set ((\<lambda>s. f s) ` ({..<q} - {0}))"
    by(simp add: inj_on)
  also have "f ` ({..<q} - {0}) = ({..<q} - {0})"
    apply(rule endo_inj_surj) by(simp, simp add: sur, simp add: inj_on)
  ultimately show ?thesis using rhs by simp
qed

lemma one_time_pad:
  assumes inj_on: "inj_on f {..<q}"
    and sur: "f ` {..<q} = {..<q}"
  shows "map_spmf f (sample_uniform q) = (sample_uniform q)"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set ({..< q})"
    by(auto simp add: sample_uniform_def)
  also have "map_spmf(\<lambda>s. f s) (spmf_of_set {..<q}) = spmf_of_set ((\<lambda>s. f s) ` {..<q})"
    by(simp add: inj_on)
  also have "f ` {..<q} = {..<q}"
    apply(rule endo_inj_surj) by(simp, simp add: sur, simp add: inj_on)
  ultimately show ?thesis using rhs by simp
qed

(*(y + b)*)

lemma plus_inj_eq:
  assumes x: "x < q"
    and x': "x' < q"
    and map: "((y :: nat) + x) mod q = (y + x') mod q"
shows "x = x'"
proof-
  have "((y :: nat) + x) mod q = (y + x') mod q \<Longrightarrow> x mod q = x' mod q"
  proof-
    have "((y:: nat) + x) mod q = (y + x') mod q \<Longrightarrow> [((y:: nat) + x) = (y + x')] (mod q)"
      by(simp add: cong_def)
    moreover have "[((y:: nat) + x) = (y + x')] (mod q) \<Longrightarrow> [x = x'] (mod q)"
      by (simp add: cong_add_lcancel_nat)
    moreover have "[x = x'] (mod q) \<Longrightarrow> x mod q = x' mod q"
      by(simp add: cong_def)
    ultimately show ?thesis by(simp add: map)
  qed
  moreover have "x mod q = x' mod q \<Longrightarrow> x = x'"
    by(simp add: x x')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_uni_samp_plus: "inj_on  (\<lambda>(b :: nat). (y + b) mod q ) {..<q}"
  by(simp add: inj_on_def)(auto simp only: plus_inj_eq)

lemma surj_uni_samp_plus:
  assumes inj: "inj_on  (\<lambda>(b :: nat). (y + b) mod q ) {..<q}"
  shows "(\<lambda>(b :: nat). (y + b) mod q) ` {..< q} =  {..< q}"
  apply(rule endo_inj_surj) using inj by auto

lemma samp_uni_plus_one_time_pad:
shows "map_spmf (\<lambda>b. (y + b) mod q) (sample_uniform q) = sample_uniform q"
  using inj_uni_samp_plus surj_uni_samp_plus one_time_pad by simp

(*x*b*)

lemma mult_inj_eq:
  assumes coprime: "coprime x (q::nat)"
    and y: "y < q"
    and y': "y' < q"
    and map: "x * y mod q = x * y' mod q"
  shows "y = y'"
proof-
  have "x*y mod q = x*y' mod q \<Longrightarrow> y mod q = y' mod q"
  proof-
    have "x*y mod q = x*y' mod q \<Longrightarrow> [x*y = x*y'] (mod q)"
      by(simp add: cong_def)
    moreover have "[x*y = x*y'] (mod q) = [y = y'] (mod q)"
      by(simp add: cong_mult_lcancel_nat coprime)
    moreover have "[y = y'] (mod q) \<Longrightarrow> y mod q = y' mod q"
      by(simp add: cong_def)
    ultimately show ?thesis by(simp add: map)
  qed
  moreover have "y mod q = y' mod q \<Longrightarrow> y = y'"
    by(simp add: y y')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_on_mult:
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. x*b mod q) {..<q}"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: mult_inj_eq)

lemma surj_on_mult:
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. x*b mod q) {..<q}"
  shows "(\<lambda> b. x*b mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using coprime inj by auto

lemma mult_one_time_pad:
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. x*b mod q) (sample_uniform q) = sample_uniform q"
  using inj_on_mult surj_on_mult one_time_pad coprime by simp

lemma inj_on_mult':
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. x*b mod q) ({..<q} - {0})"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: mult_inj_eq)

lemma surj_on_mult':
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. x*b mod q) ({..<q} - {0})"
  shows "(\<lambda> b. x*b mod q) ` ({..<q} - {0}) = ({..<q} - {0})"
proof(rule endo_inj_surj)
  show " finite ({..<q} - {0})" by auto
  show "(\<lambda>b. x * b mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
  proof-
    obtain nn :: "nat set \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat set \<Rightarrow> nat" where
      "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x2 \<and> x1 v3 \<notin> x0) = (nn x0 x1 x2 \<in> x2 \<and> x1 (nn x0 x1 x2) \<notin> x0)"
        by moura
    hence 1: "\<forall>N f Na. nn Na f N \<in> N \<and> f (nn Na f N) \<notin> Na \<or> f ` N \<subseteq> Na"
      by (meson image_subsetI)
    have 2: "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<notin> {..<q} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q}"
      by force
    have 3: "(x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q} - {0}) = (x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0})"
      by simp
    { assume "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q = x * 0 mod q"
      hence "(0 \<le> q) = (0 = q) \<or> (nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<in> {0}) \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} - {0} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0}"
        by (metis antisym_conv1 insertCI lessThan_iff local.coprime mult_inj_eq) }
    moreover
    { assume "0 \<noteq> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q"
      moreover
      { assume "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q} \<and> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<notin> {0}"
        hence "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
          using 3 1 by (meson Diff_iff) }
      ultimately have "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0} \<or> (0 \<le> q) = (0 = q)"
        using 2 by (metis antisym_conv1 lessThan_iff mod_less_divisor singletonD) }
    ultimately have "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0} \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} - {0} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0}"
      by force
    thus "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
      using 1 by meson
  qed
  show "inj_on (\<lambda>b. x * b mod q) ({..<q} - {0})"
    using inj by blast
qed

lemma mult_one_time_pad':
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. x*b mod q) (sample_uniform_units q) = sample_uniform_units q"
  using inj_on_mult' surj_on_mult' one_time_pad' coprime by simp

(*y + x*b*)

lemma samp_uni_add_mult:
  assumes coprime: "coprime x (q::nat)"
    and x': "x' < q"
    and y': "y' < q"
    and map: "(y + x * x') mod q = (y + x * y') mod q"
  shows "x' = y'"
proof-
  have "(y + x * x') mod q = (y + x * y') mod q \<Longrightarrow> x' mod q = y' mod q"
  proof-
  have "(y + x * x') mod q = (y + x * y') mod q \<Longrightarrow> [y + x*x' = y + x *y'] (mod q)"
    using cong_def by blast
  moreover have "[y + x*x' = y + x *y'] (mod q) \<Longrightarrow> [x' = y'] (mod q)"
    by(simp add: cong_add_lcancel_nat)(simp add: coprime cong_mult_lcancel_nat)
  ultimately show ?thesis by(simp add: cong_def map)
  qed
  moreover have "x' mod q = y' mod q \<Longrightarrow> x' = y'"
    by(simp add: x' y')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_on_add_mult:
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. (y + x*b) mod q) {..<q}"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: samp_uni_add_mult)

lemma surj_on_add_mult:
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. (y + x*b) mod q) {..<q}"
  shows "(\<lambda> b. (y + x*b) mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using coprime inj by auto

lemma add_mult_one_time_pad:
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. (y + x*b) mod q) (sample_uniform q) = (sample_uniform q)"
  using inj_on_add_mult surj_on_add_mult one_time_pad coprime by simp

(*(y - b) *)

lemma inj_on_minus: "inj_on  (\<lambda>(b :: nat). (y + (q - b)) mod q ) {..<q}"
proof(unfold inj_on_def; auto)
  fix x :: nat and y' :: nat
  assume x: "x < q"
  assume y': "y' < q"
  assume map: "(y + q - x) mod q = (y + q - y') mod q"
  have "\<forall>n na p. \<exists>nb. \<forall>nc nd pa. (\<not> (nc::nat) < nd \<or> \<not> pa (nc - nd) \<or> pa 0) \<and> (\<not> p (0::nat) \<or> p (n - na) \<or> na + nb = n)"
    by (metis (no_types) nat_diff_split)
  hence "\<not> y < y' - q \<and> \<not> y < x - q"
    using y' x by (metis add.commute less_diff_conv not_add_less2)
  hence "\<exists>n. (y' + n) mod q = (n + x) mod q"
    using map by (metis add.commute add_diff_inverse_nat less_diff_conv mod_add_left_eq)
  thus "x = y'"
    by (metis plus_inj_eq  x y' add.commute)
qed

lemma surj_on_minus:
  assumes inj: "inj_on  (\<lambda>(b :: nat). (y + (q - b)) mod q ) {..<q}"
  shows "(\<lambda>(b :: nat). (y + (q - b)) mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using inj by auto

lemma samp_uni_minus_one_time_pad:
  shows "map_spmf(\<lambda> b. (y + (q - b)) mod q) (sample_uniform q) = sample_uniform q"
  using inj_on_minus surj_on_minus one_time_pad by simp

lemma not_coin_spmf: "map_spmf (\<lambda> a. \<not> a) coin_spmf = coin_spmf"
proof-
  have "inj_on Not {True, False}"
    by simp
  moreover have  "Not ` {True, False} = {True, False}"
    by auto
  ultimately show ?thesis using one_time_pad
    by (simp add: UNIV_bool)
qed

lemma xor_uni_samp: "map_spmf(\<lambda> b. y \<oplus> b) (coin_spmf) = map_spmf(\<lambda> b. b) (coin_spmf)"
  (is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set {True, False}"
    by (simp add: UNIV_bool insert_commute)
  also have "map_spmf(\<lambda> b. y \<oplus> b) (spmf_of_set {True, False}) = spmf_of_set((\<lambda> b. y \<oplus> b) ` {True, False})"
    by (simp add: xor_def)
  also have "(\<lambda> b. xor y b) ` {True, False} = {True, False}"
    using xor_def by auto
  finally show ?thesis using rhs by(simp)
qed

lemma ped_inv_mapping:
  assumes "(a::nat) < q"
    and "[m \<noteq> 0] (mod q)"
  shows "map_spmf (\<lambda> d. (d + a * (m::nat)) mod q) (sample_uniform q) = map_spmf (\<lambda> d. (d + q * m - a * m) mod q) (sample_uniform q)"
(is "?lhs = ?rhs")
proof-
  have ineq: "q * m - a * m > 0"
    using assms gr0I by force
  have "?lhs = map_spmf (\<lambda> d. (a * m + d) mod q) (sample_uniform q)"
    using add.commute by metis
  also have "... = sample_uniform q"
    using samp_uni_plus_one_time_pad by simp
  also have "... = map_spmf (\<lambda> d. ((q * m - a * m) + d) mod q) (sample_uniform q)"
    using ineq samp_uni_plus_one_time_pad by metis
  ultimately show ?thesis
    using add.commute ineq
    by (simp add: Groups.add_ac(2))
qed

end


(*<*)theory Star imports Main begin(*>*)

section{*The Reflexive Transitive Closure*}

text{*\label{sec:rtc}
\index{reflexive transitive closure!defining inductively|(}%
An inductive definition may accept parameters, so it can express
functions that yield sets.
Relations too can be defined inductively, since they are just sets of pairs.
A perfect example is the function that maps a relation to its
reflexive transitive closure.  This concept was already
introduced in \S\ref{sec:Relations}, where the operator @{text"\<^sup>*"} was
defined as a least fixed point because inductive definitions were not yet
available. But now they are:
*}

inductive_set
  rtc :: "('a \<times> 'a)set \<Rightarrow> ('a \<times> 'a)set"   ("_*" [1000] 999)
  for r :: "('a \<times> 'a)set"
where
  rtc_refl[iff]:  "(x,x) \<in> r*"
| rtc_step:       "\<lbrakk> (x,y) \<in> r; (y,z) \<in> r* \<rbrakk> \<Longrightarrow> (x,z) \<in> r*"

text{*\noindent
The function @{term rtc} is annotated with concrete syntax: instead of
@{text"rtc r"} we can write @{term"r*"}. The actual definition
consists of two rules. Reflexivity is obvious and is immediately given the
@{text iff} attribute to increase automation. The
second rule, @{thm[source]rtc_step}, says that we can always add one more
@{term r}-step to the left. Although we could make @{thm[source]rtc_step} an
introduction rule, this is dangerous: the recursion in the second premise
slows down and may even kill the automatic tactics.

The above definition of the concept of reflexive transitive closure may
be sufficiently intuitive but it is certainly not the only possible one:
for a start, it does not even mention transitivity.
The rest of this section is devoted to proving that it is equivalent to
the standard definition. We start with a simple lemma:
*}

lemma [intro]: "(x,y) \<in> r \<Longrightarrow> (x,y) \<in> r*"
by(blast intro: rtc_step)

text{*\noindent
Although the lemma itself is an unremarkable consequence of the basic rules,
it has the advantage that it can be declared an introduction rule without the
danger of killing the automatic tactics because @{term"r*"} occurs only in
the conclusion and not in the premise. Thus some proofs that would otherwise
need @{thm[source]rtc_step} can now be found automatically. The proof also
shows that @{text blast} is able to handle @{thm[source]rtc_step}. But
some of the other automatic tactics are more sensitive, and even @{text
blast} can be lead astray in the presence of large numbers of rules.

To prove transitivity, we need rule induction, i.e.\ theorem
@{thm[source]rtc.induct}:
@{thm[display]rtc.induct}
It says that @{text"?P"} holds for an arbitrary pair @{thm (prem 1) rtc.induct}
if @{text"?P"} is preserved by all rules of the inductive definition,
i.e.\ if @{text"?P"} holds for the conclusion provided it holds for the
premises. In general, rule induction for an $n$-ary inductive relation $R$
expects a premise of the form $(x@1,\dots,x@n) \in R$.

Now we turn to the inductive proof of transitivity:
*}

lemma rtc_trans: "\<lbrakk> (x,y) \<in> r*; (y,z) \<in> r* \<rbrakk> \<Longrightarrow> (x,z) \<in> r*"
apply(erule rtc.induct)

txt{*\noindent
Unfortunately, even the base case is a problem:
@{subgoals[display,indent=0,goals_limit=1]}
We have to abandon this proof attempt.
To understand what is going on, let us look again at @{thm[source]rtc.induct}.
In the above application of @{text erule}, the first premise of
@{thm[source]rtc.induct} is unified with the first suitable assumption, which
is @{term"(x,y) \<in> r*"} rather than @{term"(y,z) \<in> r*"}. Although that
is what we want, it is merely due to the order in which the assumptions occur
in the subgoal, which it is not good practice to rely on. As a result,
@{text"?xb"} becomes @{term x}, @{text"?xa"} becomes
@{term y} and @{text"?P"} becomes @{term"%u v. (u,z) : r*"}, thus
yielding the above subgoal. So what went wrong?

When looking at the instantiation of @{text"?P"} we see that it does not
depend on its second parameter at all. The reason is that in our original
goal, of the pair @{term"(x,y)"} only @{term x} appears also in the
conclusion, but not @{term y}. Thus our induction statement is too
general. Fortunately, it can easily be specialized:
transfer the additional premise @{prop"(y,z):r*"} into the conclusion:*}
(*<*)oops(*>*)
lemma rtc_trans[rule_format]:
  "(x,y) \<in> r* \<Longrightarrow> (y,z) \<in> r* \<longrightarrow> (x,z) \<in> r*"

txt{*\noindent
This is not an obscure trick but a generally applicable heuristic:
\begin{quote}\em
When proving a statement by rule induction on $(x@1,\dots,x@n) \in R$,
pull all other premises containing any of the $x@i$ into the conclusion
using $\longrightarrow$.
\end{quote}
A similar heuristic for other kinds of inductions is formulated in
\S\ref{sec:ind-var-in-prems}. The @{text rule_format} directive turns
@{text"\<longrightarrow>"} back into @{text"\<Longrightarrow>"}: in the end we obtain the original
statement of our lemma.
*}

apply(erule rtc.induct)

txt{*\noindent
Now induction produces two subgoals which are both proved automatically:
@{subgoals[display,indent=0]}
*}

 apply(blast)
apply(blast intro: rtc_step)
done

text{*
Let us now prove that @{term"r*"} is really the reflexive transitive closure
of @{term r}, i.e.\ the least reflexive and transitive
relation containing @{term r}. The latter is easily formalized
*}

inductive_set
  rtc2 :: "('a \<times> 'a)set \<Rightarrow> ('a \<times> 'a)set"
  for r :: "('a \<times> 'a)set"
where
  "(x,y) \<in> r \<Longrightarrow> (x,y) \<in> rtc2 r"
| "(x,x) \<in> rtc2 r"
| "\<lbrakk> (x,y) \<in> rtc2 r; (y,z) \<in> rtc2 r \<rbrakk> \<Longrightarrow> (x,z) \<in> rtc2 r"

text{*\noindent
and the equivalence of the two definitions is easily shown by the obvious rule
inductions:
*}

lemma "(x,y) \<in> rtc2 r \<Longrightarrow> (x,y) \<in> r*"
apply(erule rtc2.induct)
  apply(blast)
 apply(blast)
apply(blast intro: rtc_trans)
done

lemma "(x,y) \<in> r* \<Longrightarrow> (x,y) \<in> rtc2 r"
apply(erule rtc.induct)
 apply(blast intro: rtc2.intros)
apply(blast intro: rtc2.intros)
done

text{*
So why did we start with the first definition? Because it is simpler. It
contains only two rules, and the single step rule is simpler than
transitivity.  As a consequence, @{thm[source]rtc.induct} is simpler than
@{thm[source]rtc2.induct}. Since inductive proofs are hard enough
anyway, we should always pick the simplest induction schema available.
Hence @{term rtc} is the definition of choice.
\index{reflexive transitive closure!defining inductively|)}

\begin{exercise}\label{ex:converse-rtc-step}
Show that the converse of @{thm[source]rtc_step} also holds:
@{prop[display]"[| (x,y) : r*; (y,z) : r |] ==> (x,z) : r*"}
\end{exercise}
\begin{exercise}
Repeat the development of this section, but starting with a definition of
@{term rtc} where @{thm[source]rtc_step} is replaced by its converse as shown
in exercise~\ref{ex:converse-rtc-step}.
\end{exercise}
*}
(*<*)
lemma rtc_step2[rule_format]: "(x,y) : r* \<Longrightarrow> (y,z) : r --> (x,z) : r*"
apply(erule rtc.induct)
 apply blast
apply(blast intro: rtc_step)
done

end
(*>*)


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2010 TU Muenchen
*)

theory Quickcheck_Lattice_Examples
imports Main
begin

declare [[quickcheck_finite_type_size=5]]

text \<open>We show how other default types help to find counterexamples to propositions if
  the standard default type @{typ int} is insufficient.\<close>

notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less  (infix "\<sqsubset>" 50) and
  top ("\<top>") and
  bot ("\<bottom>") and
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65)

declare [[quickcheck_narrowing_active = false, quickcheck_timeout = 3600]]

subsection \<open>Distributive lattices\<close>

lemma sup_inf_distrib2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = no_counterexample]
by(simp add: inf_sup_aci sup_inf_distrib1)

lemma sup_inf_distrib2_1:
 "((y :: 'a :: lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma sup_inf_distrib2_2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z') \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib1_1:
 "(x :: 'a :: distrib_lattice) \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x' \<sqinter> z)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib2_1:
 "((y :: 'a :: distrib_lattice) \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (y \<sqinter> x)"
  quickcheck[expect = counterexample]
  oops

subsection \<open>Bounded lattices\<close>

lemma inf_bot_left [simp]:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_bot_left_1:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_2:
  "y \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_3:
  "x \<noteq> \<bottom> ==> y \<sqinter> (x :: 'a :: bounded_lattice_bot) \<noteq> \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_bot_right_1:
  "x \<noteq> \<bottom> ==> (x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = y"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right_2:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> ~= \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_left [simp]:
  "\<bottom> \<squnion> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma sup_bot_right_2 [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_eq_bot_iff [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> y = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

lemma sup_top_left [simp]:
  "\<top> \<squnion> (x :: 'a :: bounded_lattice_top) = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_top_right [simp]:
  "(x :: 'a :: bounded_lattice_top) \<squnion> \<top> = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma inf_top_left [simp]:
  "\<top> \<sqinter> x = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_top_right [simp]:
  "x \<sqinter> \<top> = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_eq_top_iff [simp]:
  "(x :: 'a :: bounded_lattice_top) \<sqinter> y = \<top> \<longleftrightarrow> x = \<top> \<and> y = \<top>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

no_notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less (infix "\<sqsubset>" 50) and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  top ("\<top>") and
  bot ("\<bottom>")

end


(* Title:   Setsum.thy
   Author:  Minamide Yasuhiko
*)

theory Setsum
  imports Main
begin

lemma sum1:
  fixes f::"'a \<Rightarrow> nat"
  assumes "finite s" "sum f s = 1"
  shows "\<exists>y \<in> s. f y = 1 \<and> sum f (s - {y}) = 0"
  using assms apply (simp add: sum_eq_1_iff[OF assms(1), simplified]) by fastforce

lemma sumk:
  fixes f::"'a \<Rightarrow> nat"
  assumes "finite s" "x \<in> s" "sum f s \<le> k"
  shows "f x \<le> k"
proof (rule contrapos_pp)
  assume H: "\<not> f x \<le> k"
  have "sum f s = sum f (insert x (s - {x}))"
    using assms by (simp add: insert_absorb)
  also have "... = f x + sum f (s - {x})"
    by (rule sum.insert, insert assms, auto)
  finally have "sum f s = f x + sum f (s - {x})" .
  thus "\<not> sum f s \<le> k"
  proof (simp)
    show "\<not> f x + sum f (s - {x}) \<le> k"
      using H by auto
  qed
qed (fact)

end


theory GraphIsomorphism
  imports Main ColoredGraph
begin

section \<open>Permutations of graphs\<close>

subsection\<open>The effect of vertices perm on edges\<close>
definition perm_edges :: "perm \<Rightarrow> (nat \<times> nat) set \<Rightarrow> (nat \<times> nat) set" where
  "perm_edges p es = (perm_fun_pair p) ` es"

lemma perm_edges_dom:
  assumes "\<forall> (v1, v2) \<in> E. v1 < n \<and> v2 < n"
          "(v1, v2) \<in> perm_edges p E" "perm_dom p = n"
  shows "v1 < n \<and> v2 < n"
  using assms fst_conv snd_conv
  unfolding perm_edges_def perm_fun_pair_def
  by (metis (no_types, lifting) case_prodE imageE perm_comp_perm_inv2 perm_dom_perm_inv perm_fun_perm_inv_range perm_inv_solve)

lemma card_perm_edges [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "card (perm_edges p (edges G)) = card (edges G)"
proof-
  have "inj_on (perm_fun_pair p) (edges G)"
    using assms
    unfolding perm_fun_pair_def
    by transfer (smt (verit, ccfv_threshold) Pair_inject distinct_perm edge_vertices(1) edge_vertices(2) edges.abs_eq eq_onp_same_args inj_on_def nth_eq_iff_index_eq num_vertices.abs_eq perm_fun'_def prod.collapse)
  then show ?thesis
    using assms
    unfolding perm_edges_def Let_def
    by (auto simp add: card_image)
qed

lemma perm_edges_perm_id' [simp]:
  assumes "\<forall> (x, y) \<in> es. x < n \<and> y < n"
  shows "perm_edges (perm_id n) es = es"
  using assms
  unfolding perm_edges_def
  by force

lemma perm_edges_perm_id [simp]:
  shows "perm_edges (perm_id (num_vertices G)) (edges G) = edges G"
  unfolding perm_edges_def
  by force

lemma perm_edges_perm_comp [simp]:
  assumes "perm_dom p1 = (num_vertices G)" "perm_dom p2 = (num_vertices G)"
  shows "perm_edges (perm_comp p1 p2) (edges G) =
         perm_edges p1 (perm_edges p2 (edges G))"
  using assms
  unfolding perm_edges_def
  by force

subsection \<open>The effect of vertices perm on the colored graph\<close>
definition perm_graph_Rep :: "perm \<Rightarrow> colored_graph_rec \<Rightarrow> colored_graph_rec" where
  "perm_graph_Rep p G =
   \<lparr>
      num_vertices' = num_vertices' G,
      edges' = perm_edges p (edges' G),
      colors' = perm_coloring p (colors' G)
   \<rparr>"

definition perm_graph :: "perm => colored_graph => colored_graph" where
  "perm_graph p G = Abs_colored_graph (perm_graph_Rep p (Rep_colored_graph G))"

lemma n_vertex_perm_graph_Rep:
  assumes "n_vertex G" "perm_dom p = num_vertices' G"
  shows "n_vertex (perm_graph_Rep p G)"
  using assms
  unfolding n_vertex_def Let_def perm_graph_Rep_def
  by (smt (verit, ccfv_threshold) case_prodD case_prodI2 length_perm_coloring perm_edges_dom select_convs(1) select_convs(2) select_convs(3))

lemma perm_graph_Abs_inverse [simp]:
  assumes "perm_dom p = num_vertices' G" "n_vertex G"
  shows "Rep_colored_graph (Abs_colored_graph (perm_graph_Rep p G)) = perm_graph_Rep p G"
  using assms
  by (subst Abs_colored_graph_inverse) (simp_all add: n_vertex_perm_graph_Rep)

lemma num_vertices_perm_graph [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "num_vertices (perm_graph p G) = num_vertices G"
  using assms
  using Rep_colored_graph num_vertices.rep_eq perm_graph_Abs_inverse perm_graph_Rep_def perm_graph_def
  by auto

lemma vertex_perm_graph [simp]:
  assumes "perm_dom p = num_vertices G" "vertex G v"
  shows "vertex (perm_graph p G) (perm_fun p v)"
  using assms
  by simp

lemma edges_perm_graph [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "edges (perm_graph p G) = perm_edges p (edges G)"
  using assms Rep_colored_graph edges.rep_eq num_vertices.rep_eq perm_graph_Abs_inverse perm_graph_Rep_def perm_graph_def
  by force

lemma edges_perm_graph_perm:
  assumes "perm_dom p = num_vertices G" "vertex G v" "vertex G w"
  shows "(perm_fun p v, perm_fun p w) \<in> edges (perm_graph p G) \<longleftrightarrow> (v, w) \<in> edges G"
proof
  assume "(v, w) \<in> edges G"
  then show "(perm_fun p v, perm_fun p w) \<in> edges (perm_graph p G)"
    using assms image_iff
    by (force simp add: perm_edges_def perm_fun_pair_def)
next
  assume "(perm_fun p v, perm_fun p w) \<in> edges (perm_graph p G)"
  then obtain v' w' where "(v', w') \<in> edges G" "perm_fun p v' = perm_fun p v" "perm_fun p w' = perm_fun p w"
    using assms
    by (force simp add: perm_edges_def perm_fun_pair_def)
  then show "(v, w) \<in> edges G"
    using perm_fun_inj[OF assms(1), of v v']
    using perm_fun_inj[OF assms(1), of w w'] assms(2-3)
    by auto
qed

lemma colors_perm_graph [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "colors (perm_graph p G) = perm_coloring p (colors G)"
  using assms
  using Rep_colored_graph colors.rep_eq num_vertices.rep_eq perm_graph_Abs_inverse perm_graph_Rep_def perm_graph_def
  by force

lemma num_colors_perm_graph [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "num_colors (perm_graph p G) = num_colors G"
  using assms
  by simp

lemma recolor_perm[simp]:
  assumes "perm_dom p = num_vertices G" "length \<pi> = num_vertices G"
  shows "recolor (perm_graph p G) (perm_coloring p \<pi>) = perm_graph p (recolor G \<pi>)" (is "?lhs=?rhs")
proof (rule graph_eqI)
  show "num_vertices ?lhs = num_vertices ?rhs" "edges ?lhs = edges ?rhs"
    using assms
    by simp_all
next
  show "colors ?lhs = colors ?rhs"
    using assms
    by simp
qed

lemma perm_graph_coloring_perm_node [simp]:
  assumes "vertex G v" "perm_dom p = num_vertices G"
  shows "color_fun (perm_graph p G) (perm_fun p v) = color_fun G v"
  using assms
  by auto

lemma perm_graph_perm_id [simp]:
  shows "perm_graph (perm_id (num_vertices G)) G = G"
  unfolding perm_graph_def
  by (metis (full_types) Rep_colored_graph_inverse colors.rep_eq edges.rep_eq length_colors_num_vertices old.unit.exhaust perm_coloring_perm_id perm_edges_perm_id perm_graph_Rep_def surjective)

lemma perm_graph_perm_comp [simp]:
  assumes "perm_dom p1 = num_vertices G" "perm_dom p2 = num_vertices G"
  shows "perm_graph (perm_comp p1 p2) G = perm_graph p1 (perm_graph p2 G)"
  using assms
  using perm_graph_def Rep_colored_graph colors.rep_eq edges.rep_eq length_colors_num_vertices mem_Collect_eq num_vertices.rep_eq perm_coloring_perm_comp perm_edges_perm_comp perm_graph_Abs_inverse perm_graph_Rep_def
  by force

lemma perm_graph_perm_inv1 [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "perm_graph (perm_inv p) (perm_graph p G) = G"
  using assms
  by (metis perm_comp_perm_inv1 perm_dom_perm_inv perm_graph_perm_comp perm_graph_perm_id)

lemma perm_graph_perm_inv2 [simp]:
  assumes "perm_dom p = num_vertices G"
  shows "perm_graph p (perm_graph (perm_inv p) G) = G"
  by (metis assms perm_dom_perm_inv perm_graph_perm_inv1 perm_inv_inv)

lemma cells_perm_graph:
  assumes "perm_dom p = num_vertices G"
  shows "cells (colors (perm_graph p G)) = map (perm_fun_set p) (cells (colors G))"
  using assms
  by simp

subsection \<open>Isomorphisms\<close>

definition is_isomorphism :: "perm \<Rightarrow> colored_graph \<Rightarrow> colored_graph \<Rightarrow> bool" where
  "is_isomorphism p G1 G2 \<longleftrightarrow>
      perm_dom p = num_vertices G1 \<and>
      perm_graph p G1 = G2"

definition isomorphic :: "colored_graph \<Rightarrow> colored_graph \<Rightarrow> bool" (infixl "\<simeq>" 100) where
  "isomorphic G1 G2 \<longleftrightarrow> (\<exists> p. is_isomorphism p G1 G2)"

lemma isomorphic_num_vertices:
  assumes "isomorphic G1 G2"
  shows "num_vertices G1 = num_vertices G2"
  using assms
  unfolding isomorphic_def is_isomorphism_def
  by auto

lemma isomorphic_num_edges:
  assumes "isomorphic G1 G2"
  shows "card (edges G1) = card (edges G2)"
  using assms
  unfolding isomorphic_def is_isomorphism_def
  by auto

subsubsection \<open>Automorphisms\<close>

definition is_automorphism :: "colored_graph \<Rightarrow> perm \<Rightarrow> bool" where
  "is_automorphism G p \<longleftrightarrow> is_isomorphism p G G"

definition automorphisms :: "colored_graph \<Rightarrow> perm set" where
  "automorphisms G = {p. is_automorphism G p}"

lemma id_automorphism [simp]:
  shows "perm_id (num_vertices G) \<in> automorphisms G"
  unfolding automorphisms_def is_automorphism_def is_isomorphism_def
  by auto

lemma perm_comp_automorphism [simp]:
  assumes "is_automorphism G p1" "is_automorphism G p2"
  shows "is_automorphism G (perm_comp p1 p2)"
  using assms
  unfolding is_automorphism_def is_isomorphism_def
  by auto

lemma perm_inv_automorphism [simp]:
  assumes "is_automorphism G p"
  shows "is_automorphism G (perm_inv p)"
  using assms
  unfolding is_automorphism_def is_isomorphism_def
  by (metis perm_dom_perm_inv perm_graph_perm_inv1)

lemma automorphism_retains_colors [simp]:
  assumes "is_automorphism G p" "vertex G v"
  shows "(color_fun G) (perm_fun p v) = (color_fun G) v"
  using assms
  unfolding is_automorphism_def is_isomorphism_def
  by (metis perm_graph_coloring_perm_node)

lemma is_automorphism_perm_inv:
  assumes "is_automorphism G p"
  shows "is_automorphism G (perm_inv p)"
  unfolding is_automorphism_def is_isomorphism_def
  using assms
  by (metis is_automorphism_def is_isomorphism_def perm_dom_perm_inv perm_graph_perm_inv1)

subsection \<open>Canonical forms\<close>

definition is_canon_form :: "(colored_graph \<Rightarrow> colored_graph) \<Rightarrow> bool" where
  "is_canon_form C \<longleftrightarrow>
   (\<forall> G. G \<simeq> C G \<and>
         (\<forall> p. perm_dom p = num_vertices G \<longrightarrow> C (perm_graph p G) = C G))"

lemma isomorphic_same_canon_form:
  assumes "is_canon_form C"
  shows "G \<simeq> G' \<longleftrightarrow> C G = C G'"
proof
  assume "G \<simeq> G'"
  then show "C G = C G'"
    using assms
    unfolding is_canon_form_def isomorphic_def
    by (metis is_isomorphism_def)
next
  assume "C G = C G'"
  show "G \<simeq> G'"
  proof-
    obtain p where "perm_dom p = num_vertices G" "perm_graph p G = C G"
      using assms
      unfolding is_canon_form_def isomorphic_def is_isomorphism_def
      by auto
    moreover
    obtain p' where "perm_dom p' = num_vertices G'" "perm_graph p' G' = C G'"
      using assms
      unfolding is_canon_form_def isomorphic_def is_isomorphism_def
      by auto
    ultimately
    have "perm_graph p G = perm_graph p' G'"
      using `C G = C G'`
      by simp
    then show ?thesis
      by (metis \<open>perm_dom p = num_vertices G\<close> \<open>perm_dom p' = num_vertices G'\<close> is_isomorphism_def isomorphic_def isomorphic_num_vertices perm_dom_perm_comp perm_dom_perm_inv perm_graph_perm_comp perm_graph_perm_inv1)
  qed
qed

definition orbits :: "colored_graph \<Rightarrow> vertex \<Rightarrow> vertex set" where
  "orbits G v = {perm_fun p v | p. p \<in> automorphisms G}"

definition is_orbit_subset :: "perm set \<Rightarrow> vertex set \<Rightarrow> bool" where
  "is_orbit_subset A \<Omega> \<longleftrightarrow> (\<forall> v1 \<in> \<Omega>. \<forall> v2 \<in> \<Omega>. \<exists> p \<in> A. perm_fun p v1 = v2)"

end


theory Projective_Space_Axioms
  imports Main
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk *)

text \<open>
Contents:
\<^item> We introduce the types @{typ 'point} of points and @{typ 'line} of lines and an incidence relation
between them.
\<^item> A set of axioms for the (3-dimensional) projective space.
An alternative set of axioms could use planes as basic objects in addition to points and lines
\<close>

section \<open>The axioms of the Projective Space\<close>

lemma distinct4_def:
"distinct [A,B,C,D] = ((A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D)\<and> (B \<noteq> C) \<and> (B \<noteq> D) \<and> (C \<noteq> D))"
  by auto

lemma distinct3_def:
  "distinct [A, B, C] = (A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C)"
  by auto

locale projective_space =
  (* One has a type of 'point *)
  (* We don't need an axiom for the existence of at least one point,
  since we know that the type "'point" is not empty
  TODO: why would that be true? *)
  (* One has a type of 'line *)
  (* There is a relation of incidence between 'point and 'line *)
  fixes incid :: "'point \<Rightarrow> 'line \<Rightarrow> bool"
  fixes meet :: "'line \<Rightarrow> 'line \<Rightarrow> 'point"
  assumes meet_def:  "(incid (meet l m) l \<and> incid (meet l m) m)"

  (* The relation of incidence is decidable *)
  assumes incid_dec: "(incid P l) \<or> \<not>(incid P l)"

  (* Ax1: Any two distinct 'point are incident with just one line *)
  assumes ax1_existence: "\<exists>l. (incid P l) \<and> (incid M l)"
  assumes ax1_uniqueness: "(incid P k) \<longrightarrow> (incid M k) \<longrightarrow> (incid P l) \<longrightarrow> (incid M l) \<longrightarrow> (P = M) \<or> (k = l)"

  (* Ax2: If A B C D are four distinct 'point such that AB meets CD then AC meets BD.
  Sometimes this is called Pasch's axiom, but according to Wikipedia it is misleading
  since Pasch's axiom refers to something else. *)
  assumes ax2: "distinct [A,B,C,D] \<longrightarrow> (incid A lAB \<and> incid B lAB)
  \<longrightarrow> (incid C lCD \<and> incid D lCD) \<longrightarrow> (incid A lAC \<and> incid C lAC) \<longrightarrow>
  (incid B lBD \<and> incid D lBD) \<longrightarrow> (\<exists>I.(incid I lAB \<and> incid I lCD)) \<longrightarrow>
  (\<exists>J.(incid J lAC \<and> incid J lBD))"

  (** Dimension-related axioms **)
  (* Ax3: Every line is incident with at least three Points.
  As I understand it, this axiom makes sure that Lines are not degenerated into 'point
  and since it asks for three distinct Points, not only 2, it captures the idea that
  Lines are continuous, i.e. there is always a point between two distinct Points. *)
  assumes ax3: "\<exists>A B C. distinct3 A B C \<and> (incid A l) \<and> (incid B l) \<and> (incid C l)"

  (* Ax4: There exists two Lines that do not meet,
  hence the geometry is at least 3-dimensional *)
  assumes ax4: "\<exists>l m.\<forall>P. \<not>(incid P l \<and> incid P m)"

  (* Ax5: The geometry is not 4-dimensional, hence it is exactly 3-dimensional *)
  assumes ax5: "distinct [l1,l2,l3] \<longrightarrow> (\<exists>l4 J1 J2 J3. distinct [J1,J2,J3] \<and>
  meet l1 l4 = J1 \<and> meet l2 l4 = J2 \<and> meet l3 l4 = J3)"

end


theory GabrielaLimonta
imports Main "~~/src/HOL/IMP/Big_Step"
begin

fun exec :: "com \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> state option" where
  "exec _ s 0 = None"
| "exec SKIP s (Suc f) = Some s"
| "exec (x::=v) s (Suc f) = Some (s(x:=aval v s))"
| "exec (c1;;c2) s (Suc f) = (
    case (exec c1 s f) of None \<Rightarrow> None | Some s' \<Rightarrow> exec c2 s' f)"
| "exec (IF b THEN c1 ELSE c2) s (Suc f) =
    (if bval b s then exec c1 s f else exec c2 s f)"
| "exec (WHILE b DO c) s (Suc f) = (
    if bval b s then
      (case (exec c s f) of
        None \<Rightarrow> None |
        Some s' \<Rightarrow> exec (WHILE b DO c) s' f)
    else Some s)"

text {* The two directions are proved separately. The proof of the first
  direction should be quite straightforward, and is left to you. *}
lemma exec_imp_bigstep: "exec c s f = Some s' \<Longrightarrow> (c,s) \<Rightarrow> s'"
proof (induction arbitrary: s' rule: exec.induct[case_names None SKIP ASS SEMI IF WHILE])
print_cases
case (None uu sa)
  from this have False by auto
  thus ?case by blast
next
case (SKIP sa f)
  from this have "sa = s'" by auto
  thus ?case using `sa = s'` by auto
next
case (ASS x v sa f)
  from this have "s' = sa(x := aval v sa)" by auto
  thus ?case by blast
next
case (SEMI c1 c2 sa f)
  thus ?case by (auto split: option.split_asm)
next
case (IF b c1 c2 sa f)
  thus ?case by (metis IfFalse IfTrue exec.simps(5))
next
case (WHILE b c sa f)
  thus ?case sorry
qed

lemma exec_mono: "exec c s f = Some s' \<Longrightarrow> exec c s (f+k) = Some s'"
proof (induction c s f arbitrary: s'
    rule: exec.induct[case_names None SKIP ASS SEMI IF WHILE])
print_cases
case (None uu s s')
  from this have False by simp
  thus ?case by blast
next
case (SKIP s f s')
  from this have "s' = s" by simp
  thus ?case by auto
next
case (ASS x v s f s')
  from this have "s' = s(x := aval v s)" by simp
  thus ?case by auto
next
case (SEMI c1 c2 s f)
  thus ?case by (auto split: option.split option.split_asm)
next
case (IF b c1 c2 s f s')
  thus ?case by auto
next
case (WHILE b c s i s')
  thus ?case by (auto split: option.split_asm)
qed

lemma bigstep_imp_si:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> \<exists>k. exec c s k = Some s'"
proof (induct rule: big_step_induct)
print_cases
  case (Skip s) have "exec SKIP s 1 = Some s" by auto
  thus ?case by blast
next
  case (WhileTrue b s1 c s2 s3)
  then obtain f1 f2 where "exec c s1 f1 = Some s2"
    and "exec (WHILE b DO c) s2 f2 = Some s3" by auto
  with exec_mono[of c s1 f1 s2 f2]
    exec_mono[of "WHILE b DO c" s2 f2 s3 f1] have
    "exec c s1 (f1+f2) = Some s2"
    and "exec (WHILE b DO c) s2 (f2+f1) = Some s3"
    by auto
  hence "exec (WHILE b DO c) s1 (Suc (f1+f2)) = Some s3"
    using `bval b s1` by (auto simp add: add_ac)
  thus ?case by blast
next
  case (Seq c1 s1 s2 c2 s3)
  then obtain f1 f2 where "exec c1 s1 f1 = Some s2" and "exec c2 s2 f2 = Some s3"
    by auto
  with exec_mono[of c1 s1 f1 s2 f2]
    exec_mono[of c2 s2 f2 s3 f1]
  have
    "exec c1 s1 (f1+f2) = Some s2" and "exec c2 s2 (f2+f1) = Some s3"
    by auto
  hence "exec (c1;;c2) s1 (Suc (f1+f2)) = Some s3" by (auto simp add: add_ac)
  thus ?case by blast
next
  case (Assign x a s)
  have "exec (x::=a) s (Suc 0) = Some (s(x := aval a s))" by auto
  thus ?case by blast
next
  case (IfTrue b s c1 t c2)
  then obtain f where "exec c1 s f = Some t" by auto
  from this and `bval b s` and `(c1, s) \<Rightarrow> t`
  have "exec (IF b THEN c1 ELSE c2) s (Suc f) = Some t" by auto
  thus ?case by blast
next
  case (IfFalse b s c2 t c1)
  then obtain f where "exec c2 s f = Some t" by auto
  from this and `\<not>bval b s` and `(c2, s) \<Rightarrow> t`
  have "exec (IF b THEN c1 ELSE c2) s (Suc f) = Some t" by auto
  thus ?case by blast
next
  case (WhileFalse b s c)
  from this have "exec (WHILE b DO c) s (Suc 0) = Some s" by auto
  thus ?case by blast
qed

text {* Finally, prove the main theorem of the homework: *}
theorem exec_equiv_bigstep: "(\<exists>k. exec c s k = Some s') \<longleftrightarrow> (c,s) \<Rightarrow> s'"
  proof
  assume "\<exists>k. exec c s k = Some s'"
  then obtain f where "exec c s f = Some s'" by auto
  thus "(c,s) \<Rightarrow> s'" using exec_imp_bigstep[of c s f] by auto
next
  assume "(c,s) \<Rightarrow> s'"
  then show "\<exists>k. exec c s k = Some s'" using bigstep_imp_si[of c s s'] by auto
qed

end


(* Author: R. Thiemann *)

subsection \<open>Perron-Frobenius theorem via Brouwer's fixpoint theorem.\<close>

theory Perron_Frobenius
imports
  "HOL-Analysis.Brouwer_Fixpoint"
  Perron_Frobenius_Aux
begin

text \<open>We follow the textbook proof of Serre \cite[Theorem 5.2.1]{SerreMatrices}.\<close>

context
  fixes A :: "complex ^ 'n ^ 'n :: finite"
  assumes rnnA: "real_non_neg_mat A"
begin

private abbreviation(input) sr where "sr \<equiv> spectral_radius A"

private definition max_v_ev :: "(complex^'n) \<times> complex" where
  "max_v_ev = (SOME v_ev. eigen_vector A (fst v_ev) (snd v_ev)
  \<and> norm (snd v_ev) = sr)"

private definition "max_v = (1 / norm1 (fst max_v_ev)) *\<^sub>R fst max_v_ev"
private definition "max_ev = snd max_v_ev"

private lemma max_v_ev:
  "eigen_vector A max_v max_ev"
  "norm max_ev = sr"
  "norm1 max_v = 1"
proof -
  obtain v ev where id: "max_v_ev = (v,ev)" by force
  from spectral_radius_ev[of A] someI_ex[of "\<lambda> v_ev. eigen_vector A (fst v_ev) (snd v_ev)
  \<and> norm (snd v_ev) = sr", folded max_v_ev_def, unfolded id]
  have v: "eigen_vector A v ev" and ev: "norm ev = sr" by auto
  from normalize_eigen_vector[OF v] ev
  show "eigen_vector A max_v max_ev" "norm max_ev = sr" "norm1 max_v = 1"
    unfolding max_v_def max_ev_def id by auto
qed

text \<open>In the definition of S, we use the linear norm instead of the
  default euclidean norm which is defined via the type-class.
  The reason is that S is not convex if one uses the euclidean norm.\<close>

private definition B :: "real ^ 'n ^ 'n" where "B \<equiv> \<chi> i j. Re (A $ i $ j)"
private definition S where "S = {v :: real ^ 'n . norm1 v = 1 \<and> (\<forall> i. v $ i \<ge> 0) \<and>
  (\<forall> i. (B *v v) $ i \<ge> sr * (v $ i))}"
private definition f :: "real ^ 'n \<Rightarrow> real ^ 'n" where
  "f v = (1 / norm1 (B *v v)) *\<^sub>R (B *v v)"

private

private lemma boundedS: "bounded S"
proof -
  {
    fix v :: "real ^ 'n"
    from norm1_ge_norm[of v] have "norm1 v = 1 \<Longrightarrow> norm v \<le> 1" by auto
  }
  thus ?thesis
  unfolding S_def bounded_iff
  by (auto intro!: exI[of _ 1])
qed

private lemma compactS: "compact S"
  using boundedS closedS
  by (simp add: compact_eq_bounded_closed)

private lemmas rnn = real_non_neg_matD[OF rnnA]

lemma B_norm: "B $ i $ j = norm (A $ i $ j)"
  using rnn[of i j]
  by (cases "A $ i $ j", auto simp: B_def)

lemma mult_B_mono: assumes "\<And> i. v $ i \<ge> w $ i"
  shows "(B *v v) $ i \<ge> (B *v w) $ i" unfolding matrix_vector_mult_def vec_lambda_beta
  by (rule sum_mono, rule mult_left_mono[OF assms], unfold B_norm, auto)

private lemma non_emptyS: "S \<noteq> {}"
proof -
  let ?v = "(\<chi> i. norm (max_v $ i)) :: real ^ 'n"
  have "norm1 max_v = 1" by (rule max_v_ev(3))
  hence nv: "norm1 ?v = 1" unfolding norm1_def by auto
  {
    fix i
    have "sr * (?v $ i) = sr * norm (max_v $ i)" by auto
    also have "\<dots> = (norm max_ev) * norm (max_v $ i)" using max_v_ev by auto
    also have "\<dots> = norm ((max_ev *s max_v) $ i)" by (auto simp: norm_mult)
    also have "max_ev *s max_v = A *v max_v" using max_v_ev(1)[unfolded eigen_vector_def] by auto
    also have "norm ((A *v max_v) $ i) \<le> (B *v ?v) $ i"
      unfolding matrix_vector_mult_def vec_lambda_beta
      by (rule sum_norm_le, auto simp: norm_mult B_norm)
    finally have "sr * (?v $ i) \<le> (B *v ?v) $ i" .
  } note le = this
  have "?v \<in> S" unfolding S_def using nv le by auto
  thus ?thesis by blast
qed

private lemma convexS: "convex S"
proof (rule convexI)
  fix v w a b
  assume *: "v \<in> S" "w \<in> S" "0 \<le> a" "0 \<le> b" "a + b = (1 :: real)"
  let ?lin = "a *\<^sub>R v + b *\<^sub>R w"
  from * have 1: "norm1 v = 1" "norm1 w = 1" unfolding S_def by auto
  have "norm1 ?lin = a * norm1 v + b * norm1 w"
    unfolding norm1_def sum_distrib_left sum.distrib[symmetric]
  proof (rule sum.cong)
    fix i :: 'n
    from * have "v $ i \<ge> 0" "w $ i \<ge> 0" unfolding S_def by auto
    thus "norm (?lin $ i) = a * norm (v $ i) + b * norm (w $ i)"
      using *(3-4) by auto
  qed simp
  also have "\<dots> = 1" using *(5) 1 by auto
  finally have norm1: "norm1 ?lin = 1" .
  {
    fix i
    from * have "0 \<le> v $ i" "sr * v $ i \<le> (B *v v) $ i" unfolding S_def by auto
    with \<open>a \<ge> 0\<close> have a: "a * (sr * v $ i) \<le> a * (B *v v) $ i" by (intro mult_left_mono)
    from * have "0 \<le> w $ i" "sr * w $ i \<le> (B *v w) $ i" unfolding S_def by auto
    with \<open>b \<ge> 0\<close> have b: "b * (sr * w $ i) \<le> b * (B *v w) $ i" by (intro mult_left_mono)
    from a b have "a * (sr * v $ i) + b * (sr * w $ i) \<le> a * (B *v v) $ i + b * (B *v w) $ i" by auto
  } note le = this
  have switch[simp]: "\<And> x y. x * a * y = a * x * y"  "\<And> x y. x * b * y = b * x * y" by auto
  have [simp]: "x \<in> {v,w} \<Longrightarrow> a * (r * x $h i) = r * (a * x $h i)" for a r i x by auto
  show "a *\<^sub>R v + b *\<^sub>R w \<in> S" using * norm1 le unfolding S_def
    by (auto simp: matrix_vect_scaleR matrix_vector_right_distrib ring_distribs)
qed

private abbreviation (input) r :: "real \<Rightarrow> complex" where
  "r \<equiv> of_real"

private abbreviation rv :: "real ^'n \<Rightarrow> complex ^'n" where
  "rv v \<equiv> \<chi> i. r (v $ i)"

private lemma rv_0: "(rv v = 0) = (v = 0)"
  by (simp add: of_real_hom.map_vector_0 map_vector_def vec_eq_iff)

private lemma rv_mult: "A *v rv v = rv (B *v v)"
proof -
  have "map_matrix r B = A"
    using rnnA unfolding map_matrix_def B_def real_non_neg_mat_def map_vector_def elements_mat_h_def
    by vector
  thus ?thesis
    using of_real_hom.matrix_vector_mult_hom[of B, where 'a = complex]
    unfolding map_vector_def by auto
qed

context
  assumes zero_no_ev: "\<And> v. v \<in> S \<Longrightarrow> A *v rv v \<noteq> 0"
begin
private lemma normB_S: assumes v: "v \<in> S"
  shows "norm1 (B *v v) \<noteq> 0"
proof -
  from zero_no_ev[OF v, unfolded rv_mult rv_0]
  show ?thesis by auto
qed

private lemma image_f: "f ` S \<subseteq> S"
proof -
  {
    fix v
    assume v: "v \<in> S"
    hence norm: "norm1 v = 1" and ge: "\<And> i. v $ i \<ge> 0" "\<And> i. sr * v $ i \<le> (B *v v) $ i" unfolding S_def by auto
    from normB_S[OF v] have normB: "norm1 (B *v v) > 0" using norm1_nonzero by auto
    have fv: "f v = (1 / norm1 (B *v v)) *\<^sub>R (B *v v)" unfolding f_def by auto
    from normB have Bv0: "B *v v \<noteq> 0" unfolding norm1_0_iff[symmetric] by linarith
    have norm: "norm1 (f v) = 1" unfolding fv using normB Bv0 by simp
    define c where "c = (1 / norm1 (B *v v))"
    have c: "c > 0" unfolding c_def using normB by auto
    {
      fix i
      have 1: "f v $ i \<ge> 0" unfolding fv c_def[symmetric] using c ge
        by (auto simp: matrix_vector_mult_def sum_distrib_left B_norm intro!: sum_nonneg)
      have id1: "\<And> i. (B *v f v) $ i = c * ((B *v (B *v v)) $ i)"
        unfolding f_def c_def matrix_vect_scaleR by simp
      have id3: "\<And> i. sr * f v $ i = c * ((B *v (sr *\<^sub>R v)) $ i)"
        unfolding f_def c_def[symmetric] matrix_vect_scaleR by auto
      have 2: "sr * f v $ i \<le> (B *v f v) $ i" unfolding id1 id3
        unfolding real_mult_le_cancel_iff2[OF \<open>c > 0\<close>]
        by (rule mult_B_mono, insert ge(2), auto)
      note 1 2
    }
    with norm have "f v \<in> S" unfolding S_def by auto
  }
  thus ?thesis by blast
qed

private lemma cont_f: "continuous_on S f"
  unfolding f_def[abs_def] continuous_on using normB_S
  unfolding norm1_def
  by (auto intro!: tendsto_eq_intros)

qualified lemma perron_frobenius_positive_ev:
  "\<exists> v. eigen_vector A v (r sr) \<and> real_non_neg_vec v"
proof -
  from brouwer[OF compactS convexS non_emptyS cont_f image_f]
    obtain v where v: "v \<in> S" and fv: "f v = v" by auto
  define ev where "ev = norm1 (B *v v)"
  from normB_S[OF v] have "ev \<noteq> 0" unfolding ev_def by auto
  with norm1_ge_0[of "B *v v", folded ev_def] have norm: "ev > 0" by auto
  from arg_cong[OF fv[unfolded f_def], of "\<lambda> (w :: real ^ 'n). ev *\<^sub>R w"] norm
  have ev: "B *v v = ev *s v" unfolding ev_def[symmetric] scalar_mult_eq_scaleR by simp
  with v[unfolded S_def] have ge: "\<And> i. sr * v $ i \<le> ev * v $ i" by auto
  have "A *v rv v = rv (B *v v)" unfolding rv_mult ..
  also have "\<dots> = ev *s rv v" unfolding ev vec_eq_iff
    by (simp add: scaleR_conv_of_real scaleR_vec_def)
  finally have ev: "A *v rv v = ev *s rv v" .
  from v have v0: "v \<noteq> 0" unfolding S_def by auto
  hence "rv v \<noteq> 0" unfolding rv_0 .
  with ev have ev: "eigen_vector A (rv v) ev" unfolding eigen_vector_def by auto
  hence "eigen_value A ev" unfolding eigen_value_def by auto
  from spectral_radius_max[OF this] have le: "norm (r ev) \<le> sr" .
  from v0 obtain i where "v $ i \<noteq> 0" unfolding vec_eq_iff by auto
  from v have "v $ i \<ge> 0" unfolding S_def by auto
  with \<open>v $ i \<noteq> 0\<close> have "v $ i > 0" by auto
  with ge[of i] have ge: "sr \<le> ev" by auto
  with le have sr: "r sr = ev" by auto
  from v have *: "real_non_neg_vec (rv v)" unfolding S_def real_non_neg_vec_def vec_elements_h_def by auto
  show ?thesis unfolding sr
    by (rule exI[of _ "rv v"], insert * ev norm, auto)
qed
end

qualified lemma perron_frobenius_both:
  "\<exists> v. eigen_vector A v (r sr) \<and> real_non_neg_vec v"
proof (cases "\<forall> v \<in> S. A *v rv v \<noteq> 0")
  case True
  show ?thesis
    by (rule Perron_Frobenius.perron_frobenius_positive_ev[OF rnnA], insert True, auto)
next
  case False
  then obtain v where v: "v \<in> S" and A0: "A *v rv v = 0" by auto
  hence id: "A *v rv v = 0 *s rv v" and v0: "v \<noteq> 0" unfolding S_def by auto
  from v0 have "rv v \<noteq> 0" unfolding rv_0 .
  with id have ev: "eigen_vector A (rv v) 0" unfolding eigen_vector_def by auto
  hence "eigen_value A 0" unfolding eigen_value_def ..
  from spectral_radius_max[OF this] have 0: "0 \<le> sr" by auto
  from v[unfolded S_def] have ge: "\<And> i. sr * v $ i \<le> (B *v v) $ i" by auto
  from v[unfolded S_def] have rnn: "real_non_neg_vec (rv v)"
    unfolding real_non_neg_vec_def vec_elements_h_def by auto
  from v0 obtain i where "v $ i \<noteq> 0" unfolding vec_eq_iff by auto
  from v have "v $ i \<ge> 0" unfolding S_def by auto
  with \<open>v $ i \<noteq> 0\<close> have vi: "v $ i > 0" by auto
  from rv_mult[of v, unfolded A0] have "rv (B *v v) = 0" by simp
  hence "B *v v = 0" unfolding rv_0 .
  from ge[of i, unfolded this] vi have ge: "sr \<le> 0" by (simp add: mult_le_0_iff)
  with \<open>0 \<le> sr\<close> have "sr = 0" by auto
  show ?thesis unfolding \<open>sr = 0\<close> using rnn ev by auto
qed
end

text \<open>Perron Frobenius: The largest complex eigenvalue of a real-valued non-negative matrix
  is a real one, and it has a real-valued non-negative eigenvector.\<close>

lemma perron_frobenius:
  assumes "real_non_neg_mat A"
  shows "\<exists>v. eigen_vector A v (of_real (spectral_radius A)) \<and> real_non_neg_vec v"
  by (rule Perron_Frobenius.perron_frobenius_both[OF assms])

text \<open>And a version which ignores the eigenvector.\<close>

lemma perron_frobenius_eigen_value:
  assumes "real_non_neg_mat A"
  shows "eigen_value A (of_real (spectral_radius A))"
  using perron_frobenius[OF assms] unfolding eigen_value_def by blast

end