text{*
Exercise 3.4. Take a copy of theory AExp and modify it as follows. Extend type aexp
              with a binary constructor Times that represents multiplication.
              Modify the definition of the functions aval and asimp accordingly.
              You can remove asimp_const. Function asimp should eliminate 0 and 1
              from multiplication as well as evaluate constant subterms. Update
              all proofs concerned.
*}

theory AExpMul
  imports Main
begin

subsection "Arithmetic Expressions with multiplication"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp
  = N int
  | V vname
  | Plus aexp aexp
  | Times aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val"
  where "aval (N n) s = n"
  | "aval (V x) s = s x"
  | "aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
  | "aval (Times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

value "aval (Times (N 3) (N 2)) (\<lambda>x.0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp"
  where "plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)"
  | "plus (N i) a = (if i=0 then a else Plus (N i) a)"
  | "plus a (N i) = (if i=0 then a else Plus a (N i))"
  | "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus[simp]: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
 apply(induction a1 a2 rule: plus.induct)
 apply(auto)
 done

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp"
  where "times (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1 * i\<^sub>2)"
  | "times (N i) a = (if i=1 then a else (if i=0 then N 0 else Times (N i) a))"
  | "times a (N i) = (if i=1 then a else (if i=0 then N 0 else Times (N i) a))"
  | "times a\<^sub>1 a\<^sub>2 = Times a\<^sub>1 a\<^sub>2"

lemma aval_times [simp]: "aval (times a1 a2) s = aval a1 s * aval a2 s"
 apply(induction a1 a2 rule: times.induct)
 apply simp_all
 done

fun asimp :: "aexp \<Rightarrow> aexp"
  where "asimp (N n) = N n"
  | "asimp (V x) = V x"
  | "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
  | "asimp (Times a\<^sub>1 a\<^sub>2) = times (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]: "aval (asimp a) s = aval a s"
  apply(induction a rule: asimp.induct)
  apply(auto)
  done

end


(*  Title:      HOL/Algebra/Bij.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Bij
imports Group
begin

section \<open>Bijections of a Set, Permutation and Automorphism Groups\<close>

definition
  Bij :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) set"
    \<comment>\<open>Only extensional functions, since otherwise we get too many.\<close>
   where "Bij S = extensional S \<inter> {f. bij_betw f S S}"

definition
  BijGroup :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "BijGroup S =
    \<lparr>carrier = Bij S,
     mult = \<lambda>g \<in> Bij S. \<lambda>f \<in> Bij S. compose S g f,
     one = \<lambda>x \<in> S. x\<rparr>"

declare Id_compose [simp] compose_Id [simp]

lemma Bij_imp_extensional: "f \<in> Bij S \<Longrightarrow> f \<in> extensional S"
  by (simp add: Bij_def)

lemma Bij_imp_funcset: "f \<in> Bij S \<Longrightarrow> f \<in> S \<rightarrow> S"
  by (auto simp add: Bij_def bij_betw_imp_funcset)

subsection \<open>Bijections Form a Group\<close>

lemma restrict_inv_into_Bij: "f \<in> Bij S \<Longrightarrow> (\<lambda>x \<in> S. (inv_into S f) x) \<in> Bij S"
  by (simp add: Bij_def bij_betw_inv_into)

lemma id_Bij: "(\<lambda>x\<in>S. x) \<in> Bij S "
  by (auto simp add: Bij_def bij_betw_def inj_on_def)

lemma compose_Bij: "\<lbrakk>x \<in> Bij S; y \<in> Bij S\<rbrakk> \<Longrightarrow> compose S x y \<in> Bij S"
  by (auto simp add: Bij_def bij_betw_compose)

lemma Bij_compose_restrict_eq:
     "f \<in> Bij S \<Longrightarrow> compose S (restrict (inv_into S f) S) f = (\<lambda>x\<in>S. x)"
  by (simp add: Bij_def compose_inv_into_id)

theorem group_BijGroup: "group (BijGroup S)"
apply (simp add: BijGroup_def)
apply (rule groupI)
    apply (simp add: compose_Bij)
   apply (simp add: id_Bij)
  apply (simp add: compose_Bij)
  apply (blast intro: compose_assoc [symmetric] dest: Bij_imp_funcset)
 apply (simp add: id_Bij Bij_imp_funcset Bij_imp_extensional, simp)
apply (blast intro: Bij_compose_restrict_eq restrict_inv_into_Bij)
done

subsection\<open>Automorphisms Form a Group\<close>

lemma Bij_inv_into_mem: "\<lbrakk> f \<in> Bij S;  x \<in> S\<rbrakk> \<Longrightarrow> inv_into S f x \<in> S"
by (simp add: Bij_def bij_betw_def inv_into_into)

lemma Bij_inv_into_lemma:
 assumes eq: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> h(g x y) = g (h x) (h y)"
 shows "\<lbrakk>h \<in> Bij S;  g \<in> S \<rightarrow> S \<rightarrow> S;  x \<in> S;  y \<in> S\<rbrakk>
        \<Longrightarrow> inv_into S h (g x y) = g (inv_into S h x) (inv_into S h y)"
apply (simp add: Bij_def bij_betw_def)
apply (subgoal_tac "\<exists>x'\<in>S. \<exists>y'\<in>S. x = h x' & y = h y'", clarify)
 apply (simp add: eq [symmetric] inv_f_f funcset_mem [THEN funcset_mem], blast)
done

definition
  auto :: "('a, 'b) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) set"
  where "auto G = hom G G \<inter> Bij (carrier G)"

definition
  AutoGroup :: "('a, 'c) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "AutoGroup G = BijGroup (carrier G) \<lparr>carrier := auto G\<rparr>"

lemma (in group) id_in_auto: "(\<lambda>x \<in> carrier G. x) \<in> auto G"
  by (simp add: auto_def hom_def restrictI group.axioms id_Bij)

lemma (in group) mult_funcset: "mult G \<in> carrier G \<rightarrow> carrier G \<rightarrow> carrier G"
  by (simp add:  Pi_I group.axioms)

lemma (in group) restrict_inv_into_hom:
      "\<lbrakk>h \<in> hom G G; h \<in> Bij (carrier G)\<rbrakk>
       \<Longrightarrow> restrict (inv_into (carrier G) h) (carrier G) \<in> hom G G"
  by (simp add: hom_def Bij_inv_into_mem restrictI mult_funcset
                group.axioms Bij_inv_into_lemma)

lemma inv_BijGroup:
     "f \<in> Bij S \<Longrightarrow> m_inv (BijGroup S) f = (\<lambda>x \<in> S. (inv_into S f) x)"
apply (rule group.inv_equality)
apply (rule group_BijGroup)
apply (simp_all add:BijGroup_def restrict_inv_into_Bij Bij_compose_restrict_eq)
done

lemma (in group) subgroup_auto:
      "subgroup (auto G) (BijGroup (carrier G))"
proof (rule subgroup.intro)
  show "auto G \<subseteq> carrier (BijGroup (carrier G))"
    by (force simp add: auto_def BijGroup_def)
next
  fix x y
  assume "x \<in> auto G" "y \<in> auto G"
  thus "x \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> y \<in> auto G"
    by (force simp add: BijGroup_def is_group auto_def Bij_imp_funcset
                        group.hom_compose compose_Bij)
next
  show "\<one>\<^bsub>BijGroup (carrier G)\<^esub> \<in> auto G" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto G"
  thus "inv\<^bsub>BijGroup (carrier G)\<^esub> x \<in> auto G"
    by (simp del: restrict_apply
        add: inv_BijGroup auto_def restrict_inv_into_Bij restrict_inv_into_hom)
qed

theorem (in group) AutoGroup: "group (AutoGroup G)"
by (simp add: AutoGroup_def subgroup.subgroup_is_group subgroup_auto
              group_BijGroup)

end


theory Scratch4
  imports Main
begin

(* Exercise 4.1 *)
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}"|
"set (Node l a r) = {a} \<union> (set l) \<union> (set r)"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True"|
"ord (Node l a r) = ((ord l) \<and> (ord r) \<and>
  (case l of
  Tip \<Rightarrow> True |
  Node _ a1 _ \<Rightarrow> a1 < a) \<and>
  (case r of
  Tip \<Rightarrow> True |
  Node _ a2 _ \<Rightarrow> a < a2))"

fun ins :: "int tree \<Rightarrow> int \<Rightarrow> int tree" where
"ins Tip x = (Node Tip x Tip)"|
"ins (Node l y r)  x = (if (y = x)
                        then Node l y r
                        else (if (x < y)
                              then Node (ins l x) y r
                              else Node l y (ins r x)))"

lemma "set (ins t x) = {x} \<union> set t"
  apply (induction t)
   apply (auto)
  done

lemma "ord t \<Longrightarrow> ord (ins t i)"
  apply (induction t arbitrary: i)
   apply (auto split: tree.split)
  done

lemma "\<forall> x. \<exists> y. x = y"
  by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<forall> xs \<in> A. \<exists> ys. xs = ys @ ys \<Longrightarrow> us \<in> A \<Longrightarrow> \<exists> n . length us = n + n"
  by fastforce

lemma "\<forall> x y. T x y \<or> T y x \<Longrightarrow>
       \<forall> x y. A x y \<and> A y x \<longrightarrow> x = y \<Longrightarrow>
       \<forall> x y. T x y \<longrightarrow> A x y \<Longrightarrow>
       \<forall> x y. A x y \<longrightarrow> T x y"
  by blast

lemma "[a] = [b] \<Longrightarrow> a = b"
  by simp

lemma "(a :: nat) \<le> x + b \<Longrightarrow> 2 * x < c \<Longrightarrow> 2 * a + 1 \<le> 2 * b + c"
  by arith

inductive ev :: "nat \<Rightarrow> bool" where
ev0 : "ev 0"|
evSS : "ev n \<Longrightarrow> ev (Suc (Suc n))"

thm evSS
thm ev.intros
lemma "ev (Suc(Suc(Suc(Suc 0))))"
  apply (auto intro: evSS ev0)
  done

lemma "ev (Suc(Suc(Suc(Suc 0))))"
  apply (rule evSS)
  apply (rule evSS)
  apply (rule ev0)
  done

lemma "ev (Suc(Suc(Suc(Suc 0))))"
  apply (rule)
  apply (rule)
  apply (rule)
  done

value "ev0 \<Longrightarrow> ev(0+2) \<Longrightarrow>  ev((0+2) +2) = ev 4"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True"|
"evn (Suc 0) = False"|
"evn (Suc (Suc n)) = evn n"

lemma "ev m \<Longrightarrow> evn m"
  apply (induction rule: ev.induct)
  by (simp_all)

lemma "evn n \<Longrightarrow> ev n"
  apply (induction n rule: evn.induct)
    apply (auto  intro: ev0 evSS)
  done

lemma "evn n \<Longrightarrow> ev n"
  apply (induction n rule: evn.induct)
  by (simp_all add: ev0 evSS)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x"|
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply (auto intro: refl step)
  done

lemma star_trans': "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply (assumption)
  apply (metis step)
  done

(* exercise 4.2 *)
inductive palindrome :: "'a list \<Rightarrow> bool" where
pal0: "palindrome []"|
pal1: "palindrome [x]"|
paln: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

lemma "palindrome xs \<Longrightarrow> palindrome (rev xs)"
  apply (induction rule : palindrome.induct)
  by (simp_all add: pal0 pal1 paln)

(* exercise 4.3 *)
inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x"|
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star_then_step[simp]:"\<lbrakk>star r x y; r y z\<rbrakk> \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply (auto intro: refl step)
  done

lemma "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
   apply (auto simp add: refl)
  done

lemma star'_then_step[simp]:"\<lbrakk>star' r y z; r x y\<rbrakk> \<Longrightarrow> star' r x z"
  apply (induction rule: star'.induct)
   apply (auto intro: refl' step')
  done

lemma "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
   apply (auto simp add: refl')
  done

(* exercise 4.4 *)
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x"|
itern: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Succ n) x z"

lemma "star r x y \<Longrightarrow> \<exists> n . iter r n x y"
  apply (induction rule: star.induct)
   apply (auto intro: iter0 itern)
  done

(* exercise 4.5 *)
datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
S\<^sub>\<epsilon>: "S []"|
S\<^sub>1: "S x \<Longrightarrow> S (a # x @ [b])"|
S\<^sub>2: "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

inductive T :: "alpha list \<Rightarrow> bool" where
T\<^sub>\<epsilon>: "T []"|
T\<^sub>1: "T x \<Longrightarrow> T y \<Longrightarrow> T (x @ [a] @ y @ [b])"

lemma T_imp_S: "T w \<Longrightarrow> S w"
  apply (induction rule: T.induct)
  by (auto intro: S\<^sub>\<epsilon> S\<^sub>1 S\<^sub>2)

lemma T_app_nil:"T ([] @ [a] @ x @ [b]) \<Longrightarrow> T (a # x @ [b])"
  by auto

lemma helper: "\<lbrakk>T y; T x\<rbrakk> \<Longrightarrow> T (x @ y)"
  apply (induction rule: T.induct)
   apply (auto)
  using T\<^sub>1 by force

lemma S_imp_T: "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
    apply (auto simp add: helper intro: T\<^sub>\<epsilon> T\<^sub>1 T_app_nil)
  done

lemma "S w = T w"
  apply (rule) using S_imp_T T_imp_S by auto

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"
datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n"|
"aval (V v) s = s v"|
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

inductive aval_rel' :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
naval: "aval_rel' (N n) s n"|
vaval: "aval_rel' (V v) s (s v)"|
plaval: "aval_rel' a1 s v1 \<Longrightarrow>
         aval_rel' a2 s v2 \<Longrightarrow>
         aval_rel' (Plus a1 a2) s (v1 + v2)"

lemma "(aval_rel' e s v) \<Longrightarrow> (aval e s = v)"
  apply (induction rule: aval_rel'.induct)
  by auto

lemma "(aval e s = v) \<Longrightarrow> (aval_rel' e s v)"
  apply (induction e arbitrary: v)
    apply (auto intro: naval vaval plaval)
  done

end


theory HoareLogicTR

imports Main "HOL-Hoare.Hoare_Logic"

begin

section \<open>Hoare Logic in Isabelle/HOL\<close>

lemma slow_sub_isa:
"VARS  (x::nat) (z::nat)
{x=M \<and> z=P}
WHILE \<not>(x=0)
  INV { z-x = P-M \<and> x\<ge>0}
  DO z:=z-1;x:=x-1 OD
{z = P-M}"
apply (vcg)
apply (auto)
done

lemma imp_pot:
"VARS (a::int) (b::nat) (p::int) (i::nat)
{a=A \<and> b=B}
i := 0; p := 1;
WHILE i<b
  INV { p = a^i \<and> i\<le> b \<and> a=A \<and> b = B}
  DO p := p * a;i:=i+1 OD
{p = A^B}"
apply (vcg)
apply (auto)
done

lemma imp_pot_isar:"VARS (a::int) (b::nat) p i
{a=A \<and> b=B}
i := 0; p := 1;
WHILE i<b
  INV { p = a^i \<and> i\<le> b \<and> a=A \<and> b = B}
  DO p := p * a;i:=i+1 OD
{p = A^B}"

  proof (vcg)
    fix a b p i
    let ?INV = "p = a ^ i \<and> i \<le> b \<and> a = A \<and> b = B"
    assume ass:"?INV  \<and> i < b"
    show "p * a = a ^ (i + 1) \<and> i + 1 \<le> b
          \<and> a = A \<and> b = B"
      proof -
        from ass obtain 1: "p = a ^ i" and 2:"i \<le> b"
        and 3:"a = A \<and> b = B" and 5:"i<b"  by blast
        from 1 have 6:"p*a=a^i*a" by simp
        from this have 7:"p * a = a ^ (i + 1)" by simp
        from 5 have 8:"i+1\<le>b" by simp
        from this 3 7 show ?thesis by simp
      qed
  qed (auto)

section \<open>Preliminary Example - List Reversal\<close>

lemma hd_tl:"xs \<noteq> [] \<Longrightarrow> xs = hd xs # tl xs"
  by simp

fun tail_rev::"'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"tail_rev [] acc = acc" |
"tail_rev (x#xs) acc = tail_rev xs (x # acc)"

lemma tail_rev:"\<forall>ys. tail_rev xs ys = rev xs @ ys"
apply (induction xs)
apply (auto)
done

lemma "tail_rev xs [] = rev xs" by (simp add:tail_rev)

lemma hd_tl_app:"xs \<noteq> [] \<Longrightarrow>
        xs = [hd xs] @ tl xs"
            by simp

lemma impRev: "VARS (acc::'a list) (xs::'a list)
 {xs=X}
 acc:=[];
 WHILE xs \<noteq> []
   INV {rev(xs)@acc = rev(X)}
 DO acc := (hd xs # acc); xs := tl xs OD
 {acc=rev(X)}"
apply (vcg)
apply (simp)
    using hd_tl_app apply (force)
apply (auto)
done

lemma impRev_isar: "VARS acc x
 {x=X}  acc:=[];
 WHILE x \<noteq> []  INV {rev(x)@acc = rev(X)}
 DO acc := (hd x # acc); x := tl x OD
 {acc=rev(X)}"
proof (vcg)
  fix acc x
  assume ass:"rev x @ acc = rev X \<and> x \<noteq> []"
  show "rev (tl x) @ hd x # acc = rev X"
    proof -
      from ass obtain 1:"rev x @ acc = rev X"
        and 2:" x\<noteq>[]" by blast
      from 2 have "x = hd x # tl x"  by simp
      from 1 and this
        have 3:"rev x = rev (hd x # tl x)"
            by simp
        have "rev (hd x # tl x) =
              rev (tl x) @ [hd x]" by simp
      from 3 and this
        have "rev x =
              rev (tl x) @ [hd x]" by simp
      from this and 1 show ?thesis by simp
    qed
qed (auto)

section \<open>Case Study: Insertion Sort\<close>

fun ins::"'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list"
where  "ins x [] = [x]" |
 "ins x (y # ys)=(if x \<le> y then (x # y # ys)
                    else y#ins x ys)"

fun iSort::"('a::linorder) list \<Rightarrow> 'a list"
where "iSort [] = []" |
      "iSort (x # xs) = ins x (iSort xs)"

fun le::"('a::linorder) \<Rightarrow> 'a list \<Rightarrow> bool"
where  "le x [] = True" |
       "le x (y # ys) = (x \<le>y \<and> le x ys)"

fun isorted::"('a::linorder) list \<Rightarrow> bool"
where
  "isorted [] = True" |
  "isorted (x # xs) = (le x xs \<and> isorted xs)"

fun count:: "'a \<Rightarrow> 'a list \<Rightarrow> int"  where
  "count x [] = 0" |
  "count x (y # ys) = (if x=y then
     1 + count x ys else count x ys)"

fun tail_iSort::"('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"tail_iSort [] acc = acc" |
"tail_iSort (x#xs)  acc = tail_iSort xs (ins x acc)"

value "iSort [12,-3,-4,200,2::int]"
value "tail_iSort [12,-3,-4,200,2::int] []"
value "isorted(tail_iSort [12,-3,-4,200,2::int] [1,2,3])"

text\<open>
  lemma le_ins: "le x (ins a xs) = (x \<le> a \<and> le x xs)"                       sorry
  lemma le_mon:"x\<le>y \<Longrightarrow> le y xs \<Longrightarrow> le x xs"                                sorry
  lemma ins_sorted: "isorted (ins a xs) = isorted xs"                        sorry
  lemma is_sorted:"isorted(iSort xs)"                                        sorry
  lemma ins_count:
   "count x (ins k xs) = (if x = k then 1
          + count x xs else count x xs)"                                     sorry
  lemma count_sum:"count x (xs @ ys) =
          count x xs + count x ys"                                           sorry
  lemma len_sort:"length(iSort xs) = length xs"                              sorry
  lemma count_iSort: "count x (iSort xs) = count x xs"                       sorry
  lemma ins_len:"length (ins k xs) = 1 + length xs"                          sorry
\<close>

lemma le_ins: "le x (ins a xs) = (x \<le> a \<and> le x xs)"
  apply (induction xs)
  apply auto
done

lemma le_mon:"x\<le>y \<Longrightarrow> le y xs \<Longrightarrow> le x xs"
  apply (induction xs)
  apply (auto)
done

lemma ins_sorted: "isorted (ins a xs) = isorted xs"
  apply (induct_tac xs)
  apply (auto simp add: le_ins le_mon)
done

lemma is_sorted:"isorted(iSort xs)"
  apply (induction xs)
  apply (auto simp add:ins_sorted)
done

lemma ins_count:
   "count x (ins k xs) = (if x = k then 1 + count x xs
                          else count x xs)"
apply (induction xs)
apply (auto)
done

lemma count_sum:"count x (xs @ ys) = count x xs + count x ys"
      (is "?P xs")
proof (induction xs)
  show "?P []" by simp
next
  fix a xs
  assume IH: "count x (xs @ ys) = count x xs + count x ys"
  show "count x ((a # xs) @ ys) = count x (a # xs) +  count x ys"
    proof (cases "x=a")
      assume h0:"x=a"
      have "count x ((a # xs) @ ys) = count x (a # (xs @ ys))"
          by simp
      also have "\<dots> = 1 + count x (xs @ ys)" using h0 by simp
      also have "\<dots> = (1 + count x xs)  + count x ys"
          using IH h0 by simp
      also have "\<dots> =  count x (a # xs) + count x ys" using h0 by simp
      finally show ?thesis by this
    next
      assume h1:"x\<noteq>a"
      have "count x ((a # xs) @ ys) = count x (a # (xs @ ys))"
          by simp
      also have "\<dots> =  count x (xs @ ys)" using h1 by simp
      also have "\<dots> = count x xs  + count x ys"
          using IH h1 by simp
      also have "\<dots> =  count x (a # xs) + count x ys" using h1 by simp
      finally show ?thesis by this
    qed
qed

lemma ins_len:"length (ins k xs) = 1 + length xs"
apply (induction xs)
apply (auto)
done

lemma len_sort:"length(iSort xs) = length xs"
apply (induction xs)
apply (simp_all add:ins_len)
done

lemma count_iSort: "count x (iSort xs) = count x xs"
apply (induction xs)
apply (auto simp add: ins_count)
  done

definition is_perm::"'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where "is_perm l1 l2 \<equiv> length l1 = length l2
              \<and> (\<forall>x. count x l1 = count x l2)"

  lemma inss_hoare:
    "VARS xs ys :: ('a::linorder) list
   {xs=X}
   ys:=[];
   WHILE xs \<noteq> []
      INV {isorted ys \<and> is_perm X (ys @ xs)}
   DO ys := ins (hd xs) ys; xs := tl xs OD
  {isorted ys \<and> is_perm X ys}"
   apply (vcg)
   apply (auto simp add:is_perm_def) \<comment> \<open> 1 \<close>
     apply (simp add: ins_sorted) \<comment> \<open>1.1\<close>
     apply (simp add: ins_len) \<comment> \<open>1.2\<close>
     apply  (smt count.simps(2) count_sum
            ins_count list.collapse) \<comment>\<open>1.3\<close>
  done

lemma inss_hoareb: "VARS xs ys :: ('a::linorder) list
 {xs=X}
 ys:=[];
 WHILE xs \<noteq> []
    INV {isorted ys \<and> is_perm X (ys @ xs)}
 DO ys := ins (hd xs) ys; xs := tl xs OD
{isorted ys \<and> is_perm X ys}"
  apply (vcg)
  apply (simp add:is_perm_def) \<comment> \<open> 1 \<close>
  apply (rule conjI)  \<comment> \<open> 2 \<close>
      apply (simp add: ins_sorted) \<comment> \<open>2.1\<close>
      apply (simp add:is_perm_def) \<comment>\<open>2.2\<close>
        apply (rule conjI)
        apply (simp add: ins_len)
        apply (smt count.simps(2) count_sum
              ins_count list.collapse)
      apply (auto) \<comment>\<open>2.3\<close>
  done

lemma inss_isar_draft:
"VARS xs ys :: ('a::linorder) list
 {xs=X} ys:=[];
 WHILE xs \<noteq> []
    INV {isorted ys \<and> is_perm X (ys @ xs)}
 DO ys := ins (hd xs) ys; xs := tl xs OD
{isorted ys \<and> is_perm X ys}"
proof (vcg)
   fix xs ys
   assume ass:"(isorted ys \<and>
      is_perm X (ys @ xs)) \<and> xs \<noteq> []"
   show "isorted (ins (hd xs) ys)
     \<and> is_perm X ((ins (hd xs) ys) @ tl xs)"
   proof (rule conjI)
     show "isorted (ins (hd xs) ys)"
        sorry
   next
       have pg1:"length X  =
        length ((ins (hd xs) ys) @ tl xs)"
           sorry
       have pg2:"\<forall> k. count k X =
        count k (ins (hd xs) ys @ tl xs)"
           sorry
       from pg1 pg2 show
        "is_perm X (ins (hd xs) ys @ tl xs)"
           sorry
   qed
qed (auto simp add:is_perm_def)

lemma inss_isar: "VARS xs ys :: ('a::linorder) list
       {xs=X}
       ys:=[];
       WHILE xs \<noteq> []
       INV {isorted ys \<and> is_perm X (ys @ xs)}
       DO ys := ins (hd xs) ys; xs := tl xs OD
       {isorted ys \<and> is_perm X ys}"
proof (vcg)
 fix xs ys
 assume ass:"(isorted ys \<and> is_perm X (ys @ xs))
               \<and> xs \<noteq> []"
 show "isorted (ins (hd xs) ys)
      \<and> is_perm X ((ins (hd xs) ys) @ tl xs)"
  proof (rule conjI)
     from ass have "isorted ys" by simp
     from this show "isorted (ins (hd xs) ys)"
        by (simp add:ins_sorted)
  next
    from ass have 1:"is_perm X (ys @ xs)"
       and 2:"xs \<noteq> []" by auto
    from 2 have hdtl:"xs = hd xs # tl xs" by simp
    from 1 have
         3:"\<forall> x. count x X = count x (ys @ xs)"
             by (simp add:is_perm_def)
    have pg1:"length X
          =  length ((ins (hd xs) ys) @ tl xs)"
     proof -
       from 1 have 4:"length X = length (xs @ ys)"
             by (simp add:is_perm_def)
       also have "\<dots>= length xs + length ys" by simp
       also have "\<dots> =  1 + length ys +
               length xs - 1" by simp
       also have "\<dots> = length (ins (hd xs) ys) +
                 length (tl xs)"
                        by (simp add: "2" ins_len)
       also have "\<dots> =
         length ((ins (hd xs) ys) @ tl xs)" by simp
       finally show ?thesis  by simp
     qed
    have pg2:"\<forall> k. count k X = count k (ins (hd xs) ys @ tl xs)"
       proof (rule allI)
         fix k
         have "count k X = count k ((ins (hd xs) ys) @ tl xs)"
            proof (cases "k= hd xs")
               assume case1: "k = hd xs"
               have "count k ((ins (hd xs) ys) @ tl xs) =
                     count k (ins (hd xs) ys) + count k (tl xs)"
                         by (simp add:count_sum)
               also have "\<dots> = 1 + count k ys + count k (tl xs)"
                   by (simp add:case1 ins_count)
               also have "\<dots> =  count k ys + 1 + count k (tl xs)" by simp
               also have "\<dots>= count k ys + count k ((hd xs) # tl xs)"
                    by (simp add: case1)
               also have "\<dots>= count k ys + count k xs"  using hdtl by auto
               also have "\<dots>= count k (ys @ xs)" by (simp add:count_sum)
               also have "\<dots>= count k X" by (simp add: "3")
               finally show "count k X = count k ((ins (hd xs) ys) @ tl xs)"
                  by simp
            next
               assume case2: "k \<noteq> hd xs"
                have "count k ((ins (hd xs) ys) @ tl xs) =
                     count k (ins (hd xs) ys) + count k (tl xs)"
                         by (simp add:count_sum)
               also have "\<dots> = count k ys + count k (tl xs)"
                   by (simp add:case2 ins_count)
               also have "\<dots>= count k ys + count k ((hd xs) # tl xs)"
                    by (simp add: case2)
               also have "\<dots>= count k ys + count k xs"  using hdtl by auto
               also have "\<dots>= count k (ys @ xs)" by (simp add:count_sum)
               also have "\<dots>= count k X" by (simp add: "3")
               finally show "count k X = count k ((ins (hd xs) ys) @ tl xs)"
                  by simp
            qed
            from this show "count k X = count k (ins (hd xs) ys @ tl xs)"
              by assumption
         qed
    from pg1 pg2 show "is_perm X (ins (hd xs) ys @ tl xs)"
         by (simp add:is_perm_def)
  qed
qed (auto simp add:is_perm_def)

end


theory Prog_Prove_2_3
  imports Main
begin

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x # xs) = (reverse xs) @ [x]"

lemma rev_distributes_over_app: "reverse (xs @ ys) = (reverse ys) @ (reverse xs)"
apply(induction xs)
apply(auto)
done

lemma rev_undos_self: "reverse (reverse xs) = xs"
apply(induction xs)
apply(auto)
apply(simp add: rev_distributes_over_app)
done

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma "mirror(mirror t) = t"
  apply(induction t)
   apply(auto)
  done

datatype 'a option = None | Some 'a

fun lookup :: "('a * 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup [] x = None" |
"lookup ((a,b) # ps) x = (if a = x then Some b else lookup ps x)"

definition sq :: "nat \<Rightarrow> nat" where
"sq n = n * n"

abbreviation sq' :: "nat \<Rightarrow> nat" where
"sq' n \<equiv> n * n"

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = Suc(div2 n)"

lemma "div2(n) = n div 2"
  apply(induction n rule: div2.induct)
  apply(auto)
  done

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents (Tip) = []" |
"contents (Node l a r) =
  (contents l)@(a # (contents r))"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = sum_tree(l) + a + sum_tree(r)"

lemma sum_tree_is_sum_list_of_contents :
  "sum_tree t = sum_list (contents t)"
  apply(induction t )
  apply(auto)
  done

datatype 'a tree2 = Tip 'a | Node "'a tree2" "'a tree2"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror2 (Tip x) = Tip x" |
"mirror2 (Node l r) = Node (mirror2 r) (mirror2 l)"

fun pre_order2 :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order2 (Tip x) = [x]" |
"pre_order2 (Node l r) = pre_order2 l @ pre_order2 r"

fun post_order2 :: "'a tree2 \<Rightarrow> 'a list" where
"post_order2 (Tip x) = [x]" |
"post_order2 (Node l r) = post_order2 r @ post_order2 l"

lemma "pre_order2 (mirror2 t) = rev (pre_order2 t)"
  apply(induction t)
  apply(auto)
  done

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse _ Nil = Nil" |
"intersperse _ [x] = [x]" |
"intersperse x (y # ys) = [y, x] @ intersperse x ys "

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule:intersperse.induct)
   apply(auto)
  done


theory Generate
  imports General_Groups "HOL-Algebra.Algebra"
begin

lemma (in group) generate_sincl:
  "A \<subseteq> generate G A"
  using generate.incl by fast

lemma (in group) generate_idem:
  assumes "A \<subseteq> carrier G"
  shows "generate G (generate G A) = generate G A"
  using assms generateI group.generate_is_subgroup by blast

lemma (in group) generate_idem':
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "generate G (generate G A \<union> B) = generate G (A \<union> B)"
proof
  show "generate G (generate G A \<union> B) \<subseteq> generate G (A \<union> B)"
  proof -
    have "generate G A \<union> B \<subseteq> generate G (A \<union> B)"
    proof -
      have "generate G A \<subseteq> generate G (A \<union> B)" using mono_generate by simp
      moreover have "B \<subseteq> generate G (A \<union> B)" by (simp add: generate.incl subset_iff)
      ultimately show ?thesis by simp
    qed
    then have "generate G (generate G A \<union> B) \<subseteq> generate G (generate G (A \<union> B))" using mono_generate by auto
    with generate_idem[of "A \<union> B"] show ?thesis using assms by simp
  qed
  show "generate G (A \<union> B) \<subseteq> generate G (generate G A \<union> B)"
  proof -
    have "A \<subseteq> generate G A" using generate.incl by fast
    thus ?thesis using mono_generate[of "A \<union> B" "generate G A \<union> B"] by blast
  qed
qed

lemma (in group) generate_subset_change_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G" "C \<subseteq> carrier G" "generate G A = generate G B"
  shows "generate G (A \<union> C) = generate G (B \<union> C)"
  by (metis assms generate_idem')

lemma (in group) generate_subgroup_id:
  assumes "subgroup H G"
  shows "generate G H = H"
  using assms generateI by auto

lemma (in group) generate_consistent':
  assumes "subgroup H G" "A \<subseteq> H"
  shows "\<forall>x \<in> A. generate G {x} = generate (G\<lparr>carrier := H\<rparr>) {x}"
  using generate_consistent assms by auto

lemma (in group) generate_idem_Un:
  assumes "A \<subseteq> carrier G"
  shows "generate G (\<Union>x\<in>A. generate G {x}) = generate G A"
proof
  have "A \<subseteq> (\<Union>x\<in>A. generate G {x})" using generate.incl by force
  thus "generate G A \<subseteq> generate G (\<Union>x\<in>A. generate G {x})" using mono_generate by presburger
  have "\<And>x. x \<in> A \<Longrightarrow> generate G {x} \<subseteq> generate G A" using mono_generate by auto
  then have "(\<Union>x\<in>A. generate G {x}) \<subseteq> generate G A" by blast
  thus "generate G (\<Union>x\<in>A. generate G {x}) \<subseteq> generate G A" using generate_idem[OF assms] mono_generate by blast
qed

lemma (in group) generate_idem_fUn:
  assumes "f A \<subseteq> carrier G"
  shows "generate G (\<Union> {generate G {x} |x. x \<in> f A}) = generate G (f A)"
proof
  have "f A \<subseteq> \<Union> {generate G {x} |x. x \<in> f A}"
  proof
    fix x
    assume x: "x \<in> f A"
    have "x \<in> generate G {x}" using generate.incl by fast
    thus "x \<in> \<Union> {generate G {x} |x. x \<in> f A}" using x by blast
  qed
  thus "generate G (f A) \<subseteq> generate G (\<Union> {generate G {x} |x. x \<in> f A})" using mono_generate by auto
  have "\<And>x. x \<in> f A \<Longrightarrow> generate G {x} \<subseteq> generate G (f A)" using mono_generate by simp
  then have "(\<Union> {generate G {x} |x. x \<in> f A}) \<subseteq> generate G (f A)" by blast
  with mono_generate[OF this] show "generate G (\<Union> {generate G {x} |x. x \<in> f A}) \<subseteq> generate G (f A)" using generate_idem[OF assms] by simp
qed

lemma (in group) generate_idem_fim_Un:
  assumes "\<Union>(f ` A) \<subseteq> carrier G"
  shows "generate G (\<Union>S \<in> A. generate G (f S)) = generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)})"
proof

  have "\<And>S. S \<in> A \<Longrightarrow> generate G (f S) = generate G (\<Union> {generate G {x} |x. x \<in> f S})" using generate_idem_fUn[of f] assms by blast
  then have "generate G (\<Union>S \<in> A. generate G (f S)) = generate G (\<Union>S \<in> A. generate G (\<Union> {generate G {x} |x. x \<in> f S}))" by simp

  have "\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)} \<subseteq> (\<Union>S\<in>A. generate G (f S))"
  proof
    fix x
    assume x: "x \<in> \<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}"
    then obtain a where a: "x \<in> generate G {a}" "a \<in> \<Union> (f ` A)" by blast
    then obtain M where M: "a \<in> f M" "M \<in> A" by blast
    then have "generate G {a} \<subseteq> generate G (f M)"
      using generate.incl[OF M(1), of G] mono_generate[of "{a}" "generate G (f M)"] generate_idem assms by auto
    then have "x \<in> generate G (f M)" using a by blast
    thus "x \<in> (\<Union>S\<in>A. generate G (f S))" using M by blast
  qed
  thus "generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}) \<subseteq> generate G (\<Union>S\<in>A. generate G (f S))" using mono_generate by simp
  have a: "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (\<Union> (f ` A))"
  proof -
    have "\<And>S. S \<in> A \<Longrightarrow> generate G (f S) \<subseteq> generate G (\<Union> (f ` A))" using mono_generate[of _ "\<Union> (f ` A)"] by blast
    then have "(\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (\<Union> (f ` A))" by blast
    then have "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (generate G (\<Union> (f ` A)))" using mono_generate by meson
    thus "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq>  generate G (\<Union> (f ` A))" using generate_idem assms by blast
  qed
  have "\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)} = (\<Union>x\<in>\<Union> (f ` A). generate G {x})" by blast
  with generate_idem_Un[OF assms] have "generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)}) = generate G (\<Union> (f ` A))" by simp
  with a show "generate G (\<Union>S\<in>A. generate G (f S)) \<subseteq> generate G (\<Union> {generate G {x} |x. x \<in> \<Union> (f ` A)})" by blast
qed

lemma (in group) generate_singleton_one:
  assumes "generate G {a} = {\<one>}"
  shows "a = \<one>"
  using generate.incl[of a "{a}" G] assms by auto

lemma (in group) generate_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G" "A \<subseteq> generate G B" "B \<subseteq> generate G A"
  shows "generate G A = generate G B"
  by (meson assms generate_subgroup_incl group.generate_is_subgroup is_group order_class.order.antisym)

lemma (in group) generate_inv_eq:
  assumes "a \<in> carrier G"
  shows "generate G {a} = generate G {inv a}"
  by (intro generate_eqI; use assms generate.inv[of a] generate.inv[of "inv a" "{inv a}" G] inv_inv[OF assms] in auto)

lemma (in group) generate_eq_imp_subset:
  assumes "generate G A = generate G B"
  shows "A \<subseteq> generate G B"
  using generate.incl assms by fast

lemma (in group) generate_subset_eqI:
  assumes "A \<subseteq> carrier G" "B \<subseteq> A" "A - B \<subseteq> generate G B"
  shows "generate G A = generate G B"
proof
  show "generate G B \<subseteq> generate G A" by (intro mono_generate, fact)
  show "generate G A \<subseteq> generate G B"
  proof(subst generate_idem[of "B", symmetric])
    show "generate G A \<subseteq> generate G (generate G B)"
      by (intro mono_generate, use assms generate_sincl[of B] in auto)
  qed (use assms in blast)
qed

lemma (in group) generate_one_irrel:
  "generate G A = generate G (A \<union> {\<one>})"
proof
  show "generate G A \<subseteq> generate G (A \<union> {\<one>})" by (intro mono_generate, blast)
  show "generate G (A \<union> {\<one>}) \<subseteq> generate G A"
  proof
    fix x
    assume x: "x \<in> generate G (A \<union> {\<one>})"
    thus "x \<in> generate G A"
    proof(induction rule: generate.induct)
    case one
      then show ?case using generate.one by auto
    next
      case (incl h)
      then show ?case using generate.one generate.incl by fast
    next
      case (inv h)
      then show ?case using generate.one generate.inv by fastforce
    next
      case (eng h1 h2)
      then show ?case using generate.eng by fast
    qed
  qed
qed

lemma (in group) generate_one_irrel':
  "generate G A = generate G (A - {\<one>})"
proof
  show "generate G (A - {\<one>}) \<subseteq> generate G A" by (intro mono_generate, blast)
  show "generate G A \<subseteq> generate G (A - {\<one>})"
  proof
    fix x
    assume x: "x \<in> generate G A"
    thus "x \<in> generate G (A - {\<one>})"
    proof(induction rule: generate.induct)
    case one
      then show ?case using generate.one by auto
    next
      case i: (incl h)
      then show ?case
      proof(cases "h = \<one>")
        case True
        then show ?thesis using generate.one by blast
      next
        case False
        with i have "h \<in> (A - {\<one>})" by blast
        then show ?thesis using generate.incl by metis
      qed
    next
      case i: (inv h)
      then show ?case
      proof(cases "h = \<one>")
        case True
        then show ?thesis using generate.one by auto
      next
        case False
        with i have "h \<in> (A - {\<one>})" by blast
        then show ?thesis using generate.inv by metis
      qed
    next
      case (eng h1 h2)
      then show ?case using generate.eng by fast
    qed
  qed
qed

lemma (in group) generate_one_switched_eqI:
  assumes "A \<subseteq> carrier G" "a \<in> A" "B = (A - {a}) \<union> {b}"
  and "b \<in> generate G A" "a \<in> generate G B"
  shows "generate G A = generate G B"
proof
  have gAc: "generate G A \<subseteq> carrier G" by (intro generate_incl[OF assms(1)])
  hence Bc: "B \<subseteq> carrier G" using assms by blast
  show "generate G A \<subseteq> generate G B"
  proof(subst generate_idem[OF Bc, symmetric], intro mono_generate, rule)
    fix x
    assume x: "x \<in> A"
    show "x \<in> generate G B"
    proof (cases "x = a")
      case True
      then show ?thesis using assms by blast
    next
      case False
      with x assms have "x \<in> B" by blast
      thus ?thesis using generate.incl by metis
    qed
  qed
  show "generate G B \<subseteq> generate G A"
  proof(subst generate_idem[OF assms(1), symmetric], intro mono_generate, rule)
    fix x
    assume x: "x \<in> B"
    show "x \<in> generate G A"
    proof (cases "x = b")
      case True
      then show ?thesis using assms by blast
    next
      case False
      with x assms have "x \<in> A" by blast
      thus ?thesis using generate.incl by metis
    qed
  qed
qed

lemma (in group) generate_nat_pow:
  assumes "ord a \<noteq> 0" "a \<in> carrier G"
  shows "generate G {a} = {a [^] k |k. k \<in> {0..ord a - 1}}"
proof -
  obtain n where n: "n = ord a" "n > 0" using assms by blast
  have "\<And>m. a [^] m = a [^] (m mod int n)"
    using n pow_int_mod_ord assms assms(2) by blast
  moreover have "\<And>m. a [^] (m mod int n) \<in> {a [^] k |k::int. k \<in> {0..(int n) - 1}}"
    using pos_mod_conj[of n] n(2) by auto
  ultimately have gp:"\<And>m::int. a [^] m \<in> {a [^] k |k::int. k \<in> {0..(int n) - 1}}"
    by presburger
  then have 1:"generate G {a} = {a [^] k|k::int. k \<in> {0..(int n) - 1}}"
    using generate_pow[of a] assms(2) by auto
  have 2:"{a [^] k|k::int. k \<in> {0..(int n - 1)}} = {a [^] k|k::nat. k \<in> {0..n - 1}}" (is "?L = ?R")
  proof(intro equalityI subsetI)
    fix x
    assume "x \<in> ?L"
    then obtain k where k:"x = a [^] (k::int)" "0 \<le> k" "k < n" by auto
    then have "x = a [^] (nat k)" by auto
    moreover have "nat k \<in> {0..n-1}" using k by fastforce
    ultimately show "x \<in> ?R" by fast
  next
    fix x
    assume "x \<in> ?R"
    then obtain k where k:"x = a [^] (k::nat)" "k \<le> n" by force
    then have g: "x = a [^] (int k)" using int_pow_int[of G a k] by argo
    thus "x \<in> ?L"
    proof (cases "k = n")
      case True
      then have "x = \<one>" using n k assms(2) by auto
      then show ?thesis using gp by force
    next
      case False
      then have "int k \<in> {0::int..(int n - 1)}" using k by fastforce
      with g show ?thesis by blast
    qed
  qed
  show ?thesis using 1 2 n by algebra
qed

lemma (in group) generate_nat_pow':
  assumes "ord a \<noteq> 0" "a \<in> carrier G"
  shows "generate G {a} = {a [^] k |k. k \<in> {1..ord a}}"
proof -
  have "{a [^] k |k. k \<in> {1..ord a}} = {a [^] k |k. k \<in> {0..ord a - 1}}"
  proof -
    have "a [^] k \<in> {a [^] k |k. k \<in> {0..ord a - 1}}" if "k \<in> {1..ord a}" for k
      using that pow_nat_mod_ord[OF assms(2, 1), of "ord a"] assms by (cases "k = ord a"; force)
    moreover have "a [^] k \<in> {a [^] k |k. k \<in> {1..ord a}}" if "k \<in> {0..ord a - 1}" for k
    proof(cases "k = 0")
      case True
      hence "a [^] k = a [^] ord a" using pow_ord_eq_1[OF assms(2)] by auto
      moreover have "ord a \<in> {1..ord a}" using assms unfolding atLeastAtMost_def atLeast_def atMost_def by auto
      ultimately show ?thesis by blast
    next
      case False
      then show ?thesis using that by auto
    qed
    ultimately show ?thesis by blast
  qed
  with generate_nat_pow[OF assms] show ?thesis by simp
qed

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

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

datatype Nat = Z | S "Nat"

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

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

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "Nat => Nat" where
  "nmsorttdhalf1 x =
   (if (x = (S Z)) then Z else
      (case x of
         Z => Z
         | S y => plus (S Z) (nmsorttdhalf1 (minus x (S (S Z))))))"
  by pat_completeness auto

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

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

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

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

(*fun did not finish the proof*)
function nmsorttd :: "Nat list => Nat list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (nmsorttd xs)"
  oops

end


theory Bondy
imports Main
begin

lemma card_less_if_surj_not_inj:
  "\<lbrakk> finite A; f ` A = B; \<not> inj_on f A \<rbrakk> \<Longrightarrow> card B < card A"
by (metis assms card_image_le inj_on_iff_eq_card order_le_neq_trans)

theorem Bondy :
  assumes "\<forall>A \<in> F. A \<subseteq> X" and "card X \<ge> 1" and "card F = card X"
  shows "\<exists>D. D \<subseteq> X & card D < card X & card (inter D ` F) = card F"
proof -
  from assms(2,3) have "finite F" and "finite X"
    by (metis card_infinite not_one_le_zero)+
  { fix m
    have "m < card F \<Longrightarrow> \<exists>D. D \<subseteq> X & card D \<le> m & card (inter D ` F) \<ge> m + 1"
    proof (induction m)
      case 0
      hence "{} \<subseteq> X & card {} \<le> 0 & card (inter {} ` F) \<ge> 0 + 1"
        by auto (metis Suc_leI card_eq_0_iff empty_is_image finite_imageI gr0I)
      thus "\<exists>D. (D \<subseteq> X & card D \<le> 0 & card (inter D ` F) \<ge> 0 + 1)" by blast
    next
      case (Suc m)
      hence "m < card F" by arith
      with Suc.IH obtain D
        where D: "D \<subseteq> X \<and> card D \<le> m \<and> m + 1 \<le> card (inter D ` F)" by auto
      with `finite X` have "finite D" by (auto intro: finite_subset)
      show ?case
      proof (cases "card (inter D ` F) = card F")
        case True
        hence "D \<subseteq> X \<and> card D \<le> Suc m \<and> Suc m + 1 \<le> card(inter D ` F)"
          using D Suc.prems by auto
        thus ?thesis by blast
      next
        case False
        hence "~ inj_on (inter D) F" by (auto simp: card_image)
        then obtain A1 A2 where "A1 \<in> F" and "A2 \<in> F" and
          "D \<inter> A1 = D \<inter> A2" and "A1 \<noteq> A2"  by (auto simp: inj_on_def)
        then obtain x where x: "x : (A1 - A2) \<union> (A2 - A1)" by auto
        from `\<forall>A \<in> F. A \<subseteq> X` `A1 \<in> F` `A2 \<in> F` x have "x : X" by auto
        let ?E = "insert x D"
        from D `finite D` have "card ?E \<le> Suc m"
          by (metis (full_types) Suc_le_mono card_insert_if le_Suc_eq)
        moreover with D `x:X` have "?E \<subseteq> X" by auto
        moreover have "Suc m < card (inter ?E ` F)"
        proof -
          from `D \<inter> A1 = D \<inter> A2` have 1: "(D \<inter> (?E \<inter> A1)) = (D \<inter> (?E \<inter> A2))"
            by auto
          from x have 2: "?E Int A1 \<noteq> ?E Int A2" by auto
          have 3: "inter D \<circ> inter ?E = inter D" by auto
          have 4: "~ inj_on (inter D) (inter ?E ` F)"
            unfolding inj_on_def using 1 2 `A1 \<in> F` `A2 \<in> F` by blast
          from D have "Suc m \<le> card (inter D ` F)" by auto
          also have "... < card (inter ?E ` F)"
            by (rule card_less_if_surj_not_inj[of _ "inter D"])
              (auto simp add: image_image 3 4 `finite F`)
          finally show ?thesis .
        qed
        ultimately have "?E\<subseteq>X \<and> card ?E \<le> Suc m \<and> Suc m + 1 \<le> card (inter ?E ` F)"
          by auto
        thus "\<exists>D\<subseteq>X. card D \<le> Suc m \<and> Suc m + 1 \<le> card (inter D ` F)" by blast
      qed
    qed
  }
  moreover from assms(2,3) have "card X - 1 < card F" by auto
  ultimately obtain D where
    "D \<subseteq> X & card D \<le> card X - 1 & card (inter D ` F) \<ge> (card X - 1) + 1"
    by auto
  moreover with `finite F` have "card (inter D ` F) \<le> card F"
    by (elim card_image_le)
  ultimately have "D \<subseteq> X & card D < card X & card (inter D ` F) = card F"
    using `card F = card X` by auto
  thus ?thesis by auto
qed

end


theory Heap
imports Main
begin

subsection "References"

definition "ref = (UNIV::nat set)"

typedef ref = ref by (simp add: ref_def)

code_datatype Abs_ref

lemma finite_nat_ex_max:
  assumes fin: "finite (N::nat set)"
  shows "\<exists>m. \<forall>n\<in>N. n < m"
using fin
proof (induct)
  case empty
  show ?case by auto
next
  case (insert k N)
  have "\<exists>m. \<forall>n\<in>N. n < m" by fact
  then obtain m where m_max: "\<forall>n\<in>N. n < m"..
  show "\<exists>m. \<forall>n\<in>insert k N. n < m"
  proof (rule exI [where x="Suc (max k m)"])
  qed (insert m_max, auto simp add: max_def)
qed

lemma infinite_nat: "\<not>finite (UNIV::nat set)"
proof
  assume fin: "finite (UNIV::nat set)"
  then obtain m::nat where "\<forall>n\<in>UNIV. n < m"
    by (rule finite_nat_ex_max [elim_format] ) auto
  moreover have "m\<in>UNIV"..
  ultimately show False by blast
qed

lemma infinite_ref [simp,intro]: "\<not>finite (UNIV::ref set)"
proof
  assume "finite (UNIV::ref set)"
  hence "finite (range Rep_ref)"
    by simp
  moreover
  have "range Rep_ref = ref"
  proof
    show "range Rep_ref \<subseteq> ref"
      by (simp add: ref_def)
  next
    show "ref \<subseteq> range Rep_ref"
    proof
      fix x
      assume x: "x \<in> ref"
      show "x \<in> range Rep_ref"
        by (rule Rep_ref_induct) (auto simp add: ref_def)
    qed
  qed
  ultimately have "finite ref"
    by simp
  thus False
    by (simp add: ref_def infinite_nat)
qed

consts Null :: ref

definition new :: "ref set \<Rightarrow> ref" where
  "new A = (SOME a. a \<notin> {Null} \<union> A)"

text \<open>
  Constant @{const "Null"} can be defined later on.  Conceptually
  @{const "Null"} and @{const "new"} are \<open>fixes\<close> of a locale
  with @{prop "finite A \<Longrightarrow> new A \<notin> A \<union> {Null}"}.  But since definitions
  relative to a locale do not yet work in Isabelle2005 we use this
  workaround to avoid lots of parameters in definitions.
\<close>

lemma new_notin [simp,intro]:
 "finite A \<Longrightarrow> new (A) \<notin> A"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
  done

lemma new_not_Null [simp,intro]:
  "finite A \<Longrightarrow> new (A) \<noteq> Null"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
done

end


(*  Title:       Map Function on Two Parallel Lists
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Map Function on Two Parallel Lists\<close>

theory Map2
  imports Main
begin

text \<open>
This theory defines a map function that applies a (curried) binary function elementwise to two
parallel lists.

The definition is taken from @{url "https://www.isa-afp.org/browser_info/current/AFP/Jinja/Listn.html"}.
\<close>

abbreviation map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
  "map2 f xs ys \<equiv> map (case_prod f) (zip xs ys)"

lemma map2_empty_iff[simp]: "map2 f xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
  by (metis Nil_is_map_conv list.exhaust list.simps(3) zip.simps(1) zip_Cons_Cons zip_Nil)

lemma image_map2: "length t = length s \<Longrightarrow> g ` set (map2 f t s) = set (map2 (\<lambda>a b. g (f a b)) t s)"
  by auto

lemma map2_tl: "length t = length s \<Longrightarrow> map2 f (tl t) (tl s) = tl (map2 f t s)"
  by (metis (no_types, lifting) hd_Cons_tl list.sel(3) map2_empty_iff map_tl tl_Nil zip_Cons_Cons)

lemma map_zip_assoc:
  "map f (zip (zip xs ys) zs) = map (\<lambda>(x, y, z). f ((x, y), z)) (zip xs (zip ys zs))"
  by (induct zs arbitrary: xs ys) (auto simp add: zip.simps(2) split: list.splits)

lemma set_map2_ex:
  assumes "length t = length s"
  shows "set (map2 f s t) = {x. \<exists>i < length t. x = f (s ! i) (t ! i)}"
proof (rule; rule)
  fix x
  assume "x \<in> set (map2 f s t)"
  then obtain i where i_p: "i < length (map2 f s t) \<and> x = map2 f s t ! i"
    by (metis in_set_conv_nth)
  from i_p have "i < length t"
    by auto
  moreover from this i_p have "x = f (s ! i) (t ! i)"
    using assms by auto
  ultimately show "x \<in> {x. \<exists>i < length t. x = f (s ! i) (t ! i)}"
    using assms by auto
next
  fix x
  assume "x \<in> {x. \<exists>i < length t. x = f (s ! i) (t ! i)}"
  then obtain i where i_p: "i < length t \<and> x = f (s ! i) (t ! i)"
    by auto
  then have "i < length (map2 f s t)"
    using assms by auto
  moreover from i_p have "x = map2 f s t ! i"
    using assms by auto
  ultimately show "x \<in> set (map2 f s t)"
    by (metis in_set_conv_nth)
qed

end