theory Chapter12_3
imports "HOL-IMP.Hoare_Sound_Complete"
begin

text\<open>
\exercise
Prove
\<close>

lemma "\<Turnstile> {P} c {Q} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> wp c Q s)"
    unfolding hoare_valid_def wp_def by auto

text\<open>
\endexercise

\begin{exercise}
Replace the assignment command with a new command \mbox{@{term"Do f"}} where
@{text "f ::"} @{typ "state \<Rightarrow> state"} can be an arbitrary state transformer.
Update the big-step semantics, Hoare logic and the soundness and completeness proofs.
\end{exercise}
\<close>
text \<open>
\exercise
Which of the following rules are correct? Proof or counterexample!
\<close>

lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
  \<turnstile> {\<lambda>s. P s \<or> P' s} c {\<lambda>s. Q s \<or> Q' s}"
proof -
  assume "\<turnstile> {P} c {Q}"
  then have "\<Turnstile> {P} c {Q}" by (rule hoare_sound)
  moreover assume "\<turnstile> {P'} c {Q'}"
  then have "\<Turnstile> {P'} c {Q'}" by (rule hoare_sound)
  ultimately have "\<Turnstile> {\<lambda>s. P s \<or> P' s} c {\<lambda>s. Q s \<or> Q' s}"
    unfolding hoare_valid_def by blast
  then show ?thesis by (rule hoare_complete)
qed

lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
  \<turnstile> {\<lambda>s. P s \<and> P' s} c {\<lambda>s. Q s \<and> Q' s}"
proof -
  assume "\<turnstile> {P} c {Q}"
  then have "\<Turnstile> {P} c {Q}" by (rule hoare_sound)
  moreover assume "\<turnstile> {P'} c {Q'}"
  then have "\<Turnstile> {P'} c {Q'}" by (rule hoare_sound)
  ultimately have "\<Turnstile> {\<lambda>s. P s \<and> P' s} c {\<lambda>s. Q s \<and> Q' s}"
    unfolding hoare_valid_def by blast
  then show ?thesis by (rule hoare_complete)
qed

lemma "\<exists>P Q P' Q' c. \<turnstile> {P} c {Q} \<and>  \<turnstile> {P'} c {Q'} \<and> \<not> \<turnstile> {\<lambda>s. P s \<longrightarrow> P' s} c {\<lambda>s. Q s \<longrightarrow> Q' s}"
proof -
  let ?P = "\<lambda>s::state. s ''x'' = 1"
  let ?Q = "\<lambda>s::state. True"
  have "\<turnstile> {?P} SKIP {?P}" (is ?P1) by (rule Skip)
  moreover from this have "\<turnstile> {?P} SKIP {?Q}" (is ?P2) by (rule weaken_post, blast)
  moreover have "\<not> \<turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}" (is ?P3)
  proof
    assume "\<turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}"
    then have "\<Turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}" by (rule hoare_sound)
    then have H1: "\<And>s t. \<lbrakk>(?P s \<longrightarrow> ?P s); (SKIP, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (?Q t \<longrightarrow> ?P t)"
      unfolding hoare_valid_def by (intro allI impI, blast)
    have H2: "?P <> \<longrightarrow> ?P <>" unfolding null_state_def by blast
    have H3: "(SKIP, <>) \<Rightarrow> <>" by auto
    from H1 [of "<>", OF H2 H3] show False unfolding null_state_def by simp
  qed
  ultimately show ?thesis by blast
qed
text\<open>
\endexercise

\begin{exercise}
Based on Exercise~\ref{exe:IMP:OR}, extend Hoare logic and the soundness and completeness proofs
with nondeterministic choice.
\end{exercise}

\begin{exercise}
Based on Exercise~\ref{exe:IMP:REPEAT}, extend Hoare logic and the soundness and completeness proofs
with a @{text REPEAT} loop. Hint: think of @{text"REPEAT c UNTIL b"} as
equivalent to \noquotes{@{term[source]"c;; WHILE Not b DO c"}}.
\end{exercise}

\exercise\label{exe:sp}
The dual of the weakest precondition is the \concept{strongest postcondition}
@{text sp}. Define @{text sp} in analogy with @{const wp} via the big-step semantics:
\<close>

definition sp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
  "sp c P = (\<lambda>t. \<exists>s. P s \<and> (c, s) \<Rightarrow> t)"

text\<open> Prove that @{const sp} really is the strongest postcondition: \<close>

lemma "(\<Turnstile> {P} c {Q}) \<longleftrightarrow> (\<forall>s. sp c P s \<longrightarrow> Q s)"
  unfolding hoare_valid_def sp_def by blast

text\<open>
In analogy with the derived equations for @{const wp} given in the text,
give and prove equations for ``calculating'' @{const sp} for three constructs:
@{prop"sp (x ::= a) P = Q\<^sub>1"}, @{prop"sp (c\<^sub>1;;c\<^sub>2) P = Q\<^sub>2"}, and
@{prop"sp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) P = Q\<^sub>3"}.
The @{text Q\<^sub>i} must not involve the semantics and may only call
@{const sp} recursively on the subcommands @{text c\<^sub>i}.
Hint: @{text Q\<^sub>1} requires an existential quantifier.
\<close>

lemma sp_Ass [simp]: "sp (x::=a) P = (\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x')))"
  unfolding sp_def
proof (rule ext, auto)
  fix s :: state
  have Heq: "s(x := s x) = s" by auto
  assume "P s"
  with Heq have "P (s(x := s x)) \<and> aval a s = aval a (s(x := s x))" by auto
  then show "\<exists>x'. P (s(x := x')) \<and> aval a s = aval a (s(x := x'))" by blast
next
  fix t :: state and x'
  let ?s = "t(x := x')"
  assume H: "P (t(x := x'))" "t x = aval a ?s"
  have Heq: "t(x := t x) = t" by auto
  have "(x ::= a, ?s) \<Rightarrow> ?s(x := aval a ?s)" by (rule big_step.Assign)
  with H(2) Heq have "(x ::= a, ?s) \<Rightarrow> t" by simp
  with H have "P ?s \<and> (x ::= a, ?s) \<Rightarrow> t" by simp
  from exI [of "\<lambda>s. P s \<and> (x ::= a, s) \<Rightarrow> t", OF this]
  show "\<exists>s. P s \<and> (x ::= a, s) \<Rightarrow> t" .
qed

lemma sp_Seq [simp]: "sp (c\<^sub>1;; c\<^sub>2) P = sp c\<^sub>2 (sp c\<^sub>1 P)"
  unfolding sp_def by (rule ext) auto

lemma sp_If [simp]: "sp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) P =
  (\<lambda>t. sp c\<^sub>1 (\<lambda>s. P s \<and> bval b s) t \<or> sp c\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s) t)"
  unfolding sp_def by (rule ext) auto

text\<open>
\endexercise
\<close>

end


(*
    ex.thy,v 1.1 2016/09/29 17:37:37 jdf Exp
    Original Author: Tjark Weber
    Updated to Isabelle 2016 and additions by Jacques Fleuriot

    File completed and renamed to: propositional_logic.thy
    Name: Athiya Deviyani
    UUN: S1709906
*)

section {* Propositional Logic *}

theory propositional_logic imports Main begin

text {* In this exercise, we will prove some lemmas of propositional
logic with the aid of a calculus of natural deduction.

For the proofs, you may only use

notI: (?P \<Longrightarrow> False) \<Longrightarrow> \<not> ?P
notE: \<lbrakk>\<not> ?P; ?P\<rbrakk> \<Longrightarrow> ?R
conjI: \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?P \<and> ?Q
conjE: \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
disjI1:?P \<Longrightarrow> ?P \<or> ?Q
disjI2: ?Q \<Longrightarrow> ?P \<or> ?Q
disjE: \<lbrakk>?P \<or> ?Q; ?P \<Longrightarrow> ?R; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
impI: (?P \<Longrightarrow> ?Q) \<Longrightarrow> ?P \<longrightarrow> ?Q
impE:\<lbrakk>?P \<longrightarrow> ?Q; ?P; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
mp: \<lbrakk>?P \<longrightarrow> ?Q; ?P\<rbrakk> \<Longrightarrow> ?Q
iffI:\<lbrakk>?P \<Longrightarrow> ?Q; ?Q \<Longrightarrow> ?P\<rbrakk> \<Longrightarrow> ?P = ?Q
iffE:\<lbrakk>?P = ?Q; \<lbrakk>?P \<longrightarrow> ?Q; ?Q \<longrightarrow> ?P\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
classical: (\<not> ?P \<Longrightarrow> ?P) \<Longrightarrow> ?P

and the proof methods rule, erule and assumption.
\end{itemize}

Prove:
*}

lemma I: "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

lemma "A \<and> B \<longrightarrow> B \<and> A"
  apply (rule impI)
  apply (erule conjE)
  apply (rule conjI)
   apply assumption
  apply assumption

lemma "(A \<and> B) \<longrightarrow> (A \<or> B)"
  apply (rule impI)
  apply (erule conjE)
  apply (rule disjI1)
  apply assumption

lemma "((A \<or> B) \<or> C) \<longrightarrow> A \<or> (B \<or> C)"
  apply (rule impI)
  apply (erule disjE)
   apply (erule disjE)
    apply (rule disjI1)
    apply assumption
   apply (rule disjI2)
   apply (rule disjI1)
  apply assumption
  apply(rule disjI2)
  apply (rule disjI2)
  apply assumption

lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
   apply (erule disjE)
    apply (rule conjI)
     apply assumption
    apply assumption
   apply (rule conjI)
    apply assumption
  apply assumption
  apply (erule conjE)
  apply (rule disjI1)
  apply assumption

lemma S: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule impE)
    apply assumption
  apply (erule impE)
   apply assumption
  apply assumption

lemma "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption
  apply assumption

lemma "\<not> \<not> A \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule notE)
  apply assumption

lemma "A \<longrightarrow> \<not> \<not> A"
  apply (rule impI)
  apply (rule notI)
  apply (erule notE)
  apply assumption

lemma "(\<not> A \<longrightarrow> B) \<longrightarrow> (\<not> B \<longrightarrow> A)"
  apply (rule impI)+
  apply (rule classical)
  apply (erule notE)
  apply (erule impE)
   apply assumption
  apply assumption

lemma "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
  apply (rule impI)
  apply (erule notE)
   apply (assumption)
  apply (erule notE)
  apply assumption

lemma "A \<or> \<not> A"
  apply (rule classical)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI1)
  apply assumption

lemma "(\<not> (A \<and> B)) = (\<not> A \<or> \<not> B)"
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule conjI)
    apply (rule classical)
    apply (erule notE)
    apply (rule disjI1)
    apply assumption
   apply (rule classical)
   apply (erule notE)
   apply (rule disjI2)
   apply assumption
  apply (rule classical)
  apply (erule notE)
  apply (erule disjE)
   apply (rule notI)
  apply (erule notE)
   apply (erule conjE)
   apply assumption
  apply (rule notI)
  apply (erule conjE)
  apply (erule notE)
  apply assumption

end


theory Chapter5
imports Main
begin

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

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_0: "iter r 0 x x" |
iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

text \<open>
\section*{Chapter 5}

\exercise
Give a readable, structured proof of the following lemma:
\<close>

lemma
  assumes T: "\<forall>x y. T x y \<or> T y x"
    and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
    and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof -
  have "T x y \<or> T y x" using T by blast
  thus "T x y"
  proof
    assume "T x y"
    thus ?thesis by assumption
  next
    assume "T y x"
    hence "A y x" using TA by blast
    hence "x = y" using A and `A x y` by blast
    thus "T x y" using `T y x` by blast
  qed
qed

text\<open>
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof -
  have "even (length xs) \<or> odd (length xs)" by simp
  thus ?thesis
  proof
    assume "even (length xs)"
    hence "\<exists> k. k + k = length xs" by arith
    then obtain k where Hk: "k + k = length xs" by auto
    let ?ys = "take k xs"
    let ?zs = "drop k xs"
    have "xs = ?ys @ ?zs" (is ?Heq) by simp
    moreover from Hk have "length ?ys = length ?zs" (is ?Hlen) by auto
    ultimately have "?Heq \<and> ?Hlen" by simp
    thus ?thesis by blast
  next
    assume "odd (length xs)"
    hence "\<exists> k. (k + 1) + k = length xs" by arith
    then obtain k where Hk: "(k + 1) + k = length xs" by auto
    let ?ys = "take (k + 1) xs"
    let ?zs = "drop (k + 1) xs"
    have "xs = ?ys @ ?zs" (is ?Heq) by simp
    moreover from Hk have "length ?ys = length ?zs + 1" (is ?Hlen) by auto
    ultimately have "?Heq \<and> ?Hlen" by simp
    thus ?thesis by blast
  qed
qed

text\<open>
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
\<close>
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
proof (cases "Suc (Suc n)" rule: ev.cases)
  case ev0
  from a show ?case by assumption
next
  case evSS
  assume "ev n"
  then show ?thesis by assumption
qed

text\<open>
\exercise
Give a structured proof by rule inversions:
\<close>

lemma "\<not> ev(Suc(Suc(Suc 0)))" (is "\<not> ?P")
proof
  assume "?P"
  thus False
  proof (cases "Suc (Suc (Suc 0))")
    case evSS
    thus False by cases
  qed
qed

text\<open>
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
\<close>

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induct rule: iter.induct)
  case (iter_0 x)
  show ?case by (simp add: refl)
next
  case (iter_Suc x y n z)
  thus ?case by (simp add: step)
qed

text\<open>
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
\<close>

fun elems :: "'a list \<Rightarrow> 'a set" where
  "elems [] = {}" |
  "elems (x # xs) = {x} \<union> elems xs"

text\<open> that collects all elements of a list into a set. Prove \<close>

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induct xs)
  case Nil
  hence False by simp
  thus ?case by simp
next
  case (Cons a xs)
  hence HxUn: "x \<in> {a} \<union> elems xs" by simp
  consider (xa) "x \<in> {a}" | (nxa) "x \<notin> {a}" by blast
  thus ?case
  proof cases
    case xa
    hence "x = a" ..
    hence "a # xs = x # xs" by simp
    also have "\<dots> = [] @ x # xs" by simp
    finally have "a # xs = [] @ x # xs" by simp
    moreover have "x \<notin> {}" by simp
    hence "x \<notin> elems []" by simp
    ultimately show ?thesis by blast
  next
    case nxa
    from HxUn
    show ?thesis
    proof
      assume "x \<in> {a}"
      thus ?thesis using nxa by simp
    next
      assume "x \<in> elems xs"
      then obtain ys zs where "xs = ys @ x # zs" and "x \<notin> elems ys" using Cons.hyps by blast
      hence "a # xs = (a # ys) @ x # zs" and "x \<notin> elems ys" by auto
      hence "a # xs = (a # ys) @ x # zs" and "x \<notin> elems (a # ys)" using nxa by auto
      thus ?thesis by blast
    qed
  qed
qed

text\<open>
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function \<close>

datatype alpha = alphaa | alphab

inductive S :: "alpha list \<Rightarrow> bool" where
S_\<epsilon>: "S []" |
S_aSb: "S w \<Longrightarrow> S (alphaa # w @ [alphab])" |
S_SS: "\<lbrakk> S v; S w \<rbrakk> \<Longrightarrow> S (v @ w)"

fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
  "balanced 0 [] = True" |
  "balanced (Suc _) [] = False" | (* too many a's *)
  "balanced n (alphaa # as) = balanced (Suc n) as" |
  "balanced 0 (alphab # as) = False" | (* too many b's *)
  "balanced (Suc n) (alphab # as) = balanced n as"

text\<open> such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove \<close>

lemma balanced_r: "balanced n as \<Longrightarrow> balanced (Suc n) (as @ [alphab])"
proof (induction n as rule: balanced.induct)
  case 1
  thus ?case by simp
next
  case (2 uu)
  thus ?case by simp
next
  case (3 n as)
  from 3(2) have "balanced (Suc n) as" by simp
  thus ?case using 3(1) by simp
next
  case (4 as)
  then show ?case by simp
next
  case (5 n as)
  from 5(2) have "balanced n as" by simp
  thus ?case using 5(1) by simp
qed

lemma balanced_app: "\<lbrakk>balanced m as; balanced n bs\<rbrakk> \<Longrightarrow> balanced (m + n) (as @ bs)"
proof (induct m as arbitrary: n bs rule: balanced.induct)
  case 1
  then show ?case by simp
next
  case (2 uu)
  then show ?case by simp
next
  case (3 nn as)
  from 3(2) have "balanced (Suc nn) as" by simp
  with 3(1, 3) have "balanced (Suc nn + n) (as @ bs)" by simp
  hence "balanced (Suc (nn + n)) (as @ bs)" by simp
  thus ?case by simp
next
  case (4 as)
  then show ?case by simp
next
  case (5 nn as)
  from 5(2) have "balanced nn as" by simp
  with 5(1, 3) have "balanced (nn + n) (as @ bs)" by simp
  hence "balanced (Suc (nn + n)) (alphab # as @ bs)" by simp
  thus ?case by simp
qed

lemma S_ends: "S w \<Longrightarrow> w = [] \<or> (\<exists> v. w = alphaa # v @ [alphab])"
proof (induct w rule: S.induct)
  case S_\<epsilon>
  have "[] = []" by simp
  thus ?case by blast
next
  case (S_aSb w)
  have "alphaa # w @ [alphab] = alphaa # w @ [alphab]" by simp
  thus ?case by blast
next
  case (S_SS v w)
  from S_SS(2) show ?case
  proof
    assume Hv: "v = []"
    from S_SS(4) show ?thesis
    proof
      assume "w = []"
      with Hv have "v @ w = []" by simp
      thus ?thesis by blast
    next
      assume "\<exists>u. w = alphaa # u @ [alphab]"
      then obtain u where "w = alphaa # u @ [alphab]" ..
      with Hv have "v @ w = alphaa # u @ [alphab]" by simp
      thus ?thesis by blast
    qed
  next
    assume "\<exists>u. v = alphaa # u @ [alphab]"
    then obtain n where Hv: "v = alphaa # n @ [alphab]" ..
    from S_SS(4) show ?thesis
    proof
      assume "w = []"
      with Hv have "v @ w = alphaa # n @ [alphab]" by simp
      thus ?thesis by blast
    next
      assume "\<exists>u. w = alphaa # u @ [alphab]"
      then obtain m where "w = alphaa # m @ [alphab]" ..
      with Hv have "v @ w = alphaa # n @ [alphab] @ alphaa # m @ [alphab]" by simp
      hence "v @ w = alphaa # (n @ [alphab] @ alphaa # m) @ [alphab]" by simp
      thus ?thesis by blast
    qed
  qed
qed

lemma S_replicate: "\<lbrakk>S (alphaa # v); v @ w = replicate n alphaa @ x\<rbrakk> \<Longrightarrow> \<exists> u. v = replicate n alphaa @ u"
proof -
  assume Hvw: "v @ w = replicate n alphaa @ x"
  assume Sav: "S (alphaa # v)"
  hence "\<exists> vv. alphaa # v = alphaa # vv @ [alphab]"
  proof -
    assume "S (alphaa # v)"
    with S_ends have "alphaa # v = [] \<or> (\<exists> vv. alphaa # v = alphaa # vv @ [alphab])" by auto
    thus "\<exists>vv. alphaa # v = alphaa # vv @ [alphab]"
    proof
      assume "alphaa # v = []"
      thus ?thesis by simp
    next
      assume "\<exists>vv. alphaa # v = alphaa # vv @ [alphab]"
      thus ?thesis by simp
    qed
  qed
  then obtain vv where "alphaa # v = alphaa # vv @ [alphab]" ..
  hence Hv: "v = vv @ [alphab]" by simp
  hence Hvvw: "vv @ [alphab] @ w = replicate n alphaa @ x" using Hvw by simp
  hence "\<exists> xx. vv @ [alphab] = replicate n alphaa @ xx"
  proof (induct n arbitrary: x)
    case 0
    have "vv @ [alphab] = replicate 0 alphaa @ vv @ [alphab]" by simp
    thus ?case by simp
  next
    case (Suc n)
    from Suc(2) have Suc2s: "vv @ [alphab] @ w = replicate n alphaa @ alphaa # x" by (simp add: replicate_app_Cons_same)
    hence "\<exists>xx. vv @ [alphab] = replicate n alphaa @ xx" using Suc(1) by simp
    then obtain xx where Hxx1: "vv @ [alphab] = replicate n alphaa @ xx" ..
    hence "\<exists> xl. vv @ [alphab] = replicate n alphaa @ xl @ [alphab]"
      by (metis alpha.distinct(1) append_butlast_last_id empty_replicate last_append last_replicate last_snoc self_append_conv2)
    then obtain xl where Hvvb: "vv @ [alphab] = replicate n alphaa @ xl @ [alphab]" ..
    hence Hxl1: "vv = replicate n alphaa @ xl" by simp
    with Suc2s have "replicate n alphaa @ xl @ [alphab] @ w = replicate n alphaa @ alphaa # x" by simp
    hence Hxx: "xl @ [alphab] @ w = alphaa # x" by simp
    hence "\<exists> xlr. xl = alphaa # xlr"
      by (metis alpha.distinct(1) append_eq_Cons_conv list.sel(1))
    then obtain xlr where "xl = alphaa # xlr" ..
    with Hvvb have "vv @ [alphab] = replicate n alphaa @ alphaa # xlr @ [alphab]" by simp
    hence "vv @ [alphab] = replicate (Suc n) alphaa @ xlr @ [alphab]" by (simp add: replicate_app_Cons_same)
    then show ?case by blast
  qed
  thus ?thesis using Hv by simp
qed

corollary "balanced n w \<longleftrightarrow> S (replicate n alphaa @ w)" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  thus ?Q
  proof (induct n w rule: balanced.induct)
    case 1 show ?case by (auto intro: S.S_\<epsilon>)
  next case (2 uu) thus ?case by simp
  next
    case (3 n as)
    moreover from this have "balanced (Suc n) as" by simp
    ultimately have "S (replicate (Suc n) alphaa @ as)" by simp
    hence "S ((replicate n alphaa @ [alphaa]) @ as)" by (simp add: replicate_append_same)
    thus ?case by auto
  next case (4 as) thus ?case by simp
  next
    case (5 n as)
    moreover from this have "balanced n as" by simp
    ultimately have "S (replicate n alphaa @ as)" by simp
    then show ?case
    proof (induct "replicate n alphaa @ as" arbitrary: n as rule: S.induct)
      case S_\<epsilon>
      from S_\<epsilon> have Hn: "replicate n alphaa = []" by simp
      from S_\<epsilon> have Has: "as = []" by simp
      from Hn have Hl: "replicate (Suc n) alphaa = [alphaa]" by simp
      from S.S_\<epsilon> have "S []" by simp
      with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
      with Hl Has show ?case by auto
    next
      case (S_aSb w)
      then show ?case
      proof (cases "rev as")
        case Nil
        hence "alphaa # w @ [alphab] = replicate n alphaa @ []" using S_aSb(3) by simp
        thus ?thesis
          by (metis Nil_is_append_conv alpha.distinct(1) append_Nil2 empty_replicate last.simps last_replicate last_snoc list.discI)
      next
        case (Cons a al)
        hence Has: "as = rev al @ [a]" by simp
        hence Ha: "a = alphab" using S_aSb(3) by auto
        from S_aSb(3) Has Ha have Haw: "alphaa # w = replicate n alphaa @ rev al" by auto
        have "S (replicate (Suc n) alphaa @ alphab # rev al @ [a])"
        proof (cases n)
          case 0
          with Haw have "alphaa # w @ [alphab] = rev al @ [alphab]" by simp
          with S_aSb(1) S.S_aSb have "S (rev al @ [alphab])" by metis
          moreover
          from S.S_\<epsilon> have "S []" by simp
          with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
          hence "S ([alphaa, alphab])" by simp
          ultimately have "S ([alphaa, alphab] @ rev al @ [alphab])" using S.S_SS by blast
          hence "S ([alphaa] @ alphab # rev al @ [alphab])" by auto
          with 0 Ha show ?thesis by auto
        next
          case (Suc m)
          with Haw have Hw: "w = replicate m alphaa @ rev al" by simp
          with S_aSb(2) have "S (replicate (Suc m) alphaa @ alphab # rev al)" by blast
          with S.S_aSb have "S (alphaa # (replicate (Suc m) alphaa @ alphab # rev al) @ [alphab])" by blast
          hence "S (replicate (Suc (Suc m)) alphaa @ alphab # rev al @ [alphab])" by auto
          thus ?thesis using Suc Ha by simp
        qed
        thus ?thesis using Has by simp
      qed
    next
      case (S_SS v w)
      from \<open>S v\<close> have "v = [] \<or> (\<exists> k. v = alphaa # k @ [alphab])" using S_ends by simp
      then show ?case
      proof
        assume "v = []"
        with S_SS(5) have "w = replicate n alphaa @ as" by simp
        with S_SS(4) show ?thesis by simp
      next
        assume "\<exists>k. v = alphaa # k @ [alphab]"
        then obtain k where Hk: "v = alphaa # k @ [alphab]" ..
        show ?thesis
        proof (cases n)
          case 0
          with S_SS(5) have "v @ w = as" by simp
          with S.S_SS S_SS(1,3) have "S as" by blast
          moreover
          from S.S_\<epsilon> have "S []" by simp
          with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
          hence "S ([alphaa] @ [alphab])" by auto
          ultimately have "S (([alphaa] @ [alphab]) @ as)" using S.S_SS by blast
          thus ?thesis using 0 by auto
        next
          case (Suc m)
          have "S (alphaa # k @ [alphab])" using \<open>S v\<close> and Hk by simp
          moreover
          from this Suc S_SS(5) have "v @ w = alphaa # replicate m alphaa @ as" by simp
          with Hk have "k @ [alphab] @ w = replicate m alphaa @ as" by simp
          ultimately have "\<exists> u. k @ [alphab] = replicate m alphaa @ u" using S_replicate by simp
          then obtain u where "k @ [alphab] = replicate m alphaa @ u" ..
          hence "v = alphaa # replicate m alphaa @ u" using Hk by simp
          hence Hv: "v = replicate n alphaa @ u" using Suc by simp
          hence Svv: "S (replicate (Suc n) alphaa @ alphab # u)" using S_SS(2) by simp
          from Hv S_SS(5) have Has: "as = u @ w" by simp
          from Svv S_SS(3) S.S_SS have "S ((replicate (Suc n) alphaa @ alphab # u) @ w)" by blast
          with Has show ?thesis by auto
        qed
      qed
    qed
  qed
next
  assume ?Q
  thus ?P
  proof (induct "replicate n alphaa @ w" arbitrary: n w rule: S.induct)
    case S_\<epsilon>
    hence "replicate n alphaa = []" by simp
    hence "n = 0" by simp
    moreover from S_\<epsilon> have "w = []" by simp
    ultimately show ?case by simp
  next
    case (S_aSb ww)
    then show ?case
    proof (cases n)
      case 0
      with S_aSb have Hw: "w = alphaa # ww @ [alphab]" by simp
      from S_aSb(2) have "balanced 0 ww" by auto
      hence "balanced (Suc 0) (ww @ [alphab])" using balanced_r by simp
      hence "balanced 0 (alphaa # ww @ [alphab])" by simp
      with 0 Hw show ?thesis by simp
    next
      case (Suc m)
      with S_aSb(3) have Hwwb: "ww @ [alphab] = replicate m alphaa @ w" by simp
      hence "\<exists> wl. ww @ [alphab] = replicate m alphaa @ wl @ [alphab]"
        by (metis alpha.distinct(1) append_butlast_last_id empty_replicate last_append last_replicate last_snoc self_append_conv2)
      then obtain wl where Hww: "ww = replicate m alphaa @ wl" by auto
      with S_aSb(2) have Bwl: "balanced m wl" by blast
      from Hwwb Hww have Hw: "w = wl @ [alphab]" by simp
      from Bwl balanced_r have "balanced (Suc m) (wl @ [alphab])" by simp
      thus ?thesis using Hw Suc by simp
    qed
  next
    case (S_SS vv ww)
    from S_SS(1) S_ends have "vv = [] \<or> (\<exists>vvv. vv = alphaa # vvv @ [alphab])" by simp
    thus ?case
    proof
      assume "vv = []"
      with S_SS(5) have "ww = replicate n alphaa @ w" by simp
      with S_SS(4) show ?thesis by simp
    next
      assume "\<exists>vvv. vv = alphaa # vvv @ [alphab]"
      then obtain vvv where Hvv: "vv = alphaa # vvv @ [alphab]" ..
      hence Svv: "S (alphaa # vvv @ [alphab])" using S_SS(1) by simp
      show ?thesis
      proof (cases n)
        case 0
        with S_SS(5) have Hw: "w = vv @ ww" by simp
        from S_SS(2) have Hvv: "balanced 0 vv" by simp
        from S_SS(4) have Hww: "balanced 0 ww" by simp
        from Hvv Hww balanced_app Hw have "balanced (0 + 0) w" by blast
        with 0 show ?thesis by simp
      next
        case (Suc m)
        hence H: "vvv @ [alphab] @ ww = replicate m alphaa @ w" using Hvv S_SS(5) by auto
        hence "\<exists> u. vvv @ [alphab] = replicate m alphaa @ u" using Svv S_replicate by auto
        then obtain u where Hu: "vvv @ [alphab] = replicate m alphaa @ u" ..
        hence "vv = replicate n alphaa @ u" using Hvv Suc by auto
        with S_SS(2) have Hbu: "balanced n u" by simp
        from H have H': "(vvv @ [alphab]) @ ww = replicate m alphaa @ w" by simp
        from Hu H' have "replicate m alphaa @ u @ ww = replicate m alphaa @ w" by auto
        from Hu H' have Hw: "u @ ww = w" by auto
        from S_SS(3, 4) have Hbww: "balanced 0 ww" by simp
        hence "balanced (n + 0) (u @ ww)" using Hbu balanced_app by blast
        thus ?thesis using Hw by auto
      qed
    qed
  qed
qed

text\<open> where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
\<close>

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Powerset\<close>
theory Powerset
  imports Order_Set
begin

lemma mem_powerset_if_subset: "A \<subseteq> B \<Longrightarrow> A \<in> powerset B"
  by auto

lemma subset_if_mem_powerset: "A \<in> powerset B  \<Longrightarrow> A \<subseteq> B"
  by auto

lemma empty_mem_powerset [iff]: "{} \<in> powerset A"
  by auto

lemma mem_powerset_self [iff]: "A \<in> powerset A"
  by auto

lemma mem_powerset_empty_iff_eq_empty [iff]: "x \<in> powerset {} \<longleftrightarrow> x = {}"
  by auto

lemma mono_powerset: "mono powerset"
  by (intro monoI) auto

end


section \<open>\isaheader{Orderings By Comparison Operator}\<close>
theory Intf_Comp
imports
  Automatic_Refinement.Automatic_Refinement
begin

subsection \<open>Basic Definitions\<close>

datatype comp_res = LESS | EQUAL | GREATER

consts i_comp_res :: interface
abbreviation "comp_res_rel \<equiv> Id :: (comp_res \<times> _) set"
lemmas [autoref_rel_intf] = REL_INTFI[of comp_res_rel i_comp_res]

definition "comp2le cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> True | EQUAL \<Rightarrow> True | GREATER \<Rightarrow> False"

definition "comp2lt cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> True | EQUAL \<Rightarrow> False | GREATER \<Rightarrow> False"

definition "comp2eq cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> False | EQUAL \<Rightarrow> True | GREATER \<Rightarrow> False"

locale linorder_on =
  fixes D :: "'a set"
  fixes cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp_res"
  assumes lt_eq: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = LESS \<longleftrightarrow> (cmp y x = GREATER)"
  assumes refl[simp, intro!]: "x\<in>D \<Longrightarrow> cmp x x = EQUAL"
  assumes trans[trans]:
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = LESS; cmp y z = LESS\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = LESS; cmp y z = EQUAL\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = EQUAL; cmp y z = LESS\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = EQUAL; cmp y z = EQUAL\<rbrakk> \<Longrightarrow> cmp x z = EQUAL"
begin
  abbreviation "le \<equiv> comp2le cmp"
  abbreviation "lt \<equiv> comp2lt cmp"

  lemma eq_sym: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<Longrightarrow> cmp y x = EQUAL"
    apply (cases "cmp y x")
    using lt_eq lt_eq[symmetric]
    by auto
end

abbreviation "linorder \<equiv> linorder_on UNIV"

lemma linorder_to_class:
  assumes "linorder cmp"
  assumes [simp]: "\<And>x y. cmp x y = EQUAL \<Longrightarrow> x=y"
  shows "class.linorder (comp2le cmp) (comp2lt cmp)"
proof -
  interpret linorder_on UNIV cmp by fact
  show ?thesis
    apply (unfold_locales)
    unfolding comp2le_def comp2lt_def
    apply (auto split: comp_res.split comp_res.split_asm)
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    done
qed

definition "dflt_cmp le lt a b \<equiv>
  if lt a b then LESS
  else if le a b then EQUAL
  else GREATER"

lemma (in linorder) class_to_linorder:
  "linorder (dflt_cmp (\<le>) (<))"
  apply (unfold_locales)
  unfolding dflt_cmp_def
  by (auto split: if_split_asm)

lemma restrict_linorder: "\<lbrakk>linorder_on D cmp ; D'\<subseteq>D\<rbrakk> \<Longrightarrow> linorder_on D' cmp"
  apply (rule linorder_on.intro)
  apply (drule (1) rev_subsetD)+
  apply (erule (2) linorder_on.lt_eq)
  apply (drule (1) rev_subsetD)+
  apply (erule (1) linorder_on.refl)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  done

subsection \<open>Operations on Linear Orderings\<close>

text \<open>Map with injective function\<close>
definition cmp_img where "cmp_img f cmp a b \<equiv> cmp (f a) (f b)"

lemma img_linorder[intro?]:
  assumes LO: "linorder_on (f`D) cmp"
  shows "linorder_on D (cmp_img f cmp)"
  apply unfold_locales
  unfolding cmp_img_def
  apply (rule linorder_on.lt_eq[OF LO], auto) []
  apply (rule linorder_on.refl[OF LO], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  done

text \<open>Combine\<close>
definition "cmp_combine D1 cmp1 D2 cmp2 a b \<equiv>
  if a\<in>D1 \<and> b\<in>D1 then cmp1 a b
  else if a\<in>D1 \<and> b\<in>D2 then LESS
  else if a\<in>D2 \<and> b\<in>D1 then GREATER
  else cmp2 a b
"

(* TODO: Move *)
lemma UnE':
  assumes "x\<in>A\<union>B"
  obtains "x\<in>A" | "x\<notin>A" "x\<in>B"
  using assms by blast

lemma combine_linorder[intro?]:
  assumes "linorder_on D1 cmp1"
  assumes "linorder_on D2 cmp2"
  assumes "D = D1\<union>D2"
  shows "linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
  apply unfold_locales
  unfolding cmp_combine_def
  using assms apply -
  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.lt_eq) [4]

  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.refl) [2]

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)
  done

subsection \<open>Universal Linear Ordering\<close>
text \<open>With Zorn's Lemma, we get a universal linear (even wf) ordering\<close>

definition "univ_order_rel \<equiv> (SOME r. well_order_on UNIV r)"
definition "univ_cmp x y \<equiv>
  if x=y then EQUAL
  else if (x,y)\<in>univ_order_rel then LESS
  else GREATER"

lemma univ_wo: "well_order_on UNIV univ_order_rel"
  unfolding univ_order_rel_def
  using well_order_on[of UNIV]
  ..

lemma univ_linorder[intro?]: "linorder univ_cmp"
  apply unfold_locales
  unfolding univ_cmp_def
  apply (auto split: if_split_asm)
  using univ_wo
  apply -
  unfolding well_order_on_def linear_order_on_def partial_order_on_def
    preorder_on_def
  apply (auto simp add: antisym_def) []
  apply (unfold total_on_def, fast) []
  apply (unfold trans_def, fast) []
  apply (auto simp add: antisym_def) []
  done

text \<open>Extend any linear order to a universal order\<close>
definition "cmp_extend D cmp \<equiv>
  cmp_combine D cmp UNIV univ_cmp"

lemma extend_linorder[intro?]:
  "linorder_on D cmp \<Longrightarrow> linorder (cmp_extend D cmp)"
  unfolding cmp_extend_def
  apply rule
  apply assumption
  apply rule
  by simp

subsubsection \<open>Lexicographic Order on Lists\<close>

fun cmp_lex where
  "cmp_lex cmp [] [] = EQUAL"
| "cmp_lex cmp [] _ = LESS"
| "cmp_lex cmp _ [] = GREATER"
| "cmp_lex cmp (a#l) (b#m) = (
    case cmp a b of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp_lex cmp l m
    | GREATER \<Rightarrow> GREATER)"

primrec cmp_lex' where
  "cmp_lex' cmp [] m = (case m of [] \<Rightarrow> EQUAL | _ \<Rightarrow> LESS)"
| "cmp_lex' cmp (a#l) m = (case m of [] \<Rightarrow> GREATER | (b#m) \<Rightarrow>
    (case cmp a b of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp_lex' cmp l m
    | GREATER \<Rightarrow> GREATER
  ))"

lemma cmp_lex_alt: "cmp_lex cmp l m = cmp_lex' cmp l m"
  apply (induct l arbitrary: m)
  apply (auto split: comp_res.split list.split)
  done

lemma (in linorder_on) lex_linorder[intro?]:
  "linorder_on (lists D) (cmp_lex cmp)"
proof
  fix l m
  assume "l\<in>lists D" "m\<in>lists D"
  thus "(cmp_lex cmp l m = LESS) = (cmp_lex cmp m l = GREATER)"
    apply (induct cmp\<equiv>cmp l m rule: cmp_lex.induct)
    apply (auto split: comp_res.split simp: lt_eq)
    apply (auto simp: lt_eq[symmetric])
    done
next
  fix x
  assume "x\<in>lists D"
  thus "cmp_lex cmp x x = EQUAL"
    by (induct x) auto
next
  fix x y z
  assume M: "x\<in>lists D" "y\<in>lists D" "z\<in>lists D"

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = EQUAL"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (drule (4) trans, simp)+
      done
  }
qed

subsubsection \<open>Lexicographic Order on Pairs\<close>

fun cmp_prod where
  "cmp_prod cmp1 cmp2 (a1,a2) (b1,b2)
  = (
    case cmp1 a1 b1 of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp2 a2 b2
    | GREATER \<Rightarrow> GREATER)"

lemma cmp_prod_alt: "cmp_prod = (\<lambda>cmp1 cmp2 (a1,a2) (b1,b2). (
    case cmp1 a1 b1 of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp2 a2 b2
    | GREATER \<Rightarrow> GREATER))"
  by (auto intro!: ext)

  show ?thesis
    apply unfold_locales
    apply (auto split: comp_res.split comp_res.split_asm,
      simp_all add: A.lt_eq B.lt_eq,
      simp_all add: A.lt_eq[symmetric]
      ) []

    apply (auto split: comp_res.split comp_res.split_asm) []

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+
    done
qed

subsection \<open>Universal Ordering for Sets that is Effective for Finite Sets\<close>

subsubsection \<open>Sorted Lists of Sets\<close>
text \<open>Some more results about sorted lists of finite sets\<close>

lemma set_to_map_set_is_map_of:
  "distinct (map fst l) \<Longrightarrow> set_to_map (set l) = map_of l"
  apply (induct l)
  apply (auto simp: set_to_map_insert)
  done

context linorder begin

  lemma sorted_list_of_set_eq_nil[simp]:
    assumes "finite A"
    shows "sorted_list_of_set A = [] \<longleftrightarrow> A={}"
    using assms
    apply (induct rule: finite_induct)
    apply simp
    apply simp
    done

  lemma sorted_list_of_set_eq_nil2[simp]:
    assumes "finite A"
    shows "[] = sorted_list_of_set A \<longleftrightarrow> A={}"
    using assms
    by (auto dest: sym)

  lemma set_insort[simp]: "set (insort x l) = insert x (set l)"
    by (induct l) auto

  lemma sorted_list_of_set_inj_aux:
    fixes A B :: "'a set"
    assumes "finite A"
    assumes "finite B"
    assumes "sorted_list_of_set A = sorted_list_of_set B"
    shows "A=B"
    using assms
  proof -
    from \<open>finite B\<close> have "B = set (sorted_list_of_set B)" by simp
    also from assms have "\<dots> = set (sorted_list_of_set (A))"
      by simp
    also from \<open>finite A\<close>
    have "set (sorted_list_of_set (A)) = A"
      by simp
    finally show ?thesis by simp
  qed

  lemma sorted_list_of_set_inj: "inj_on sorted_list_of_set (Collect finite)"
    apply (rule inj_onI)
    using sorted_list_of_set_inj_aux
    by blast

  lemma the_sorted_list_of_set:
    assumes "distinct l"
    assumes "sorted l"
    shows "sorted_list_of_set (set l) = l"
    using assms
    by (simp
      add: sorted_list_of_set_sort_remdups distinct_remdups_id sorted_sort_id)

  definition "sorted_list_of_map m \<equiv>
    map (\<lambda>k. (k, the (m k))) (sorted_list_of_set (dom m))"

  lemma the_sorted_list_of_map:
    assumes "distinct (map fst l)"
    assumes "sorted (map fst l)"
    shows "sorted_list_of_map (map_of l) = l"
  proof -
    have "dom (map_of l) = set (map fst l)" by (induct l) force+
    hence "sorted_list_of_set (dom (map_of l)) = map fst l"
      using the_sorted_list_of_set[OF assms] by simp
    hence "sorted_list_of_map (map_of l)
      = map (\<lambda>k. (k, the (map_of l k))) (map fst l)"
      unfolding sorted_list_of_map_def by simp
    also have "\<dots> = l" using \<open>distinct (map fst l)\<close>
    proof (induct l)
      case Nil thus ?case by simp
    next
      case (Cons a l)
      hence
        1: "distinct (map fst l)"
        and 2: "fst a\<notin>fst`set l"
        and 3: "map (\<lambda>k. (k, the (map_of l k))) (map fst l) = l"
        by simp_all

      from 2 have [simp]: "\<not>(\<exists>x\<in>set l. fst x = fst a)"
        by (auto simp: image_iff)

      show ?case
        apply simp
        apply (subst (3) 3[symmetric])
        apply simp
        done
    qed
    finally show ?thesis .
  qed

  lemma map_of_sorted_list_of_map[simp]:
    assumes FIN: "finite (dom m)"
    shows "map_of (sorted_list_of_map m) = m"
    unfolding sorted_list_of_map_def
  proof -
    have "set (sorted_list_of_set (dom m)) = dom m"
      and DIST: "distinct (sorted_list_of_set (dom m))"
      by (simp_all add: FIN)

    have [simp]: "(fst \<circ> (\<lambda>k. (k, the (m k)))) = id" by auto

    have [simp]: "(\<lambda>k. (k, the (m k))) ` dom m = map_to_set m"
      by (auto simp: map_to_set_def)

    show "map_of (map (\<lambda>k. (k, the (m k))) (sorted_list_of_set (dom m))) = m"
      apply (subst set_to_map_set_is_map_of[symmetric])
      apply (simp add: DIST)
      apply (subst set_map)
      apply (simp add: FIN map_to_set_inverse)
      done
  qed

  lemma sorted_list_of_map_inj_aux:
    fixes A B :: "'a\<rightharpoonup>'b"
    assumes [simp]: "finite (dom A)"
    assumes [simp]: "finite (dom B)"
    assumes E: "sorted_list_of_map A = sorted_list_of_map B"
    shows "A=B"
    using assms
  proof -
    have "A = map_of (sorted_list_of_map A)" by simp
    also note E
    also have "map_of (sorted_list_of_map B) = B" by simp
    finally show ?thesis .
  qed

  lemma sorted_list_of_map_inj:
    "inj_on sorted_list_of_map (Collect (finite o dom))"
    apply (rule inj_onI)
    using sorted_list_of_map_inj_aux
    by auto
end

definition "cmp_set cmp \<equiv>
  cmp_extend (Collect finite) (
    cmp_img
      (linorder.sorted_list_of_set (comp2le cmp))
      (cmp_lex cmp)
  )"

thm img_linorder

lemma set_ord_linear[intro?]:
  "linorder cmp \<Longrightarrow> linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_linorder)
  apply (erule linorder_on.lex_linorder)
  apply simp
  done

definition "cmp_map cmpk cmpv \<equiv>
  cmp_extend (Collect (finite o dom)) (
    cmp_img
      (linorder.sorted_list_of_map (comp2le cmpk))
      (cmp_lex (cmp_prod cmpk cmpv))
  )
"

lemma map_to_set_inj[intro!]: "inj map_to_set"
  apply (rule inj_onI)
  unfolding map_to_set_def
  apply (rule ext)
  apply (case_tac "x xa")
  apply (case_tac [!] "y xa")
  apply force+
  done

corollary map_to_set_inj'[intro!]: "inj_on map_to_set S"
  by (metis map_to_set_inj subset_UNIV subset_inj_on)

lemma map_ord_linear[intro?]:
  assumes A: "linorder cmpk"
  assumes B: "linorder cmpv"
  shows "linorder (cmp_map cmpk cmpv)"
proof -
  interpret lk: linorder_on UNIV cmpk by fact
  interpret lv: linorder_on UNIV cmpv by fact

  show ?thesis
    unfolding cmp_map_def
    apply rule
    apply rule
    apply (rule restrict_linorder)
    apply (rule linorder_on.lex_linorder)
    apply (rule)
    apply fact
    apply fact
    apply simp
    done
qed

locale eq_linorder_on = linorder_on +
  assumes cmp_imp_equal: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<Longrightarrow> x = y"
begin
  lemma cmp_eq[simp]: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<longleftrightarrow> x = y"
    by (auto simp: cmp_imp_equal)
end

abbreviation "eq_linorder \<equiv> eq_linorder_on UNIV"

lemma dflt_cmp_2inv[simp]:
  "dflt_cmp (comp2le cmp) (comp2lt cmp) = cmp"
  unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
  apply (auto split: comp_res.splits intro!: ext)
  done

lemma (in linorder) dflt_cmp_inv2[simp]:
  shows
  "(comp2le (dflt_cmp (\<le>) (<)))= (\<le>)"
  "(comp2lt (dflt_cmp (\<le>) (<)))= (<)"
proof -
  show "(comp2lt (dflt_cmp (\<le>) (<)))= (<)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

  show "(comp2le (dflt_cmp (\<le>) (<))) = (\<le>)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

qed

lemma eq_linorder_class_conv:
  "eq_linorder cmp \<longleftrightarrow> class.linorder (comp2le cmp) (comp2lt cmp)"
proof
  assume "eq_linorder cmp"
  then interpret eq_linorder_on UNIV cmp .
  have "linorder cmp" by unfold_locales
  show "class.linorder (comp2le cmp) (comp2lt cmp)"
    apply (rule linorder_to_class)
    apply fact
    by simp
next
  assume "class.linorder (comp2le cmp) (comp2lt cmp)"
  then interpret linorder "comp2le cmp" "comp2lt cmp" .

  from class_to_linorder interpret linorder_on UNIV cmp
    by simp
  show "eq_linorder cmp"
  proof
    fix x y
    assume "cmp x y = EQUAL"
    hence "comp2le cmp x y" "\<not>comp2lt cmp x y"
      by (auto simp: comp2le_def comp2lt_def)
    thus "x=y" by simp
  qed
qed

lemma (in linorder) class_to_eq_linorder:
  "eq_linorder (dflt_cmp (\<le>) (<))"
proof -
  interpret linorder_on UNIV "dflt_cmp (\<le>) (<)"
    by (rule class_to_linorder)

  show ?thesis
    apply unfold_locales
    apply (auto simp: dflt_cmp_def split: if_split_asm)
    done
qed

lemma eq_linorder_comp2eq_eq:
  assumes "eq_linorder cmp"
  shows "comp2eq cmp = (=)"
proof -
  interpret eq_linorder_on UNIV cmp by fact
  show ?thesis
    apply (intro ext)
    unfolding comp2eq_def
    apply (auto split: comp_res.split dest: refl)
    done
qed

lemma restrict_eq_linorder:
  assumes "eq_linorder_on D cmp"
  assumes S: "D'\<subseteq>D"
  shows "eq_linorder_on D' cmp"
proof -
  interpret eq_linorder_on D cmp by fact

  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply (rule restrict_linorder[where D=D])
    apply unfold_locales []
    apply fact
    apply unfold_locales
    using S
    apply -
    apply (drule (1) rev_subsetD)+
    apply auto
    done
qed

lemma combine_eq_linorder[intro?]:
  assumes A: "eq_linorder_on D1 cmp1"
  assumes B: "eq_linorder_on D2 cmp2"
  assumes EQ: "D=D1\<union>D2"
  shows "eq_linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  interpret linorder_on "(D1 \<union> D2)" "(cmp_combine D1 cmp1 D2 cmp2)"
    apply rule
    apply unfold_locales
    by simp

  show ?thesis
    apply (simp only: EQ)
    apply unfold_locales
    unfolding cmp_combine_def
    by (auto split: if_split_asm)
qed

lemma img_eq_linorder[intro?]:
  assumes A: "eq_linorder_on (f`D) cmp"
  assumes INJ: "inj_on f D"
  shows "eq_linorder_on D (cmp_img f cmp)"
proof -
  interpret eq_linorder_on "f`D" cmp by fact
  interpret L: linorder_on "(D)" "(cmp_img f cmp)"
    apply rule
    apply unfold_locales
    done

  show ?thesis
    apply unfold_locales
    unfolding cmp_img_def
    using INJ
    apply (auto dest: inj_onD)
    done
qed

lemma univ_eq_linorder[intro?]:
  shows "eq_linorder univ_cmp"
  apply (rule eq_linorder_on.intro)
  apply rule
  apply unfold_locales
  unfolding univ_cmp_def
  apply (auto split: if_split_asm)
  done

lemma extend_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder (cmp_extend D cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    unfolding cmp_extend_def
    apply (rule)
    apply fact
    apply rule
    by simp
qed

lemma lex_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder_on (lists D) (cmp_lex cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    subgoal for l m
      apply (induct cmp\<equiv>cmp l m rule: cmp_lex.induct)
      apply (auto split: comp_res.splits)
      done
    done
qed

lemma prod_eq_linorder[intro?]:
  assumes "eq_linorder_on D1 cmp1"
  assumes "eq_linorder_on D2 cmp2"
  shows "eq_linorder_on (D1\<times>D2) (cmp_prod cmp1 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    apply (auto split: comp_res.splits)
    done
qed

lemma set_ord_eq_linorder[intro?]:
  "eq_linorder cmp \<Longrightarrow> eq_linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_set_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

lemma map_ord_eq_linorder[intro?]:
  "\<lbrakk>eq_linorder cmpk; eq_linorder cmpv\<rbrakk> \<Longrightarrow> eq_linorder (cmp_map cmpk cmpv)"
  unfolding cmp_map_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply rule
  apply assumption
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_map_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

definition cmp_unit :: "unit \<Rightarrow> unit \<Rightarrow> comp_res"
  where [simp]: "cmp_unit u v \<equiv> EQUAL"

lemma cmp_unit_eq_linorder:
  "eq_linorder cmp_unit"
  by unfold_locales simp_all

subsection \<open>Parametricity\<close>

lemma param_cmp_extend[param]:
  assumes "(cmp,cmp')\<in>R \<rightarrow> R \<rightarrow> Id"
  assumes "Range R \<subseteq> D"
  shows "(cmp,cmp_extend D cmp') \<in> R \<rightarrow> R \<rightarrow> Id"
  unfolding cmp_extend_def cmp_combine_def[abs_def]
  using assms
  apply clarsimp
  by (blast dest!: fun_relD)

lemma param_cmp_img[param]:
  "(cmp_img,cmp_img) \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rb\<rightarrow>Rb\<rightarrow>Rc) \<rightarrow> Ra \<rightarrow> Ra \<rightarrow> Rc"
  unfolding cmp_img_def[abs_def]
  by parametricity

lemma param_comp_res[param]:
  "(LESS,LESS)\<in>Id"
  "(EQUAL,EQUAL)\<in>Id"
  "(GREATER,GREATER)\<in>Id"
  "(case_comp_res,case_comp_res)\<in>Ra\<rightarrow>Ra\<rightarrow>Ra\<rightarrow>Id\<rightarrow>Ra"
  by (auto split: comp_res.split)

term cmp_lex
lemma param_cmp_lex[param]:
  "(cmp_lex,cmp_lex)\<in>(Ra\<rightarrow>Rb\<rightarrow>Id)\<rightarrow>\<langle>Ra\<rangle>list_rel\<rightarrow>\<langle>Rb\<rangle>list_rel\<rightarrow>Id"
  unfolding cmp_lex_alt[abs_def] cmp_lex'_def
  by (parametricity)

term cmp_prod
lemma param_cmp_prod[param]:
  "(cmp_prod,cmp_prod)\<in>
  (Ra\<rightarrow>Rb\<rightarrow>Id)\<rightarrow>(Rc\<rightarrow>Rd\<rightarrow>Id)\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel\<rightarrow>\<langle>Rb,Rd\<rangle>prod_rel\<rightarrow>Id"
  unfolding cmp_prod_alt
  by (parametricity)

lemma param_cmp_unit[param]:
  "(cmp_unit,cmp_unit)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemma param_comp2eq[param]: "(comp2eq,comp2eq)\<in>(R\<rightarrow>R\<rightarrow>Id)\<rightarrow>R\<rightarrow>R\<rightarrow>Id"
  unfolding comp2eq_def[abs_def]
  by (parametricity)

lemma cmp_combine_paramD:
  assumes "(cmp,cmp_combine D1 cmp1 D2 cmp2)\<in>R\<rightarrow>R\<rightarrow>Id"
  assumes "Range R \<subseteq> D1"
  shows "(cmp,cmp1)\<in>R\<rightarrow>R\<rightarrow>Id"
  using assms
  unfolding cmp_combine_def[abs_def]
  apply (intro fun_relI)
  apply (drule_tac x=a in fun_relD, assumption)
  apply (drule_tac x=aa in fun_relD, assumption)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply simp
  done

lemma cmp_extend_paramD:
  assumes "(cmp,cmp_extend D cmp')\<in>R\<rightarrow>R\<rightarrow>Id"
  assumes "Range R \<subseteq> D"
  shows "(cmp,cmp')\<in>R\<rightarrow>R\<rightarrow>Id"
  using assms
  unfolding cmp_extend_def
  apply (rule cmp_combine_paramD)
  done

subsection \<open>Tuning of Generated Implementation\<close>
lemma [autoref_post_simps]: "comp2eq (dflt_cmp (\<le>) ((<)::_::linorder\<Rightarrow>_)) = (=)"
  by (simp add: class_to_eq_linorder eq_linorder_comp2eq_eq)

end