header{* Preliminaries *}
theory Preliminaries
imports "~~/src/HOL/Cardinals/Cardinals"
        "~~/src/HOL/Library/Countable_Set_Type"
begin

subsection {* Miscelanea *}

text{* A fixed countable universe for interpreting countable models:  *}

datatype univ = UU nat

lemma infinite_univ[simp]: "infinite (UNIV :: univ set)"
unfolding infinite_iff_card_of_nat card_of_ordLeq[symmetric]
unfolding inj_on_def by auto

lemma countable_univ[simp]: "countable (UNIV :: univ set)"
unfolding countable_card_of_nat apply(rule surj_imp_ordLeq[of _ UU])
by (metis subset_UNIV surj_def univ.exhaust)

text{* Picking an element from a nonempty set (Hilbert choice for sets): *}

definition "pick X \<equiv> SOME x. x \<in> X"

lemma pick[simp]: "x \<in> X \<Longrightarrow> pick X \<in> X"
unfolding pick_def by (metis someI_ex)

lemma pick_NE[simp]: "X \<noteq> {} \<Longrightarrow> pick X \<in> X" by auto

definition sappend (infix "@@" 60) where
"Al @@ Bl = {al @ bl | al bl. al \<in> Al \<and> bl \<in> Bl}"

lemma sappend_NE[simp]: "A @@ B \<noteq> {} \<longleftrightarrow> A \<noteq> {} \<and> B \<noteq> {}"
unfolding sappend_def by auto

abbreviation fst3 :: "'a * 'b * 'c \<Rightarrow> 'a" where "fst3 abc \<equiv> fst abc"
abbreviation "snd3 abc \<equiv> fst (snd abc)"
abbreviation "trd3 abc \<equiv> snd (snd abc)"

hide_const int

abbreviation "any \<equiv> undefined"

text{* Non-emptyness of predicates: *}

abbreviation (input) "NE \<phi> \<equiv> \<exists> a. \<phi> a"

lemma NE_NE: "NE NE"
apply(rule exI[of _ "\<lambda> a. True"]) by auto

lemma length_Suc_0:
"length al = Suc 0 \<longleftrightarrow> (\<exists> a. al = [a])"
by (metis (lifting) length_0_conv length_Suc_conv)

subsection{* List combinators *}

lemmas list_all2_length = list_all2_conv_all_nth
lemmas list_eq_iff = list_eq_iff_nth_eq
lemmas list_all_iff
lemmas list_all_length

definition "singl a = [a]"

lemma length_singl[simp]: "length (singl a) = Suc 0"
unfolding singl_def by simp

lemma hd_singl[simp]: "hd (singl a) = a"
unfolding singl_def by simp

lemma hd_o_singl[simp]: "hd o singl = id"
unfolding comp_def fun_eq_iff by simp

lemma singl_hd[simp]: "length al = Suc 0 \<Longrightarrow> singl (hd al) = al"
unfolding singl_def by (cases al, auto)

lemma singl_inj[simp]: "singl a = singl b \<longleftrightarrow> a = b"
unfolding singl_def by simp

(* The list of a finite set: *)
definition "list A \<equiv> SOME al. distinct al \<and> set al = A"

lemma distinct_set_list:
"finite A \<Longrightarrow> distinct (list A) \<and> set (list A) = A"
unfolding list_def apply(rule someI_ex) using finite_distinct_list by auto

lemmas distinct_list[simp] = distinct_set_list[THEN conjunct1]
lemmas set_list[simp] = distinct_set_list[THEN conjunct2]

lemma set_list_set[simp]: "set (list (set xl)) = set xl" by auto

lemma length_list[simp]: "finite A \<Longrightarrow> length (list A) = card A"
by (metis assms distinct_card distinct_set_list)

lemma list_all_mp[elim]:
assumes "list_all (\<lambda> a. \<phi> a \<longrightarrow> \<psi> a) al" and "list_all \<phi> al"
shows "list_all \<psi> al"
using assms unfolding list_all_iff by auto

lemma list_all_map:
"list_all \<phi> (map f al) = list_all (\<phi> o f) al"
by (metis (no_types) length_map list_all_length nth_map o_def)

lemma list_Emp[simp]: "list {} = []"
by (metis set_empty2 set_list_set)

lemma distinct_set_eq_Singl[simp]: "distinct al \<Longrightarrow> set al = {a} \<longleftrightarrow> al = [a]"
apply(cases al, simp)
by (metis (lifting) List.set_simps distinct.simps
           distinct_singleton empty_not_insert insert_eq_iff set_empty2)

lemma list_Singl[simp]: "list {b} = [b]"
unfolding list_def apply(rule some_equality) by auto

lemma list_insert:
assumes A: "finite A" and b: "b \<notin> A"
shows
"\<exists> al1 al2.
   A = set (al1 @ al2) \<and> distinct (al1 @ [b] @ al2) \<and>
   list (insert b A) = al1 @ [b] @ al2"
proof-
  have "b \<in> set (list (insert b A))" using A by auto
  then obtain al1 al2 where 0: "list (insert b A) = al1 @ [b] @ al2"
  by (metis append_Cons eq_Nil_appendI split_list_last)
  hence 1: "distinct (al1 @ [b] @ al2)" using A
  by (metis distinct_set_list finite_insert)
  hence "b \<notin> set (al1 @ al2)" by simp
  moreover have "insert b A = insert b (set (al1 @ al2))"
  using 0 set_list[OF finite.insertI[OF A, of b]] by auto
  ultimately have "A = set (al1 @ al2)" using b by auto
  thus ?thesis using 0 1 by auto
qed

lemma list_all_list[simp]:
assumes "finite A" shows "list_all \<phi> (list A) \<longleftrightarrow> (\<forall> a \<in> A. \<phi> a)"
using assms unfolding list_all_iff by simp

lemma list_ex_list[simp]:
"finite A \<Longrightarrow> list_ex \<phi> (list A) = (\<exists>a\<in>A. \<phi> a)"
unfolding list_ex_iff by simp

text{* list update: *}

fun lupd where
"lupd Nil Nil F = F"
|
"lupd (a # al) (b # bl) F = lupd al bl (F(a := b))"
|
"lupd _ _ F = any"

lemma set_lupd:
assumes "a \<in> set al \<or> F1 a = F2 a"
shows "lupd al bl F1 a = lupd al bl F2 a"
using assms apply(induct arbitrary: F1 F2 rule: list_induct2') by auto

lemma lupd_map:
assumes "length al = length bl" and "a1 \<in> set al \<or> G a1 = F (H a1)"
shows "lupd al (map F bl) G a1 = F (lupd al bl H a1)"
using assms apply (induct arbitrary: F G H rule: list_induct2) by auto

definition map2 where
"map2 f xl yl \<equiv> map (split f) (zip xl yl)"

lemma nth_map2[simp]:
assumes "length bl = length al" and "i < length al"
shows "(map2 f al bl) ! i = f (al!i) (bl!i)"
using assms unfolding map2_def by auto

lemma list_all2_Nil_iff:
assumes "list_all2 R xs ys"
shows "xs = [] \<longleftrightarrow> ys = []"
using assms by (cases xs, cases ys) auto

lemma list_all2_NilL[simp]:
"list_all2 R [] ys \<longleftrightarrow> ys = []"
using list_all2_Nil_iff by auto

lemma list_all2_NilR[simp]:
"list_all2 R xs [] \<longleftrightarrow> xs = []"
using list_all2_Nil_iff by auto

lemma list_all2_ConsL:
assumes "list_all2 R (x # xs') ys"
shows "\<exists> y ys'. ys = y # ys' \<and> R x y \<and> list_all2 R xs' ys'"
using assms by(cases ys) auto

lemma list_all2_elimL[elim, consumes 2, case_names Cons]:
assumes xs: "xs = x # xs'" and h: "list_all2 R xs ys"
and Cons: "\<And> y ys'. \<lbrakk>ys = y # ys'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsL assms by metis

lemma list_all2_elimL2[elim, consumes 1, case_names Cons]:
assumes h: "list_all2 R (x # xs') ys"
and Cons: "\<And> y ys'. \<lbrakk>ys = y # ys'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsL assms by metis

lemma list_all2_ConsR:
assumes "list_all2 R xs (y # ys')"
shows "\<exists> x xs'. xs = x # xs' \<and> R x y \<and> list_all2 R xs' ys'"
using assms by(cases xs) auto

lemma list_all2_elimR[elim, consumes 2, case_names Cons]:
assumes ys: "ys = y # ys'" and h: "list_all2 R xs ys"
and Cons: "\<And> x xs'. \<lbrakk>xs = x # xs'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsR assms by metis

lemma list_all2_elimR2[elim, consumes 1, case_names Cons]:
assumes h: "list_all2 R xs (y # ys')"
and Cons: "\<And> x xs'. \<lbrakk>xs = x # xs'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsR assms by metis

lemma ex_list_all2:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<exists>y. f x y"
shows "\<exists> ys. list_all2 f xs ys"
using assms apply(induct xs)
apply fastforce
by (metis set_simps insertCI list_all2_Cons)

lemma list_all2_cong[fundef_cong]:
assumes "xs1 = ys1" and "xs2 = ys2"
and "\<And> i . i < length xs2 \<Longrightarrow> R (xs1!i) (xs2!i) \<longleftrightarrow> R' (ys1!i) (ys2!i)"
shows "list_all2 R xs1 xs2 \<longleftrightarrow> list_all2 R' ys1 ys2"
by (metis assms list_all2_length)

lemma list_all2_o: "list_all2 (P o f) al bl = list_all2 P (map f al) bl"
unfolding list_all2_map1 comp_def ..

lemma set_size_list:
assumes "x \<in> set xs"
shows "f x \<le> size_list f xs"
by (metis assms size_list_estimation' order_eq_refl)

lemma nth_size_list:
assumes "i < length xs"
shows "f (xs!i) \<le> size_list f xs"
by (metis assms nth_mem set_size_list)

lemma list_all2_list_all[simp]:
"list_all2 (\<lambda> x. f) xs ys \<longleftrightarrow>
 length xs = length ys \<and> list_all f ys"
by (metis list_all2_length list_all_length)

lemma list_all2_list_allR[simp]:
"list_all2 (\<lambda> x y. f x) xs ys \<longleftrightarrow>
 length xs = length ys \<and> list_all f xs"
by (metis (lifting) list_all2_length list_all_length)

lemma list_all2_list_all_2[simp]:
"list_all2 f xs xs \<longleftrightarrow> list_all (\<lambda> x. f x x) xs"
unfolding list_all2_iff list_all_iff
by (metis splitD splitI2 zip_same)

lemma list_all2_map_map:
"list_all2 \<phi> (map f Tl) (map g Tl) =
 list_all (\<lambda>T. \<phi> (f T) (g T)) Tl"
unfolding list_all2_map1 list_all2_map2 list_all2_list_all_2 ..

lemma length_map2[simp]:
assumes "length ys = length xs"
shows "length (map2 f xs ys) = length xs"
using assms unfolding map2_def by auto

lemma listAll2_map2I[intro?]:
assumes "length xs = length ys"
and "\<And> i. i < length xs \<Longrightarrow> R (xs!i) (f (xs!i) (ys!i))"
shows "list_all2 R xs (map2 f xs ys)"
apply(rule list_all2I) using assms unfolding set_zip map2_def by auto

(*
lemma listAll2_map2I[intro?]:
assumes "length xs = length ys" and "\<And> x y. R x (f x y)"
shows "list_all2 R xs (map2 f xs ys)"
apply(rule list_all2I) using assms unfolding set_zip map2_def by auto
*)

lemma set_incl_pred:
"A \<le> B \<longleftrightarrow> (\<forall> a. A a \<longrightarrow> B a)"
by (metis predicate1D predicate1I)

lemma set_incl_pred2:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2. A a1 a2 \<longrightarrow> B a1 a2)"
by (metis predicate2I rev_predicate2D)

lemma set_incl_pred3:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2 a3. A a1 a2 a3 \<longrightarrow> B a1 a2 a3)" (is "_ \<longleftrightarrow> ?R")
proof-
  have "A \<le> B \<longleftrightarrow> (\<forall> a1. A a1 \<le> B a1)" by (metis le_funD le_funI)
  also have "... \<longleftrightarrow> ?R" apply(rule iff_allI)
  unfolding set_incl_pred2 ..
  finally show ?thesis .
qed

lemma set_incl_pred4:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2 a3 a4. A a1 a2 a3 a4 \<longrightarrow> B a1 a2 a3 a4)" (is "_ \<longleftrightarrow> ?R")
proof-
  have "A \<le> B \<longleftrightarrow> (\<forall> a1. A a1 \<le> B a1)" by (metis le_funD le_funI)
  also have "... \<longleftrightarrow> ?R" apply(rule iff_allI)
  unfolding set_incl_pred3 ..
  finally show ?thesis .
qed

lemma list_all_mono:
assumes "phi \<le> chi"
shows "list_all phi \<le> list_all chi"
using assms unfolding set_incl_pred list_all_iff by auto

lemma list_all2_mono:
assumes "phi \<le> chi"
shows "list_all2 phi \<le> list_all2 chi"
using assms by (metis (full_types) list_all2_mono set_incl_pred2)

subsection{* Variables *}

text{* The type of variables: *}

datatype var = Variable nat

lemma card_of_var: "|UNIV::var set| =o natLeq"
proof-
  have "|UNIV::var set| =o |UNIV::nat set|"
  apply(rule ordIso_symmetric,rule card_of_ordIsoI)
  unfolding bij_betw_def inj_on_def surj_def using var.exhaust by auto
  also have "|UNIV::nat set| =o natLeq" by(rule card_of_nat)
  finally show ?thesis .
qed

lemma infinite_var[simp]: "infinite (UNIV :: var set)"
using card_of_var by (rule ordIso_natLeq_infinite1)

lemma countable_var: "countable (UNIV :: var set)"
proof-
  have 0: "(UNIV :: var set) \<noteq> {}" by simp
  show ?thesis unfolding countable_card_of_nat unfolding card_of_ordLeq2[symmetric, OF 0]
  apply(rule exI[of _ Variable]) unfolding image_def apply auto by (case_tac x, auto)
qed

(* FIXME: Move into Countable_Set *)
lemma countable_infinite:
assumes A: "countable A" and B: "infinite B"
shows "|A| \<le>o |B|"
proof-
  have "|A| \<le>o natLeq" using A unfolding countable_card_le_natLeq .
  also have "natLeq \<le>o |B|" by (metis B infinite_iff_natLeq_ordLeq)
  finally show ?thesis .
qed

(* Partitioning V in two infinite disjoint sets *)
definition "part12_pred V V1_V2 \<equiv>
 V = fst V1_V2 \<union> snd V1_V2 \<and> fst V1_V2 \<inter> snd V1_V2 = {} \<and>
 infinite (fst V1_V2) \<and> infinite (snd V1_V2)"

definition "part12 V \<equiv> SOME V1_V2. part12_pred V V1_V2"
definition "part1 = fst o part12"  definition "part2 = snd o part12"

lemma part12_pred:
assumes "infinite (V::'a set)"  shows "\<exists> V1_V2. part12_pred V V1_V2"
proof-
  obtain f :: "nat \<Rightarrow> 'a" where f: "inj f" and r: "range f \<subseteq> V"
  using assms by (metis infinite_iff_countable_subset)
  let ?u = "\<lambda> k::nat. 2 * k"  let ?v = "\<lambda> k::nat. Suc (2 * k)"
  let ?A = "?u ` UNIV"  let ?B = "?v ` UNIV"
  have 0: "inj ?u \<and> inj ?v" unfolding inj_on_def by auto
  hence 1: "infinite ?A \<and> infinite ?B" using finite_imageD by auto
  let ?V1 = "f ` ?A"  let ?V2 = "V - ?V1"
  have "V = ?V1 \<union> ?V2 \<and> ?V1 \<inter> ?V2 = {}" using r by blast
  moreover have "infinite ?V1" using 1 f
  by (metis finite_imageD subset_inj_on top_greatest)
  moreover
  {have "infinite (f ` ?B)" using 1 f
   by (metis finite_imageD subset_inj_on top_greatest)
   moreover have "f ` ?B \<subseteq> ?V2" using r f by (auto simp: inj_eq) arith
   ultimately have "infinite ?V2" by (metis infinite_super)
  }
  ultimately show ?thesis unfolding part12_pred_def
  by (intro exI[of _ "(?V1,?V2)"]) auto
qed

lemma part1_Un_part2: "infinite V \<Longrightarrow> part1 V \<union> part2 V = V"
using part12 unfolding part1_def part2_def part12_pred_def by auto

lemma part1_Int_part2: "infinite V \<Longrightarrow> part1 V \<inter> part2 V = {}"
using part12 unfolding part1_def part2_def part12_pred_def by auto

lemma infinite_part1: "infinite V \<Longrightarrow> infinite (part1 V)"
using part12 unfolding part1_def part12_pred_def by auto

lemma part1_su: "infinite V \<Longrightarrow> part1 V \<subseteq> V"
using part1_Un_part2 by auto

lemma infinite_part2: "infinite V \<Longrightarrow> infinite (part2 V)"
using part12 unfolding part2_def part12_pred_def by auto

lemma part2_su: "infinite V \<Longrightarrow> part2 V \<subseteq> V"
using part1_Un_part2 by auto

end


theory Nielson_Examples
imports Nielson_VCG
begin

subsubsection \<open>example\<close>

lemma "\<turnstile>\<^sub>1 {%l s. True} SKIP;; SKIP { %s. 1 \<Down> %l s. True}"
proof -
 let ?T = "%l s. True"
 have "\<turnstile>\<^sub>1 {%l s. True} strip (Aconseq ?T ?T (%s. 1) (Aseq Askip Askip)) { %s. 1 \<Down> %l s. True}"
   apply(rule vc_sound'') by auto
 then show ?thesis by simp
qed

lemma "finite (support P) \<Longrightarrow> \<turnstile>\<^sub>1 {P} strip Askip {time Askip \<Down> P}"
  apply(rule vc_sound')
      apply(simp)
     apply(simp)
    apply(simp)
   apply(simp)  done

lemma support_single2: "support (\<lambda>l s. P s) = {}"
  unfolding support_def by fastforce

lemma "\<turnstile>\<^sub>1 { %l s. True } strip (Aassign a (N 1)) {time (Aassign a (N 1)) \<Down> %l s. s a = 1}"
  apply(rule vc_sound')
      apply(simp_all add: support_single2)  done

lemma "\<turnstile>\<^sub>1 { %l s. True } strip ( (a ::= (N 1)) ;; Askip ) {time ( (a ::= (N 1)) ;; Askip ) \<Down> %l s. s a = 1}"
  apply(rule vc_sound')
      apply(simp_all add: support_single2) done

lemma "\<turnstile>\<^sub>1 { %l s. True } strip ( (a ::= (N 1)) ;; b ::= (V a) ) {time ( (a ::= (N 1)) ;; b ::= (V a) ) \<Down> %l s. s b = 1}"
  apply(rule vc_sound')
  by(simp_all add: support_single2)

lemma assumes
  E: "E = (%s. 1 + 2 * (4 - nat (s a)))" and
  C: "C = ({(I,(S,(E)))} WHILE Less (V a) (N 3) DO a ::= Plus (V a) (N 1) )"
shows "\<And>s. 0 \<le> s a \<Longrightarrow> time C s \<le> 9"
  unfolding C E apply(simp) done

paragraph "Count up to 3"

lemma example_count_upto_3: assumes
  I: "I = (%l s. s a \<ge> 0)" and
  E: "E = (%s. 1 + 2 * (4 - nat (s a)))" and
  S: "S = (%s. (if s a \<ge> 3 then s else s(a:=3) ))" and
  C: "C = ({(I,(S,(E)))} WHILE Less (V a) (N 3) DO a ::= Plus (V a) (N 1) )"
shows "\<turnstile>\<^sub>1 { %l s. 0 \<le> s a } strip C {time C \<Down> %l s. True }"
  unfolding C
  apply(rule vc_sound')
  subgoal
    apply(simp)
    apply(safe)
    subgoal unfolding I by simp
    subgoal unfolding I E by simp
    subgoal unfolding S by auto
    subgoal unfolding I E by auto
    subgoal unfolding I S by auto
    done
  subgoal
    by simp
  subgoal
    unfolding I  by(simp add: support_inv)
  subgoal unfolding I by simp
  done

paragraph "Count up to b"

lemma example_count_upto_b: assumes
  I: "I = (%l s. s a \<ge> 0 )" and
  E: "E = (%s. 1 + 2 * ((nat b+1) - nat (s a)))" and
  S: "S = (%s. (if s a \<ge> b then s else s(a:=b) ))" and
  C: "C = ({(I,(S,(E)))} WHILE Less (V a) (N b) DO a ::= Plus (V a) (N 1) )"
shows "\<turnstile>\<^sub>1 { %l s. 0 \<le> s a } strip C {time C \<Down> %l s. True }"
  unfolding C
  apply(rule vc_sound') by(auto simp: I E S support_inv)

paragraph " Example: multiplication by repeated addition"

lemma helper: "(A::int) * B + B = (A+1) * B" by(auto simp: distrib_right)

lemma mult: assumes
  I: "I = (%l s. s ''a'' \<ge> 0 \<and> s ''a'' \<ge> s ''z'' \<and> s ''z'' \<ge> 0  \<and> s ''y'' =  s ''z'' * (s ''b'')  )" and
  E: "E = (%s. 1 + 3 * ((nat (s ''a'') + 1) - nat (s ''z'')))" and
  S: "S = (%s. (if s ''z'' \<ge> s ''a'' then s else s(''y'':=(s ''a'') * (s ''b''), ''z'':=s ''a''  ) ))" and
  C: "C = (''y'' ::= (N 0);; ''z'' ::= (N 0) ;; {(I,(S,(E)))}  WHILE Less (V ''z'') (V ''a'') DO (''y'' ::= Plus (V ''y'') (V ''b'') ;; ''z'' ::= Plus (V ''z'') (N 1)) )" and
  f: "f = (%s. 3 * (nat(s ''a'') + 2))"
shows "\<turnstile>\<^sub>1 { %l s. 0 \<le> s ''a''  } strip C { f \<Down> %l s. s ''y'' = s ''a'' * (s ''b'') }"
  unfolding C
  apply(rule vc_sound'')
     apply(auto simp: I E S distrib_right support_inv f)
  subgoal for s by (auto simp add: helper)
  done

(* try to use abstraction *)
lemma mult_abstract: assumes
  I: "I = (%l s. s ''a'' \<ge> 0 \<and> s ''a'' \<ge> s ''z'' \<and> s ''z'' \<ge> 0  \<and> s ''y'' =  s ''z'' * (s ''b'')  )" and
  E: "E = (%s. 1 + 2* ((nat (s ''a'') + 1) - nat (s ''z'')))" and
  S: "S = (%s. (if s ''z'' \<ge> s ''a'' then s else s(''y'':=(s ''a'') * (s ''b''), ''z'':=s ''a''  ) ))" and
  e: "e = (%s. 1)" and
  lb[simp]: "(lb::acom) = ({\<lambda>l s. I l s \<and> s ''z'' < s ''a''  /I/e} CONSEQ (''y'' ::= Plus (V ''y'') (V ''b'') ;; ''z'' ::= Plus (V ''z'') (N 1)) )" and
  l[simp]: "(l::acom) = {(I,(S,(E)))}  WHILE  (Less (V ''z'') (V ''a'')) DO lb" and
  e'[simp]: "e' = (%s. 1 + (nat (s ''a'')))" and
  wl[simp]: "(wl::acom) = {I/\<lambda>l s. I l s \<and> s ''z'' \<ge> s ''a''/e'} CONSEQ l" and
  C: "(C::acom) = (''y'' ::= (N 0);; ''z'' ::= (N 0) ;; wl )" and
  f: "f = (%s. nat(s ''a'') + 1)"
shows "\<turnstile>\<^sub>1 { %l s. 0 \<le> s ''a''  } strip (  {%l s. 0 \<le> s ''a''/ %l s. s ''y'' = s ''a'' * (s ''b'')/ f} CONSEQ C) { f \<Down> %l s. s ''y'' = s ''a'' * (s ''b'') }"
  unfolding C
  apply(rule vc_sound'')
     apply(auto simp: I E S distrib_right support_inv f e)
  subgoal for s by (auto simp add: helper)
    apply(rule exI[where x=100]) apply auto
    apply(rule exI[where x=100]) apply auto
  done

paragraph \<open>Example: nested loops\<close>

lemma nested: assumes
    I2: "I2 = (%l s. s ''a'' \<ge> 0 \<and> s ''b'' \<ge> 0  \<and> s ''a'' >  s ''z''  \<and> s ''z'' \<ge> 0 \<and>   s ''b'' \<ge> s ''g'' \<and> s ''g'' \<ge> 0  \<and> s ''y'' = (s ''z'')  * (s ''b'') + s ''g''  )" and

  I1: "I1 = (%l s. s ''a'' \<ge> 0 \<and> s ''b'' \<ge> 0 \<and> s ''a'' \<ge>  s ''z'' \<and> s ''z'' \<ge> 0  \<and> s ''y'' =  s ''z'' * (s ''b'')  )" and

  E2: "E2 = (%s. 1 + 3 * ((nat (s ''b'') ) - nat (s ''g'')))" and
  S2: "S2 = (%s. (if s ''g'' \<ge> s ''b'' then s else s(''y'':=(s ''z'')  * (s ''b'') + s ''b'' , ''g'':=s ''b''  ) ))" and

  E1: "E1 = (%s. 1 + ( 4 + (3 * ((nat (s ''b'')  ))) ) * ((nat (s ''a'') ) - nat (s ''z'')))" and
  S1: "S1 = (%s. (if s ''z'' \<ge> s ''a'' then s else s(''y'':=(s ''a'') * (s ''b''), ''z'':=s ''a'', ''g'':=s ''b''  ) ))" and
  C: "C = (''y'' ::= (N 0);;
  ''z'' ::= (N 0) ;;
  {(I1,(S1,(E1)))}  WHILE Less (V ''z'') (V ''a'') DO
  (
  ''g'' ::= (N 0) ;;
  (
  {(I2,(S2,(E2)))}  WHILE Less (V ''g'') (V ''b'') DO
  (''y'' ::= Plus (V ''y'') (N 1);;
  ''g'' ::= Plus (V ''g'') (N 1))

  ) ;;
  ''z'' ::= Plus (V ''z'') (N 1))
  )" and
  f: "f = (%s. 3 + 4*nat(s ''a'')+ 3 * (nat(s ''a'') * nat(s ''b'')))"
shows "\<turnstile>\<^sub>1 { %l s. 0 \<le> s ''a'' \<and> s ''b'' \<ge> 0  } strip C { f \<Down> %l s. s ''y'' = s ''a'' * (s ''b'') }"
  unfolding C
  apply(rule vc_sound'')
proof( goal_cases)
  case 1
  show ?case   apply(simp)
  proof(safe, goal_cases)
    case (1 l s) (* outer loop: invariant implies precondition of body *)
    from 1 show ?case unfolding I1 unfolding I2   by(auto )
  next
    case (2 l s) (* outer loop:  E1 is correct *)
    then show ?case unfolding I1 S2  apply(auto) unfolding E2 apply(simp) unfolding E2   apply(auto)
      unfolding E1 apply(simp)

      apply(simp)
    proof (goal_cases)
      case 1
      then have g: "s ''a'' > s ''z''" by linarith
      then have p: "(nat (s ''a'') - nat (s ''z'' + 1)) = (nat (s ''a'') - nat (s ''z'')) - 1" and z: "(nat (s ''a'') - nat (s ''z'')) \<ge> 1"
        using "1" apply linarith
        using g 1 by linarith

      have "Suc (Suc (Suc (Suc ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'' + 1)) + 3 * nat (s ''b''))))) =
        4 + ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'' + 1)) + 3 * nat (s ''b''))
        " by auto
      also
      have "\<dots> = 4 + ( (4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'')) - (4 + 3 * nat (s ''b''))  + 3 * nat (s ''b''))"
        apply(simp only: p)
      proof -
        have "\<And>n na. (n::nat) * na - n = n * (na - 1)"
          by (simp add: diff_mult_distrib2)
        then show "4 + ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'') - 1) + 3 * nat (s ''b'')) = 4 + ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'')) - (4 + 3 * nat (s ''b'')) + 3 * nat (s ''b''))"
          by presburger
      qed
      also
      have "\<dots> = (4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z''))"
        using z
        by (smt \<open>4 + ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'' + 1)) + 3 * nat (s ''b'')) = 4 + ((4 + 3 * nat (s ''b'')) * (nat (s ''a'') - nat (s ''z'')) - (4 + 3 * nat (s ''b'')) + 3 * nat (s ''b''))\<close> add.left_commute diff_add distrib_left mult.right_neutral p)

      finally show ?case by simp
    qed

  next
    case (3 l s)  (* outer loop: S is preserved *)
    { fix i :: int assume "0 \<le> i" then have "int (\<Sum>{0..<nat i}) + i = int (\<Sum>{0..nat i})"
        by (simp add: sum.last_plus)    } note bla=this
    from 3 show ?case unfolding I1 S1 S2  apply(auto simp add:  )
    proof (goal_cases)
      case 1
      then have a: "s ''a'' =  s ''z'' + 1" by linarith
      show ?case apply(simp only: a) using 1
        by (simp add: distrib_left mult.commute fun_upd_twist)
    qed
  next
    case (4 l s) (* outer loop: post condition is correct after exiting the loop *)
    then show ?case unfolding I1  by (auto)
  next
    case (5 l s) (* outer loop: time expression is correct after exiting the loop *)
    then show ?case unfolding I1 E1 by auto
  next
    case (6 l s) (* outer loop: S correct if loop guard not fullfilled *)
    then show ?case unfolding I1 S1 by(simp)

  next
    case (7 l s)  (* inner loop: invariant for >0 implies loop guard *)
    then show ?case unfolding I2 apply(simp) done
  next
    case (8 l s) (* inner loop:  E1 is correct *)
    then show ?case unfolding I2    apply(auto) unfolding  E2  by(auto)
  next
    case (9 l s)  (* inner loop: S is preserved *)
    { fix i :: int assume "0 \<le> i" then have "int (\<Sum>{0..<nat i}) + i = int (\<Sum>{0..nat i})"
        by (simp add: sum.last_plus)    } note bla=this
    from 9 show ?case unfolding I2   S2  apply(auto simp add:  ) done
  next
    case (10 l s) (* inner loop: post condition is correct after exiting the loop *)
    then show ?case unfolding I2 I1 by (auto simp add: distrib_left mult.commute)
  next
    case (11 l s) (* inner loop: time expression is correct after exiting the loop *)
    then show ?case unfolding I2 E2 by (simp)
  next
    case (12 l s) (* inner loop: S correct if loop guard not fullfilled *)
    then show ?case unfolding I2 S2 by(simp)
  qed
next
  case 2
  show ?case apply (rule exI[where x=1]) by (auto simp add: I1 C E1 f distrib_left mult.commute)
qed (auto simp: I1 I2 support_single2)

paragraph "with logical variables"

lemma fin_sup_single: "finite (support (\<lambda>l. P (l a)))"
  apply(rule finite_subset[OF support_single]) by simp

lemmas fin_support = fin_sup_single

lemma finite_support_and: "finite (support A) \<Longrightarrow> finite (support B) \<Longrightarrow> finite (support (\<lambda>l s. A l s \<and> B l s))"
  apply(rule finite_subset[OF support_and]) by blast

end


(*
    Title:      Matrix_To_IArray.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Matrices as nested IArrays\<close>

theory Matrix_To_IArray
imports
  Rank_Nullity_Theorem.Mod_Type
  Elementary_Operations
  IArray_Addenda
begin

subsection\<open>Isomorphism between matrices implemented by vecs and matrices implemented by iarrays\<close>

subsubsection\<open>Isomorphism between vec and iarray\<close>

definition vec_to_iarray :: "'a^'n::{mod_type} \<Rightarrow> 'a iarray"
  where "vec_to_iarray A = IArray.of_fun (\<lambda>i. A $ (from_nat i)) (CARD('n))"

definition iarray_to_vec :: "'a iarray \<Rightarrow> 'a^'n::{mod_type}"
  where "iarray_to_vec A = (\<chi> i. A !! (to_nat i))"

(*
definition iarray_to_vec_option :: "'a iarray \<Rightarrow> ('a^'n::{mod_type}) option"
where "iarray_to_vec_option A = (if (IArray.length A) = CARD('n)
                                    then Some (\<chi> i::'n. A!!(to_nat i))
                                    else None)"
*)

lemma vec_to_iarray_nth:
  fixes A::"'a^'n::{finite, mod_type}"
  assumes i: "i<CARD('n)"
  shows "(vec_to_iarray A) !! i = A $ (from_nat i)"
  unfolding vec_to_iarray_def using of_fun_nth[OF i] .

lemma vec_to_iarray_nth':
  fixes A::"'a^'n::{mod_type}"
  shows "(vec_to_iarray A) !! (to_nat i) = A $ i"
proof -
  have to_nat_less_card: "to_nat i<CARD('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by fastforce
  show ?thesis unfolding vec_to_iarray_def unfolding of_fun_nth[OF to_nat_less_card] from_nat_to_nat_id ..
qed

lemma iarray_to_vec_nth:
  shows "(iarray_to_vec A) $ i = A !! (to_nat i)"
  unfolding iarray_to_vec_def by simp

lemma vec_to_iarray_morph:
  fixes A::"'a^'n::{mod_type}"
  shows "(A = B) = (vec_to_iarray A = vec_to_iarray B)"
  by (metis vec_eq_iff vec_to_iarray_nth')

lemma inj_vec_to_iarray:
  shows "inj vec_to_iarray"
  using vec_to_iarray_morph unfolding inj_on_def by blast

lemma iarray_to_vec_vec_to_iarray:
  fixes A::"'a^'n::{mod_type}"
  shows "iarray_to_vec (vec_to_iarray A)=A"
proof (unfold vec_to_iarray_def iarray_to_vec_def, vector, auto)
  fix i::'n
  have "to_nat i<CARD('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by auto
  thus "map (\<lambda>i. A $ from_nat i) [0..<CARD('n)] ! to_nat i = A $ i" by simp
qed

lemma vec_to_iarray_iarray_to_vec:
  assumes length_eq: "IArray.length A = CARD('n::{mod_type})"
  shows "vec_to_iarray (iarray_to_vec A::'a^'n::{mod_type}) = A"
proof (unfold vec_to_iarray_def iarray_to_vec_def, vector, auto)
  obtain xs where xs: "A = IArray xs" by (metis iarray.exhaust)
  show "IArray (map (\<lambda>i. IArray.list_of A ! to_nat (from_nat i::'n)) [0..<CARD('n)]) = A"
  proof(unfold xs iarray.inject list_eq_iff_nth_eq, auto)
    show "CARD('n) = length xs" using length_eq unfolding xs by simp
    fix i assume i: "i < CARD('n)"
    show "xs ! to_nat (from_nat i::'n) = xs ! i" unfolding to_nat_from_nat_id[OF i] ..
  qed
qed

lemma length_vec_to_iarray:
  fixes xa::"'a^'n::{mod_type}"
  shows "IArray.length (vec_to_iarray xa) = CARD('n)"
  unfolding vec_to_iarray_def by simp

subsubsection\<open>Isomorphism between matrix and nested iarrays\<close>

definition matrix_to_iarray :: "'a^'n::{mod_type}^'m::{mod_type} => 'a iarray iarray"
  where "matrix_to_iarray A = IArray (map (vec_to_iarray \<circ> (($) A) \<circ> (from_nat::nat=>'m)) [0..<CARD('m)])"

definition iarray_to_matrix :: "'a iarray iarray \<Rightarrow> 'a^'n::{mod_type}^'m::{mod_type}"
  where "iarray_to_matrix A = (\<chi> i j. A !! (to_nat i) !! (to_nat j))"

lemma matrix_to_iarray_morph:
  fixes A::"'a^'n::{mod_type}^'m::{mod_type}"
shows "(A = B) = (matrix_to_iarray A = matrix_to_iarray B)"
  unfolding matrix_to_iarray_def apply simp
  unfolding forall_from_nat_rw[of "\<lambda>x. vec_to_iarray (A $ x) = vec_to_iarray (B $ x)"]
  by (metis from_nat_to_nat_id vec_eq_iff vec_to_iarray_morph)

lemma matrix_to_iarray_eq_of_fun:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  assumes vec_eq_f: "\<forall>i. vec_to_iarray (A $ i) = f (to_nat i)"
  and n_eq_length: "n=IArray.length (matrix_to_iarray A)"
  shows "matrix_to_iarray A = IArray.of_fun f n"
proof (unfold IArray.of_fun_def matrix_to_iarray_def iarray.inject list_eq_iff_nth_eq, auto)
  show *: "CARD('rows) = n" using n_eq_length unfolding matrix_to_iarray_def by auto
  fix i assume i: "i < CARD('rows)"
  hence i_less_n: "i<n" using * i by simp
  show "vec_to_iarray (A $ from_nat i) = map f [0..<n] ! i"
    using vec_eq_f  using i_less_n
    by (simp, unfold to_nat_from_nat_id[OF i], simp)
qed

lemma map_vec_to_iarray_rw[simp]:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<CARD('rows)] ! to_nat i = vec_to_iarray (A $ i)"
proof -
  have i_less_card: "to_nat i < CARD('rows)" using bij_to_nat[where ?'a='rows] unfolding bij_betw_def by fastforce
  hence "map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<CARD('rows)] ! to_nat i = vec_to_iarray (A $ from_nat (to_nat i))" by simp
  also have "... =  vec_to_iarray (A $ i)" unfolding from_nat_to_nat_id ..
  finally show ?thesis .
qed

lemma matrix_to_iarray_nth:
  "matrix_to_iarray A !! to_nat i !! to_nat j = A $ i $ j"
  unfolding matrix_to_iarray_def o_def using vec_to_iarray_nth' by auto

lemma vec_matrix: "vec_to_iarray (A$i) = (matrix_to_iarray A) !! (to_nat i)"
  unfolding matrix_to_iarray_def o_def by fastforce

lemma iarray_to_matrix_matrix_to_iarray:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "iarray_to_matrix (matrix_to_iarray A)=A" unfolding matrix_to_iarray_def iarray_to_matrix_def o_def
  by (vector, auto, metis IArray.sub_def vec_to_iarray_nth')

subsection\<open>Definition of operations over matrices implemented by iarrays\<close>

definition mult_iarray :: "'a::{times} iarray => 'a => 'a iarray"
  where "mult_iarray A q = IArray.of_fun (\<lambda>n. q * A!!n) (IArray.length A)"

definition row_iarray :: "nat => 'a iarray iarray => 'a iarray"
  where "row_iarray k A = A !! k"

definition column_iarray :: "nat => 'a iarray iarray  => 'a iarray"
  where "column_iarray k A = IArray.of_fun (\<lambda>m. A !! m !! k) (IArray.length A)"

definition nrows_iarray :: "'a iarray iarray => nat"
  where "nrows_iarray A = IArray.length A"

definition ncols_iarray :: "'a iarray iarray => nat"
  where "ncols_iarray A = IArray.length (A!!0)"

definition "rows_iarray A = {row_iarray i A | i. i \<in> {..<nrows_iarray A}}"
definition "columns_iarray A = {column_iarray i A | i. i \<in> {..<ncols_iarray A}}"

definition tabulate2 :: "nat => nat => (nat => nat => 'a) => 'a iarray iarray"
  where "tabulate2 m n f = IArray.of_fun (\<lambda>i. IArray.of_fun (f i) n) m"

definition transpose_iarray :: "'a iarray iarray => 'a iarray iarray"
  where "transpose_iarray A =  tabulate2 (ncols_iarray A) (nrows_iarray A) (\<lambda>a b. A!!b!!a)"

definition matrix_matrix_mult_iarray :: "'a::{times, comm_monoid_add} iarray iarray => 'a iarray iarray => 'a iarray iarray"  (infixl "**i" 70)
  where "A **i B = tabulate2 (nrows_iarray A) (ncols_iarray B) (\<lambda>i j. sum (\<lambda>k. ((A!!i)!!k) * ((B!!k)!!j)) {0..<ncols_iarray A})"

definition matrix_vector_mult_iarray :: "'a::{semiring_1} iarray iarray => 'a iarray => 'a iarray" (infixl "*iv" 70)
  where "A *iv x = IArray.of_fun (\<lambda>i. sum (\<lambda>j. ((A!!i)!!j) * (x!!j)) {0..<IArray.length x}) (nrows_iarray A)"

definition vector_matrix_mult_iarray :: "'a::{semiring_1} iarray => 'a iarray iarray => 'a iarray" (infixl "v*i" 70)
  where "x v*i A = IArray.of_fun (\<lambda>j. sum (\<lambda>i. ((A!!i)!!j) * (x!!i)) {0..<IArray.length x}) (ncols_iarray A)"

definition mat_iarray :: "'a::{zero} => nat => 'a iarray iarray"
  where "mat_iarray k n = tabulate2 n n (\<lambda> i j. if i = j then k else 0)"

definition is_zero_iarray :: "'a::{zero} iarray \<Rightarrow> bool"
  where "is_zero_iarray A = IArray.all (\<lambda>i. A !! i = 0) (IArray[0..<IArray.length A])"

subsubsection\<open>Properties of previous definitions\<close>
lemma is_zero_iarray_eq_iff:
  fixes A::"'a::{zero}^'n::{mod_type}"
  shows "(A = 0) = (is_zero_iarray (vec_to_iarray A))"
proof (auto)
  show "is_zero_iarray (vec_to_iarray 0)" by (simp add: vec_to_iarray_def is_zero_iarray_def Option.is_none_def find_None_iff)
  show "is_zero_iarray (vec_to_iarray A) \<Longrightarrow> A = 0"
  proof (simp add: vec_to_iarray_def is_zero_iarray_def Option.is_none_def find_None_iff vec_eq_iff, clarify)
    fix i::'n
    assume "\<forall>i\<in>{0..<CARD('n)}. A $ mod_type_class.from_nat i = 0"
    hence eq_zero: "\<forall>x<CARD('n). A $ from_nat x = 0" by force
    have "to_nat i<CARD('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by fastforce
    hence "A $ (from_nat (to_nat i)) = 0" using eq_zero by blast
    thus "A $ i = 0" unfolding from_nat_to_nat_id .
  qed
qed

lemma mult_iarray_works:
  assumes "a<IArray.length A" shows "mult_iarray A q !! a = q * A!!a"
  unfolding mult_iarray_def
  unfolding IArray.of_fun_def unfolding sub_def
  using assms by simp

lemma length_eq_card_rows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "IArray.length (matrix_to_iarray A) = CARD('rows)"
  unfolding matrix_to_iarray_def by auto

lemma nrows_eq_card_rows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "nrows_iarray (matrix_to_iarray A) = CARD('rows)"
  unfolding nrows_iarray_def length_eq_card_rows ..

lemma length_eq_card_columns:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "IArray.length (matrix_to_iarray A !! 0) = CARD ('columns)"
  unfolding matrix_to_iarray_def o_def vec_to_iarray_def by simp

lemma ncols_eq_card_columns:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "ncols_iarray (matrix_to_iarray A) = CARD('columns)"
  unfolding ncols_iarray_def length_eq_card_columns ..

lemma matrix_to_iarray_nrows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "nrows A = nrows_iarray (matrix_to_iarray A)"
  unfolding nrows_def nrows_eq_card_rows ..

lemma matrix_to_iarray_ncols:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "ncols A = ncols_iarray (matrix_to_iarray A)"
  unfolding ncols_def ncols_eq_card_columns ..

lemma vec_to_iarray_row[code_unfold]: "vec_to_iarray (row i A) = row_iarray (to_nat i) (matrix_to_iarray A)"
  unfolding row_def row_iarray_def vec_to_iarray_def
  by (auto, metis IArray.sub_def IArray.of_fun_def vec_matrix vec_to_iarray_def)

lemma vec_to_iarray_row': "vec_to_iarray (row i A) = (matrix_to_iarray A) !! (to_nat i)"
  unfolding row_def vec_to_iarray_def
  by (auto, metis IArray.sub_def IArray.of_fun_def vec_matrix vec_to_iarray_def)

lemma vec_to_iarray_column[code_unfold]: "vec_to_iarray (column i A) = column_iarray (to_nat i) (matrix_to_iarray A)"
  unfolding column_def vec_to_iarray_def column_iarray_def length_eq_card_rows
   by (auto, metis IArray.sub_def from_nat_not_eq vec_matrix vec_to_iarray_nth')

lemma vec_to_iarray_column':
assumes k: "k<ncols A"
shows "(vec_to_iarray (column (from_nat k) A)) = (column_iarray k (matrix_to_iarray A))"
unfolding vec_to_iarray_column unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] ..

lemma column_iarray_nth:
  assumes i: "i<nrows_iarray A"
  shows "column_iarray j A !! i = A !! i !! j"
  proof -
  have "column_iarray j A !! i = map (\<lambda>m. A !! m !! j) [0..<IArray.length A] ! i"
  unfolding column_iarray_def by auto
  also have "... = (\<lambda>m. A !! m !! j) ([0..<IArray.length A] ! i)" using i nth_map unfolding nrows_iarray_def by auto
  also have "... = (\<lambda>m. A !! m !! j) (i)" using nth_upt[of 0 i "IArray.length A"] i unfolding nrows_iarray_def by simp
  finally show ?thesis .
qed

lemma vec_to_iarray_rows: "vec_to_iarray` (rows A) = rows_iarray (matrix_to_iarray A)"
  unfolding rows_def unfolding rows_iarray_def
  apply (auto simp add: vec_to_iarray_row to_nat_less_card nrows_eq_card_rows)
  by (unfold image_def, auto, metis from_nat_not_eq vec_to_iarray_row)

lemma vec_to_iarray_columns: "vec_to_iarray` (columns A) = columns_iarray (matrix_to_iarray A)"
  unfolding columns_def unfolding columns_iarray_def
  apply(auto simp add: ncols_eq_card_columns to_nat_less_card vec_to_iarray_column)
  by (unfold image_def, auto, metis from_nat_not_eq vec_to_iarray_column)

subsection\<open>Definition of elementary operations\<close>

definition interchange_rows_iarray :: "'a iarray iarray => nat => nat => 'a iarray iarray"
  where "interchange_rows_iarray A a b = IArray.of_fun (\<lambda>n. if n=a then A!!b else if n=b then A!!a else A!!n) (IArray.length A)"

definition mult_row_iarray :: "'a::{times} iarray iarray => nat => 'a => 'a iarray iarray"
  where "mult_row_iarray A a q = IArray.of_fun (\<lambda>n. if n=a then mult_iarray (A!!a) q else A!!n) (IArray.length A)"

definition row_add_iarray :: "'a::{plus, times} iarray iarray => nat => nat => 'a => 'a iarray iarray"
  where "row_add_iarray A a b q = IArray.of_fun (\<lambda>n. if n=a then A!!a + mult_iarray (A!!b) q else A!!n) (IArray.length A)"

definition interchange_columns_iarray :: "'a iarray iarray => nat => nat => 'a iarray iarray"
  where "interchange_columns_iarray A a b =  tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = a then A !! i !! b else if j = b then A !! i !! a else A !! i !! j)"

definition mult_column_iarray :: "'a::{times} iarray iarray => nat => 'a => 'a iarray iarray"
  where "mult_column_iarray A n q = tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = n then A !! i !! j * q else A !! i !! j)"

definition column_add_iarray :: "'a::{plus, times} iarray iarray => nat => nat => 'a => 'a iarray iarray"
  where "column_add_iarray A n m q = tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = n then A !! i !! n + A !! i !! m * q else A !! i !! j)"

subsubsection\<open>Code generator\<close>

lemma vec_to_iarray_plus[code_unfold]: "vec_to_iarray (a + b) =  (vec_to_iarray a) + (vec_to_iarray b)"
  unfolding vec_to_iarray_def
  unfolding plus_iarray_def by auto

lemma matrix_to_iarray_plus[code_unfold]: "matrix_to_iarray (A + B) = (matrix_to_iarray A) + (matrix_to_iarray B)"
  unfolding matrix_to_iarray_def o_def
  by (simp add: plus_iarray_def vec_to_iarray_plus)

lemma matrix_to_iarray_mat[code_unfold]:
  "matrix_to_iarray (mat k ::'a::{zero}^'n::{mod_type}^'n::{mod_type}) = mat_iarray k CARD('n::{mod_type})"
  unfolding matrix_to_iarray_def o_def vec_to_iarray_def mat_def mat_iarray_def tabulate2_def
  using from_nat_eq_imp_eq by fastforce

lemma matrix_to_iarray_transpose[code_unfold]:
shows "matrix_to_iarray (transpose A) = transpose_iarray (matrix_to_iarray A)"
  unfolding matrix_to_iarray_def transpose_def transpose_iarray_def
    o_def tabulate2_def nrows_iarray_def ncols_iarray_def vec_to_iarray_def
  by auto

lemma matrix_to_iarray_matrix_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and B::"'a^'b::{mod_type}^'m::{mod_type}"
  shows "matrix_to_iarray (A ** B) = (matrix_to_iarray A) **i (matrix_to_iarray B)"
  unfolding matrix_to_iarray_def matrix_matrix_mult_iarray_def matrix_matrix_mult_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def vec_to_iarray_def
  using sum.reindex[of "from_nat::nat=>'m"] using bij_from_nat unfolding bij_betw_def by fastforce

lemma vec_to_iarray_matrix_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and x::"'a^'m::{mod_type}"
  shows "vec_to_iarray (A *v x) = (matrix_to_iarray A) *iv (vec_to_iarray x)"
  unfolding matrix_vector_mult_iarray_def matrix_vector_mult_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def matrix_to_iarray_def vec_to_iarray_def
  using sum.reindex[of "from_nat::nat=>'m"] using bij_from_nat unfolding bij_betw_def by fastforce

lemma vec_to_iarray_vector_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and x::"'a^'n::{mod_type}"
  shows "vec_to_iarray (x v* A) = (vec_to_iarray x) v*i (matrix_to_iarray A)"
  unfolding vector_matrix_mult_def vector_matrix_mult_iarray_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def matrix_to_iarray_def vec_to_iarray_def
proof (auto)
  fix xa
  have "(UNIV::'n set) = from_nat `{0..<CARD('n)}"  using bij_from_nat[where ?'a='n] unfolding bij_betw_def by fast
  show "(\<Sum>i\<in>UNIV. A $ i $ from_nat xa * x $ i) = (\<Sum>i = 0..<CARD('n). A $ from_nat i $ from_nat xa * x $ from_nat i)"
  using sum.reindex[of "from_nat::nat=>'n"]  using bij_from_nat[where ?'a='n] unfolding bij_betw_def by force
qed

lemma matrix_to_iarray_interchange_rows[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (interchange_rows A i j) = interchange_rows_iarray (matrix_to_iarray A) (to_nat i) (to_nat j)"
proof (unfold matrix_to_iarray_def interchange_rows_iarray_def o_def map_vec_to_iarray_rw, auto)
  fix x assume x_less_card: "x < CARD('rows)"
    and x_not_j: "x \<noteq> to_nat j" and x_not_i: "x \<noteq> to_nat i"
  show "vec_to_iarray (interchange_rows A i j $ from_nat x) = vec_to_iarray (A $ from_nat x)"
    by (metis interchange_rows_preserves to_nat_from_nat_id x_less_card x_not_i x_not_j)
qed

lemma matrix_to_iarray_mult_row[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (mult_row A i q) = mult_row_iarray (matrix_to_iarray A) (to_nat i) q"
  unfolding matrix_to_iarray_def mult_row_iarray_def o_def
  unfolding mult_iarray_def vec_to_iarray_def mult_row_def apply auto
proof -
  fix i x
  assume i_contr:"i \<noteq> to_nat (from_nat i::'rows)" and "x < CARD('columns)"
    and "i<CARD('rows)"
  hence "i = to_nat (from_nat i::'rows)" using to_nat_from_nat_id by fastforce
  thus "q * A $ from_nat i $ from_nat x = A $ from_nat i $ from_nat x"
    using i_contr by contradiction
qed

lemma matrix_to_iarray_row_add[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (row_add A i j q) = row_add_iarray (matrix_to_iarray A) (to_nat i) (to_nat j) q"
  proof (unfold matrix_to_iarray_def row_add_iarray_def o_def, auto)
  show "vec_to_iarray (row_add A i j q $ i) = vec_to_iarray (A $ i) + mult_iarray (vec_to_iarray (A $ j)) q"
    unfolding mult_iarray_def vec_to_iarray_def unfolding plus_iarray_def row_add_def by auto
  fix ia assume ia_not_i: "ia \<noteq> to_nat i" and ia_card: "ia < CARD('rows) "
  have from_nat_ia_not_i: "from_nat ia \<noteq> i"
  proof (rule ccontr)
    assume "\<not> from_nat ia \<noteq> i" hence "from_nat ia = i" by simp
    hence "to_nat (from_nat ia::'rows) = to_nat i" by simp
    hence "ia=to_nat i" using to_nat_from_nat_id ia_card by fastforce
    thus False  using ia_not_i by contradiction
  qed
  show "vec_to_iarray (row_add A i j q $ from_nat ia) = vec_to_iarray (A $ from_nat ia)"
    using ia_not_i
    unfolding vec_to_iarray_morph[symmetric] unfolding row_add_def using from_nat_ia_not_i by vector
qed

lemma matrix_to_iarray_interchange_columns[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (interchange_columns A i j) = interchange_columns_iarray (matrix_to_iarray A) (to_nat i) (to_nat j)"
  unfolding interchange_columns_def interchange_columns_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id to_nat_less_card[of i] to_nat_less_card[of j])

lemma matrix_to_iarray_mult_columns[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (mult_column A i q) = mult_column_iarray (matrix_to_iarray A) (to_nat i) q"
  unfolding mult_column_def mult_column_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding  matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id)

lemma matrix_to_iarray_column_add[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (column_add A i j q) = column_add_iarray (matrix_to_iarray A) (to_nat i) (to_nat j) q"
  unfolding column_add_def column_add_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding  matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id to_nat_less_card[of i] to_nat_less_card[of j])

end


section\<open>Misc\<close>
theory OpenFlow_Helpers
imports Main
begin

lemma hrule: "(S = UNIV) = (\<forall>x. x \<in> S)"
  by blast

subsection\<open>Single valuedness on lists\<close>

lemma foldr_True_set: "foldr (\<lambda>x. op \<and> (f x)) l True = (\<forall>x \<in> set l. f x)"
  by (induction l) simp_all

fun single_valued_code where
"single_valued_code [] = True" |
"single_valued_code (e#es) = (foldr (\<lambda>x. op \<and> (fst x \<noteq> fst e \<or> snd x = snd e)) es True \<and> single_valued_code es)"
lemma single_valued_code_lam[code_unfold]:
  "single_valued (set r) = single_valued_code r"
proof(induction r)
  case Nil show ?case by simp
next
  case (Cons e es)
  show ?case
  proof (rule iffI, goal_cases fwd bwd)
    case bwd
    have "single_valued (set es)" using Cons.IH conjunct2[OF bwd[unfolded single_valued_code.simps]] ..
    moreover
    have "\<forall>x\<in>set es. fst x \<noteq> fst e \<or> snd x = snd e"
      using conjunct1[OF bwd[unfolded single_valued_code.simps(2)], unfolded foldr_True_set] .
    ultimately
    show ?case unfolding single_valued_def by auto
  next
    case fwd
    have "single_valued (set es)" using fwd unfolding single_valued_def by simp
    with Cons.IH[symmetric] have "single_valued_code es" ..
    moreover
    have "\<forall>x\<in>set es. fst x \<noteq> fst e \<or> snd x = snd e" using fwd unfolding single_valued_def by clarsimp
    from conjI[OF this calculation, unfolded foldr_True_set[symmetric]]
    show ?case unfolding single_valued_code.simps .
  qed
qed

lemma set_Cons: "e \<in> set (a # as) \<longleftrightarrow> (e = a \<or> e \<in> set as)" by simp

subsection\<open>List fun\<close>

lemma sorted_const: "sorted (map (\<lambda>y. x) k)"
	by(induction k) (simp_all add: sorted_Cons)

lemma list_all_map: "list_all f (map g l) = list_all (f \<circ> g) l"
unfolding comp_def by (simp add: list_all_length) (* by(induction l) simp_all *)

lemma distinct_2lcomprI: "distinct as \<Longrightarrow> distinct bs \<Longrightarrow>
	(\<And>a b e i. f a b = f e i \<Longrightarrow> a = e \<and> b = i) \<Longrightarrow>
	distinct [f a b. a \<leftarrow> as, b \<leftarrow> bs]"
  apply(induction as)
   apply(simp;fail)
  apply(clarsimp simp only: distinct.simps simp_thms list.map concat.simps map_append distinct_append)
  apply(rule)
  subgoal
   apply(clarify;fail | subst distinct_map, rule)+
   by (rule inj_onI) simp
  subgoal by fastforce
done

lemma distinct_3lcomprI: "distinct as \<Longrightarrow> distinct bs \<Longrightarrow> distinct cs \<Longrightarrow>
	(\<And>a b c e i g. f a b c = f e i g \<Longrightarrow> a = e \<and> b = i \<and> c = g) \<Longrightarrow>
	distinct [f a b c. a \<leftarrow> as, b \<leftarrow> bs, c \<leftarrow> cs]"
  apply(induction as)
   apply(simp;fail)
  apply(clarsimp simp only: distinct.simps simp_thms list.map concat.simps map_append distinct_append)
  apply(rule)
   apply(rule distinct_2lcomprI; simp_all; fail)
  apply fastforce
done

lemma distinct_fst: "distinct (map fst a) \<Longrightarrow> distinct a" by (metis distinct_zipI1 zip_map_fst_snd)
lemma distinct_snd: "distinct (map snd a) \<Longrightarrow> distinct a" by (metis distinct_zipI2 zip_map_fst_snd)

lemma inter_empty_fst2: "(\<lambda>(p, m, a). (p, m)) ` S \<inter> (\<lambda>(p, m, a). (p, m)) ` T = {} \<Longrightarrow> S \<inter> T = {}" by blast

subsection\<open>Cardinality and Existence of Distinct Members\<close>

lemma card1_eI: "1 \<le> card S \<Longrightarrow> \<exists>y S'. S = {y} \<union> S' \<and> y \<notin> S'"
	by (metis One_nat_def card_infinite card_le_Suc_iff insert_is_Un leD zero_less_Suc)
lemma card2_eI: "2 \<le> card S \<Longrightarrow> \<exists>x y. x \<noteq> y \<and> x \<in> S \<and> y \<in> S"
proof goal_cases
	case (1)
	then have "1 \<le> card S" by simp
	note card1_eI[OF this]
	then obtain x S' where xs: "S = {x} \<union> S' \<and> x \<notin> S'" by presburger
	then have "1 \<le> card S'"
		by (metis 1 Suc_1 card_infinite card_insert_if finite_Un insert_is_Un le0 not_less_eq_eq)
	then obtain y where "y \<in> S'" by fastforce
	then show ?case using xs by force
qed
lemma card3_eI: "3 \<le> card S \<Longrightarrow> \<exists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> S \<and> y \<in> S"
proof goal_cases
  case 1
  then have "2 \<le> card S" by simp
	note card2_eI[OF this]
	then obtain x y S' where xs: "S = {x,y} \<union> S' \<and> x \<notin> S' \<and> y \<notin> S' \<and> x \<noteq> y"
	  by (metis Set.set_insert Un_insert_left insert_eq_iff insert_is_Un)
	then have "1 \<le> card S'"
	  using 1  by (metis One_nat_def Suc_leI Un_insert_left card_gt_0_iff insert_absorb numeral_3_eq_3 singleton_insert_inj_eq card_infinite card_insert_if finite_Un insert_is_Un le0 not_less_eq_eq) (* uuuh *)
	then obtain z where "z \<in> S'" by fastforce
	then show ?case using xs by force
qed

lemma card1_eE: "finite S \<Longrightarrow> \<exists>y. y \<in> S \<Longrightarrow> 1 \<le> card S" using card_0_eq by fastforce
lemma card2_eE: "finite S \<Longrightarrow> \<exists>x y. x \<noteq> y \<and> x \<in> S \<and> y \<in> S \<Longrightarrow> 2 \<le> card S"
using card1_eE card_Suc_eq card_insert_if by fastforce
lemma card3_eE: "finite S \<Longrightarrow> \<exists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> S \<and> y \<in> S \<Longrightarrow> 3 \<le> card S"
using card2_eE card_Suc_eq card_insert_if oops

lemma f_Img_ex_set: "{f x|x. P x} = f ` {x. P x}" by auto

lemma set_maps: "set (List.maps f a) = (\<Union>a\<in>set a. set (f a))"
unfolding List.maps_def set_concat set_map UN_simps(10) ..

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_int_add_inv_right
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

definition(*fun*) zero :: "Integer" where
"zero = P Z"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

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

fun neg :: "Integer => Integer" where
"neg (P (Z)) = P Z"
| "neg (P (S z)) = N z"
| "neg (N n) = P (plus (S Z) n)"

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus2 :: "Integer => Integer => Integer" where
"plus2 (P m) (P n) = P (plus m n)"
| "plus2 (P m) (N o2) = t2 m (plus (S Z) o2)"
| "plus2 (N m2) (P n2) = t2 n2 (plus (S Z) m2)"
| "plus2 (N m2) (N n3) = N (plus (plus (S Z) m2) n3)"

theorem property0 :
  "((plus2 x (neg x)) = zero)"
  oops

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_StoogeSortPermutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort xs) xs"
  oops

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_list_PairOdds
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun pairs :: "'t list => (('t, 't) pair) list" where
"pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((map
       (% (x :: ('a, 'a) pair) => (case x of pair2 y z => z))
       (pairs xs)) =
      (odds xs))"
  oops

end


(*  Title:      HOL/Nunchaku_Examples/Induct_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples featuring Nunchaku applied to (co)inductive definitions.
*)

section {* Examples Featuring Nunchaku Applied to (Co)inductive Definitions *}

theory Induct_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
  "p1 0"
| "p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
  "q1 0"
| "q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nunchaku [expect = none]
nunchaku [wf, expect = none]
nunchaku [non_wf, expect = none]
oops

lemma "p1 \<noteq> q1"
nunchaku [expect = potential]
nunchaku [wf, expect = potential]
nunchaku [non_wf, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nunchaku [expect = genuine]
nunchaku [non_wf, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nunchaku [expect = genuine]
nunchaku [non_wf, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
  "p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
  "q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nunchaku [expect = none]
sorry

lemma "q2 = bot"
nunchaku [expect = genuine]
nunchaku [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nunchaku [expect = genuine]
oops

lemma "q2 = top"
nunchaku [expect = none]
nunchaku [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nunchaku [expect = genuine]
oops

lemma "p2 n"
nunchaku [expect = genuine]
oops

lemma "q2 n"
nunchaku [expect = none]
sorry

lemma "\<not> p2 n"
nunchaku [expect = none]
sorry

lemma "\<not> q2 n"
nunchaku [expect = genuine]
oops

inductive p3 and p4 where
  "p3 0"
| "p3 n \<Longrightarrow> p4 (Suc n)"
| "p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
  "q3 0"
| "q3 n \<Longrightarrow> q4 (Suc n)"
| "q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nunchaku [expect = none]
nunchaku [non_wf, expect = none]
sorry

lemma "p4 = q4"
nunchaku [expect = none]
nunchaku [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nunchaku [expect = none]
nunchaku [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nunchaku [expect = none]
nunchaku [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nunchaku [expect = potential]
nunchaku [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nunchaku [expect = potential]
nunchaku [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nunchaku [expect = potential]
nunchaku [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nunchaku [expect = potential]
nunchaku [non_wf, expect = potential]
sorry

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Irreflexive\<close>
theory SBinary_Relations_Irreflexive
  imports
    Pairs
begin

definition "irreflexive D R \<equiv> \<forall>x \<in> D. \<langle>x, x\<rangle> \<notin> R"

lemma irreflexiveI [intro]:
  assumes "\<And>x. x \<in> D \<Longrightarrow> \<langle>x, x\<rangle> \<notin> R"
  shows "irreflexive D R"
  using assms unfolding irreflexive_def by blast

lemma irreflexiveD:
  assumes "irreflexive D R"
  and "x \<in> D"
  shows "\<langle>x, x\<rangle> \<notin> R"
  using assms unfolding irreflexive_def by blast

end


(*  Title:      HOL/Induct/QuoNestedDataType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2004  University of Cambridge
*)

section\<open>Quotienting a Free Algebra Involving Nested Recursion\<close>

theory QuoNestedDataType imports MainRLT begin

subsection\<open>Defining the Free Algebra\<close>

text\<open>Messages with encryption and decryption as free constructors.\<close>
datatype
     freeExp = VAR  nat
             | PLUS  freeExp freeExp
             | FNCALL  nat "freeExp list"

datatype_compat freeExp

text\<open>The equivalence relation, which makes PLUS associative.\<close>

text\<open>The first rule is the desired equation. The next three rules
make the equations applicable to subterms. The last two rules are symmetry
and transitivity.\<close>
inductive_set
  exprel :: "(freeExp * freeExp) set"
  and exp_rel :: "[freeExp, freeExp] => bool"  (infixl "\<sim>" 50)
  where
    "X \<sim> Y == (X,Y) \<in> exprel"
  | ASSOC: "PLUS X (PLUS Y Z) \<sim> PLUS (PLUS X Y) Z"
  | VAR: "VAR N \<sim> VAR N"
  | PLUS: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> PLUS X Y \<sim> PLUS X' Y'"
  | FNCALL: "(Xs,Xs') \<in> listrel exprel \<Longrightarrow> FNCALL F Xs \<sim> FNCALL F Xs'"
  | SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
  | TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"
  monos listrel_mono

text\<open>Proving that it is an equivalence relation\<close>

lemma exprel_refl: "X \<sim> X"
  and list_exprel_refl: "(Xs,Xs) \<in> listrel(exprel)"
  by (induct X and Xs rule: compat_freeExp.induct compat_freeExp_list.induct)
    (blast intro: exprel.intros listrel.intros)+

theorem equiv_exprel: "equiv UNIV exprel"
proof -
  have "refl exprel" by (simp add: refl_on_def exprel_refl)
  moreover have "sym exprel" by (simp add: sym_def, blast intro: exprel.SYM)
  moreover have "trans exprel" by (simp add: trans_def, blast intro: exprel.TRANS)
  ultimately show ?thesis by (simp add: equiv_def)
qed

theorem equiv_list_exprel: "equiv UNIV (listrel exprel)"
  using equiv_listrel [OF equiv_exprel] by simp

lemma FNCALL_Nil: "FNCALL F [] \<sim> FNCALL F []"
apply (rule exprel.intros)
apply (rule listrel.intros)
done

lemma FNCALL_Cons:
     "\<lbrakk>X \<sim> X'; (Xs,Xs') \<in> listrel(exprel)\<rbrakk>
      \<Longrightarrow> FNCALL F (X#Xs) \<sim> FNCALL F (X'#Xs')"
by (blast intro: exprel.intros listrel.intros)

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Variables\<close>

text\<open>A function to return the set of variables present in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.
Note that the "free" refers to the free datatype rather than to the concept
of a free variable.\<close>
primrec freevars :: "freeExp \<Rightarrow> nat set"
  and freevars_list :: "freeExp list \<Rightarrow> nat set" where
  "freevars (VAR N) = {N}"
| "freevars (PLUS X Y) = freevars X \<union> freevars Y"
| "freevars (FNCALL F Xs) = freevars_list Xs"

| "freevars_list [] = {}"
| "freevars_list (X # Xs) = freevars X \<union> freevars_list Xs"

text\<open>This theorem lets us prove that the vars function respects the
equivalence relation.  It also helps us prove that Variable
  (the abstract constructor) is injective\<close>
theorem exprel_imp_eq_freevars: "U \<sim> V \<Longrightarrow> freevars U = freevars V"
apply (induct set: exprel)
apply (erule_tac [4] listrel.induct)
apply (simp_all add: Un_assoc)
done

subsubsection\<open>Functions for Freeness\<close>

text\<open>A discriminator function to distinguish vars, sums and function calls\<close>
primrec freediscrim :: "freeExp \<Rightarrow> int" where
  "freediscrim (VAR N) = 0"
| "freediscrim (PLUS X Y) = 1"
| "freediscrim (FNCALL F Xs) = 2"

theorem exprel_imp_eq_freediscrim:
     "U \<sim> V \<Longrightarrow> freediscrim U = freediscrim V"
  by (induct set: exprel) auto

text\<open>This function, which returns the function name, is used to
prove part of the injectivity property for FnCall.\<close>
primrec freefun :: "freeExp \<Rightarrow> nat" where
  "freefun (VAR N) = 0"
| "freefun (PLUS X Y) = 0"
| "freefun (FNCALL F Xs) = F"

theorem exprel_imp_eq_freefun:
     "U \<sim> V \<Longrightarrow> freefun U = freefun V"
  by (induct set: exprel) (simp_all add: listrel.intros)

text\<open>This function, which returns the list of function arguments, is used to
prove part of the injectivity property for FnCall.\<close>
primrec freeargs :: "freeExp \<Rightarrow> freeExp list" where
  "freeargs (VAR N) = []"
| "freeargs (PLUS X Y) = []"
| "freeargs (FNCALL F Xs) = Xs"

theorem exprel_imp_eqv_freeargs:
  assumes "U \<sim> V"
  shows "(freeargs U, freeargs V) \<in> listrel exprel"
proof -
  from equiv_list_exprel have sym: "sym (listrel exprel)" by (rule equivE)
  from equiv_list_exprel have trans: "trans (listrel exprel)" by (rule equivE)
  from assms show ?thesis
    apply induct
    apply (erule_tac [4] listrel.induct)
    apply (simp_all add: listrel.intros)
    apply (blast intro: symD [OF sym])
    apply (blast intro: transD [OF trans])
    done
qed

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

definition "Exp = UNIV//exprel"

typedef exp = Exp
  morphisms Rep_Exp Abs_Exp
  unfolding Exp_def by (auto simp add: quotient_def)

text\<open>The abstract message constructors\<close>

definition
  Var :: "nat \<Rightarrow> exp" where
  "Var N = Abs_Exp(exprel``{VAR N})"

definition
  Plus :: "[exp,exp] \<Rightarrow> exp" where
   "Plus X Y =
       Abs_Exp (\<Union>U \<in> Rep_Exp X. \<Union>V \<in> Rep_Exp Y. exprel``{PLUS U V})"

definition
  FnCall :: "[nat, exp list] \<Rightarrow> exp" where
   "FnCall F Xs =
       Abs_Exp (\<Union>Us \<in> listset (map Rep_Exp Xs). exprel `` {FNCALL F Us})"

text\<open>Reduces equality of equivalence classes to the \<^term>\<open>exprel\<close> relation:
  \<^term>\<open>(exprel `` {x} = exprel `` {y}) = ((x,y) \<in> exprel)\<close>\<close>
lemmas equiv_exprel_iff = eq_equiv_class_iff [OF equiv_exprel UNIV_I UNIV_I]

declare equiv_exprel_iff [simp]

text\<open>All equivalence classes belong to set of representatives\<close>

lemma inj_on_Abs_Exp: "inj_on Abs_Exp Exp"
apply (rule inj_on_inverseI)
apply (erule Abs_Exp_inverse)
done

text\<open>Reduces equality on abstractions to equality on representatives\<close>
declare inj_on_Abs_Exp [THEN inj_on_eq_iff, simp]

declare Abs_Exp_inverse [simp]

text\<open>Case analysis on the representation of a exp as an equivalence class.\<close>
lemma eq_Abs_Exp [case_names Abs_Exp, cases type: exp]:
     "(!!U. z = Abs_Exp(exprel``{U}) ==> P) ==> P"
apply (rule Rep_Exp [of z, unfolded Exp_def, THEN quotientE])
apply (drule arg_cong [where f=Abs_Exp])
apply (auto simp add: Rep_Exp_inverse intro: exprel_refl)
done

subsection\<open>Every list of abstract expressions can be expressed in terms of a
  list of concrete expressions\<close>

definition
  Abs_ExpList :: "freeExp list => exp list" where
  "Abs_ExpList Xs = map (%U. Abs_Exp(exprel``{U})) Xs"

lemma Abs_ExpList_Nil [simp]: "Abs_ExpList [] == []"
by (simp add: Abs_ExpList_def)

lemma Abs_ExpList_Cons [simp]:
     "Abs_ExpList (X#Xs) == Abs_Exp (exprel``{X}) # Abs_ExpList Xs"
by (simp add: Abs_ExpList_def)

lemma ExpList_rep: "\<exists>Us. z = Abs_ExpList Us"
apply (induct z)
apply (rename_tac [2] a b)
apply (rule_tac [2] z=a in eq_Abs_Exp)
apply (auto simp add: Abs_ExpList_def Cons_eq_map_conv intro: exprel_refl)
done

lemma eq_Abs_ExpList [case_names Abs_ExpList]:
     "(!!Us. z = Abs_ExpList Us ==> P) ==> P"
by (rule exE [OF ExpList_rep], blast)

subsubsection\<open>Characteristic Equations for the Abstract Constructors\<close>

lemma Plus: "Plus (Abs_Exp(exprel``{U})) (Abs_Exp(exprel``{V})) =
             Abs_Exp (exprel``{PLUS U V})"
proof -
  have "(\<lambda>U V. exprel `` {PLUS U V}) respects2 exprel"
    by (auto simp add: congruent2_def exprel.PLUS)
  thus ?thesis
    by (simp add: Plus_def UN_equiv_class2 [OF equiv_exprel equiv_exprel])
qed

text\<open>It is not clear what to do with FnCall: it's argument is an abstraction
of an \<^typ>\<open>exp list\<close>. Is it just Nil or Cons? What seems to work best is to
regard an \<^typ>\<open>exp list\<close> as a \<^term>\<open>listrel exprel\<close> equivalence class\<close>

text\<open>This theorem is easily proved but never used. There's no obvious way
even to state the analogous result, \<open>FnCall_Cons\<close>.\<close>
lemma FnCall_Nil: "FnCall F [] = Abs_Exp (exprel``{FNCALL F []})"
  by (simp add: FnCall_def)

lemma FnCall_respects:
     "(\<lambda>Us. exprel `` {FNCALL F Us}) respects (listrel exprel)"
  by (auto simp add: congruent_def exprel.FNCALL)

lemma FnCall_sing:
     "FnCall F [Abs_Exp(exprel``{U})] = Abs_Exp (exprel``{FNCALL F [U]})"
proof -
  have "(\<lambda>U. exprel `` {FNCALL F [U]}) respects exprel"
    by (auto simp add: congruent_def FNCALL_Cons listrel.intros)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_exprel])
qed

lemma listset_Rep_Exp_Abs_Exp:
     "listset (map Rep_Exp (Abs_ExpList Us)) = listrel exprel `` {Us}"
  by (induct Us) (simp_all add: listrel_Cons Abs_ExpList_def)

lemma FnCall:
     "FnCall F (Abs_ExpList Us) = Abs_Exp (exprel``{FNCALL F Us})"
proof -
  have "(\<lambda>Us. exprel `` {FNCALL F Us}) respects (listrel exprel)"
    by (auto simp add: congruent_def exprel.FNCALL)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_list_exprel]
                  listset_Rep_Exp_Abs_Exp)
qed

text\<open>Establishing this equation is the point of the whole exercise\<close>

subsection\<open>The Abstract Function to Return the Set of Variables\<close>

definition
  vars :: "exp \<Rightarrow> nat set" where
  "vars X = (\<Union>U \<in> Rep_Exp X. freevars U)"

lemma vars_respects: "freevars respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freevars)

text\<open>The extension of the function \<^term>\<open>vars\<close> to lists\<close>
primrec vars_list :: "exp list \<Rightarrow> nat set" where
  "vars_list []    = {}"
| "vars_list(E#Es) = vars E \<union> vars_list Es"

text\<open>Now prove the three equations for \<^term>\<open>vars\<close>\<close>

lemma vars_Variable [simp]: "vars (Var N) = {N}"
by (simp add: vars_def Var_def
              UN_equiv_class [OF equiv_exprel vars_respects])

lemma vars_Plus [simp]: "vars (Plus X Y) = vars X \<union> vars Y"
apply (cases X, cases Y)
apply (simp add: vars_def Plus
                 UN_equiv_class [OF equiv_exprel vars_respects])
done

lemma vars_FnCall [simp]: "vars (FnCall F Xs) = vars_list Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall)
apply (induct_tac Us)
apply (simp_all add: vars_def UN_equiv_class [OF equiv_exprel vars_respects])
done

lemma vars_FnCall_Nil: "vars (FnCall F Nil) = {}"
by simp

lemma vars_FnCall_Cons: "vars (FnCall F (X#Xs)) = vars X \<union> vars_list Xs"
by simp

subsection\<open>Injectivity Properties of Some Constructors\<close>

lemma VAR_imp_eq: "VAR m \<sim> VAR n \<Longrightarrow> m = n"
by (drule exprel_imp_eq_freevars, simp)

text\<open>Can also be proved using the function \<^term>\<open>vars\<close>\<close>
lemma Var_Var_eq [iff]: "(Var m = Var n) = (m = n)"
by (auto simp add: Var_def exprel_refl dest: VAR_imp_eq)

lemma VAR_neqv_PLUS: "VAR m \<sim> PLUS X Y \<Longrightarrow> False"
by (drule exprel_imp_eq_freediscrim, simp)

theorem Var_neq_Plus [iff]: "Var N \<noteq> Plus X Y"
apply (cases X, cases Y)
apply (simp add: Var_def Plus)
apply (blast dest: VAR_neqv_PLUS)
done

theorem Var_neq_FnCall [iff]: "Var N \<noteq> FnCall F Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (auto simp add: FnCall Var_def)
apply (drule exprel_imp_eq_freediscrim, simp)
done

subsection\<open>Injectivity of \<^term>\<open>FnCall\<close>\<close>

definition
  "fun" :: "exp \<Rightarrow> nat" where
  "fun X = the_elem (\<Union>U \<in> Rep_Exp X. {freefun U})"

lemma fun_respects: "(%U. {freefun U}) respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freefun)

lemma fun_FnCall [simp]: "fun (FnCall F Xs) = F"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall fun_def UN_equiv_class [OF equiv_exprel fun_respects])
done

definition
  args :: "exp \<Rightarrow> exp list" where
  "args X = the_elem (\<Union>U \<in> Rep_Exp X. {Abs_ExpList (freeargs U)})"

text\<open>This result can probably be generalized to arbitrary equivalence
relations, but with little benefit here.\<close>
lemma Abs_ExpList_eq:
     "(y, z) \<in> listrel exprel \<Longrightarrow> Abs_ExpList (y) = Abs_ExpList (z)"
  by (induct set: listrel) simp_all

lemma args_respects: "(%U. {Abs_ExpList (freeargs U)}) respects exprel"
by (auto simp add: congruent_def Abs_ExpList_eq exprel_imp_eqv_freeargs)

lemma args_FnCall [simp]: "args (FnCall F Xs) = Xs"
apply (cases Xs rule: eq_Abs_ExpList)
apply (simp add: FnCall args_def UN_equiv_class [OF equiv_exprel args_respects])
done

lemma FnCall_FnCall_eq [iff]:
     "(FnCall F Xs = FnCall F' Xs') = (F=F' & Xs=Xs')"
proof
  assume "FnCall F Xs = FnCall F' Xs'"
  hence "fun (FnCall F Xs) = fun (FnCall F' Xs')"
    and "args (FnCall F Xs) = args (FnCall F' Xs')" by auto
  thus "F=F' & Xs=Xs'" by simp
next
  assume "F=F' & Xs=Xs'" thus "FnCall F Xs = FnCall F' Xs'" by simp
qed

subsection\<open>The Abstract Discriminator\<close>
text\<open>However, as \<open>FnCall_Var_neq_Var\<close> illustrates, we don't need this
function in order to prove discrimination theorems.\<close>

definition
  discrim :: "exp \<Rightarrow> int" where
  "discrim X = the_elem (\<Union>U \<in> Rep_Exp X. {freediscrim U})"

lemma discrim_respects: "(\<lambda>U. {freediscrim U}) respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freediscrim)

text\<open>Now prove the four equations for \<^term>\<open>discrim\<close>\<close>

lemma discrim_Var [simp]: "discrim (Var N) = 0"
by (simp add: discrim_def Var_def
              UN_equiv_class [OF equiv_exprel discrim_respects])

lemma discrim_Plus [simp]: "discrim (Plus X Y) = 1"
apply (cases X, cases Y)
apply (simp add: discrim_def Plus
                 UN_equiv_class [OF equiv_exprel discrim_respects])
done

lemma discrim_FnCall [simp]: "discrim (FnCall F Xs) = 2"
apply (rule_tac z=Xs in eq_Abs_ExpList)
apply (simp add: discrim_def FnCall
                 UN_equiv_class [OF equiv_exprel discrim_respects])
done

text\<open>The structural induction rule for the abstract type\<close>
theorem exp_inducts:
  assumes V:    "\<And>nat. P1 (Var nat)"
      and P:    "\<And>exp1 exp2. \<lbrakk>P1 exp1; P1 exp2\<rbrakk> \<Longrightarrow> P1 (Plus exp1 exp2)"
      and F:    "\<And>nat list. P2 list \<Longrightarrow> P1 (FnCall nat list)"
      and Nil:  "P2 []"
      and Cons: "\<And>exp list. \<lbrakk>P1 exp; P2 list\<rbrakk> \<Longrightarrow> P2 (exp # list)"
  shows "P1 exp" and "P2 list"
proof -
  obtain U where exp: "exp = (Abs_Exp (exprel `` {U}))" by (cases exp)
  obtain Us where list: "list = Abs_ExpList Us" by (rule eq_Abs_ExpList)
  have "P1 (Abs_Exp (exprel `` {U}))" and "P2 (Abs_ExpList Us)"
  proof (induct U and Us rule: compat_freeExp.induct compat_freeExp_list.induct)
    case (VAR nat)
    with V show ?case by (simp add: Var_def)
  next
    case (PLUS X Y)
    with P [of "Abs_Exp (exprel `` {X})" "Abs_Exp (exprel `` {Y})"]
    show ?case by (simp add: Plus)
  next
    case (FNCALL nat list)
    with F [of "Abs_ExpList list"]
    show ?case by (simp add: FnCall)
  next
    case Nil_freeExp
    with Nil show ?case by simp
  next
    case Cons_freeExp
    with Cons show ?case by simp
  qed
  with exp and list show "P1 exp" and "P2 list" by (simp_all only:)
qed

end


text\<open> 21 October 2021: Exercise for Homework Assignment 07 in CS 511 \<close>
text\<open> Your task to remove the invocations of the pre-defined method
      'blast' by an equivalent sequence of 'apply' steps \<close>

theory HW07
  imports Main
begin

text\<open> 'blast' is invoked three times, once in the proof of each of
      lemmas B1, C1, and D1 below \<close>

(* the proof of the next lemma is just an example of how to use the
   rules for manipulating quantifiers *)
lemma preliminary : "(\<exists>z. P z) \<and> Q \<longrightarrow> (\<exists>y. P y \<and> Q)"
apply (rule impI)
apply (erule conjE)
apply (erule exE)
apply (rule_tac x="z" in exI)
apply (rule conjI)
apply assumption+
done

(* lemma A1 is the same in Exercise 2.3.9 (a), page 161, in [LCS] *)
lemma A1 : "(\<exists>x. S \<longrightarrow> Q x) \<Longrightarrow> S \<longrightarrow> (\<exists>x. Q x)"
  apply (erule exE)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (rule_tac x="x" in exI)
  apply assumption
  done

(* lemma A2 is the same as lemma A1 but with a different proof *)
lemma A2 : "(\<exists>x. S \<longrightarrow> Q x) \<Longrightarrow> S \<longrightarrow> (\<exists>x. Q x)"
  apply clarify
  apply (rule_tac x="x" in exI)
  apply assumption
  done

(* lemma B1 is the same in Exercise 2.3.9 (b), page 161, in [LCS] *)
lemma B1 : "S \<longrightarrow> (\<exists>x. Q x) \<Longrightarrow> (\<exists>x. S \<longrightarrow> Q x)"
  by blast

(* lemma C1 is the same in Exercise 2.3.9 (c), page 161, in [LCS] *)
lemma C1 : "(\<exists>x. P x) \<longrightarrow> S \<Longrightarrow> \<forall>x. (P x \<longrightarrow> S)"
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule_tac x="x" in exI)
   apply assumption+
  done

(* lemma D1 is the same in Exercise 2.3.9 (d), page 161, in [LCS] *)
lemma D1 : " (\<forall>x. P x) \<longrightarrow> S \<Longrightarrow> \<exists>x. (P x \<longrightarrow> S)"
  by blast

end