theory cyclePath
imports segmentList
begin

(*closed path*)
definition cyclePath :: "point2d list \<Rightarrow> point2d list" where
  "pointList P \<Longrightarrow> cyclePath P \<equiv> P @ [hd P]"
lemma cyclePathHd [simp]: "pointList L \<Longrightarrow> hd L \<noteq> last L"by (cases L, auto simp add: pointList_def)
lemma cyclePathLength [simp]: "pointList L \<Longrightarrow> length (cyclePath L) = length L + 1"
  by (simp add: cyclePath_def)
lemma cyclePathHd1 [simp]: "pointList L \<Longrightarrow> hd(cyclePath L) = last(cyclePath L)"
  by (simp add: cyclePath_def hd_append)

(*Output cycle in reverse*)
definition revCycle :: "point2d list \<Rightarrow> point2d list" where
  "pointList L \<Longrightarrow> revCycle L \<equiv> cyclePath (hd L # rev (tl L))"

(*all adjacent edges of cyclePath are segments*)
lemma cyclePathLastSegment : "pointList L \<Longrightarrow> segment (last L) (last (cyclePath L))"
  by (simp add: cyclePath_def segment_def, subst neq_commute, simp)
theorem cyclePathSegments : "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> i < length P - 1 \<Longrightarrow>
  segment (P!i) (P! Suc i)"
  apply (unfold cyclePath_def, simp, cut_tac L=L and a="hd L" in pointsSegmentsAppend1, simp)
by (simp add: segment_def, cases L, auto simp add: pointList_def)

(*two adjacent nodes in cyclepath are unequal*)
lemma cyclePathAdjacentSame: "pointList L \<Longrightarrow> i < length (cyclePath L) - 1 \<Longrightarrow>
    cyclePath L ! i \<noteq> cyclePath L ! Suc i"
  apply (cut_tac L=L and P= "cyclePath L" and i=i in cyclePathSegments, simp+)
  apply (simp add: segment_def)
done
lemma cyclePathAdjacentSame1: "pointList L \<Longrightarrow> i < length (cyclePath L) - 1 \<Longrightarrow>
    k < length (cyclePath L) - 1 \<Longrightarrow> cyclePath L ! i \<noteq> cyclePath L ! k \<Longrightarrow>
    cyclePath L ! Suc i \<noteq> cyclePath L ! Suc k"
    apply (rule ccontr, simp)
by (smt Cons_nth_drop_Suc Suc_lessI cyclePath_def diff_Suc_1 hd_append hd_drop_conv_nth
  id_take_nth_drop nat.distinct(1) nth_append nth_append_length nth_eq_iff_index_eq pointList_def
  take_0 zero_less_Suc)

(*no 3 consecutive points in cyclepath L are collinear if L is collinear-free*)
lemma cyclePathNotCollinear1:"pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
  a < length P - 2 \<Longrightarrow> signedArea (P ! a) (P ! Suc a) (P ! Suc (Suc a)) \<noteq> 0"
  apply (subgoal_tac "(a = length P - 3 \<longrightarrow> \<not> collinear (P! a)(P!Suc a)(last P)) \<and>
    (a < length P - 3 \<longrightarrow> signedArea (P ! a) (P ! Suc a) (P ! Suc (Suc a)) \<noteq> 0) ")
  apply (simp only: colliniearRight)
   apply (smt Suc_diff_Suc Suc_eq_plus1 add_2_eq_Suc' colliniearRight diff_Suc_1 last_conv_nth
     diff_Suc_eq_diff_pred gr_implies_not0  length_0_conv less_SucE less_diff_conv less_imp_Suc_add
     less_trans_Suc numeral_2_eq_2 numeral_3_eq_3 zero_less_Suc)
  apply (safe)
  apply (simp add: cyclePath_def collinearList_def)
  apply (erule_tac x=0 in allE, safe, simp)
  apply (erule_tac x="(length L - 2)" in allE, safe, simp)
  apply (erule_tac x="Suc (length L - 2)" in allE, safe, simp)
  apply (smt One_nat_def Suc_1 Suc_diff_1 Suc_diff_Suc le_refl length_greater_0_conv list.size(3)
    not_less_eq_eq not_less_iff_gr_or_eq numeral_eq_Suc pointList_def pred_numeral_simps(3) zero_less_diff)
  apply (simp)
  apply (metis One_nat_def Suc_eq_plus1 Suc_lessD hd_conv_nth length_0_conv less_diff_conv
    less_nat_zero_code nth_append)
  apply (simp add: cyclePath_def collinearList_def)
  apply (erule_tac x=a in allE, safe, simp)
  apply (erule_tac x="Suc a" in allE, safe, simp)
  apply (erule_tac x="Suc (Suc a)" in allE, safe, simp)
  apply (simp, simp, simp)
by(smt One_nat_def Suc_eq_plus1 Suc_lessD add_Suc_right colliniearRight less_diff_conv
    nth_append numeral_2_eq_2)

(*all consecutive 3 corners in cyclepath are left or right oriented; if L is collinear-free*)
theorem cyclePathNotCollinear2: "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
  a < length P - 2 \<Longrightarrow> (signedArea (P!a) (P ! Suc a) (P ! Suc(Suc a)) < 0)
  \<or> ( signedArea (P ! a) (P ! Suc a) (P ! Suc (Suc a)) > 0)"
  apply (safe del: allI)
  apply (simp)
  apply (simp add: collinearList_def)
  apply (case_tac "a < length P - 3", simp)
    apply (subgoal_tac "signedArea (cyclePath L ! a) (cyclePath L ! Suc a)
      (cyclePath L ! Suc (Suc a)) = signedArea (L ! a) (L ! Suc a) (L ! Suc (Suc a))")
    apply (smt collinearListAdj collinearList_def colliniearRight)
    apply (simp add: cyclePath_def)
    apply (smt Suc_diff_Suc Suc_less_SucD Suc_mono diff_Suc_less diff_less_Suc less_trans_Suc nth_append numeral_2_eq_2 zero_less_diff)
  apply (simp)
  apply (case_tac "a = length L - 2", auto simp add: cyclePath_def)
  apply (subgoal_tac "signedArea ((L @ [hd L]) ! (length L - 2)) ((L @ [hd L]) ! Suc (length L - 2))
     ((L @ [hd L]) ! Suc (Suc (length L - 2))) \<noteq> 0", simp)
using collinearList_def cyclePathNotCollinear1 cyclePath_def less_imp_Suc_add by auto

(*no 3 corners in cyclepath are collinear, except Last node; if L is collinear-free*)
theorem cyclePathNotCollinear: "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
  a < length P \<Longrightarrow> b < length P \<Longrightarrow> c < length P \<Longrightarrow>
  P!a \<noteq> P!b \<and> P!a \<noteq> P!c \<and> P!c \<noteq> P!b \<Longrightarrow> \<not>collinear (P ! a) (P ! b) (P ! c)"
by (smt Cons_nth_drop_Suc collRotate collinearList_def cyclePath_def diff_Suc_1 hd_append
  hd_drop_conv_nth id_take_nth_drop last_conv_nth last_snoc length_append_singleton nth_append
  length_greater_0_conv less_antisym less_imp_Suc_add less_nat_zero_code list.size(3) take_0)

(*intersection(cyclePath, Strecke A B)*)
fun lineCyclePathInters :: "point2d list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "lineCyclePathInters [] P R = False"
| "lineCyclePathInters [a] P R = False"
| "lineCyclePathInters (a#b#xs) P R = (intersect a b P R \<or> lineCyclePathInters (b#xs) P R)"
(*some simple Lemmas. Simplifies proofs*)
lemma lineCyclePathIntersSimp [simp]: "\<not>lineCyclePathInters (b#L) A B \<Longrightarrow>
    lineCyclePathInters (a#b#L) A B = lineCyclePathInters [a,b] A B"
  by (simp)
lemma lineCyclePathIntersSimp1: "length L \<ge> 1 \<Longrightarrow> \<not>lineCyclePathInters (b#L) A B \<Longrightarrow>
    \<not>intersect b (hd L) A B"
  by (cases L, auto)
lemma lineCyclePathIntersSimp2 [simp]: "\<not>lineCyclePathInters [a,b] A B \<Longrightarrow>
    lineCyclePathInters (a#b#L) A B = lineCyclePathInters (b#L) A B"
  by (simp)
lemma lineCyclePathIntersSimp6 : " \<not>lineCyclePathInters (b # xs) P R
  \<Longrightarrow> \<exists> i < length (a # b # xs) - 1. intersect P R ((a # b # xs) ! i) ((a # b # xs) ! Suc i) \<Longrightarrow>
  intersect P R a b"
  apply (induct "(b # xs)" P R rule: lineCyclePathInters.induct)
  apply (auto)
  apply (case_tac "i > 0", auto)
oops
lemma lineCyclePathIntersSimp3 : "i < length (a # b # xs) - 1 \<Longrightarrow> \<not>lineCyclePathInters (b # xs) P R
  \<Longrightarrow> intersect P R ((a # b # xs) ! i) ((a # b # xs) ! Suc i) \<Longrightarrow> intersect P R a b"
  apply (simp)
  apply (subgoal_tac "\<not>intersect P R ((b # xs) ! i) ((xs) ! i)", auto)
oops
lemma lineCyclePathIntersNeg : "\<not>lineCyclePathInters (a#b#L) A B \<Longrightarrow>
    \<not>lineCyclePathInters [a,b] A B \<and> \<not>lineCyclePathInters (b#L) A B"
  by (simp)

(*when there is an intersection between cyclepath and segment AB?*)
lemma lineCyclePathInters1: "lineCyclePathInters L A B \<Longrightarrow>
  (\<exists> i. i<length L - 1 \<and> intersect (L!i) (L ! Suc i) A B)"
  apply (induct L A B rule:lineCyclePathInters.induct, simp, simp)
by (auto, rule_tac x="i + 1" in exI, simp)
lemma lineCyclePathInters2: "(\<exists> i. i < length L - 1 \<and> intersect (L ! i) (L ! Suc i) A B) \<Longrightarrow>
  segment A B \<Longrightarrow> lineCyclePathInters L A B"
  apply (induction rule: lineCyclePathInters.induct, auto)
by (metis Suc_eq_plus1 Suc_less_eq Suc_pred add.left_neutral neq0_conv nth_Cons')

theorem lineCyclePathIntersEq: "segment A B \<Longrightarrow> lineCyclePathInters L A B =
  (\<exists> i. i < length L - 1 \<and> intersect (L!i) (L ! Suc i) A B)"
  apply (rule iffI, metis lineCyclePathInters1)
by(metis lineCyclePathInters2)

(*intersection(CyclePath, CyclePath)*)
definition cyclePathIntersect ::  "point2d list \<Rightarrow> point2d list \<Rightarrow> bool" where
  "cyclePathIntersect A B \<equiv> \<exists> i < length B - 1. lineCyclePathInters A (B!i) (B!Suc i)"
lemma cyclePathNotIntersectSame: "pointList P \<Longrightarrow> A = cyclePath P \<Longrightarrow> intersectionFreePList A \<Longrightarrow>
  cyclePathIntersect A A \<Longrightarrow> False"
  apply (auto simp add: cyclePathIntersect_def)
  apply (case_tac "(A, (A!0), (A!Suc 0))" rule: lineCyclePathInters.cases)
  apply (simp add: cyclePath_def)
  using cyclePath_def apply auto[1]
  apply (simp,safe, simp add: pointList_def)
  apply (subgoal_tac "segment a b \<and> segment ((a # b # xs) ! i) ((b # xs) ! i)", simp add: intersect_def)
oops

lemma cyclePathIntersectSym: "pointList P \<Longrightarrow> pointList Q \<Longrightarrow> A = cyclePath P \<Longrightarrow> B = cyclePath Q\<Longrightarrow>
  cyclePathIntersect A B = cyclePathIntersect B A"
  apply (auto simp add: cyclePathIntersect_def)
  apply (case_tac "(A, (B ! i), (B ! Suc i))" rule: lineCyclePathInters.cases,safe)
  apply (simp+, safe)
  apply (rule_tac x=0 in exI, safe, simp add: pointList_def, simp)
  apply (metis cyclePathSegments cyclePath_def diff_Suc_1 impossible_Cons intersectSym1 length_Cons
     le0 length_append_singleton lineCyclePathInters2 list.sel(3) neq0_conv nth_Cons_0 nth_tl)
  apply (smt Suc_mono cyclePathSegments cyclePath_def diff_Suc_1 intersectSym1 length_Cons nth_tl
    length_append_singleton less_SucI lineCyclePathInters1 lineCyclePathInters2 list.sel(3))
by (metis add_diff_cancel_right' cyclePathLength cyclePathSegments intersectSym1 lineCyclePathInters1 lineCyclePathInters2)

(*at least one of cyclepaths intersected*)
definition cyclePathsIntersect :: "(point2d list) list \<Rightarrow> bool" where
  "pointLists PL \<Longrightarrow> cyclePathsIntersect PL \<equiv> \<exists> i j. i\<noteq>j \<and> i < length PL \<and> j < length PL
    \<and> cyclePathIntersect (cyclePath (PL!i)) (cyclePath (PL!j))"
lemma cyclePathsIntersectSimp: "pointList P \<Longrightarrow> pointList Q \<Longrightarrow>
  cyclePathIntersect (cyclePath P) (cyclePath Q) = cyclePathsIntersect [P , Q]"
  apply (subgoal_tac "pointLists [P, Q]")
  apply (simp only: cyclePathsIntersect_def, safe) defer
  apply (simp, case_tac i, simp)
  apply (smt One_nat_def Suc_1 cyclePathIntersect_def cyclePathSegments intersectSym1 less_2_cases
    lineCyclePathIntersEq nth_Cons' nth_Cons_Suc)
  using pointListsSimp apply blast
by (rule_tac x=0 in exI, rule_tac x=1 in exI, auto)

end


(*  Title:      HOL/UNITY/Comp/Counterc.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

A family of similar counters, version with a full use of
"compatibility ".

From Charpentier and Chandy,
Examples of Program Composition Illustrating the Use of Universal Properties
   In J. Rolim (editor), Parallel and Distributed Processing,
   Spriner LNCS 1586 (1999), pages 1215-1227.
*)

section{*A Family of Similar Counters: Version with Compatibility*}

theory Counterc imports "../UNITY_Main" begin

typedecl state

consts
  C :: "state=>int"
  c :: "state=>nat=>int"

primrec sum  :: "[nat,state]=>int" where
  (* sum I s = sigma_{i<I}. c s i *)
  "sum 0 s = 0"
| "sum (Suc i) s = (c s) i + sum i s"

primrec sumj :: "[nat, nat, state]=>int" where
  "sumj 0 i s = 0"
| "sumj (Suc n) i s = (if n=i then sum n s else (c s) n + sumj n i s)"

type_synonym command = "(state*state)set"

definition a :: "nat=>command" where
 "a i = {(s, s'). (c s') i = (c s) i + 1 & (C s') = (C s) + 1}"

definition Component :: "nat => state program" where
  "Component i = mk_total_program({s. C s = 0 & (c s) i = 0},
                                  {a i},
                                  \<Union>G \<in> preserves (%s. (c s) i). Acts G)"

declare Component_def [THEN def_prg_Init, simp]
declare Component_def [THEN def_prg_AllowedActs, simp]
declare a_def [THEN def_act_simp, simp]

(* Theorems about sum and sumj *)
lemma sum_sumj_eq1: "I<i ==> sum I s = sumj I i s"
  by (induct I) auto

lemma sum_sumj_eq2: "i<I ==> sum I s  = c s i + sumj I i s"
  by (induct I) (auto simp add: linorder_neq_iff sum_sumj_eq1)

lemma sum_ext: "(\<And>i. i<I \<Longrightarrow> c s' i = c s i) ==> sum I s' = sum I s"
  by (induct I) auto

lemma sumj_ext: "(\<And>j. j<I ==> j\<noteq>i ==> c s' j =  c s j) ==> sumj I i s' = sumj I i s"
  by (induct I) (auto intro!: sum_ext)

lemma sum0: "(\<And>i. i<I ==> c s i = 0) ==> sum I s = 0"
  by (induct I) auto

(* Safety properties for Components *)

lemma Component_ok_iff:
     "(Component i ok G) =
      (G \<in> preserves (%s. c s i) & Component i \<in> Allowed G)"
apply (auto simp add: ok_iff_Allowed Component_def [THEN def_total_prg_Allowed])
done
declare Component_ok_iff [iff]
declare OK_iff_ok [iff]
declare preserves_def [simp]

lemma p2: "Component i \<in> stable {s. C s = (c s) i + k}"
by (simp add: Component_def, safety)

lemma p3:
     "[| OK I Component; i\<in>I |]
      ==> Component i \<in> stable {s. \<forall>j\<in>I. j\<noteq>i --> c s j = c k j}"
apply simp
apply (unfold Component_def mk_total_program_def)
apply (simp (no_asm_use) add: stable_def constrains_def)
apply blast
done

lemma p2_p3_lemma1:
     "[| OK {i. i<I} Component; i<I |] ==>
      \<forall>k. Component i \<in> stable ({s. C s = c s i + sumj I i k} Int
                                {s. \<forall>j\<in>{i. i<I}. j\<noteq>i --> c s j = c k j})"
by (blast intro: stable_Int [OF p2 p3])

lemma p2_p3_lemma2:
     "(\<forall>k. F \<in> stable ({s. C s = (c s) i + sumj I i k} Int
                        {s. \<forall>j\<in>{i. i<I}. j\<noteq>i --> c s j = c k j}))
      ==> (F \<in> stable {s. C s = c s i + sumj I i s})"
apply (simp add: constrains_def stable_def)
apply (force intro!: sumj_ext)
done

lemma p2_p3:
     "[| OK {i. i<I} Component; i<I |]
      ==> Component i \<in> stable {s. C s = c s i + sumj I i s}"
by (blast intro: p2_p3_lemma1 [THEN p2_p3_lemma2])

(* Compositional correctness *)
lemma safety:
     "[| 0<I; OK {i. i<I} Component |]
      ==> (\<Squnion>i\<in>{i. i<I}. (Component i)) \<in> invariant {s. C s = sum I s}"
apply (simp (no_asm) add: invariant_def JN_stable sum_sumj_eq2)
apply (auto intro!: sum0 p2_p3)
done

end


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

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

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

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

theorem property0 :
  "((take n (drop m xs)) = (drop m (take (t2 n m) xs)))"
  oops

end


theory "HOLCF-Meet-Classes"
imports "HOLCF-Meet" "HOLCF-Join"
begin

subsubsection {* Type classes for various kinds of meets *}

text {* Meets for finite nonempty sets with a lower bound. *}

class Bounded_Nonempty_Meet_cpo = cpo +
  assumes bounded_nonempty_meet_exists: "S \<noteq> {} \<Longrightarrow> (\<exists>z. S >| z) \<Longrightarrow> \<exists>x. S >>| x"
begin
  lemma nonempty_ub_implies_lub_exists:
  assumes "S <| u"
  assumes "S \<noteq> {}"
  shows "\<exists> z. S <<| z"
  proof-
    have "{u. S <| u} \<noteq> {}" using assms(1) by auto
    hence "\<exists>x. {u. S <| u} >>| x"
      apply (rule bounded_nonempty_meet_exists)
      by (metis CollectE assms(2) equals0I is_lbI is_ub_def)
    then obtain lu where lb: "{u. S <| u} >>| lu" by auto
    hence "S <| lu"
      by (metis is_glb_above_iff is_lb_def is_ub_def mem_Collect_eq)
    hence "S <<| lu"
      by (metis (full_types) is_lubI is_glbD1 is_lb_def lb mem_Collect_eq)
    thus ?thesis ..
  qed

  lemma ub_implies_compatible:
    "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> compatible x y"
    unfolding compatible_def
    by (rule nonempty_ub_implies_lub_exists, auto)
end

text {* Meets for finite nonempty sets. *}

class Nonempty_Meet_cpo = cpo +
  assumes nonempty_meet_exists: "S \<noteq> {} \<Longrightarrow> \<exists>x. S >>| x"
begin
  lemma ub_implies_lub_exists:
  assumes "S <| u"
  shows "\<exists> z. S <<| z"
  proof-
    have "{u. S <| u} \<noteq> {}" using assms by auto
    from nonempty_meet_exists[OF this]
    obtain lu where lb: "{u. S <| u} >>| lu" by auto
    hence "S <| lu"
      by (metis is_glb_above_iff is_lb_def is_ub_def mem_Collect_eq)
    hence "S <<| lu"
      by (metis (full_types) is_lubI is_glbD1 is_lb_def lb mem_Collect_eq)
    thus ?thesis ..
  qed
end

context Nonempty_Meet_cpo
begin
  subclass Bounded_Nonempty_Meet_cpo
  apply default by (metis nonempty_meet_exists)
end

lemma (in Bounded_Nonempty_Meet_cpo) compatible_down_closed:
    assumes "compatible x y"
    and "z \<sqsubseteq> x"
    shows "compatible z y"
proof-
    from assms(1) obtain ub where "{x, y} <<| ub" by (metis compatible_def)
    hence "{x,y} <| ub" by (metis is_lubD1)
    hence "{z,y} <| ub" using assms(2) by (metis is_ub_insert rev_below_trans)
    thus ?thesis unfolding compatible_def by (metis insert_not_empty nonempty_ub_implies_lub_exists)
qed

lemma (in Bounded_Nonempty_Meet_cpo) compatible_down_closed2:
    assumes "compatible y x"
    and "z \<sqsubseteq> x"
    shows "compatible y z"
proof-
    from assms(1) obtain ub where "{y, x} <<| ub" by (metis compatible_def)
    hence "{y,x} <| ub" by (metis is_lubD1)
    hence "{y,z} <| ub" using assms(2) by (metis is_ub_insert rev_below_trans)
    thus ?thesis unfolding compatible_def by (metis insert_not_empty nonempty_ub_implies_lub_exists)
qed

lemma join_mono':
  assumes  "compatible (c::'a::Bounded_Nonempty_Meet_cpo) d"
  and "a \<sqsubseteq> c"
  and "b \<sqsubseteq> d"
  shows "a \<squnion> b \<sqsubseteq> c \<squnion> d"
  apply (rule join_mono[OF _ assms(1) assms(2) assms(3)])
  by (metis assms(1) assms(2) assms(3) compatible_down_closed2 compatible_sym)

subsubsection {* Bifinite domains with finite nonempty meets have arbitrary nonempty meets. *}

class Finite_Meet_bifinite_cpo = Finite_Meet_cpo + bifinite

lemma is_ub_range:
     "S >| u \<Longrightarrow> Rep_cfun f ` S >| f \<cdot> u"
  apply (rule is_lbI)
  apply (erule imageE)
  by (metis monofun_cfun_arg is_lbD)

lemma (in approx_chain) lub_approx_arg: "(\<Squnion>i. approx i \<cdot> u ) = u"
  by (metis chain_approx lub_ID_reach lub_approx)

instance Finite_Meet_bifinite_cpo \<subseteq> Nonempty_Meet_cpo
proof (default)
  from bifinite obtain approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain approx" by auto
  fix S
  assume "(S :: 'a set) \<noteq> {}"
  have "\<And>i. \<exists> l . Rep_cfun (approx i) ` S >>|l"
    apply (rule finite_meet_exists)
    using `S \<noteq> {}` apply auto[1]
    using  finite_deflation.finite_range[OF approx_chain.finite_deflation_approx[OF `approx_chain approx`]]
    by (metis (full_types) image_mono rev_finite_subset top_greatest)
  then obtain Y where Y_is_glb: "\<And>i. Rep_cfun (approx i) ` S >>| Y i" by metis

  have "chain Y"
    apply (rule chainI)
    apply (subst is_glb_above_iff[OF Y_is_glb])
    apply (rule is_lbI)
    apply (erule imageE)
    apply (erule ssubst)
    apply (rule rev_below_trans[OF monofun_cfun_fun[OF chainE[OF approx_chain.chain_approx[OF `approx_chain approx`]]]])
    apply (rule is_lbD[OF is_glbD1[OF Y_is_glb]])
    apply (erule imageI)
    done

  have "S >| Lub Y"
  proof(rule is_lbI, rule lub_below[OF `chain Y`])
    fix x i
    assume "x \<in> S"
    hence "Y i \<sqsubseteq> approx i \<cdot> x"
      by (rule imageI[THEN is_lbD[OF is_glbD1[OF Y_is_glb]]])
    also have "approx i \<cdot> x \<sqsubseteq> x"
      by (rule  approx_chain.approx_below[OF `approx_chain approx`])
    finally
    show "Y i \<sqsubseteq> x".
  qed

  have "S >>| Lub Y"
  proof (rule is_glbI[OF `S >| Lub Y`])
    fix u
    assume "S >| u"
    hence "\<And> i. Rep_cfun (approx i) ` S >| approx i \<cdot> u"
      by (rule is_ub_range)
    hence "\<And> i.  approx i \<cdot> u \<sqsubseteq> Y i"
      by (rule is_glbD2[OF Y_is_glb])
    hence "(\<Squnion>i. approx i \<cdot> u ) \<sqsubseteq> Lub Y"
      by (rule lub_mono[OF
            ch2ch_Rep_cfunL[OF approx_chain.chain_approx[OF `approx_chain approx`]]
            `chain Y`
            ])
    thus "u \<sqsubseteq> Lub Y"
      by (metis approx_chain.lub_approx_arg[OF `approx_chain approx`])
  qed
  thus "\<exists>x. S >>| x"..
qed

instantiation "fun" :: (type, cont_binary_meet) Finite_Meet_cpo
begin
  definition fun_meet :: "('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b)"
    where "fun_meet = (\<Lambda> f g . (\<lambda> x. (f x) \<sqinter> (g x)))"

  lemma fun_meet_eq: "fun_meet \<cdot> f \<cdot> g = (\<lambda> x. (f x) \<sqinter> (g x))"
    unfolding fun_meet_def
      apply (subst beta_cfun, intro cont2cont cont2cont_lambda cont2cont_fun)+
      ..

  instance
  apply default
  proof(intro exI conjI strip)
    fix x y
    show "fun_meet\<cdot>x\<cdot>y \<sqsubseteq> x"  by (auto simp add: fun_below_iff)
    show "fun_meet\<cdot>x\<cdot>y \<sqsubseteq> y"  by (auto simp add: fun_below_iff)
    fix z
    assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    thus "z \<sqsubseteq> fun_meet\<cdot>x\<cdot>y" by (auto simp add: fun_below_iff meet_above_iff)
  qed
end

lemma fun_meet_simp[simp]: "(f \<sqinter> g) x = f x \<sqinter> (g x::'a::cont_binary_meet)"
proof-
  have "f \<sqinter> g = (\<lambda> x. f x \<sqinter> g x)"
  by (rule is_meetI)(auto simp add: fun_below_iff meet_above_iff)
  thus ?thesis by simp
qed

instance "fun" :: (type, cont_binary_meet) cont_binary_meet
  apply default
  apply (rule ext)
  apply (simp add: lub_fun chain_meet1 fun_chain_iff meet_cont')
  done

instantiation cfun :: (cpo,cont_binary_meet) Finite_Meet_cpo begin
  definition cfun_meet :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)"
    where "cfun_meet = (\<Lambda> f g . (\<Lambda> x. (f \<cdot> x) \<sqinter> (g \<cdot> x)))"

  lemma cfun_meet_eq: "cfun_meet \<cdot> f \<cdot> g = (\<Lambda> x. (f \<cdot> x) \<sqinter> (g \<cdot> x))"
    unfolding cfun_meet_def
      apply (subst beta_cfun, intro cont2cont cont2cont_lambda cont2cont_fun)+
      ..

  lemma [simp]: "cfun_meet\<cdot>f\<cdot>g\<cdot>x = (f \<cdot> x) \<sqinter> (g \<cdot> x)"
    unfolding cfun_meet_eq by simp

  instance
  apply default
  proof(intro exI conjI strip)
    fix x y
    show "cfun_meet\<cdot>x\<cdot>y \<sqsubseteq> x" by (auto simp add: cfun_below_iff)
    show "cfun_meet\<cdot>x\<cdot>y \<sqsubseteq> y" by (auto simp add: cfun_below_iff)
    fix z
    assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    thus "z \<sqsubseteq> cfun_meet\<cdot>x\<cdot>y" by (auto simp add: cfun_below_iff meet_above_iff)
  qed
end

lemma cfun_meet_simp[simp]: "(f \<sqinter> g) \<cdot> x = f \<cdot> x \<sqinter> (g  \<cdot> x::'a::cont_binary_meet)"
proof-
  have "f \<sqinter> g = (\<Lambda> x. f  \<cdot> x \<sqinter> g \<cdot> x)"
  by (rule is_meetI) (auto simp add: cfun_below_iff meet_above_iff)
  thus ?thesis by simp
qed

instance "cfun" :: (cpo, cont_binary_meet) cont_binary_meet
  apply default
  apply (rule cfun_eqI)
  apply (simp add: lub_cfun chain_meet1  meet_cont')
  done

end


(*
    File:     Group_Hom.thy
    Author:   Joseph Thommes, TU München
*)
section \<open>Group Homomorphisms\<close>

theory Group_Hom
  imports Set_Multiplication
begin

text \<open>This section extends the already existing library about group homomorphisms in HOL-Algebra by
some useful lemmas. These were mainly inspired by the needs that arised throughout the other proofs.\<close>

lemma (in group_hom) generate_hom:
  assumes "A \<subseteq> carrier G"
  shows "h ` (generate G A) = generate H (h ` A)"
  using assms group_hom.generate_img group_hom_axioms by blast

text \<open>For two elements with the same image we can find an element in the kernel that maps one of the
two elements on the other by multiplication.\<close>

lemma (in group_hom) kernel_assoc_elem:
  assumes "x \<in> carrier G" "y \<in> carrier G" "h x = h y"
  obtains z where "x = y \<otimes>\<^bsub>G\<^esub> z" "z \<in> kernel G H h"
proof -
  have c: "inv y \<otimes>\<^bsub>G\<^esub> x \<in> carrier G" using assms by simp
  then have e: "x = y \<otimes>\<^bsub>G\<^esub> (inv y \<otimes>\<^bsub>G\<^esub> x)" using assms G.m_assoc
    using G.inv_solve_left by blast
  then have "h x = h (y \<otimes>\<^bsub>G\<^esub> (inv y \<otimes>\<^bsub>G\<^esub> x))" by simp
  then have "h x = h y \<otimes>\<^bsub>H\<^esub> h (inv y \<otimes>\<^bsub>G\<^esub> x)" using c assms by simp
  then have "\<one>\<^bsub>H\<^esub> = h (inv y \<otimes>\<^bsub>G\<^esub> x)" using assms by simp
  then have "(inv y \<otimes>\<^bsub>G\<^esub> x) \<in> kernel G H h" unfolding kernel_def using c by simp
  thus ?thesis using e that by blast
qed

text \<open>This can then be used to characterize the pre-image of a set $A$ under homomorphism as a
product of $A$ itself with the kernel of the homomorphism.\<close>

lemma (in group_hom) vimage_eq_set_mult_kern_right:
  assumes "A \<subseteq> carrier G"
  shows "{x \<in> carrier G. h x \<in> h ` A} = A <#> kernel G H h"
proof(intro equalityI subsetI)
  fix x
  assume assm: "x \<in> A <#> kernel G H h"
  then have xc: "x \<in> carrier G" unfolding kernel_def set_mult_def using assms by blast
  from assm obtain a b where ab: "a \<in> A" "b \<in> kernel G H h" "x = a \<otimes>\<^bsub>G\<^esub> b"
    unfolding set_mult_def by blast
  then have abc: "a \<in> carrier G" "b \<in> carrier G" unfolding kernel_def using assms by auto
  from ab have "h x = h (a \<otimes>\<^bsub>G\<^esub> b)" by blast
  also have "\<dots> = h a \<otimes>\<^bsub>H\<^esub> h b" using abc by simp
  also have "\<dots> = h a \<otimes>\<^bsub>H\<^esub> \<one>\<^bsub>H\<^esub>" using ab(2) unfolding kernel_def by simp
  also have "\<dots> = h a" using abc by simp
  also have "\<dots> \<in> h ` A" using ab by blast
  finally have "h x \<in> h ` A" .
  thus "x \<in> {x \<in> carrier G. h x \<in> h ` A}" using xc by blast
next
  fix x
  assume "x \<in> {x \<in> carrier G. h x \<in> h ` A}"
  then have x: "x \<in> carrier G" "h x \<in> h ` A" by simp+
  then obtain y where y: "y \<in> A" "h x = h y" "y \<in> carrier G" using assms by auto
  with kernel_assoc_elem obtain z where "x = y \<otimes>\<^bsub>G\<^esub> z" "z \<in> kernel G H h" using x by metis
  thus "x \<in> A <#> kernel G H h" unfolding set_mult_def using y by blast
qed

lemma (in group_hom) vimage_subset_generate_kern:
  assumes "A \<subseteq> carrier G"
  shows "{x \<in> carrier G. h x \<in> h ` A} \<subseteq> generate G (A \<union> kernel G H h)"
  using vimage_eq_set_mult_kern_right[of A] G.set_mult_subset_generate[of "A" "kernel G H h"] assms
  unfolding kernel_def by blast

text \<open>The preimage of a subgroup under a homomorphism is also a subgroup.\<close>

lemma (in group_hom) subgroup_vimage_is_subgroup:
  assumes "subgroup I H"
  shows "subgroup {x \<in> carrier G. h x \<in> I} G" (is "subgroup ?J G")
proof
  show "?J \<subseteq> carrier G" by blast
  show "\<one> \<in> ?J" using subgroup.one_closed[of I H] assms by simp
  fix x
  assume x: "x \<in> ?J"
  then have hx: "h x \<in> I" by blast
  show "inv x \<in> ?J"
  proof -
    from hx have "inv\<^bsub>H\<^esub> (h x) \<in> I" using subgroup.m_inv_closed assms by fast
    moreover have "inv x \<in> carrier G" using x by simp
    moreover have "inv\<^bsub>H\<^esub> (h x) = h (inv x)" using x by auto
    ultimately show "inv x \<in> ?J" by simp
  qed
  fix y
  assume y: "y \<in> ?J"
  then have hy: "h y \<in> I" by blast
  show "x \<otimes> y \<in> {x \<in> carrier G. h x \<in> I}"
  proof -
    have "h (x \<otimes> y) = h x \<otimes>\<^bsub>H\<^esub> h y" using x y by simp
    also have "\<dots> \<in> I" using hx hy assms subgroup.m_closed by fast
    finally have "h (x \<otimes> y) \<in> I" .
    moreover have "x \<otimes> y \<in> carrier G" using x y by simp
    ultimately show ?thesis by blast
  qed
qed

lemma (in group_hom) iso_kernel:
  assumes "h \<in> iso G H"
  shows "kernel G H h = {\<one>\<^bsub>G\<^esub>}"
  unfolding kernel_def using assms
  using hom_one iso_iff by blast

\<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close> (* adapted by Joseph Thommes *)
lemma (in group_hom) induced_group_hom_same_group:
  assumes "subgroup I G"
  shows "group_hom (G \<lparr> carrier := I \<rparr>) H h"
proof -
  have "h \<in> hom (G \<lparr> carrier := I \<rparr>) H"
    using homh subgroup.mem_carrier[OF assms] unfolding hom_def by auto
  thus ?thesis
    unfolding group_hom_def group_hom_axioms_def
    using subgroup.subgroup_is_group[OF assms G.is_group] by simp
qed

text \<open>The order of an element under a homomorphism divides the order of the element.\<close>

lemma (in group_hom) hom_ord_dvd_ord:
  assumes "a \<in> carrier G"
  shows "H.ord (h a) dvd G.ord a"
proof -
  have "h a [^]\<^bsub>H\<^esub> (G.ord a) = h (a [^]\<^bsub>G\<^esub> G.ord a)"
    using assms local.hom_nat_pow by presburger
  also have "\<dots> = h (\<one>\<^bsub>G\<^esub>)" using G.pow_ord_eq_1 assms by simp
  also have "\<dots> = \<one>\<^bsub>H\<^esub>" by simp
  finally have "h a [^]\<^bsub>H\<^esub> G.ord a = \<one>\<^bsub>H\<^esub>" .
  then show ?thesis using pow_eq_id assms by simp
qed

text \<open>In particular, this implies that the image of an element with a finite order also will have a
finite order.\<close>

lemma (in group_hom) finite_ord_stays_finite:
  assumes "a \<in> carrier G" "G.ord a \<noteq> 0"
  shows "H.ord (h a) \<noteq> 0"
  using hom_ord_dvd_ord assms by fastforce

text \<open>For injective homomorphisms, the order stays the same.\<close>

lemma (in group_hom) inj_imp_ord_eq:
  assumes "a \<in> carrier G" "inj_on h (carrier G)" "G.ord a \<noteq> 0"
  shows "H.ord (h a) = G.ord a"
proof (rule antisym)
  show "H.ord (h a) \<le> G.ord a" using hom_ord_dvd_ord assms by force
  show "G.ord a \<le> H.ord (h a)"
  proof -
    have "\<one>\<^bsub>H\<^esub> = h (a [^]\<^bsub>G\<^esub> H.ord(h a))" using H.pow_ord_eq_1 assms
      by (simp add: local.hom_nat_pow)
    then have "a [^]\<^bsub>G\<^esub> H.ord (h a) = \<one>\<^bsub>G\<^esub>" using assms inj_on_one_iff by simp
    then have "G.ord a dvd H.ord (h a)" using G.pow_eq_id assms(1) by blast
    thus ?thesis using assms finite_ord_stays_finite by fastforce
  qed
qed

lemma (in group_hom) one_in_kernel:
  "\<one> \<in> kernel G H h"
  using subgroup.one_closed subgroup_kernel by blast

lemma hom_in_carr:
  assumes "f \<in> hom G H"
  shows "\<And>x. x \<in> carrier G \<Longrightarrow> f x \<in> carrier H"
  using assms unfolding hom_def bij_betw_def by blast

lemma iso_in_carr:
  assumes "f \<in> iso G H"
  shows "\<And>x. x \<in> carrier G \<Longrightarrow> f x \<in> carrier H"
  using assms unfolding iso_def bij_betw_def by blast

lemma triv_iso:
  assumes "group G" "group H" "carrier G = {\<one>\<^bsub>G\<^esub>}" "carrier H = {\<one>\<^bsub>H\<^esub>}"
  shows "G \<cong> H"
proof(unfold is_iso_def iso_def)
  interpret G: group G by fact
  interpret H: group H by fact
  let ?f = "\<lambda>_. \<one>\<^bsub>H\<^esub>"
  have "?f \<in> hom G H" by (intro homI, auto)
  moreover have "bij_betw ?f (carrier G) (carrier H)" unfolding bij_betw_def
    using assms(3, 4) by auto
  ultimately show "{h \<in> hom G H. bij_betw h (carrier G) (carrier H)} \<noteq> {}" by blast
qed

text \<open>The cardinality of the image of a group homomorphism times the cardinality of its kernel is
equal to the group order. This is basically another form of Lagrange's theorem.\<close>

lemma (in group_hom) image_kernel_product: "card (h ` (carrier G)) * card (kernel G H h) = order G"
proof -
  interpret G: group G by simp
  interpret H: group H by simp
  interpret ih: subgroup "h ` (carrier G)" H using img_is_subgroup by blast
  interpret ih: group "H\<lparr>carrier := h ` (carrier G)\<rparr>" using subgroup.subgroup_is_group by blast
  interpret h: group_hom G "H\<lparr>carrier := h ` (carrier G)\<rparr>"
    by (unfold_locales, unfold hom_def, auto)
  interpret k: subgroup "kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h" G using h.subgroup_kernel by blast
  from h.FactGroup_iso
  have "G Mod kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h \<cong> H\<lparr>carrier := h ` carrier G\<rparr>" by auto
  hence "card (h ` (carrier G)) = order (G Mod kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h)"
    using iso_same_card unfolding order_def by fastforce
  moreover have "order (G Mod kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h)
                 * card (kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h) = order G"
    using G.lagrange[OF k.subgroup_axioms] unfolding order_def FactGroup_def by force
  moreover have "kernel G (H\<lparr>carrier := h ` carrier G\<rparr>) h = kernel G H h"
    unfolding kernel_def by auto
  ultimately show ?thesis by argo
qed

end


chapter \<open>Homework 2\<close>
theory Homework2sol
imports Main
begin

  (*
    This file is intended to be viewed within the Isabelle/jEdit IDE.
    In a standard text-editor, it is pretty unreadable!
  *)

  (*
    HOMEWORK #2 Sample solution and comments
  *)

section \<open>General Remarks\<close>

(* Isabelle errors

  Please try to avoid submitting theories with Isabelle errors!
*)

(* Intentionally some Isabelle errors *)
term "(0::int) = (0::nat)"

lemma True done
    oops

fun f where "f x = f x"

fun g :: "int \<Rightarrow> nat" where "g x = (x>5)"

(*
  Isabelle indicates errors by
    * a red squiggly line under the erroneous text
    * A red bar on the right side of the editor window, just next to the scrollbar
    * A red highlighting on the left hand side of the editor window, in the code folding and line-number area (if this is switched on for you)
    * A red highlighting in the theory panel

*)

(* If you cannot finish a proof, end it with oops *)

lemma "Suc n > 0 \<Longrightarrow> n>0"
  apply auto
  (* No idea how to continue here \<dots>*)
  oops

(* If you need the lemma as auxiliary lemma for further proofs, and if
  you are sure it holds, you only cannot prove it, then end the proof with
  sorry, which will make Isabelle accept the lemma as true.
*)

lemma aux_lemma: "sum_list (filter (\<lambda>x. x<(0::int)) l) + sum_list (filter (\<lambda>x. x>0) l) = sum_list l"
  (* No idea how to prove that right now, but I'm sure it holds, and I need this for further proofs \<dots> *)
  sorry

(* Be careful, with sorry Isabelle will accept any nonsense! *)
lemma nonsense: "x>Suc 0 \<Longrightarrow> y>0" sorry

(* And once you have an inconsistency in the system, you can prove everything *)
lemma "True = False" using nonsense[of 2 0] by auto

section \<open>For all elements in list\<close>
  (* Define a function that checks wether a predicate P holds for all elements in a list.
     Note: A predicate is just a function of type "'a \<Rightarrow> bool". It must evaluate to True for all elements in the list.
  *)

  fun listall :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
    "listall P [] \<longleftrightarrow> True" (* Return True for the empty list. *)
(*<*)
  | "listall P (x#xs) \<longleftrightarrow> P x \<and> listall P xs"
(*>*)

  (* Show: P holds for all elements of xs@ys, if and only if it holds for all elements of xs and for all elements of ys: *)
  lemma "listall P (xs@ys) \<longleftrightarrow> listall P xs \<and> listall P ys"
(*<*)
    by (induction xs) auto
(*>*)

  (* Show: When checking P for a  mapped list, we can also apply the function before we evaluate P *)
  lemma "listall P (map f xs) = listall (\<lambda>x. P (f x)) xs"
(*<*)
    by (induction xs) auto
(*>*)

  (* Specify and show: If we filter the list with P, all elements in the result will satisfy P.
    Note: In this exercise, you have to come up with both, the formula and the proof!
  *)
  lemma
(*<*)
    "listall P (filter P xs)"
      by (induction xs) auto
(*>*)

section \<open>Sum of elements in a list\<close>

(* Specify a function to sum up all elements in a list of integers. The empty list has sum 0. *)

  fun listsum :: "int list \<Rightarrow> int" where
  (*<*)
    "listsum [] = 0"
  | "listsum (x#xs) = x + listsum xs"
  (*>*)

  (* Some solutions inserted a superfluous equation here:
  *)

  fun listsum_complicated :: "int list \<Rightarrow> int" where
    "listsum_complicated [] = 0"
  | "listsum_complicated [x] = x"
  | "listsum_complicated (x#xs) = x + listsum_complicated xs"

  (* This makes the function unnecessarily complicated, and will cause trouble in the proofs later.

    An important thing to note here:
  *)
  thm listsum_complicated.simps

  (*
    "listsum_complicated (x#xs) = x + listsum_complicated xs"
    is not a simplification lemma: Prior patterns override later ones, such that
    the third equation is only applied if xs is not empty!

    Sometimes, such cases are not avoidable, then you have to prove the
    missing lemmas yourself:
  *)

  (* Instead of summing over xs@ys, we can also add the results from summing over xs and summing over ys *)
  lemma listsum_append: "listsum (xs@ys) = listsum xs + listsum ys"
    (*<*)
    by (induction xs) auto
    (*>*)

  (* Filtering out zeroes does not affect the sum *)
  lemma listsum_filter_z: "listsum (filter (op\<noteq>0) l) = listsum l"
    (*<*)
    by (induction l) auto
    (*>*)

  (* Reversing a list does not affect the sum. HINT: You'll need an auxiliary lemma. (that you already have proved) *)
  lemma listsum_rev: "listsum (rev xs) = listsum xs"
    (*<*)
    apply (induction xs) apply (auto simp: listsum_append)
    done
    (*>*)

  (* Specify and prove: If summing up a list with only non-negative numbers, the result will be non-negative: *)

  lemma "listall (\<lambda>x. 0\<le>x) xs \<Longrightarrow> 0 \<le> listsum xs"
    by (induction xs) auto

  (** I saw many wrong solutions here. The two most common mistakes were:

    1. Confusing positive (x>0) with non-negative (x\<ge>0)

    2. Specifying the list that does only contain non-negative numbers by a filter:
  *)

      prop "listsum (filter (\<lambda>x. x\<ge>0) xs) \<ge> 0"

  (**
    While this is, intuitively, an equivalent formula, it does not reflect
    the textual specification precisely. In particular, it is not trivial
    (although easy) to see that all lists with only non-negative numbers can
    actually be represented by filtering of some list.
  *)

section \<open>Bonus: Delta-Encoding\<close>
  (*
    We want to encode a list of integers as follows:
      The first element is unchanged, and every next element
      only indicates the difference to its predecessor.

      For example: (Hint: Use this as test cases for your spec!)
        enc [1,2,4,8] = [1,1,2,4]
        enc [3,4,5] = [3,1,1]
        enc [5] = [5]
        enc [] = []

      Background: This algorithm may be used in lossless data compression,
        when the difference between two adjacent values is expected to be
        small, e.g., audio data, image data, sensor data.

        It typically requires much less space to store the small deltas, than
        the absolute values.

        Disadvantage: If the stream gets corrupted, recovery is only possible
          when the next absolute value is transmitted. For this reason, in
          practice, one will submit the current absolute value from time to
          time. (This is not modeled in this exercise!)

  *)

  (* Specify a function to encode a list with delta-encoding.
    The first argument is used to represent the previous value, and can be initialized to 0.
  *)
  fun denc :: "int \<Rightarrow> int list \<Rightarrow> int list" where
    (*<*)
    "denc prv [] = []"
  | "denc prv (x#xs) = (x-prv)#denc x xs"
    (*>*)

  (* Specify the decoder. Again, the first argument represents the previous
      decoded value, and can be initialized to 0. *)
  fun ddec :: "int \<Rightarrow> int list \<Rightarrow> int list" where
    (*<*)
    "ddec prv [] = []"
  | "ddec prv (d#ds) = (prv+d) # ddec (prv+d) ds"
    (*>*)

  (* Show that encoding and then decoding yields the same list. HINT: The lemma will need generalization. *)

  (*<*)
  lemma dec_enc_id_aux: "ddec s (denc s l) = l"
    by (induction l arbitrary: s) auto
  (*>*)

  lemma "ddec 0 (denc 0 l) = l"
  (*<*)
    by (simp add: dec_enc_id_aux)
  (*>*)

end


theory ex3_03 imports Main "~~/src/HOL/IMP/AExp" begin

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V v) = (if x = v then a else (V v))" |
"subst x a (Plus l r) = Plus (subst x a l) (subst x a r)"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y''))"

theorem "aval (subst x a e) s = aval e (s(x := aval a s))"
by (induction e, auto)

theorem "aval a_1 s = aval a_2 s \<Longrightarrow> aval (subst x a_1 e) s = aval (subst x a_2 e) s"
by (induction e, auto)

end


theory Homomorphism_Eq
imports Main UniversalProperty
begin

definition (in group) hom_eq::"_ \<Rightarrow> _ \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> bool"
  where
"hom_eq \<equiv> (\<lambda> G H f g. (((f \<in> hom G H) \<and> (g \<in> hom G H) \<and> (\<forall>x \<in> carrier G. f x = g x))))"

lemma (in group) assumes "group G" "group H" "hom_eq G H f g" "hom_eq G H g h"
  shows "hom_eq G H f h"
  using assms   group.hom_eq_def
  by (smt (verit, ccfv_SIG))

lemma (in group) assumes "group G" "group H" "hom_eq G H f g"
  shows "hom_eq G H g f"
  using assms   group.hom_eq_def
  by (smt (verit, ccfv_SIG))

lemma (in group) assumes "group G" "group H" "f \<in> hom G H"
  shows "hom_eq G H f f"
  using assms   group.hom_eq_def
  by metis

end


theory Part_4 imports Main Part_2

begin

(* 2.9 *)

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

theorem itadd_is_add : "itadd m n = add m n"
  apply(induction m arbitrary: n)
   apply(auto)
  done

end


(*
   File:    Linorder_Relations.thy
   Author:  Manuel Eberl

   Linear orderings represented as relations (i.e. set of pairs). Also contains
   material connecting such orderings to lists, and insertion sort w.r.t. a
   given ordering relation.
*)
section \<open>Linear orderings as relations\<close>
theory Linorder_Relations
  imports
    Complex_Main
    "HOL-Combinatorics.Multiset_Permutations"
    "List-Index.List_Index"
begin

subsection \<open>Auxiliary facts\<close>

(* TODO: Move *)
lemma distinct_count_atmost_1':
  "distinct xs = (\<forall>a. count (mset xs) a \<le> 1)"
proof -
  {
    fix x have "count (mset xs) x = (if x \<in> set xs then 1 else 0) \<longleftrightarrow> count (mset xs) x \<le> 1"
      using count_eq_zero_iff[of "mset xs" x]
      by (cases "count (mset xs) x") (auto simp del: count_mset_0_iff)
  }
  thus ?thesis unfolding distinct_count_atmost_1 by blast
qed

lemma distinct_mset_mono:
  assumes "distinct ys" "mset xs \<subseteq># mset ys"
  shows   "distinct xs"
  unfolding distinct_count_atmost_1'
proof
  fix x
  from assms(2) have "count (mset xs) x \<le> count (mset ys) x"
    by (rule mset_subset_eq_count)
  also from assms(1) have "\<dots> \<le> 1" unfolding distinct_count_atmost_1' ..
  finally show "count (mset xs) x \<le> 1" .
qed

lemma mset_eq_imp_distinct_iff:
  assumes "mset xs = mset ys"
  shows   "distinct xs \<longleftrightarrow> distinct ys"
  using assms by (simp add: distinct_count_atmost_1')

lemma total_on_subset: "total_on B R \<Longrightarrow> A \<subseteq> B \<Longrightarrow> total_on A R"
  by (auto simp: total_on_def)

subsection \<open>Sortedness w.r.t. a relation\<close>

inductive sorted_wrt :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> bool" for R where
  "sorted_wrt R []"
| "sorted_wrt R xs \<Longrightarrow> (\<And>y. y \<in> set xs \<Longrightarrow> (x,y) \<in> R) \<Longrightarrow> sorted_wrt R (x # xs)"

lemma sorted_wrt_Nil [simp]: "sorted_wrt R []"
  by (rule sorted_wrt.intros)

lemma sorted_wrt_Cons: "sorted_wrt R (x # xs) \<longleftrightarrow> (\<forall>y\<in>set xs. (x,y) \<in> R) \<and> sorted_wrt R xs"
  by (auto intro: sorted_wrt.intros elim: sorted_wrt.cases)

lemma sorted_wrt_singleton [simp]: "sorted_wrt R [x]"
  by (intro sorted_wrt.intros) simp_all

lemma sorted_wrt_many:
  assumes "trans R"
  shows   "sorted_wrt R (x # y # xs) \<longleftrightarrow> (x,y) \<in> R \<and> sorted_wrt R (y # xs)"
  by (force intro: sorted_wrt.intros transD[OF assms] elim: sorted_wrt.cases)

lemma sorted_wrt_imp_le_last:
  assumes "sorted_wrt R xs" "xs \<noteq> []" "x \<in> set xs" "x \<noteq> last xs"
  shows   "(x, last xs) \<in> R"
  using assms by induction auto

lemma sorted_wrt_append:
  assumes "sorted_wrt R xs" "sorted_wrt R ys"
          "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> (x,y) \<in> R" "trans R"
  shows   "sorted_wrt R (xs @ ys)"
  using assms by (induction xs) (auto simp: sorted_wrt_Cons)

lemma sorted_wrt_snoc:
  assumes "sorted_wrt R xs" "(last xs, y) \<in> R" "trans R"
  shows   "sorted_wrt R (xs @ [y])"
  using assms(1,2)
proof induction
  case (2 xs x)
  show ?case
  proof (cases "xs = []")
    case False
    with 2 have "(z,y) \<in> R" if "z \<in> set xs" for z
      using that by (cases "z = last xs")
                    (auto intro: assms transD[OF assms(3), OF sorted_wrt_imp_le_last[OF 2(1)]])
    from False have *: "last xs \<in> set xs" by simp
    moreover from 2 False have "(x,y) \<in> R" by (intro transD[OF assms(3) 2(2)[OF *]]) simp
    ultimately show ?thesis using 2 False
      by (auto intro!: sorted_wrt.intros)
  qed (insert 2, auto intro: sorted_wrt.intros)
qed simp_all

lemma sorted_wrt_conv_nth:
  "sorted_wrt R xs \<longleftrightarrow> (\<forall>i j. i < j \<and> j < length xs \<longrightarrow> (xs!i, xs!j) \<in> R)"
  by (induction xs) (auto simp: sorted_wrt_Cons nth_Cons set_conv_nth split: nat.splits)

subsection \<open>Linear orderings\<close>

definition linorder_on :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  where
  "linorder_on A R \<longleftrightarrow> refl_on A R \<and> antisym R \<and> trans R \<and> total_on A R"

lemma linorder_on_cases:
  assumes "linorder_on A R" "x \<in> A" "y \<in> A"
  shows   "x = y \<or> ((x, y) \<in> R \<and> (y, x) \<notin> R) \<or> ((y, x) \<in> R \<and> (x, y) \<notin> R)"
  using assms by (auto simp: linorder_on_def refl_on_def total_on_def antisym_def)

lemma sorted_wrt_linorder_imp_index_le:
  assumes "linorder_on A R" "set xs \<subseteq> A" "sorted_wrt R xs"
          "x \<in> set xs" "y \<in> set xs" "(x,y) \<in> R"
  shows   "index xs x \<le> index xs y"
proof -
  define i j where "i = index xs x" and "j = index xs y"
  {
    assume "j < i"
    moreover from assms have "i < length xs" by (simp add: i_def)
    ultimately have "(xs!j,xs!i) \<in> R" using assms by (auto simp: sorted_wrt_conv_nth)
    with assms have "x = y" by (auto simp: linorder_on_def antisym_def i_def j_def)
  }
  hence "i \<le> j \<or> x = y" by linarith
  thus ?thesis by (auto simp: i_def j_def)
qed

lemma sorted_wrt_linorder_index_le_imp:
  assumes "linorder_on A R" "set xs \<subseteq> A" "sorted_wrt R xs"
          "x \<in> set xs" "y \<in> set xs" "index xs x \<le> index xs y"
  shows   "(x,y) \<in> R"
proof (cases "x = y")
  case False
  define i j where "i = index xs x" and "j = index xs y"
  from False and assms have "i \<noteq> j" by (simp add: i_def j_def)
  with \<open>index xs x \<le> index xs y\<close> have "i < j" by (simp add: i_def j_def)
  moreover from assms have "j < length xs" by (simp add: j_def)
  ultimately have "(xs ! i, xs ! j) \<in> R" using assms(3)
    by (auto simp: sorted_wrt_conv_nth)
  with assms show ?thesis by (simp_all add: i_def j_def)
qed (insert assms, auto simp: linorder_on_def refl_on_def)

lemma sorted_wrt_linorder_index_le_iff:
  assumes "linorder_on A R" "set xs \<subseteq> A" "sorted_wrt R xs"
          "x \<in> set xs" "y \<in> set xs"
  shows   "index xs x \<le> index xs y \<longleftrightarrow> (x,y) \<in> R"
  using sorted_wrt_linorder_index_le_imp[OF assms] sorted_wrt_linorder_imp_index_le[OF assms]
  by blast

lemma sorted_wrt_linorder_index_less_iff:
  assumes "linorder_on A R" "set xs \<subseteq> A" "sorted_wrt R xs"
          "x \<in> set xs" "y \<in> set xs"
  shows   "index xs x < index xs y \<longleftrightarrow> (y,x) \<notin> R"
  by (subst sorted_wrt_linorder_index_le_iff[OF assms(1-3) assms(5,4), symmetric]) auto

lemma sorted_wrt_distinct_linorder_nth:
  assumes "linorder_on A R" "set xs \<subseteq> A" "sorted_wrt R xs" "distinct xs"
          "i < length xs" "j < length xs"
  shows   "(xs!i, xs!j) \<in> R \<longleftrightarrow> i \<le> j"
proof (cases i j rule: linorder_cases)
  case less
  with assms show ?thesis by (simp add: sorted_wrt_conv_nth)
next
  case equal
  from assms have "xs ! i \<in> set xs" "xs ! j \<in> set xs" by (auto simp: set_conv_nth)
  with assms(2) have "xs ! i \<in> A" "xs ! j \<in> A" by blast+
  with \<open>linorder_on A R\<close> and equal show ?thesis by (simp add: linorder_on_def refl_on_def)
next
  case greater
  with assms have "(xs!j, xs!i) \<in> R" by (auto simp add: sorted_wrt_conv_nth)
  moreover from assms and greater have "xs ! i \<noteq> xs ! j" by (simp add: nth_eq_iff_index_eq)
  ultimately show ?thesis using \<open>linorder_on A R\<close> greater
    by (auto simp: linorder_on_def antisym_def)
qed

subsection \<open>Converting a list into a linear ordering\<close>

definition linorder_of_list :: "'a list \<Rightarrow> ('a \<times> 'a) set" where
  "linorder_of_list xs = {(a,b). a \<in> set xs \<and> b \<in> set xs \<and> index xs a \<le> index xs b}"

lemma linorder_linorder_of_list [intro, simp]:
  assumes "distinct xs"
  shows   "linorder_on (set xs) (linorder_of_list xs)"
  unfolding linorder_on_def using assms
  by (auto simp: refl_on_def antisym_def trans_def total_on_def linorder_of_list_def)

lemma sorted_wrt_linorder_of_list [intro, simp]:
  "distinct xs \<Longrightarrow> sorted_wrt (linorder_of_list xs) xs"
  by (auto simp: sorted_wrt_conv_nth linorder_of_list_def index_nth_id)

subsection \<open>Insertion sort\<close>

primrec insert_wrt :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insert_wrt R x [] = [x]"
| "insert_wrt R x (y # ys) = (if (x, y) \<in> R then x # y # ys else y # insert_wrt R x ys)"

lemma set_insert_wrt [simp]: "set (insert_wrt R x xs) = insert x (set xs)"
  by (induction xs) auto

lemma mset_insert_wrt [simp]: "mset (insert_wrt R x xs) = add_mset x (mset xs)"
  by (induction xs) auto

lemma length_insert_wrt [simp]: "length (insert_wrt R x xs) = Suc (length xs)"
  by (induction xs) simp_all

definition insort_wrt :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insort_wrt R xs = foldr (insert_wrt R) xs []"

lemma set_insort_wrt [simp]: "set (insort_wrt R xs) = set xs"
  by (induction xs) (simp_all add: insort_wrt_def)

lemma mset_insort_wrt [simp]: "mset (insort_wrt R xs) = mset xs"
  by (induction xs) (simp_all add: insort_wrt_def)

lemma length_insort_wrt [simp]: "length (insort_wrt R xs) = length xs"
  by (induction xs) (simp_all add: insort_wrt_def)

lemma sorted_wrt_insert_wrt [intro]:
  "linorder_on A R \<Longrightarrow> set (x # xs) \<subseteq> A \<Longrightarrow>
     sorted_wrt R xs \<Longrightarrow> sorted_wrt R (insert_wrt R x xs)"
proof (induction xs)
  case (Cons y ys)
  from Cons.prems have "(x,y) \<in> R \<or> (y,x) \<in> R"
    by (cases "x = y") (auto simp: linorder_on_def refl_on_def total_on_def)
  with Cons show ?case
    by (auto simp: sorted_wrt_Cons intro: transD simp: linorder_on_def)
qed auto

lemma sorted_wrt_insort [intro]:
  assumes "linorder_on A R" "set xs \<subseteq> A"
  shows   "sorted_wrt R (insort_wrt R xs)"
proof -
  from assms have "set (insort_wrt R xs) = set xs \<and> sorted_wrt R (insort_wrt R xs)"
    by (induction xs) (auto simp: insort_wrt_def intro!: sorted_wrt_insert_wrt)
  thus ?thesis ..
qed

lemma distinct_insort_wrt [simp]: "distinct (insort_wrt R xs) \<longleftrightarrow> distinct xs"
  by (simp add: distinct_count_atmost_1)

lemma sorted_wrt_linorder_unique:
  assumes "linorder_on A R" "mset xs = mset ys" "sorted_wrt R xs" "sorted_wrt R ys"
  shows   "xs = ys"
proof -
  from \<open>mset xs = mset ys\<close> have "length xs = length ys" by (rule mset_eq_length)
  from this and assms(2-) show ?thesis
  proof (induction xs ys rule: list_induct2)
    case (Cons x xs y ys)
    have "set (x # xs) = set_mset (mset (x # xs))" by simp
    also have "mset (x # xs) = mset (y # ys)" by fact
    also have "set_mset \<dots> = set (y # ys)" by simp
    finally have eq: "set (x # xs) = set (y # ys)" .

    have "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      with eq have "x \<in> set ys" "y \<in> set xs" by auto
      with Cons.prems and assms(1) and eq have "(x, y) \<in> R" "(y, x) \<in> R"
        by (auto simp: sorted_wrt_Cons)
      with assms(1) have "x = y" by (auto simp: linorder_on_def antisym_def)
      with \<open>x \<noteq> y\<close> show False by contradiction
    qed
    with Cons show ?case by (auto simp: sorted_wrt_Cons)
  qed auto
qed

subsection \<open>Obtaining a sorted list of a given set\<close>

definition sorted_wrt_list_of_set where
  "sorted_wrt_list_of_set R A =
     (if finite A then (THE xs. set xs = A \<and> distinct xs \<and> sorted_wrt R xs) else [])"

lemma mset_remdups: "mset (remdups xs) = mset_set (set xs)"
proof (induction xs)
  case (Cons x xs)
  thus ?case by (cases "x \<in> set xs") (auto simp: insert_absorb)
qed auto

lemma sorted_wrt_list_set:
  assumes "linorder_on A R" "set xs \<subseteq> A"
  shows   "sorted_wrt_list_of_set R (set xs) = insort_wrt R (remdups xs)"
proof -
  have "sorted_wrt_list_of_set R (set xs) =
          (THE xsa. set xsa = set xs \<and> distinct xsa \<and> sorted_wrt R xsa)"
    by (simp add: sorted_wrt_list_of_set_def)
  also have "\<dots> = insort_wrt R (remdups xs)"
  proof (rule the_equality)
    fix xsa assume xsa: "set xsa = set xs \<and> distinct xsa \<and> sorted_wrt R xsa"
    from xsa have "mset xsa = mset_set (set xsa)" by (subst mset_set_set) simp_all
    also from xsa have "set xsa = set xs" by simp
    also have "mset_set \<dots> = mset (remdups xs)" by (simp add: mset_remdups)
    finally show "xsa = insort_wrt R (remdups xs)" using xsa assms
      by (intro sorted_wrt_linorder_unique[OF assms(1)])
         (auto intro!: sorted_wrt_insort)
  qed (insert assms, auto intro!: sorted_wrt_insort)
  finally show ?thesis .
qed

lemma linorder_sorted_wrt_exists:
  assumes "linorder_on A R" "finite B" "B \<subseteq> A"
  shows   "\<exists>xs. set xs = B \<and> distinct xs \<and> sorted_wrt R xs"
proof -
  from \<open>finite B\<close> obtain xs where "set xs = B" "distinct xs"
    using finite_distinct_list by blast
  hence "set (insort_wrt R xs) = B" "distinct (insort_wrt R xs)" by simp_all
  moreover have "sorted_wrt R (insort_wrt R xs)"
    using assms \<open>set xs = B\<close> by (intro sorted_wrt_insort[OF assms(1)]) auto
  ultimately show ?thesis by blast
qed

lemma linorder_sorted_wrt_list_of_set:
  assumes "linorder_on A R" "finite B" "B \<subseteq> A"
  shows   "set (sorted_wrt_list_of_set R B) = B" "distinct (sorted_wrt_list_of_set R B)"
          "sorted_wrt R (sorted_wrt_list_of_set R B)"
proof -
  have "\<exists>!xs. set xs = B \<and> distinct xs \<and> sorted_wrt R xs"
  proof (rule ex_ex1I)
    show "\<exists>xs. set xs = B \<and> distinct xs \<and> sorted_wrt R xs"
      by (rule linorder_sorted_wrt_exists assms)+
  next
    fix xs ys assume "set xs = B \<and> distinct xs \<and> sorted_wrt R xs"
                     "set ys = B \<and> distinct ys \<and> sorted_wrt R ys"
    thus "xs = ys"
      by (intro sorted_wrt_linorder_unique[OF assms(1)]) (auto simp: set_eq_iff_mset_eq_distinct)
  qed
  from theI'[OF this] show  "set (sorted_wrt_list_of_set R B) = B"
    "distinct (sorted_wrt_list_of_set R B)" "sorted_wrt R (sorted_wrt_list_of_set R B)"
    by (simp_all add: sorted_wrt_list_of_set_def \<open>finite B\<close>)
qed

lemma sorted_wrt_list_of_set_eqI:
  assumes "linorder_on B R" "A \<subseteq> B" "set xs = A" "distinct xs" "sorted_wrt R xs"
  shows   "sorted_wrt_list_of_set R A = xs"
proof (rule sorted_wrt_linorder_unique)
  show "linorder_on B R" by fact
  let ?ys = "sorted_wrt_list_of_set R A"
  have fin [simp]: "finite A" by (simp_all add: assms(3) [symmetric])
  have *: "distinct ?ys" "set ?ys = A" "sorted_wrt R ?ys"
    by (rule linorder_sorted_wrt_list_of_set[OF assms(1)] fin assms)+
  from assms * show "mset ?ys = mset xs"
    by (subst set_eq_iff_mset_eq_distinct [symmetric]) simp_all
  show "sorted_wrt R ?ys" by fact
qed fact+

subsection \<open>Rank of an element in an ordering\<close>

text \<open>
  The `rank' of an element in a set w.r.t. an ordering is how many smaller elements exist.
  This is particularly useful in linear orders, where there exists a unique $n$-th element
  for every $n$.
\<close>
definition linorder_rank where
  "linorder_rank R A x = card {y\<in>A-{x}. (y,x) \<in> R}"

lemma linorder_rank_le:
  assumes "finite A"
  shows   "linorder_rank R A x \<le> card A"
  unfolding linorder_rank_def using assms
  by (rule card_mono) auto

lemma linorder_rank_less:
  assumes "finite A" "x \<in> A"
  shows   "linorder_rank R A x < card A"
proof -
  have "linorder_rank R A x \<le> card (A - {x})"
    unfolding linorder_rank_def using assms by (intro card_mono) auto
  also from assms have "\<dots> < card A" by (intro psubset_card_mono) auto
  finally show ?thesis .
qed

lemma linorder_rank_union:
  assumes "finite A" "finite B" "A \<inter> B = {}"
  shows   "linorder_rank R (A \<union> B) x = linorder_rank R A x + linorder_rank R B x"
proof -
  have "linorder_rank R (A \<union> B) x = card {y\<in>(A\<union>B)-{x}. (y,x) \<in> R}"
    by (simp add: linorder_rank_def)
  also have "{y\<in>(A\<union>B)-{x}. (y,x) \<in> R} = {y\<in>A-{x}. (y,x) \<in> R} \<union> {y\<in>B-{x}. (y,x) \<in> R}" by blast
  also have "card \<dots> = linorder_rank R A x + linorder_rank R B x" unfolding linorder_rank_def
    using assms by (intro card_Un_disjoint) auto
  finally show ?thesis .
qed

lemma linorder_rank_empty [simp]: "linorder_rank R {} x = 0"
  by (simp add: linorder_rank_def)

lemma linorder_rank_singleton:
  "linorder_rank R {y} x = (if x \<noteq> y \<and> (y,x) \<in> R then 1 else 0)"
proof -
  have "linorder_rank R {y} x = card {z\<in>{y}-{x}. (z,x) \<in> R}" by (simp add: linorder_rank_def)
  also have "{z\<in>{y}-{x}. (z,x) \<in> R} = (if x \<noteq> y \<and> (y,x) \<in> R then {y} else {})" by auto
  also have "card \<dots> = (if x \<noteq> y \<and> (y,x) \<in> R then 1 else 0)" by simp
  finally show ?thesis .
qed

lemma linorder_rank_insert:
  assumes "finite A" "y \<notin> A"
  shows   "linorder_rank R (insert y A) x =
             (if x \<noteq> y \<and> (y,x) \<in> R then 1 else 0) + linorder_rank R A x"
  using linorder_rank_union[of "{y}" A R x] assms by (auto simp: linorder_rank_singleton)

lemma linorder_rank_mono:
  assumes "linorder_on B R" "finite A" "A \<subseteq> B" "(x, y) \<in> R"
  shows   "linorder_rank R A x \<le> linorder_rank R A y"
  unfolding linorder_rank_def
proof (rule card_mono)
  from assms have trans: "trans R" and antisym: "antisym R" by (simp_all add: linorder_on_def)
  from assms antisym show "{y \<in> A - {x}. (y, x) \<in> R} \<subseteq> {ya \<in> A - {y}. (ya, y) \<in> R}"
    by (auto intro: transD[OF trans] simp: antisym_def)
qed (insert assms, simp_all)

lemma linorder_rank_strict_mono:
  assumes "linorder_on B R" "finite A" "A \<subseteq> B" "y \<in> A" "(y, x) \<in> R" "x \<noteq> y"
  shows   "linorder_rank R A y < linorder_rank R A x"
proof -
  from assms(1) have trans: "trans R" by (simp add: linorder_on_def)
  from assms have *: "(x, y) \<notin> R" by (auto simp: linorder_on_def antisym_def)
  from this and \<open>(y,x) \<in> R\<close> have "{z\<in>A-{y}. (z, y) \<in> R} \<subseteq> {z\<in>A-{x}. (z,x) \<in> R}"
    by (auto intro: transD[OF trans])
  moreover from * and assms have "y \<notin> {z\<in>A-{y}. (z, y) \<in> R}" "y \<in> {z\<in>A-{x}. (z, x) \<in> R}"
    by auto
  ultimately have "{z\<in>A-{y}. (z, y) \<in> R} \<subset> {z\<in>A-{x}. (z,x) \<in> R}" by blast
  thus ?thesis using assms unfolding linorder_rank_def by (intro psubset_card_mono) auto
qed

lemma linorder_rank_le_iff:
  assumes "linorder_on B R" "finite A" "A \<subseteq> B" "x \<in> A" "y \<in> A"
  shows   "linorder_rank R A x \<le> linorder_rank R A y \<longleftrightarrow> (x, y) \<in> R"
proof (cases "x = y")
  case True
  with assms show ?thesis by (auto simp: linorder_on_def refl_on_def)
next
  case False
  from assms(1) have trans: "trans R" by (simp_all add: linorder_on_def)
  from assms have "x \<in> B" "y \<in> B" by auto
  with \<open>linorder_on B R\<close> and False have "((x,y) \<in> R \<and> (y,x) \<notin> R) \<or> ((y,x) \<in> R \<and> (x,y) \<notin> R)"
    by (fastforce simp: linorder_on_def antisym_def total_on_def)
  thus ?thesis
  proof
    assume "(x,y) \<in> R \<and> (y,x) \<notin> R"
    with assms show ?thesis by (auto intro!: linorder_rank_mono)
  next
    assume *: "(y,x) \<in> R \<and> (x,y) \<notin> R"
    with linorder_rank_strict_mono[OF assms(1-3), of y x] assms False
      show ?thesis by auto
  qed
qed

lemma linorder_rank_eq_iff:
  assumes "linorder_on B R" "finite A" "A \<subseteq> B" "x \<in> A" "y \<in> A"
  shows   "linorder_rank R A x = linorder_rank R A y \<longleftrightarrow> x = y"
proof
  assume "linorder_rank R A x = linorder_rank R A y"
  with linorder_rank_le_iff[OF assms(1-5)] linorder_rank_le_iff[OF assms(1-3) assms(5,4)]
    have "(x, y) \<in> R" "(y, x) \<in> R" by simp_all
  with assms show "x = y" by (auto simp: linorder_on_def antisym_def)
qed simp_all

lemma linorder_rank_set_sorted_wrt:
  assumes "linorder_on B R" "set xs \<subseteq> B" "sorted_wrt R xs" "x \<in> set xs" "distinct xs"
  shows   "linorder_rank R (set xs) x = index xs x"
proof -
  define j where "j = index xs x"
  from assms have j: "j < length xs" by (simp add: j_def)
  have *: "x = y \<or> ((x, y) \<in> R \<and> (y, x) \<notin> R) \<or> ((y, x) \<in> R \<and> (x, y) \<notin> R)" if "y \<in> set xs" for y
    using linorder_on_cases[OF assms(1), of x y] assms that by auto
  from assms have "{y\<in>set xs-{x}. (y, x) \<in> R} = {y\<in>set xs-{x}. index xs y < index xs x}"
    by (auto simp: sorted_wrt_linorder_index_less_iff[OF assms(1-3)] dest: *)
  also have "\<dots> = {y\<in>set xs. index xs y < j}" by (auto simp: j_def)
  also have "\<dots> = (\<lambda>i. xs ! i) ` {i. i < j}"
  proof safe
    fix y assume "y \<in> set xs" "index xs y < j"
    moreover from this and j have "y = xs ! index xs y" by simp
    ultimately show "y \<in> (!) xs ` {i. i < j}" by blast
  qed (insert assms j, auto simp: index_nth_id)
  also from assms and j have "card \<dots> = card {i. i < j}"
    by (intro card_image) (auto simp: inj_on_def nth_eq_iff_index_eq)
  also have "\<dots> = j" by simp
  finally show ?thesis by (simp only: j_def linorder_rank_def)
qed

lemma bij_betw_linorder_rank:
  assumes "linorder_on B R" "finite A" "A \<subseteq> B"
  shows   "bij_betw (linorder_rank R A) A {..<card A}"
proof -
  define xs where "xs = sorted_wrt_list_of_set R A"
  note xs = linorder_sorted_wrt_list_of_set[OF assms, folded xs_def]
  from \<open>distinct xs\<close> have len_xs: "length xs = card A"
    by (subst \<open>set xs = A\<close> [symmetric]) (auto simp: distinct_card)
  have rank: "linorder_rank R (set xs) x = index xs x" if "x \<in> A" for x
    using linorder_rank_set_sorted_wrt[OF assms(1), of xs x] assms that xs by simp_all
  from xs len_xs show ?thesis
    by (intro bij_betw_byWitness[where f' = "\<lambda>i. xs ! i"])
       (auto simp: rank index_nth_id intro!: nth_mem)
qed

subsection \<open>The bijection between linear orderings and lists\<close>

theorem bij_betw_linorder_of_list:
  assumes "finite A"
  shows   "bij_betw linorder_of_list (permutations_of_set A) {R. linorder_on A R}"
proof (intro bij_betw_byWitness[where f' = "\<lambda>R. sorted_wrt_list_of_set R A"] ballI subsetI,
       goal_cases)
  case (1 xs)
  thus ?case by (intro sorted_wrt_list_of_set_eqI) (auto simp: permutations_of_set_def)
next
  case (2 R)
  hence R: "linorder_on A R" by simp
  from R have in_R: "x \<in> A" "y \<in> A" if "(x,y) \<in> R" for x y using that
    by (auto simp: linorder_on_def refl_on_def)
  let ?xs = "sorted_wrt_list_of_set R A"
  have xs: "distinct ?xs" "set ?xs = A" "sorted_wrt R ?xs"
    by (rule linorder_sorted_wrt_list_of_set[OF R] assms order.refl)+
  thus ?case using sorted_wrt_linorder_index_le_iff[OF R, of ?xs]
    by (auto simp: linorder_of_list_def dest: in_R)
next
  case (4 xs)
  then obtain R where R: "linorder_on A R" and xs [simp]: "xs = sorted_wrt_list_of_set R A" by auto
  let ?xs = "sorted_wrt_list_of_set R A"
  have xs: "distinct ?xs" "set ?xs = A" "sorted_wrt R ?xs"
    by (rule linorder_sorted_wrt_list_of_set[OF R] assms order.refl)+
  thus ?case by auto
qed (auto simp: permutations_of_set_def)

corollary card_finite_linorders:
  assumes "finite A"
  shows   "card {R. linorder_on A R} = fact (card A)"
proof -
  have "card {R. linorder_on A R} = card (permutations_of_set A)"
    by (rule sym, rule bij_betw_same_card [OF bij_betw_linorder_of_list[OF assms]])
  also from assms have "\<dots> = fact (card A)" by (rule card_permutations_of_set)
  finally show ?thesis .
qed

end


theory sqrt2Irrational
  imports Complex_Main "HOL-Number_Theory.Number_Theory"
begin

theorem sqrt_2_irrational:
  shows "(sqrt (real 2)) ∉ ℚ"
proof
  {
    assume "sqrt (real 2) ∈ ℚ"
    then obtain m n :: nat
      where nIsNotZero: "n ≠ 0"
        and rationalDefinition: "¦sqrt (real 2)¦ = real m / real n"
        and gcdIsOne: "gcd m n = (1::nat)" by (rule Rats_abs_nat_div_natE)

    hence contradiction: "2 * n^2 = m^2"
    proof -
      {
        from nIsNotZero and rationalDefinition have "sqrt (2) * (n) = (m)" by simp
        then have "(m^2) = (sqrt (2))^2 * (n^2)" by (metis of_nat_power power_mult_distrib)
        also have "(sqrt 2)^2 = 2" by simp
        finally show ?thesis by arith
      }
    qed

    hence showDivisibility: "2 dvd n ∧ 2 dvd m"
    proof -
      {
        from contradiction have "2 dvd m^2" by arith
        then have mdiv: "2 dvd m" by simp
        then obtain k where "m = 2 * k" ..

        also with contradiction have "2 * n^2 = 2^2 * k^2" by (auto)
        then have "n^2 = 2 * k^2" by simp
        then have "2 dvd n^2" by arith
        then have ndiv: "2 dvd n" by simp

        show ?thesis by (simp add: mdiv ndiv)
      }
    qed

    have gcdEven: "2 dvd (gcd n m)" by (simp add: showDivisibility)
    have gcdOdd: "¬(2 dvd (gcd n m))" by (simp add: gcd.commute gcdIsOne)
    show False using gcdEven gcdOdd by auto
  }
qed

end


section \<open>Auxiliary lemmas\<close>

theory AuxLemmas imports Main begin

abbreviation "arbitrary == undefined"

text \<open>Lemmas about left- and rightmost elements in lists\<close>

lemma leftmost_element_property:
  assumes "\<exists>x \<in> set xs. P x"
  obtains zs x' ys where "xs = zs@x'#ys" and "P x'" and "\<forall>z \<in> set zs. \<not> P z"
proof(atomize_elim)
  from \<open>\<exists>x \<in> set xs. P x\<close>
  show "\<exists>zs x' ys. xs = zs @ x' # ys \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)"
  proof(induct xs)
    case Nil thus ?case by simp
  next
    case (Cons x' xs')
    note IH = \<open>\<exists>a\<in>set xs'. P a
      \<Longrightarrow> \<exists>zs x' ys. xs' = zs@x'#ys \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)\<close>
    show ?case
    proof (cases "P x'")
      case True
      then have "(\<exists>ys. x' # xs' = [] @ x' # ys) \<and> P x' \<and> (\<forall>x\<in>set []. \<not> P x)" by simp
      then show ?thesis by blast
    next
      case False
      with \<open>\<exists>y\<in>set (x'#xs'). P y\<close> have "\<exists>y\<in>set xs'. P y" by simp
      from IH[OF this] obtain y ys zs where "xs' = zs@y#ys"
        and "P y" and "\<forall>z\<in>set zs. \<not> P z" by blast
      from \<open>\<forall>z\<in>set zs. \<not> P z\<close> False have "\<forall>z\<in>set (x'#zs). \<not> P z" by simp
      with \<open>xs' = zs@y#ys\<close> \<open>P y\<close> show ?thesis by (metis Cons_eq_append_conv)
    qed
  qed
qed

lemma rightmost_element_property:
  assumes "\<exists>x \<in> set xs. P x"
  obtains ys x' zs where "xs = ys@x'#zs" and "P x'" and "\<forall>z \<in> set zs. \<not> P z"
proof(atomize_elim)
  from \<open>\<exists>x \<in> set xs. P x\<close>
  show "\<exists>ys x' zs. xs = ys @ x' # zs \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)"
  proof(induct xs)
    case Nil thus ?case by simp
  next
    case (Cons x' xs')
    note IH = \<open>\<exists>a\<in>set xs'. P a
      \<Longrightarrow> \<exists>ys x' zs. xs' = ys @ x' # zs \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)\<close>
    show ?case
    proof(cases "\<exists>y\<in>set xs'. P y")
      case True
      from IH[OF this] obtain y ys zs where "xs' = ys @ y # zs"
        and "P y" and "\<forall>z\<in>set zs. \<not> P z" by blast
      thus ?thesis by (metis Cons_eq_append_conv)
    next
      case False
      with \<open>\<exists>y\<in>set (x'#xs'). P y\<close> have "P x'" by simp
      with False show ?thesis by (metis eq_Nil_appendI)
    qed
  qed
qed

text \<open>Lemma concerning maps and \<open>@\<close>\<close>

lemma map_append_append_maps:
  assumes map:"map f xs = ys@zs"
  obtains xs' xs'' where "map f xs' = ys" and "map f xs'' = zs" and "xs=xs'@xs''"
by (metis append_eq_conv_conj append_take_drop_id assms drop_map take_map that)

text \<open>Lemma concerning splitting of @{term list}s\<close>

lemma  path_split_general:
assumes all:"\<forall>zs. xs \<noteq> ys@zs"
obtains j zs where "xs = (take j ys)@zs" and "j < length ys"
  and "\<forall>k > j. \<forall>zs'. xs \<noteq> (take k ys)@zs'"
proof(atomize_elim)
  from \<open>\<forall>zs. xs \<noteq> ys@zs\<close>
  show "\<exists>j zs. xs = take j ys @ zs \<and> j < length ys \<and>
               (\<forall>k>j. \<forall>zs'. xs \<noteq> take k ys @ zs')"
  proof(induct ys arbitrary:xs)
    case Nil thus ?case by auto
  next
    case (Cons y' ys')
    note IH = \<open>\<And>xs. \<forall>zs. xs \<noteq> ys' @ zs \<Longrightarrow>
      \<exists>j zs. xs = take j ys' @ zs \<and> j < length ys' \<and>
      (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs \<noteq> take k ys' @ zs'))\<close>
    show ?case
    proof(cases xs)
      case Nil thus ?thesis by simp
    next
      case (Cons x' xs')
      with \<open>\<forall>zs. xs \<noteq> (y' # ys') @ zs\<close> have "x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)"
        by simp
      show ?thesis
      proof(cases "x' = y'")
        case True
        with \<open>x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)\<close> have "\<forall>zs. xs' \<noteq> ys' @ zs" by simp
        from IH[OF this] have "\<exists>j zs. xs' = take j ys' @ zs \<and> j < length ys' \<and>
          (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs'))" .
        then obtain j zs where "xs' = take j ys' @ zs"
          and "j < length ys'"
          and all_sub:"\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs')"
          by blast
        from \<open>xs' = take j ys' @ zs\<close> True
          have "(x'#xs') = take (Suc j) (y' # ys') @ zs"
          by simp
        from all_sub True have all_imp:"\<forall>k. j < k \<longrightarrow>
          (\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs')"
          by auto
        { fix l assume "(Suc j) < l"
          then obtain k where [simp]:"l = Suc k" by(cases l) auto
          with \<open>(Suc j) < l\<close> have "j < k" by simp
          with all_imp
          have "\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs'"
            by simp
          hence "\<forall>zs'. (x'#xs') \<noteq> take l (y' # ys') @ zs'"
            by simp }
        with \<open>(x'#xs') = take (Suc j) (y' # ys') @ zs\<close> \<open>j < length ys'\<close> Cons
        show ?thesis by (metis Suc_length_conv less_Suc_eq_0_disj)
      next
        case False
        with Cons have "\<forall>i zs'. i > 0 \<longrightarrow> xs \<noteq> take i (y' # ys') @ zs'"
          by auto(case_tac i,auto)
        moreover
        have "\<exists>zs. xs = take 0 (y' # ys') @ zs" by simp
        ultimately show ?thesis by(rule_tac x="0" in exI,auto)
      qed
    qed
  qed
qed

end


(*  Author:      Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
*)
theory Efficient_Sort
  imports "HOL-Library.Multiset"
begin

section \<open>GHC Version of Mergesort\<close>

text \<open>
  In the following we show that the mergesort implementation
  used in GHC (see \<^url>\<open>http://hackage.haskell.org/package/base-4.11.1.0/docs/src/Data.OldList.html#sort\<close>)
  is a correct and stable sorting algorithm. Furthermore, experimental
  data suggests that generated code for this implementation is much more
  efficient than for the implementation provided by \<^theory>\<open>HOL-Library.Multiset\<close>.

  A high-level overview of an older version of this formalization as well as some experimental data
  is to be found in \<^cite>\<open>"Sternagel2012"\<close>.
\<close>
subsection \<open>Definition of Natural Mergesort\<close>

context
  fixes key :: "'a \<Rightarrow> 'k::linorder"
begin

text \<open>
  Split a list into chunks of ascending and descending parts, where
  descending parts are reversed on the fly.
  Thus, the result is a list of sorted lists.
\<close>
fun sequences :: "'a list \<Rightarrow> 'a list list"
  and asc :: "'a \<Rightarrow> ('a list \<Rightarrow> 'a list) \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  and desc :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  where
    "sequences (a # b # xs) =
      (if key a > key b then desc b [a] xs else asc b ((#) a) xs)"
  | "sequences [x] = [[x]]"
  | "sequences [] = []"
  | "asc a as (b # bs) =
      (if key a \<le> key b then asc b (\<lambda>ys. as (a # ys)) bs
      else as [a] # sequences (b # bs))"
  | "asc a as [] = [as [a]]"
  | "desc a as (b # bs) =
      (if key a > key b then desc b (a # as) bs
      else (a # as) # sequences (b # bs))"
  | "desc a as [] = [a # as]"

fun merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
    "merge (a # as) (b # bs) =
      (if key a > key b then b # merge (a # as) bs else a # merge as (b # bs))"
  | "merge [] bs = bs"
  | "merge as [] = as"

fun merge_pairs :: "'a list list \<Rightarrow> 'a list list"
  where
    "merge_pairs (a # b # xs) = merge a b # merge_pairs xs"
  | "merge_pairs xs = xs"

lemma length_merge [simp]:
  "length (merge xs ys) = length xs + length ys"
  by (induct xs ys rule: merge.induct) simp_all

lemma length_merge_pairs [simp]:
  "length (merge_pairs xs) = (1 + length xs) div 2"
  by (induct xs rule: merge_pairs.induct) simp_all

fun merge_all :: "'a list list \<Rightarrow> 'a list"
  where
    "merge_all [] = []"
  | "merge_all [x] = x"
  | "merge_all xs = merge_all (merge_pairs xs)"

fun msort_key :: "'a list \<Rightarrow> 'a list"
  where
    "msort_key xs = merge_all (sequences xs)"

subsection \<open>The Functional Argument of @{const asc}\<close>

text \<open>\<open>f\<close> is a function that only adds some prefix to a given list.\<close>
definition "ascP f = (\<forall>xs. f xs = f [] @ xs)"

lemma ascP_Cons [simp]: "ascP ((#) x)" by (simp add: ascP_def)

lemma ascP_comp_append_Cons [simp]:
  "ascP (\<lambda>xs. f [] @ x # xs)"
  by (auto simp: ascP_def)

lemma ascP_f_Cons:
  assumes "ascP f"
  shows "f (x # xs) = f [] @ x # xs"
  using \<open>ascP f\<close> [unfolded ascP_def, THEN spec, of "x # xs"] .

lemma ascP_comp_Cons [simp]:
  assumes "ascP f"
  shows "ascP (\<lambda>ys. f (x # ys))"
proof (unfold ascP_def, intro allI)
  fix xs show "f (x # xs) = f [x] @ xs"
    using assms by (simp add: ascP_f_Cons)
qed

lemma ascP_f_singleton:
  assumes "ascP f"
  shows "f [x] = f [] @ [x]"
  by (rule ascP_f_Cons [OF assms])

subsection \<open>Facts about Lengths\<close>

lemma
  shows length_sequences: "length (sequences xs) \<le> length xs"
    and length_asc: "ascP f \<Longrightarrow> length (asc a f ys) \<le> 1 + length ys"
    and length_desc: "length (desc a xs ys) \<le> 1 + length ys"
  by (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct) auto

lemma length_concat_merge_pairs [simp]:
  "length (concat (merge_pairs xss)) = length (concat xss)"
  by (induct xss rule: merge_pairs.induct) simp_all

subsection \<open>Functional Correctness\<close>

lemma mset_merge [simp]:
  "mset (merge xs ys) = mset xs + mset ys"
  by (induct xs ys rule: merge.induct) simp_all

lemma set_merge [simp]:
  "set (merge xs ys) = set xs \<union> set ys"
  by (simp flip: set_mset_mset)

lemma mset_concat_merge_pairs [simp]:
  "mset (concat (merge_pairs xs)) = mset (concat xs)"
  by (induct xs rule: merge_pairs.induct) auto

lemma set_concat_merge_pairs [simp]:
  "set (concat (merge_pairs xs)) = set (concat xs)"
  by (simp flip: set_mset_mset)

lemma mset_merge_all [simp]:
  "mset (merge_all xs) = mset (concat xs)"
  by (induct xs rule: merge_all.induct) simp_all

lemma set_merge_all [simp]:
  "set (merge_all xs) = set (concat xs)"
  by (simp flip: set_mset_mset)

lemma
  shows mset_seqeuences [simp]: "mset (concat (sequences xs)) = mset xs"
    and mset_asc: "ascP f \<Longrightarrow> mset (concat (asc x f ys)) = {#x#} + mset (f []) + mset ys"
    and mset_desc: "mset (concat (desc x xs ys)) = {#x#} + mset xs + mset ys"
  by (induct xs and x f ys and x xs ys rule: sequences_asc_desc.induct)
    (auto simp: ascP_f_singleton)

lemma mset_msort_key:
  "mset (msort_key xs) = mset xs"
  by (auto)

lemma sorted_merge [simp]:
  assumes "sorted (map key xs)" and "sorted (map key ys)"
  shows "sorted (map key (merge xs ys))"
  using assms by (induct xs ys rule: merge.induct) (auto)

lemma sorted_merge_pairs [simp]:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "\<forall>x\<in>set (merge_pairs xs). sorted (map key x)"
  using assms by (induct xs rule: merge_pairs.induct) simp_all

lemma sorted_merge_all:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "sorted (map key (merge_all xs))"
  using assms by (induct xs rule: merge_all.induct) simp_all

lemma
  shows sorted_sequences: "\<forall>x \<in> set (sequences xs). sorted (map key x)"
    and sorted_asc: "ascP f \<Longrightarrow> sorted (map key (f [])) \<Longrightarrow> \<forall>x\<in>set (f []). key x \<le> key a \<Longrightarrow> \<forall>x\<in>set (asc a f ys). sorted (map key x)"
    and sorted_desc: "sorted (map key xs) \<Longrightarrow> \<forall>x\<in>set xs. key a \<le> key x \<Longrightarrow> \<forall>x\<in>set (desc a xs ys). sorted (map key x)"
  by (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct)
    (auto simp: ascP_f_singleton sorted_append not_less dest: order_trans, fastforce)

lemma sorted_msort_key:
  "sorted (map key (msort_key xs))"
  by (unfold msort_key.simps) (intro sorted_merge_all sorted_sequences)

subsection \<open>Stability\<close>

lemma
  shows filter_by_key_sequences [simp]: "[y\<leftarrow>concat (sequences xs). key y = k] = [y\<leftarrow>xs. key y = k]"
    and filter_by_key_asc: "ascP f \<Longrightarrow> [y\<leftarrow>concat (asc a f ys). key y = k] = [y\<leftarrow>f [a] @ ys. key y = k]"
    and filter_by_key_desc: "sorted (map key xs) \<Longrightarrow> \<forall>x\<in>set xs. key a \<le> key x \<Longrightarrow> [y\<leftarrow>concat (desc a xs ys). key y = k] = [y\<leftarrow>a # xs @ ys. key y = k]"
proof (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct)
  case (4 a f b bs)
  then show ?case
    by (auto simp: o_def ascP_f_Cons [where f = f])
next
  case (6 a as b bs)
  then show ?case
  proof (cases "key b < key a")
    case True
    with 6 have "[y\<leftarrow>concat (desc b (a # as) bs). key y = k] = [y\<leftarrow>b # (a # as) @ bs. key y = k]"
      by (auto simp: less_le order_trans)
    then show ?thesis
      using True and 6
      by (cases "key a = k", cases "key b = k")
        (auto simp: Cons_eq_append_conv intro!: filter_False)
  qed auto
qed auto

lemma filter_by_key_merge_is_append [simp]:
  assumes "sorted (map key xs)"
  shows "[y\<leftarrow>merge xs ys. key y = k] = [y\<leftarrow>xs. key y = k] @ [y\<leftarrow>ys. key y = k]"
  using assms
  by (induct xs ys rule: merge.induct) (auto simp: Cons_eq_append_conv leD intro!: filter_False)

lemma filter_by_key_merge_pairs [simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>concat (merge_pairs xss). key y = k] = [y\<leftarrow>concat xss. key y = k]"
  using assms by (induct xss rule: merge_pairs.induct) simp_all

lemma filter_by_key_merge_all [simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>merge_all xss. key y = k] = [y\<leftarrow>concat xss. key y = k]"
  using assms by (induct xss rule: merge_all.induct) simp_all

lemma filter_by_key_merge_all_sequences [simp]:
  "[x\<leftarrow>merge_all (sequences xs) . key x = k] = [x\<leftarrow>xs . key x = k]"
  using sorted_sequences [of xs] by simp

lemma msort_key_stable:
  "[x\<leftarrow>msort_key xs. key x = k] = [x\<leftarrow>xs. key x = k]"
  by auto

lemma sort_key_msort_key_conv:
  "sort_key key = msort_key"
  using msort_key_stable [of "key x" for x]
  by (intro ext properties_for_sort_key mset_msort_key sorted_msort_key)
    (metis (mono_tags, lifting) filter_cong)

end

text \<open>
  Replace existing code equations for \<^const>\<open>sort_key\<close> by \<^const>\<open>msort_key\<close>.
\<close>
declare sort_key_by_quicksort_code [code del]
declare sort_key_msort_key_conv [code]

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Equivalences\<close>
theory Order_Equivalences
  imports
    Order_Functors_Base
    Partial_Equivalence_Relations
    Preorders
begin

context order_functors
begin

definition "order_equivalence \<equiv>
  ((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l \<and>
  ((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r \<and>
  rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta> \<and>
  rel_equivalence_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>) \<epsilon>"

notation order_functors.order_equivalence (infix "\<equiv>\<^sub>o" 50)

lemma order_equivalenceI [intro]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding order_equivalence_def using assms by blast

lemma order_equivalenceE [elim]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  obtains "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l" "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
    "rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
    "rel_equivalence_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  using assms unfolding order_equivalence_def by blast

interpretation of : order_functors S T f g for S T f g .

lemma rel_inv_order_equivalence_eq_order_equivalence [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>))"
  by (intro ext)
  (auto intro!: of.order_equivalenceI simp: of.flip_unit_eq_counit)

corollary order_equivalence_right_left_iff_order_equivalence_left_right:
  "((\<le>\<^bsub>R\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>L\<^esub>)) r l \<longleftrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  by (simp flip: rel_inv_order_equivalence_eq_order_equivalence)

text \<open>Due to the symmetry given by
@{thm "order_equivalence_right_left_iff_order_equivalence_left_right"},
for any theorem on @{term "(\<le>\<^bsub>L\<^esub>)"}, we obtain a corresponding theorem on
@{term "(\<le>\<^bsub>R\<^esub>)"} by flipping the roles of the two functors.
As such, in what follows, we do not explicitly state these free theorems but
users can obtain them as needed by creating a flipped interpretation
of @{locale order_functors}.\<close>

lemma order_equivalence_rel_inv_eq_order_equivalence [simp]:
  "((\<ge>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<ge>\<^bsub>R\<^esub>)) = ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>))"
  by (intro ext) (auto intro!: of.order_equivalenceI)

lemma in_codom_left_eq_in_dom_left_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  shows "in_codom (\<le>\<^bsub>L\<^esub>) = in_dom (\<le>\<^bsub>L\<^esub>)"
  using assms by (elim order_equivalenceE)
  (rule in_codom_eq_in_dom_if_rel_equivalence_on_in_field)

corollary preorder_on_in_field_left_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)"
  shows "preorder_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  using assms by (elim order_equivalenceE)
  (rule preorder_on_in_field_if_transitive_if_rel_equivalence_on)

lemma order_equivalence_partial_equivalence_rel_not_reflexive_not_transitive:
  assumes "\<exists>(y :: 'b) y'. y \<noteq> y'"
  shows "\<exists>(L :: 'a \<Rightarrow> 'a \<Rightarrow> bool) (R :: 'b \<Rightarrow> 'b \<Rightarrow> bool) l r.
    (L \<equiv>\<^sub>o R) l r \<and> partial_equivalence_rel L \<and>
    \<not>(reflexive_on (in_field R) R) \<and> \<not>(transitive_on (in_field R) R)"
proof -
  from assms obtain cy cy' where "(cy :: 'b) \<noteq> cy'" by blast
  let ?cx = "undefined :: 'a"
  let ?L = "\<lambda>x x'. ?cx = x \<and> x = x'"
  and ?R = "\<lambda>y y'. (y = cy \<or> y = cy') \<and> (y' = cy \<or> y' = cy') \<and> (y \<noteq> cy' \<or> y' \<noteq> cy')"
  and ?l = "\<lambda>(a :: 'a). cy"
  and ?r = "\<lambda>(b :: 'b). ?cx"
  have "(?L \<equiv>\<^sub>o ?R)?l ?r" using \<open>cy \<noteq> cy'\<close>
    by (intro of.order_equivalenceI) (auto 0 4)
  moreover have "partial_equivalence_rel ?L" by blast
  moreover have
    "\<not>(transitive_on (in_field ?R) ?R)" and "\<not>(reflexive_on (in_field ?R) ?R)"
    using \<open>cy \<noteq> cy'\<close> by auto
  ultimately show "?thesis" by blast
qed

end

end


(* Title:      Examples using Hoare Logic for Total Correctness
   Author:     Walter Guttmann
*)

section \<open>Examples using Hoare Logic for Total Correctness\<close>

theory ExamplesTC
  imports Hoare_Logic
begin

text \<open>
This theory demonstrates a few simple partial- and total-correctness proofs.
The first example is taken from HOL/Hoare/Examples.thy written by N. Galm.
We have added the invariant \<open>m \<le> a\<close>.
\<close>

lemma multiply_by_add: "VARS m s a b
  {a=A \<and> b=B}
  m := 0; s := 0;
  WHILE m\<noteq>a
  INV {s=m*b \<and> a=A \<and> b=B \<and> m\<le>a}
  DO s := s+b; m := m+(1::nat) OD
  {s = A*B}"
  by vcg_simp

text \<open>
Here is the total-correctness proof for the same program.
It needs the additional invariant \<open>m \<le> a\<close>.
\<close>

lemma multiply_by_add_tc: "VARS m s a b
  [a=A \<and> b=B]
  m := 0; s := 0;
  WHILE m\<noteq>a
  INV {s=m*b \<and> a=A \<and> b=B \<and> m\<le>a}
  VAR {a-m}
  DO s := s+b; m := m+(1::nat) OD
  [s = A*B]"
  apply vcg_tc_simp
  by auto

text \<open>
Next, we prove partial correctness of a program that computes powers.
\<close>

lemma power: "VARS (p::int) i
  { True }
  p := 1;
  i := 0;
  WHILE i < n
    INV { p = x^i \<and> i \<le> n }
     DO p := p * x;
        i := i + 1
     OD
  { p = x^n }"
  apply vcg_simp
  by auto

text \<open>
Here is its total-correctness proof.
\<close>

lemma power_tc: "VARS (p::int) i
  [ True ]
  p := 1;
  i := 0;
  WHILE i < n
    INV { p = x^i \<and> i \<le> n }
    VAR { n - i }
     DO p := p * x;
        i := i + 1
     OD
  [ p = x^n ]"
  apply vcg_tc
  by auto

text \<open>
The last example is again taken from HOL/Hoare/Examples.thy.
We have modified it to integers so it requires precondition \<open>0 \<le> x\<close>.
\<close>

lemma sqrt_tc: "VARS r
  [0 \<le> (x::int)]
  r := 0;
  WHILE (r+1)*(r+1) <= x
  INV {r*r \<le> x}
  VAR { nat (x-r)}
  DO r := r+1 OD
  [r*r \<le> x \<and> x < (r+1)*(r+1)]"
  apply vcg_tc_simp
  by (smt (verit) div_pos_pos_trivial mult_less_0_iff nonzero_mult_div_cancel_left)

text \<open>
A total-correctness proof allows us to extract a function for further use.
For every input satisfying the precondition the function returns an output satisfying the postcondition.
\<close>

lemma sqrt_exists:
  "0 \<le> (x::int) \<Longrightarrow> \<exists>r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
  using tc_extract_function sqrt_tc by blast

definition "sqrt (x::int) \<equiv> (SOME r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1))"

lemma sqrt_function:
  assumes "0 \<le> (x::int)"
    and "r' = sqrt x"
  shows "r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
proof -
  let ?P = "\<lambda>r' . r'*r' \<le> x \<and> x < (r'+1)*(r'+1)"
  have "?P (SOME z . ?P z)"
    by (metis (mono_tags, lifting) assms(1) sqrt_exists some_eq_imp)
  thus ?thesis
    using assms(2) sqrt_def by auto
qed

text \<open>Nested loops!\<close>

lemma "VARS (i::nat) j
  [ True ]
  WHILE 0 < i
    INV { True }
    VAR { z = i }
     DO i := i - 1; j := i;
        WHILE 0 < j
        INV { z = i+1 }
        VAR { j }
        DO j := j - 1 OD
     OD
  [ i \<le> 0 ]"
  apply vcg_tc
  by auto

end


theory Submission
  imports Defs
begin

fun find_pfx :: "nat list \<Rightarrow> nat \<Rightarrow> nat list"  where
  "find_pfx [] v = []" |
  "find_pfx (x#xs) v = (if x = v then [x] else x#(find_pfx xs v))"

value "find_pfx [1::nat,2,3] 2 = [1,2]"
value "find_pfx [] (1::nat) = []"

lemma find_pfx_append:
  "(find_pfx (xs1 @ [x] @ xs2) x) = (find_pfx (xs1 @ [x]) x)"
  by(induction xs1, auto)

lemma find_pfx_not_empty: "x \<in> set xs \<Longrightarrow> length (find_pfx xs x) > 0"
  by(induction xs, auto)

lemma last_find_pfx_val:
  "last (find_pfx (xs @ [x]) x) = x"
  using find_pfx_not_empty by(induction xs, auto)

lemma find_pfx_suff[simp]: "x \<in> set xs \<Longrightarrow> find_pfx (xs @ ys) x = find_pfx xs x"
  by(induction xs, auto)

lemma pfx_append_same: "x \<in> set xs \<Longrightarrow> find_pfx (xs @ xs) x = find_pfx xs x"
  by simp

end


theory Exe2p5
  imports Main
begin

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

lemma simp_sum_upto: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
   apply(auto)
  done