(* Author: Tobias Nipkow *)

section "Skew Heap Analysis"

theory Skew_Heap_Analysis
imports
  Complex_Main
  Skew_Heap.Skew_Heap
  Amortized_Framework
  Priority_Queue_ops_merge
begin

text\<open>The following proof is a simplified version of the one by Kaldewaij and
Schoenmakers~\cite{KaldewaijS-IPL91}.\<close>

text \<open>right-heavy:\<close>
definition rh :: "'a tree => 'a tree => nat" where
"rh l r = (if size l < size r then 1 else 0)"

text \<open>Function \<open>\<Gamma>\<close> in \cite{KaldewaijS-IPL91}: number of right-heavy nodes on left spine.\<close>
fun lrh :: "'a tree \<Rightarrow> nat" where
"lrh Leaf = 0" |
"lrh (Node l _ r) = rh l r + lrh l"

text \<open>Function \<open>\<Delta>\<close> in \cite{KaldewaijS-IPL91}: number of not-right-heavy nodes on right spine.\<close>
fun rlh :: "'a tree \<Rightarrow> nat" where
"rlh Leaf = 0" |
"rlh (Node l _ r) = (1 - rh l r) + rlh r"

lemma Gexp: "2 ^ lrh h \<le> size h + 1"
by (induction h) (auto simp: rh_def)

corollary Glog: "lrh h \<le> log 2 (size1 h)"
by (metis Gexp le_log2_of_power size1_size)

lemma Dexp: "2 ^ rlh h \<le> size h + 1"
by (induction h) (auto simp: rh_def)

corollary Dlog: "rlh h \<le> log 2 (size1 h)"
by (metis Dexp le_log2_of_power size1_size)

function t_merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
"t_merge Leaf h = 1" |
"t_merge h Leaf = 1" |
"t_merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then t_merge (Node l2 a2 r2) r1 else t_merge (Node l1 a1 r1) r2) + 1"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

fun \<Phi> :: "'a heap \<Rightarrow> int" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + rh l r"

lemma \<Phi>_nneg: "\<Phi> t \<ge> 0"
by (induction t) auto

lemma plus_log_le_2log_plus: "\<lbrakk> x > 0; y > 0; b > 1 \<rbrakk>
  \<Longrightarrow> log b x + log b y \<le> 2 * log b (x + y)"
by(subst mult_2; rule add_mono; auto)

lemma rh1: "rh l r \<le> 1"
by(simp add: rh_def)

lemma amor_le_long:
  "t_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
proof (induction t1 t2 rule: merge.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 l1 a1 r1 l2 a2 r2)
  show ?case
  proof (cases "a1 \<le> a2")
    case True
    let ?t1 = "Node l1 a1 r1" let ?t2 = "Node l2 a2 r2" let ?m = "merge ?t2 r1"
    have "t_merge ?t1 ?t2 + \<Phi> (merge ?t1 ?t2) - \<Phi> ?t1 - \<Phi> ?t2
          = t_merge ?t2 r1 + 1 + \<Phi> ?m + \<Phi> l1 + rh ?m l1 - \<Phi> ?t1 - \<Phi> ?t2"
      using True by (simp)
    also have "\<dots> = t_merge ?t2 r1 + 1 + \<Phi> ?m + rh ?m l1 - \<Phi> r1 - rh l1 r1 - \<Phi> ?t2"
      by simp
    also have "\<dots> \<le> lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 2 - rh l1 r1"
      using "3.IH"(1)[OF True] by linarith
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 1 + (1 - rh l1 r1)"
      using rh1[of l1 r1] by (simp)
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh ?t1 + rh ?m l1 + 1"
      by (simp)
    also have "\<dots> = lrh (merge ?t1 ?t2) + rlh ?t1 + rlh ?t2 + 1"
      using True by(simp)
    finally show ?thesis .
  next
    case False with 3 show ?thesis by auto
  qed
qed

lemma amor_le:
  "t_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
by(induction t1 t2 rule: merge.induct)(auto)

lemma a_merge:
  "t_merge t1 t2 + \<Phi>(merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   3 * log 2 (size1 t1 + size1 t2) + 1" (is "?l \<le> _")
proof -
  have "?l \<le> lrh(merge t1 t2) + rlh t1 + rlh t2 + 1" using amor_le[of t1 t2] by arith
  also have "\<dots> = real(lrh(merge t1 t2)) + rlh t1 + rlh t2 + 1" by simp
  also have "\<dots> = real(lrh(merge t1 t2)) + (real(rlh t1) + rlh t2) + 1" by simp
  also have "rlh t1 \<le> log 2 (size1 t1)" by(rule Dlog)
  also have "rlh t2 \<le> log 2 (size1 t2)" by(rule Dlog)
  also have "lrh (merge t1 t2) \<le> log 2 (size1(merge t1 t2))" by(rule Glog)
  also have "size1(merge t1 t2) = size1 t1 + size1 t2 - 1" by(simp add: size1_size)
  also have "log 2 (size1 t1 + size1 t2 - 1) \<le> log 2 (size1 t1 + size1 t2)" by(simp add: size1_size)
  also have "log 2 (size1 t1) + log 2 (size1 t2) \<le> 2 * log 2 (real(size1 t1) + (size1 t2))"
    by(rule plus_log_le_2log_plus) (auto simp: size1_size)
  finally show ?thesis by(simp)
qed

definition t_insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> int" where
"t_insert a h = t_merge (Node Leaf a Leaf) h + 1"

lemma a_insert: "t_insert a h + \<Phi>(Skew_Heap.insert a h) - \<Phi> h \<le> 3 * log 2 (size1 h + 2) + 2"
using a_merge[of "Node Leaf a Leaf" "h"]
by (simp add: numeral_eq_Suc t_insert_def Skew_Heap.insert_def rh_def)

definition t_del_min :: "('a::linorder) heap \<Rightarrow> int" where
"t_del_min h = (case h of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> t_merge t1 t2 + 1)"

lemma a_del_min: "t_del_min h + \<Phi>(del_min h) - \<Phi> h \<le> 3 * log 2 (size1 h + 2) + 2"
proof (cases h)
  case Leaf thus ?thesis by (simp add: t_del_min_def)
next
  case (Node t1 _ t2)
  have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
                log 2 (4 + (real (size t1) + real (size t2)))" by simp
  from Node show ?thesis using a_merge[of t1 t2]
    by (simp add: size1_size t_del_min_def rh_def)
qed

subsubsection "Instantiation of Amortized Framework"

lemma t_merge_nneg: "t_merge h1 h2 \<ge> 0"
by(induction h1 h2 rule: t_merge.induct) auto

fun exec :: "'a::linorder op \<Rightarrow> 'a heap list \<Rightarrow> 'a heap" where
"exec Empty [] = Leaf" |
"exec (Insert a) [h] = Skew_Heap.insert a h" |
"exec Del_min [h] = del_min h" |
"exec Merge [h1,h2] = merge h1 h2"

fun cost :: "'a::linorder op \<Rightarrow> 'a heap list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Insert a) [h] = t_merge (Node Leaf a Leaf) h" |
"cost Del_min [h] = (case h of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> t_merge t1 t2)" |
"cost Merge [h1,h2] = t_merge h1 h2"

fun U where
"U Empty [] = 1" |
"U (Insert _) [h] = 3 * log 2 (size1 h + 2) + 1" |
"U Del_min [h] = 3 * log 2 (size1 h + 2) + 3" |
"U Merge [h1,h2] = 3 * log 2 (size1 h1 + size1 h2) + 1"

interpretation Amortized
where arity = arity and exec = exec and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 h) show ?case using \<Phi>_nneg[of h] by linarith
next
  case (3 ss f)
  show ?case
  proof (cases f)
    case Empty thus ?thesis using 3(2) by (auto)
  next
    case [simp]: (Insert a)
    obtain h where [simp]: "ss = [h]" using 3(2) by (auto)
    thus ?thesis using a_merge[of "Node Leaf a Leaf" "h"]
      by (simp add: numeral_eq_Suc insert_def rh_def t_merge_nneg)
  next
    case [simp]: Del_min
    obtain h where [simp]: "ss = [h]" using 3(2) by (auto)
    thus ?thesis
    proof (cases h)
      case Leaf with Del_min show ?thesis by simp
    next
      case (Node t1 _ t2)
      have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
               log 2 (4 + (real (size t1) + real (size t2)))" by simp
      from Del_min Node show ?thesis using a_merge[of t1 t2]
        by (simp add: size1_size t_merge_nneg)
    qed
  next
    case [simp]: Merge
    obtain h1 h2 where "ss = [h1,h2]" using 3(2) by (auto simp: numeral_eq_Suc)
    thus ?thesis using a_merge[of h1 h2] by (simp add: t_merge_nneg)
  qed
qed

end


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

header{*Inverse of a matrix using the Gauss Jordan algorithm over nested IArrays*}

theory Inverse_IArrays
imports
  Inverse
  Gauss_Jordan_PA_IArrays
begin

subsection{*Definitions*}

definition "invertible_iarray A = (rank_iarray A = nrows_iarray A)"
definition "inverse_matrix_iarray A = (if invertible_iarray A then Some(fst(Gauss_Jordan_iarrays_PA A)) else None)"
definition "matrix_to_iarray_option A = (if A \<noteq> None then Some (matrix_to_iarray (the A)) else None)"

subsection{*Some lemmas and code generation*}
lemma matrix_inv_Gauss_Jordan_iarrays_PA:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes inv_A: "invertible A"
shows "matrix_to_iarray (matrix_inv A) = fst (Gauss_Jordan_iarrays_PA (matrix_to_iarray A))"
by (metis inv_A matrix_inv_Gauss_Jordan_PA matrix_to_iarray_fst_Gauss_Jordan_PA)

lemma matrix_to_iarray_invertible[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "invertible A = invertible_iarray (matrix_to_iarray A)"
unfolding invertible_iarray_def invertible_eq_full_rank[of A] matrix_to_iarray_rank matrix_to_iarray_nrows ..

lemma matrix_to_iarray_option_inverse_matrix:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "matrix_to_iarray_option (inverse_matrix A) = (inverse_matrix_iarray (matrix_to_iarray A))"
proof (unfold inverse_matrix_def, auto)
assume inv_A: "invertible A"
show "matrix_to_iarray_option (Some (matrix_inv A)) = inverse_matrix_iarray (matrix_to_iarray A)"
unfolding matrix_to_iarray_option_def unfolding inverse_matrix_iarray_def using inv_A unfolding matrix_to_iarray_invertible
using matrix_inv_Gauss_Jordan_iarrays_PA[OF inv_A] by auto
next
assume not_inv_A: "\<not> invertible A"
show "matrix_to_iarray_option None = inverse_matrix_iarray (matrix_to_iarray A)"
unfolding matrix_to_iarray_option_def inverse_matrix_iarray_def
using not_inv_A unfolding matrix_to_iarray_invertible by simp
qed

lemma matrix_to_iarray_option_inverse_matrix_code[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "matrix_to_iarray_option (inverse_matrix A) = (let matrix_to_iarray_A = matrix_to_iarray A; GJ = Gauss_Jordan_iarrays_PA matrix_to_iarray_A
  in if nrows_iarray matrix_to_iarray_A = length [x\<leftarrow>IArray.list_of (snd GJ) . \<not> is_zero_iarray x] then Some (fst GJ) else None)"
unfolding matrix_to_iarray_option_inverse_matrix
unfolding inverse_matrix_iarray_def
unfolding invertible_iarray_def
unfolding rank_iarrays_code
unfolding Let_def
unfolding matrix_to_iarray_snd_Gauss_Jordan_PA[symmetric]
unfolding Gauss_Jordan_PA_eq
unfolding matrix_to_iarray_Gauss_Jordan by presburger

end


theory Chapter3
imports Main HOL.Fun
begin

(** Section 3.1 Arithmetic expressions **)

datatype var_name = VarName string

(*
fun abc_var :: "var_name" where
"abc_var = VarName ''abc''"
*)

datatype aexp =
    N int
  | V var_name
  | Plus aexp aexp

type_synonym val   = int
type_synonym state = "var_name \<Rightarrow> val"

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

value "aval (Plus (N 3) (V (VarName ''x''))) ((\<lambda> _. 0) (VarName ''x'' := 5))"

fun undef_state :: "state" where
"undef_state (VarName []) = 1"

value "aval (Plus (N 3) (V (VarName ''x''))) undef_state"

(*fun mk_state :: "int \<Rightarrow> (string * int) list \<Rightarrow> state" where
"mk_state initial bindings = "
*)

fun init_state :: "state" where
"init_state _ = 0"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V v) = V v" |
"asimp_const (Plus x y) =
 (case (asimp_const x, asimp_const y) of
   (N x', N y') \<Rightarrow> N (x' + y') |
   (x',   y')   \<Rightarrow> Plus x' y')"

theorem asimp_const_preserves_semantics : "aval (asimp_const e) s = aval e s"
apply(induction e)
apply(auto split: aexp.split)
done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N x) (N y) = N (x + y)"                               |
"plus (N x) y     = (if x = 0 then y else Plus (N x) y)"     |
"plus x     (N y) = (if y = 0 then x else Plus x     (N y))" |
"plus x     y     = Plus x y"

lemma plus_adds : "aval (plus e1 e2) s = aval e1 s + aval e2 s"
apply(induction e1 e2 rule: plus.induct)
apply(auto)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N x)      = N x" |
"asimp (V x)      = V x" |
"asimp (Plus x y) = plus x y"

theorem asimp_preserves_semantics : "aval (asimp e) s = aval e s"
apply(induction e)
apply(auto simp add: plus_adds)
done

(* Exercise 3.1 *)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N _)              = True"  |
"optimal (V _)              = True"  |
"optimal (Plus (N _) (N _)) = False" |
"optimal (Plus x     y)     = (optimal x \<and> optimal y)"

theorem "optimal (asimp_const e)"
apply(induction e)
apply(auto split: aexp.split)
done

(* Exercise 3.2 *)

value "Some 1"
value "None"
type "fst"
value "let (x, y) = (1, 2 :: int) in x + y"

datatype aexp_simplified =
    Constant int
  | VanillaTerm aexp
  (* Term plus some constant *)
  | Term aexp int (* integer is always nonzero *)

fun unsimplify :: "aexp_simplified \<Rightarrow> aexp" where
"unsimplify (Constant n)    = N n" |
"unsimplify (VanillaTerm e) = e"   |
"unsimplify (Term e n)      = Plus e (N n)"

fun addConstant :: "int \<Rightarrow> aexp_simplified \<Rightarrow> aexp_simplified" where
"addConstant n e =
 (if n = 0
  then e
  else case e of
    Constant m    \<Rightarrow> Constant (n + m) |
    VanillaTerm e \<Rightarrow> Term e n         |
    Term e m      \<Rightarrow> Term e (n + m)
  )"
(*
  "addConstant n (Constant m)    = Constant (n + m)"                            |
"addConstant n (VanillaTerm e) = (if n = 0 then VanillaTerm e else Term e n)" |
"addConstant n (Term e m)      = Term e (n + m)"
*)

fun full_asimp_helper :: "aexp \<Rightarrow> aexp_simplified" where
"full_asimp_helper (N n)      = Constant n"        |
"full_asimp_helper (V v)      = VanillaTerm (V v)" |
"full_asimp_helper (Plus x y) =
 (case (full_asimp_helper x, full_asimp_helper y) of
   (Constant n,    e)              \<Rightarrow> addConstant n e         |
   (e,             Constant m)     \<Rightarrow> addConstant m e         |
   (VanillaTerm e, VanillaTerm e') \<Rightarrow> VanillaTerm (Plus e e') |
   (VanillaTerm e, Term e' m)      \<Rightarrow> Term (Plus e e') m      |
   (Term e n,      VanillaTerm e') \<Rightarrow> Term (Plus e e') n      |
   (Term e n,      Term e' m)      \<Rightarrow> Term (Plus e e') (n + m))"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp x = (unsimplify \<circ> full_asimp_helper) x" (* Enter composition via \circ *)

lemma addConstant_preserves_semantics :
  "aval (unsimplify (addConstant n e)) s = n + aval (unsimplify e) s"
apply(induction e)
apply(auto split: aexp_simplified.split)
done

theorem full_asimp_preserves_semantics : "aval (full_asimp e) s = aval e s"
apply(induction e)
apply(auto split: aexp_simplified.split simp add: addConstant_preserves_semantics)
(* apply(auto simp add: split_def Let_def split: option.split) (* split_def is needed to expand cases over tuples *) *)
done

(* Exercise 3.3 *)

fun subst :: "var_name \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst _ _ (N n)       = N n"                          |
"subst v x (V v')      = (if v = v' then x else V v')" |
"subst v x (Plus e e') = Plus (subst v x e) (subst v x e')"

lemma substitution_lemma : "aval (subst v x e) s = aval e (s (v := aval x s))"
apply(induction e)
apply(auto)
done

theorem substitute_equals_preserves_semantics : "aval x s = aval y s \<Longrightarrow> aval (subst v x e) s = aval (subst v y e) s"
apply(induction e)
apply(auto)
done

(* Exercise 3.4 - See file Chapter3_ex3_04_AExp.thy *)

(* Exercise 3.5 *)

datatype aexp\<^sub>2 =
    N\<^sub>2 int
  | V\<^sub>2 var_name
  | Plus\<^sub>2 aexp\<^sub>2 aexp\<^sub>2
  | Div aexp\<^sub>2 aexp\<^sub>2
  | PostIncrement var_name

fun liftOpt :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> 'c option" where
"liftOpt _ None     _        = None" |
"liftOpt _ _        None     = None" |
"liftOpt f (Some x) (Some y) = Some (f x y)"

fun aval\<^sub>2 :: "aexp\<^sub>2 \<Rightarrow> state \<Rightarrow> val option \<times> state" where
"aval\<^sub>2 (N\<^sub>2 n)       s  = (Some n, s)"   |
"aval\<^sub>2 (V\<^sub>2 v)       s  = (Some (s v), s)" |
"aval\<^sub>2 (Plus\<^sub>2 e\<^sub>1 e\<^sub>2) s\<^sub>1 =
 (let (v\<^sub>1, s\<^sub>2) = aval\<^sub>2 e\<^sub>1 s\<^sub>1;
      (v\<^sub>2, s\<^sub>3) = aval\<^sub>2 e\<^sub>2 s\<^sub>2 in
  (liftOpt (op +) v\<^sub>1 v\<^sub>2, s\<^sub>3))" |
"aval\<^sub>2 (Div e\<^sub>1 e\<^sub>2) s\<^sub>1 =
 (let (v\<^sub>1, s\<^sub>2) = aval\<^sub>2 e\<^sub>1 s\<^sub>1;
      (v\<^sub>2, s\<^sub>3) = aval\<^sub>2 e\<^sub>2 s\<^sub>2;
      v        = if v\<^sub>2 = Some 0
                 then None
                 else liftOpt (op div) v\<^sub>1 v\<^sub>2
  in (v, s\<^sub>3))" |
"aval\<^sub>2 (PostIncrement v) s =
 (let v' = s v in
  (Some v', s (v := v' + 1)))"

value "
aval\<^sub>2
  (Plus\<^sub>2
    (PostIncrement (VarName ''x''))
    (Plus\<^sub>2
      (PostIncrement (VarName ''x''))
      (Div
        (PostIncrement (VarName ''x''))
        (N\<^sub>2 2))))
  (\<lambda> _ \<Rightarrow> 0)"

(* Exercise 3.6 *)

datatype lexp =
    Nl int
  | Vl var_name
  | Plusl lexp lexp
  | LET var_name lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
"lval (Nl n)      _ = n"                   |
"lval (Vl v)      s = s v"                 |
"lval (Plusl x y) s = lval x s + lval y s" |
"lval (LET v x y) s = lval y (s (v := lval x s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n)      = N n"                        |
"inline (Vl v)      = V v"                        |
"inline (Plusl x y) = Plus (inline x) (inline y)" |
"inline (LET v x y) = subst v (inline x) (inline y)"

theorem inline_preserves_semantics : "lval e s = aval (inline e) s"
apply(induction e arbitrary: s)
apply(auto)
apply(simp add: substitution_lemma)
done

(** Section 3.2 Boolean expressions **)

datatype bexp =
    Bc bool
  | Not bexp
  | And bexp bexp
  | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc x)     _ = x" |
"bval (Not e)    s = (\<not> bval e s)" |
"bval (And x y)  s = (bval x s \<and> bval y s)" |
"bval (Less x y) s = (aval x s < aval y s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc b)     = Bc (\<not> b)"      |
"not (Not e)    = e"             |
"not (And x y)  = Not (And x y)" |
"not (Less x y) = Not (Less x y)"

lemma not_preserves_semantics : "bval (not e) s = (\<not> bval e s)"
apply(induction e)
apply(auto)
done

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and x          (Bc True)  = x"        |
"and (Bc True)  y          = y"        |
"and _          (Bc False) = Bc False" |
"and (Bc False) _          = Bc False" |
"and x          y          = And x y"

value "False = False"
value "bval (and (Bc True) (Bc False)) undef_state"
value "bval (Bc True) undef_state \<and> bval (Bc False) undef_state"
value "bval (and (Bc True) (Bc False)) undef_state = (bval (Bc True) undef_state \<and> bval (Bc False) undef_state)"

lemma and_preserves_semantics : "bval (and e\<^sub>1 e\<^sub>2) s = (bval e\<^sub>1 s \<and> bval e\<^sub>2 s)"
apply(induction e\<^sub>1 e\<^sub>2 rule: and.induct)
apply(auto)
done

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N x) (N y) = Bc (x < y)" |
"less x     y     = Less x y"

lemma less_preserves_semantics : "bval (less e\<^sub>1 e\<^sub>2) s = (aval e\<^sub>1 s < aval e\<^sub>2 s)"
apply(induction e\<^sub>1 e\<^sub>2 rule: less.induct)
apply(auto)
done

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc x)     = Bc x"    |
"bsimp (Not e)    = not e"   |
"bsimp (And x y)  = and x y" |
"bsimp (Less x y) = less (asimp x) (asimp y)"

theorem bsimp_preserves_semantics : "bval (bsimp e) s = bval e s"
apply(induction e)
apply(auto simp add: not_preserves_semantics and_preserves_semantics)
apply(auto simp add: less_preserves_semantics asimp_preserves_semantics)
done

(* Exercise 3.7 *)

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq x y = And (Not (Less x y)) (Not (Less y x))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le x y = Not (Less y x)"

theorem eq_is_correct : "bval (Eq e\<^sub>1 e\<^sub>2) s = (aval e\<^sub>1 s = aval e\<^sub>2 s)"
apply(auto)
done

theorem le_is_correct : "bval (Le e\<^sub>1 e\<^sub>2) s = (aval e\<^sub>1 s \<le> aval e\<^sub>2 s)"
apply(auto)
done

(* Exercise 3.8 *)

datatype ifexp =
    Bc2 bool
  | If ifexp ifexp ifexp
  | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b)     _ = b"                                            |
"ifval (If c t f)  s = (if ifval c s then ifval t s else ifval f s)" |
"ifval (Less2 x y) s = (aval x s < aval y s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc b)     = Bc2 b"                                  |
"b2ifexp (Not x)    = If (b2ifexp x) (Bc2 False) (Bc2 True)"  |
"b2ifexp (And x y)  = If (b2ifexp x) (b2ifexp y) (Bc2 False)" |
"b2ifexp (Less x y) = Less2 x y"

lemma b2ifexp_preserves_semantics : "ifval (b2ifexp e) s = bval e s"
apply(induction e)
apply(auto)
done

fun or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"or x y = Not (And (Not x) (Not y))"

lemma or_is_correct : "bval (or e\<^sub>1 e\<^sub>2) s = (bval e\<^sub>1 s \<or> bval e\<^sub>2 s)"
apply(auto)
done

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 b)     = Bc b"                                                                 |
"if2bexp (If c t f)  = or (And (if2bexp c) (if2bexp t)) (And (Not (if2bexp c)) (if2bexp f))" |
"if2bexp (Less2 x y) = Less x y"

theorem if2bexp_preserves_semantics : "bval (if2bexp e) s = ifval e s"
apply(induction e)
apply(auto)
done

(* Exercise 3.9 *)

datatype pbexp =
    VAR var_name
  | NOT pbexp
  | AND pbexp pbexp
  | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (var_name \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR v)    s = s v"                       |
"pbval (NOT e)    s = (\<not> pbval e s)"             |
"pbval (AND e\<^sub>1 e\<^sub>2) s = (pbval e\<^sub>1 s \<and> pbval e\<^sub>2 s)" |
"pbval (OR e\<^sub>1 e\<^sub>2)  s = (pbval e\<^sub>1 s \<or> pbval e\<^sub>2 s)"

(* Is argument expression in Negation Normal Form - i.e. NOT is only applied to variables *)
fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR _)       = True"                  |
"is_nnf (NOT (VAR _)) = True"                  |
"is_nnf (NOT _)       = False"                 |
"is_nnf (AND x y)     = (is_nnf x \<and> is_nnf y)" |
"is_nnf (OR x y)      = (is_nnf x \<or> is_nnf y)"

(* Convert expression to NNF *)
fun nnf_go :: "bool \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"nnf_go negate (VAR v)   = (if negate then NOT (VAR v) else VAR v)"  |
"nnf_go negate (NOT x)   = nnf_go (\<not> negate) x"                      |
"nnf_go False  (AND x y) = AND (nnf_go False x) (nnf_go False y)"     |
"nnf_go False  (OR x y)  = OR  (nnf_go False x) (nnf_go False y)"     |
"nnf_go True   (AND x y) = OR  (nnf_go True x)  (nnf_go True y)"      |
"nnf_go True   (OR x y)  = AND (nnf_go True x)  (nnf_go True y)"

lemma nnf_go_preserves_semantics : "pbval (nnf_go b e) s = (if b then \<not> pbval e s else pbval e s)"
apply(induction b e rule: nnf_go.induct)
apply(simp_all)
done

lemma nnf_go_is_correct : "is_nnf (nnf_go b e)"
apply(induction b e rule: nnf_go.induct)
apply(auto)
done

definition nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf x = nnf_go False x"

theorem nnf_preserves_semantics : "pbval (nnf e) s = pbval e s"
apply(simp add: nnf_def nnf_go_preserves_semantics)
done

theorem nnf_is_correct : "is_nnf (nnf e)"
apply(induction e)
apply(auto simp add: nnf_def nnf_go_is_correct)
done

fun is_conjunct :: "pbexp \<Rightarrow> bool" where
"is_conjunct (VAR _)   = True"                            |
"is_conjunct (NOT _)   = True"                            |
"is_conjunct (AND x y) = (is_conjunct x \<and> is_conjunct y)" |
"is_conjunct (OR x y)  = False"

fun is_disj_of_conj :: "pbexp \<Rightarrow> bool" where
"is_disj_of_conj (VAR _)   = True"                            |
"is_disj_of_conj (NOT _)   = True"                            |
"is_disj_of_conj (AND x y) = (is_conjunct x \<and> is_conjunct y)" |
"is_disj_of_conj (OR x y)  = (is_disj_of_conj x \<and> is_disj_of_conj y)"

definition is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf e = (is_nnf e \<and> is_disj_of_conj e)"

fun mk_dnf_conj :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(*"mk_dnf_conj (OR x\<^sub>1 y\<^sub>1) (OR x\<^sub>2 y\<^sub>2) =
  OR (mk_dnf_conj x\<^sub>1 y\<^sub>1)
     (OR (mk_dnf_conj x\<^sub>1 y\<^sub>2)
         (OR (mk_dnf_conj x\<^sub>2 y\<^sub>1)
             (mk_dnf_conj x\<^sub>2 y\<^sub>2)))" | *)
"mk_dnf_conj e         (OR y\<^sub>1 y\<^sub>2) = OR (mk_dnf_conj e y\<^sub>1) (mk_dnf_conj e y\<^sub>2)" |
"mk_dnf_conj (OR x\<^sub>1 x\<^sub>2) e         = OR (mk_dnf_conj x\<^sub>1 e) (mk_dnf_conj x\<^sub>2 e)" |
"mk_dnf_conj x          y         = AND x y"

lemma mk_dnf_conj_preserves_semantics : "pbval (mk_dnf_conj e\<^sub>1 e\<^sub>2) s = (pbval e\<^sub>1 s \<and> pbval e\<^sub>2 s)"
apply(induction e\<^sub>1 e\<^sub>2 rule: mk_dnf_conj.induct)
apply(auto)
done

lemma mk_dnf_conj_maintains_is_nnf : "is_nnf e\<^sub>1 \<Longrightarrow> is_nnf e\<^sub>2 \<Longrightarrow> is_nnf (mk_dnf_conj e\<^sub>1 e\<^sub>2)"
apply(induction e\<^sub>1 e\<^sub>2 rule: mk_dnf_conj.induct)
apply(auto)
done

lemma mk_dnf_conj_maintains_is_disj_of_conj : "is_disj_of_conj e\<^sub>1 \<Longrightarrow> is_disj_of_conj e\<^sub>2 \<Longrightarrow> is_disj_of_conj (mk_dnf_conj e\<^sub>1 e\<^sub>2)"
apply(induction e\<^sub>1 e\<^sub>2 rule: mk_dnf_conj.induct)
apply(auto)
done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR v)   = VAR v"                                     |
"dnf_of_nnf (NOT e)   = NOT (dnf_of_nnf e)"                        |
"dnf_of_nnf (AND x y) = mk_dnf_conj (dnf_of_nnf x) (dnf_of_nnf y)" |
"dnf_of_nnf (OR x y)  = OR (dnf_of_nnf x) (dnf_of_nnf y)"

theorem dnf_of_nnf_preserves_semantics : "pbval (dnf_of_nnf e) s = pbval e s"
apply(induction e)
apply(simp_all add: mk_dnf_conj_preserves_semantics)
done

lemma nnf_of_negation : "is_nnf (NOT e) \<Longrightarrow> is_nnf e"
apply(induction e)
apply(simp_all)
done

lemma is_nnf_of_not : "is_nnf (NOT e) \<Longrightarrow> is_nnf (dnf_of_nnf e) \<Longrightarrow> is_nnf (NOT (dnf_of_nnf e))"
apply(induction e)
apply(simp_all)
done

lemma dnf_of_nnf_maintains_is_nnf : "is_nnf e \<Longrightarrow> is_nnf (dnf_of_nnf e)"
apply(induction e)
apply(auto simp add: nnf_of_negation)
apply(simp add: is_nnf_of_not)
apply(simp add: mk_dnf_conj_maintains_is_nnf)
done

lemma dnf_of_nnf_maintains_is_disj_of_conj : "is_disj_of_conj (dnf_of_nnf e)"
apply(induction e)
apply(auto simp add: mk_dnf_conj_maintains_is_disj_of_conj)
done

theorem dnf_of_nnf_is_correct : "is_nnf e \<Longrightarrow> is_dnf (dnf_of_nnf e)"
apply(induction e)
apply(simp_all add: is_dnf_def)
apply(simp add: dnf_of_nnf_maintains_is_nnf nnf_of_negation is_nnf_of_not)
apply(auto simp add: dnf_of_nnf_maintains_is_nnf dnf_of_nnf_maintains_is_disj_of_conj)
apply(simp add: dnf_of_nnf_maintains_is_nnf mk_dnf_conj_maintains_is_nnf)
apply(simp add: dnf_of_nnf_maintains_is_disj_of_conj mk_dnf_conj_maintains_is_disj_of_conj)
done

(** Section 3.3 Stack Machine and Compilation **)

datatype instr = LOADI val | LOAD var_name | ADD

datatype stack = Stack "val list"

fun push :: "val \<Rightarrow> stack \<Rightarrow> stack" where
"push x (Stack xs) = Stack (x # xs)"

fun top :: "stack \<Rightarrow> val" where
"top (Stack (x # _)) = x"

fun top2 :: "stack \<Rightarrow> val" where
"top2 (Stack (_ # x # _)) = x"

fun drop2 :: "stack \<Rightarrow> stack" where
"drop2 (Stack (_ # _ # xs)) = Stack xs"

lemma top_of_push : "top (push x xs) = x"
apply(induction xs)
apply(simp)
done

lemma top2_of_push_push : "top2 (push x (push y zs)) = y"
apply(induction zs)
apply(simp)
done

lemma drop2_of_push_push : "drop2 (push x (push y zs)) = zs"
apply(induction)
apply(simp)
done

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = push n stk"     |
"exec1 (LOAD v)  s stk = push (s v) stk" |
"exec1 ADD       _ stk = push (top stk + top2 stk) (drop2 stk)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec []       _ stk = stk" |
"exec (i # is) s stk = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n)      = [LOADI n]" |
"comp (V v)      = [LOAD v]"  |
"comp (Plus x y) = comp x @ comp y @ [ADD]"

lemma exec_composite_list_of_instructions : "exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s (exec is\<^sub>1 s stk)"
apply(induction is\<^sub>1 arbitrary: stk)
apply(simp_all)
done

lemma comp_is_correct : "exec (comp e) s stk = push (aval e s) stk"
apply(induction e arbitrary: stk)
apply(simp_all add: exec_composite_list_of_instructions)
apply(simp add: top_of_push top2_of_push_push drop2_of_push_push algebra_simps)
done

(* Exercise 3.10 - See file Chapter3_ex3_10_ASM.thy *)

(* Exercise 3.11 *)

type_synonym reg = nat

datatype reg_instr =
    LDI int reg
  | LD var_name reg
  | ADD reg reg

fun reg_exec1 :: "reg_instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
"reg_exec1 (LDI n r)  _ rs = rs (r := n)"   |
"reg_exec1 (LD v r)   s rs = rs (r := s v)" |
"reg_exec1 (ADD r\<^sub>1 r\<^sub>2) _ rs = rs (r\<^sub>1 := rs r\<^sub>1 + rs r\<^sub>2)"

fun reg_exec :: "reg_instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
"reg_exec []       _ f = f" |
"reg_exec (i # is) s f = reg_exec is s (reg_exec1 i s f)"

lemma reg_exec_instruction_sequence : "reg_exec (xs @ ys) s rs r = reg_exec ys s (reg_exec xs s rs) r"
apply(induction xs arbitrary: rs)
apply(auto)
done

fun reg_comp :: "aexp \<Rightarrow> reg \<Rightarrow> reg_instr list" where
"reg_comp (N n)      r = [LDI n r]" |
"reg_comp (V v)      r = [LD v r]"  |
"reg_comp (Plus x y) r =
  (let r' = Suc r
   in  reg_comp x r @ reg_comp y r' @ [ADD r r'])"

lemma reg_comp_preserves_lower_registers : "r < r' \<Longrightarrow> reg_exec (reg_comp e r') s rs r = rs r"
apply(induction e arbitrary: rs r')
apply(auto simp add: reg_exec_instruction_sequence)
done

theorem reg_comp_preserves_semantics : "reg_exec (reg_comp e r) s rs r = aval e s"
apply(induction e arbitrary: rs r)
apply(auto)
apply(auto simp add: reg_exec_instruction_sequence reg_comp_preserves_lower_registers)
done

(* Exercise 3.12 *)

(* All operations except MV0 leave their result in register 0. MV0 takes its input from register 0 *)
datatype instr0 =
    LDI0 val
  | LD0 var_name
  | MV0 reg
  | ADD0 reg

fun exec0_1 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> val) \<Rightarrow> (reg \<Rightarrow> val)" where
"exec0_1 (LDI0 n) _ rs = rs (0 := n)"    |
"exec0_1 (LD0 v)  s rs = rs (0 := s v)"  |
"exec0_1 (MV0 r)  _ rs = rs (r := rs 0)" |
"exec0_1 (ADD0 r) _ rs = rs (0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> val) \<Rightarrow> (reg \<Rightarrow> val)" where
"exec0 []       _ rs = rs" |
"exec0 (i # is) s rs = exec0 is s (exec0_1 i s rs)"

lemma exec0_of_composite_instruction_list : "exec0 (xs @ ys) s rs r = exec0 ys s (exec0 xs s rs) r"
apply(induction xs arbitrary: rs)
apply(auto)
done

fun comp0_with_intermed_reg :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0_with_intermed_reg (N n)      _ = [LDI0 n]" |
"comp0_with_intermed_reg (V v)      _ = [LD0 v]"  |
"comp0_with_intermed_reg (Plus x y) r =
    comp0_with_intermed_reg x (Suc r)
  @ [MV0 r]
  @ comp0_with_intermed_reg y (Suc r)
  @ [ADD0 r]"

lemma comp0_with_intermed_reg_preserves_lower_registers : "0 < r \<Longrightarrow> r < r' \<Longrightarrow> exec0 (comp0_with_intermed_reg e r') s rs r = rs r"
apply(induction e arbitrary: r' rs)
apply(auto simp add: exec0_of_composite_instruction_list)
done

lemma comp0_with_intermed_reg_preserves_semantics : "0 < r \<Longrightarrow> exec0 (comp0_with_intermed_reg e r) s rs 0 = aval e s"
apply(induction e arbitrary: r rs)
apply(auto simp add: exec0_of_composite_instruction_list comp0_with_intermed_reg_preserves_lower_registers)
done

fun comp0 :: "aexp \<Rightarrow> instr0 list" where
"comp0 e = comp0_with_intermed_reg e (Suc 0)"

theorem comp0_preserves_semantics : "exec0 (comp0 e) s rs 0 = aval e s"
apply(induction e)
apply(simp_all add:
      exec0_of_composite_instruction_list
      comp0_with_intermed_reg_preserves_lower_registers
      comp0_with_intermed_reg_preserves_semantics)
done

end


theory Bondy
imports Main
begin

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

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

end


theory Bondy
imports Main
begin

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

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

end


(*
  Title: Galois Connections
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Galois Connections\<close>

theory Galois_Connections
  imports Order_Lattice_Props

begin

subsection \<open>Definitions and Basic Properties\<close>

text \<open>The approach follows the Compendium of Continuous Lattices~\<^cite>\<open>"GierzHKLMS80"\<close>, without attempting completeness.
First, left and right adjoints of a Galois connection are defined.\<close>

definition adj :: "('a::ord \<Rightarrow> 'b::ord) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" (infixl "\<stileturn>" 70) where
  "(f \<stileturn> g) = (\<forall>x y. (f x \<le> y) = (x \<le> g y))"

definition "ladj (g::'a::Inf \<Rightarrow> 'b::ord) = (\<lambda>x. \<Sqinter>{y. x \<le> g y})"

definition "radj (f::'a::Sup \<Rightarrow> 'b::ord)  = (\<lambda>y. \<Squnion>{x. f x \<le> y})"

lemma ladj_radj_dual:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "ladj f x = \<partial> (radj (\<partial>\<^sub>F f) (\<partial> x))"
proof-
  have "ladj f x = \<partial> (\<Squnion>(\<partial> ` {y. \<partial> (f y) \<le> \<partial> x}))"
    unfolding ladj_def by (metis (no_types, lifting) Collect_cong Inf_dual_var dual_dual_ord dual_iff)
  also have "... =  \<partial> (\<Squnion>{\<partial> y|y. \<partial> (f y) \<le> \<partial> x})"
    by (simp add: setcompr_eq_image)
  ultimately show ?thesis
    unfolding ladj_def radj_def map_dual_def comp_def
    by (smt Collect_cong invol_dual_var)
qed

lemma radj_ladj_dual:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "radj f x = \<partial> (ladj (\<partial>\<^sub>F f) (\<partial> x))"
  by (metis fun_dual5 invol_dual_var ladj_radj_dual map_dual_def)

lemma ladj_prop:
  fixes g :: "'b::Inf \<Rightarrow> 'a::ord_with_dual"
  shows "ladj g = Inf \<circ> (-`) g \<circ> \<up>"
  unfolding ladj_def vimage_def upset_prop fun_eq_iff comp_def by simp

lemma radj_prop:
  fixes f :: "'b::Sup \<Rightarrow> 'a::ord"
  shows "radj f = Sup \<circ> (-`) f \<circ> \<down>"
  unfolding radj_def vimage_def downset_prop fun_eq_iff comp_def by simp

text \<open>The first set of properties holds without any sort assumptions.\<close>

lemma adj_iso1: "f \<stileturn> g \<Longrightarrow> mono f"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_iso2: "f \<stileturn> g \<Longrightarrow> mono g"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_comp: "f \<stileturn> g \<Longrightarrow> adj h k \<Longrightarrow> (f \<circ> h) \<stileturn> (k \<circ> g)"
  by (simp add: adj_def)

lemma adj_dual:
  fixes f :: "'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "f \<stileturn> g = (\<partial>\<^sub>F g) \<stileturn> (\<partial>\<^sub>F f)"
  unfolding adj_def map_dual_def comp_def by (metis (mono_tags, opaque_lifting) dual_dual_ord invol_dual_var)

subsection \<open>Properties for (Pre)Orders\<close>

text \<open>The next set of properties holds in preorders or orders.\<close>

lemma adj_cancel1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> id"
  by (simp add: adj_def le_funI)

lemma adj_cancel2:
  fixes f :: "'a::ord \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> id \<le> g \<circ> f"
  by (simp add: adj_def eq_iff le_funI)

lemma adj_prop:
  fixes f :: "'a::preorder \<Rightarrow>'a"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> g \<circ> f"
  using adj_cancel1 adj_cancel2 order_trans by blast

lemma adj_cancel_eq1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<circ> f = f"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_cancel_eq2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> g \<circ> f \<circ> g = g"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_idem1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> (f \<circ> g) \<circ> (f \<circ> g) = f \<circ> g"
  by (simp add: adj_cancel_eq1 rewriteL_comp_comp)

lemma adj_idem2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> (g \<circ> f) \<circ> (g \<circ> f) = g \<circ> f"
  by (simp add: adj_cancel_eq2 rewriteL_comp_comp)

lemma adj_iso3:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (f \<circ> g)"
   by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_iso4:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (g \<circ> f)"
  by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_canc1:
  fixes f :: "'a::order \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> ((f \<circ> g) x = (f \<circ> g) y \<longrightarrow> g x = g y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_canc2:
  fixes f :: "'a::ord \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((g \<circ> f) x = (g \<circ> f) y \<longrightarrow> f x = f y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_sur_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (f \<circ> g = id))"
  unfolding adj_def surj_def comp_def by (metis eq_id_iff eq_iff order_refl order_trans)

lemma adj_surj_inj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (inj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma adj_inj_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (g \<circ> f = id))"
  by (metis adj_cancel_eq1 eq_id_iff inj_def o_apply)

lemma adj_inj_surj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (surj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma surj_id_the_inv: "surj f \<Longrightarrow> g \<circ> f = id \<Longrightarrow> g = the_inv f"
  by (metis comp_apply id_apply inj_on_id inj_on_imageI2 surj_fun_eq the_inv_f_f)

lemma inj_id_the_inv: "inj f \<Longrightarrow> f \<circ> g = id \<Longrightarrow> f = the_inv g"
proof -
  assume a1: "inj f"
  assume "f \<circ> g = id"
  hence "\<forall>x. the_inv g x = f x"
    using a1 by (metis (no_types) comp_apply eq_id_iff inj_on_id inj_on_imageI2 the_inv_f_f)
  thus ?thesis
    by presburger
qed

subsection \<open>Properties for Complete Lattices\<close>

text \<open>The next laws state that a function between complete lattices preserves infs
  if and only if it has a lower adjoint.\<close>

lemma radj_Inf_pres:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(\<exists>f. f \<stileturn> g) \<Longrightarrow> Inf_pres g"
  apply (rule antisym, simp_all add: le_fun_def adj_def, safe)
  apply (meson INF_greatest Inf_lower dual_order.refl dual_order.trans)
  by (meson Inf_greatest dual_order.refl le_INF_iff)

lemma ladj_Sup_pres:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "(\<exists>g. f \<stileturn> g) \<Longrightarrow> Sup_pres f"
  using Sup_pres_map_dual_var adj_dual radj_Inf_pres by blast

lemma radj_adj:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "f \<stileturn> g \<Longrightarrow> g = (radj f)"
  unfolding adj_def radj_def by (metis (mono_tags, lifting) cSup_eq_maximum eq_iff mem_Collect_eq)

lemma ladj_adj:
  fixes g :: "'b::complete_lattice_with_dual \<Rightarrow> 'a::complete_lattice_with_dual"
  shows "f \<stileturn> g \<Longrightarrow> f = (ladj g)"
  unfolding adj_def ladj_def by (metis (no_types, lifting) cInf_eq_minimum eq_iff mem_Collect_eq)

lemma Inf_pres_radj_aux:
  fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (ladj g) \<stileturn> g"
proof-
  assume a: "Inf_pres g"
  {fix x y
   assume b: "ladj g x \<le> y"
  hence "g (ladj g x) \<le> g y"
    by (simp add: Inf_subdistl_iso a monoD)
  hence "\<Sqinter>{g y |y. x \<le> g y} \<le> g y"
    by (metis a comp_eq_dest_lhs setcompr_eq_image ladj_def)
  hence "x \<le> g y"
    using dual_order.trans le_Inf_iff by blast
  hence "ladj g x \<le> y \<longrightarrow> x \<le> g y"
    by simp}
  thus ?thesis
    unfolding adj_def ladj_def by (meson CollectI Inf_lower)
qed

lemma Sup_pres_ladj_aux:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "Sup_pres f \<Longrightarrow> f \<stileturn> (radj f)"
  by (metis (no_types, opaque_lifting) Inf_pres_radj_aux Sup_pres_map_dual_var adj_dual fun_dual5 map_dual_def radj_adj)

lemma Inf_pres_radj:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (\<exists>f. f \<stileturn> g)"
  using Inf_pres_radj_aux by fastforce

lemma Sup_pres_ladj:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "Sup_pres f \<Longrightarrow> (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj_aux by fastforce

lemma Inf_pres_upper_adj_eq:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(Inf_pres g) = (\<exists>f. f \<stileturn> g)"
  using radj_Inf_pres Inf_pres_radj by blast

lemma Sup_pres_ladj_eq:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows  "(Sup_pres f) = (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj ladj_Sup_pres by blast

lemma Sup_downset_adj: "(Sup::'a::complete_lattice set \<Rightarrow> 'a) \<stileturn> \<down>"
  unfolding adj_def downset_prop Sup_le_iff by force

lemma Sup_downset_adj_var: "(Sup (X::'a::complete_lattice set) \<le> y) = (X \<subseteq> \<down>y)"
  using Sup_downset_adj adj_def by auto

text \<open>Once again many statements arise by duality, which Isabelle usually picks up.\<close>

end


theory Ex3_8
imports
  "~~/src/HOL/IMP/BExp"
begin

(*
By: Vadim Zaliva <vzaliva@cmu.edu>
From: T. Nipkow and G. Klein, Concrete Semantics with Isabelle/HOL. Springer, 2014.
Exercise 3.8:
*)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bc2 v) s = v"
  | "ifval (If cond_exp then_branch else_branch) s = ifval (if ifval cond_exp s then then_branch else else_branch) s"
  | "ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = Bc2 v"
  | "b2ifexp (Less a1 a2) = Less2 a1 a2"
  | "b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)"
  | "b2ifexp (And b1 b2) = If (b2ifexp b1) (If (b2ifexp b2) (Bc2 True) (Bc2 False)) (Bc2 False)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bc2 v) = Bc v"
  | "if2bexp (Less2 a1 a2) = Less a1 a2"
  | "if2bexp (If cond_exp then_branch else_branch) =
  (Not
  (And
     (Not (And (if2bexp cond_exp) (if2bexp then_branch)))
     (Not (And (Not (if2bexp cond_exp)) (if2bexp else_branch)))
  ))"

theorem "bval exp s = ifval (b2ifexp exp) s"
  apply(induction exp)
  apply(auto)
done

theorem "ifval exp s = bval (if2bexp exp) s"
  apply(induction exp)
  apply(auto)
done

end


theory Ex1_7
  imports Main
begin

primrec  list_union :: "['a list , 'a list] \<Rightarrow> 'a list" where
  "list_union [] ys = ys"|
  "list_union (x # xs) ys = (let res = list_union xs ys in if x \<in> set res then res else x # res)"

lemma "set (list_union xs ys) = set xs \<union> set ys"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"set (list_union xs ys) = set xs \<union> set ys"
  let ?tmp = "list_union xs ys"
  have "set (list_union (a # xs) ys) =  set (if a \<in> set ?tmp then ?tmp else a # ?tmp )" by simp
  then show ?case
  proof (cases "a \<in> set ?tmp")
    case True
    assume a:"a \<in> set (list_union xs ys)"
    then show ?thesis by (auto simp add : hyp)
  next
    case False
    then show ?thesis by (auto simp add : hyp)
  qed
qed

lemma [rule_format] : "distinct xs \<longrightarrow> distinct ys \<longrightarrow> (distinct (list_union xs ys))"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"distinct xs \<longrightarrow> distinct ys \<longrightarrow> distinct (list_union xs ys)"
  show ?case
  proof (cases "a \<in> set (list_union xs ys)")
    case True
    assume "a \<in> set (list_union xs ys)"
    then show ?thesis using hyp by simp
  next
    case False
    assume "a \<notin> set (list_union xs ys)"
    then show ?thesis using hyp by simp
  qed
qed

lemma "((\<forall> x \<in> A . P x) \<and> (\<forall> x \<in> B . P x)) \<longrightarrow> (\<forall> x \<in> A \<union> B  . P x)"
  using [[simp_trace_new mode=full]]
proof -
  {
    assume a:"(\<forall> x \<in> A . P x) \<and> (\<forall> x \<in> B . P x)"
    hence b:"\<forall> x \<in> A . P x" by simp
    from a have c:"\<forall> x \<in> B . P x" by simp
    with b have "\<forall> x \<in> A \<union> B . P x" by auto
  }
  thus ?thesis by (rule impI)
qed

lemma "\<forall>x \<in> A . Q (f x) \<Longrightarrow> \<forall> y \<in> f ` A . Q y"  by blast


theory week12A_demo imports Main begin

-- ------------------------------------------------------------------

text {* Motivation *}

lemma "(A \<longrightarrow> B) = (B \<or> \<not>A)"
by blast

value "True \<longrightarrow> False"
value "False \<or> \<not> True"

lemma "(A \<longrightarrow> B) = (B \<or> \<not>A)"
  (* apply style *)
  apply(rule iffI)
   apply(case_tac A)
    apply(erule (1) impE)
    apply(erule disjI1)
   apply(erule disjI2)
  apply(erule disjE)
   apply(rule impI)
   apply assumption
  apply(rule impI)
  apply(erule notE)
  apply assumption
  done

lemma "(A \<longrightarrow> B) = (B \<or> \<not>A)"
proof (rule iffI)
  assume AB: "A \<longrightarrow> B"
  show "B \<or> \<not> A"
  proof (case_tac A)
    assume A: "A"
    from AB A have "B" by(rule impE)
    thus ?thesis by(rule disjI1)
  next
    assume "\<not> A"
    thus ?thesis by (rule disjI2)
  qed
next
  assume "B \<or> \<not> A"
  thus "A \<longrightarrow> B"
  proof (rule disjE)
    assume "B"
    thus ?thesis by(rule impI)
  next
    assume notA: "\<not> A"
    show ?thesis
    proof (rule impI)
      assume "A"
      from notA this show "B" by (rule notE)
    qed
  qed
qed

-- ----------------------------------------

text {* Isar *}

lemma "\<lbrakk> A; B \<rbrakk> \<Longrightarrow> A \<and> B"
proof
  assume "A"
  from this show "A" by assumption
next
  assume "B"
  from this show "B" by assumption
qed

lemma
  assumes PorQ: "P \<or> Q"
  shows "Q \<or> P"
using PorQ proof
  assume P: "P"
  from P show "Q \<or> P" by(rule disjI2)
next
  assume "Q"
  from this show "Q \<or> P" by(rule disjI1)
qed

lemma
  assumes "A"
  assumes B_is_true: "B"
  shows "A \<and> B"
proof(rule conjI)
  show "B" by (rule B_is_true)
  from `A` show "A" by assumption
qed

lemma "(x::nat) + 1 = 1 + x"
proof -
  have l: "x + 1 = Suc x" by simp
  have r: "1 + x = Suc x" by simp
  show "x + 1 = 1 + x" by (simp only: l r)
qed

-- ------------------------------------------------------------------

section "More Isar"

text {* . = by assumption,  .. = by rule *}

lemma "\<lbrakk> A; B \<rbrakk> \<Longrightarrow> B \<and> A"
proof
  assume "B"
  from `B` show "B"  .
next
  assume "A" from this show "A" .
qed

lemma "\<lbrakk> A; B \<rbrakk> \<Longrightarrow> B \<and> A"
proof -
  assume B: "B" and A: "A"
  from B A show "B \<and> A" by(rule conjI)
qed

text {* backward/forward *}

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  from this have "A" ..
  from `A \<and> B` have "B" ..
  from `B` `A` show "B \<and> A" ..
qed

text{* fix *}

lemma
  assumes P: "\<forall>x. P x"
  shows "\<forall>x. P (f x)"
proof
  fix a
  from P show "P (f a)" by(rule spec)
qed

text{* Proof text can only refer to global constants, free variables
in the lemma, and local names introduced via fix or obtain. *}

lemma
  assumes Pf: "\<exists>x. P (f x)"
  shows "\<exists>y. P y"
proof -
  from Pf show ?thesis
  proof
    fix x
    assume "P (f x)"
    from this show ?thesis ..
  qed
qed

text {* obtain *}

lemma
  assumes Pf: "\<exists>x. P (f x)"
  shows "\<exists>y. P y"
proof -
  from Pf obtain x where "P (f x)" ..
  from this show ?thesis ..
qed

lemma
  assumes ex: "\<exists>x. \<forall>y. P x y"
  shows "\<forall>y. \<exists>x. P x y"
proof
  fix y
  show "\<exists>x. P x y"
  proof -
    from ex obtain x where "\<forall>y. P x y" ..
    hence "P x y" ..
    thus ?thesis ..
  qed
qed

text {* moreover *}

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  from `A \<and> B` have "B" ..
  moreover from `A \<and> B` have "A" ..
  ultimately show "B \<and> A" ..
qed

thm mono_def
thm monoI

lemma
  assumes mono_f: "mono (f::int\<Rightarrow>int)"
      and mono_g: "mono (g::int\<Rightarrow>int)"
  shows "mono (\<lambda>i. f i + g i)"
proof
  fix x y
  assume le: "(x::int) \<le> y"
  from mono_f le have "f x \<le> f y" ..
  moreover from mono_g le have "g x \<le> g y" ..
  ultimately show "f x + g x \<le> f y + g y" by(rule add_mono)
qed

-- ---------------------------------------------------------------

-- {* Isar, case distinction *}

declare length_tl[simp del]

(* isar style, just using "proof (cases xs)", not using case *)
lemma "length (tl xs) = length xs - 1"
proof(cases xs)
  assume "xs = []" thus ?thesis by simp
next
  fix y ys assume "xs = y#ys" thus ?thesis by simp
qed

(* isar style, using case *)
lemma "length (tl xs) = length xs - 1"
proof(cases xs)
  case Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  from Cons show ?thesis by simp
qed

-- {* structural induction *}

(* apply style *)
lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)"
  apply(induct n, simp_all)
  done

(* isar style, not using case *)
lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)" (is "?P n")
proof(induct n)
  show "?P 0" by simp
next
  fix n
  assume "?P n"
  thus "?P (Suc n)" by simp
qed

(* isar style, using case *)
lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)"
proof(induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  from Suc show ?case by simp
qed

lemma
  fixes n::nat
  shows "n < n*n + 1"
proof(induct n)
  case 0 show ?case by simp
next
  case (Suc n) from this show ?case by simp
qed

-- {* induction with @{text"\<And>"} or @{text"\<Longrightarrow>"} *}

lemma
  assumes A: "(\<And>n. (\<And>m. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
  shows "P (n::nat)"
proof(rule A)
  show "\<And>m. m < n \<Longrightarrow> P m"
  proof(induct n)
    case 0
    thus ?case by simp
  next
    case (Suc n)
    show ?case
    proof(cases)
      assume eq: "m = n"
      from A Suc have "P n" by blast
      with eq show "P m" by simp
    next
      assume neq: "m \<noteq> n"
      from Suc neq have "m < n" by arith
      thus "P m" by(rule Suc)
    qed
  qed
qed

-- ---------------------------------------------------------------

-- "calculational reasoning"

-- "also/finally"

lemma right_inverse:
  fixes prod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"    (infixl "\<cdot>" 70)
  fixes inv :: "'a \<Rightarrow> 'a"    ("(_\<^sup>-)" [1000] 999)
  fixes one :: 'a    ("\<one>")

  assumes assoc: "\<And>x y z. (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
  assumes left_inv: "\<And>x. x\<^sup>- \<cdot> x = \<one>"
  assumes left_one: "\<And>x. \<one> \<cdot> x = x"

  shows "x \<cdot> x\<^sup>- = \<one>"
proof -
  have "x \<cdot> x\<^sup>- = \<one> \<cdot> (x \<cdot> x\<^sup>-)" by (simp only: left_one)
  also have "\<dots> = \<one> \<cdot> x \<cdot> x\<^sup>-" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> x\<^sup>- \<cdot> x \<cdot> x\<^sup>-" by (simp only: left_inv)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> (x\<^sup>- \<cdot> x) \<cdot> x\<^sup>-" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> \<one> \<cdot> x\<^sup>-" by (simp only: left_inv)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> (\<one> \<cdot> x\<^sup>-)" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> x\<^sup>-" by (simp only: left_one)
  also have "\<dots> = \<one>" by (simp only: left_inv)
  finally show ?thesis .
qed

print_trans_rules

-- "mixed operators"
lemma "1 < (5::nat)"
proof -
  have "1 < Suc 1" by simp
  also
  have "Suc 1 = 2" by simp
  also
  have "2 \<le> (5::nat)" by simp
  finally
  show ?thesis .
qed

-- "substitution"
lemma blah
proof -
  have "2*y + 2*y = (0::nat)" sorry
  also
  have "2*y = x" sorry
  also
  have "(0::nat) \<le> 2*c" sorry
  also
  have "c = d div 2" sorry
  also
  have "d = 2 * x" sorry
  finally
  have "x + x \<le> 2 * x " by simp
oops

print_trans_rules

-- "antisymmetry"
lemma blub
proof -
  have "a < (b::nat)" sorry
  also
  have "b < a" sorry
  finally
  show blub .
qed

-- "notE as trans"

thm notE
declare notE [trans]

lemma blub
proof -
  have "\<not>P" sorry
  also
  have "P" sorry
  finally
  show blub .
qed

-- "monotonicity"

lemma "a+b \<le> 2*a + 2*(b::nat)"
proof -
  have "a + b \<le> 2*a + b" by simp
  also
  have "b \<le> 2*b" by simp
  finally
  show "a+b \<le> 2*a + 2*b" by simp
qed

lemma "a+b \<le> 2*a + 2*(b::nat)"
proof -
  have "a + b \<le> 2*a + b" by simp
  also
  have "b \<le> 2*b" by simp
  also
  have "\<And>x y. x \<le> y \<Longrightarrow> 2 * a + x \<le> 2 * a + y" by simp
  ultimately
  show "a+b \<le> 2*a + 2*(b::nat)" .
qed

declare algebra_simps [simp]
lemma "(a+b::int)\<^sup>2 \<le> 2*(a\<^sup>2 + b\<^sup>2)"
proof -
       have "(a+b)\<^sup>2 \<le> (a+b)\<^sup>2 + (a-b)\<^sup>2" by simp thm numeral_2_eq_2
  also have "(a+b)\<^sup>2 \<le> a\<^sup>2 + b\<^sup>2 + 2*a*b" by (simp add: numeral_2_eq_2)
  also have "(a-b)\<^sup>2 = a\<^sup>2 + b\<^sup>2 - 2*a*b" by (simp add:numeral_2_eq_2)
  finally show ?thesis by simp
qed

-- ---------------------------------------------------------------

end


(* Authors: Heiko Loetzbeyer, Robert Sandner, Tobias Nipkow *)

section "Denotational Semantics of Commands"

theory Denotational imports Big_Step begin

type_synonym com_den = "(state \<times> state) set"

definition W :: "(state \<Rightarrow> bool) \<Rightarrow> com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
"W db dc = (\<lambda>dw. {(s,t). if db s then (s,t) \<in> dc O dw else s=t})"

fun D :: "com \<Rightarrow> com_den" where
"D SKIP   = Id" |
"D (x ::= a) = {(s,t). t = s(x := aval a s)}" |
"D (c1;;c2)  = D(c1) O D(c2)" |
"D (IF b THEN c1 ELSE c2)
 = {(s,t). if bval b s then (s,t) \<in> D c1 else (s,t) \<in> D c2}" |
"D (WHILE b DO c) = lfp (W (bval b) (D c))"

lemma W_mono: "mono (W b r)"
by (unfold W_def mono_def) auto

lemma D_While_If:
  "D(WHILE b DO c) = D(IF b THEN c;;WHILE b DO c ELSE SKIP)"
proof-
  let ?w = "WHILE b DO c" let ?f = "W (bval b) (D c)"
  have "D ?w = lfp ?f" by simp
  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF W_mono])
  also have "\<dots> = D(IF b THEN c;;?w ELSE SKIP)" by (simp add: W_def)
  finally show ?thesis .
qed

text\<open>Equivalence of denotational and big-step semantics:\<close>

lemma D_if_big_step:  "(c,s) \<Rightarrow> t \<Longrightarrow> (s,t) \<in> D(c)"
proof (induction rule: big_step_induct)
  case WhileFalse
  with D_While_If show ?case by auto
next
  case WhileTrue
  show ?case unfolding D_While_If using WhileTrue by auto
qed auto

abbreviation Big_step :: "com \<Rightarrow> com_den" where
"Big_step c \<equiv> {(s,t). (c,s) \<Rightarrow> t}"

lemma Big_step_if_D:  "(s,t) \<in> D(c) \<Longrightarrow> (s,t) \<in> Big_step c"
proof (induction c arbitrary: s t)
  case Seq thus ?case by fastforce
next
  case (While b c)
  let ?B = "Big_step (WHILE b DO c)" let ?f = "W (bval b) (D c)"
  have "?f ?B \<subseteq> ?B" using While.IH by (auto simp: W_def)
  from lfp_lowerbound[where ?f = "?f", OF this] While.prems
  show ?case by auto
qed (auto split: if_splits)

theorem denotational_is_big_step:
  "(s,t) \<in> D(c)  =  ((c,s) \<Rightarrow> t)"
by (metis D_if_big_step Big_step_if_D[simplified])

corollary equiv_c_iff_equal_D: "(c1 \<sim> c2) \<longleftrightarrow> D c1 = D c2"
by(simp add: denotational_is_big_step[symmetric] set_eq_iff)

subsection "Continuity"

definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool" where
"chain S = (\<forall>i. S i \<subseteq> S(Suc i))"

lemma chain_total: "chain S \<Longrightarrow> S i \<le> S j \<or> S j \<le> S i"
by (metis chain_def le_cases lift_Suc_mono_le)

definition cont :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
"cont f = (\<forall>S. chain S \<longrightarrow> f(UN n. S n) = (UN n. f(S n)))"

lemma mono_if_cont: fixes f :: "'a set \<Rightarrow> 'b set"
  assumes "cont f" shows "mono f"
proof
  fix a b :: "'a set" assume "a \<subseteq> b"
  let ?S = "\<lambda>n::nat. if n=0 then a else b"
  have "chain ?S" using \<open>a \<subseteq> b\<close> by(auto simp: chain_def)
  hence "f(UN n. ?S n) = (UN n. f(?S n))"
    using assms by (simp add: cont_def del: if_image_distrib)
  moreover have "(UN n. ?S n) = b" using \<open>a \<subseteq> b\<close> by (auto split: if_splits)
  moreover have "(UN n. f(?S n)) = f a \<union> f b" by (auto split: if_splits)
  ultimately show "f a \<subseteq> f b" by (metis Un_upper1)
qed

lemma chain_iterates: fixes f :: "'a set \<Rightarrow> 'a set"
  assumes "mono f" shows "chain(\<lambda>n. (f^^n) {})"
proof-
  have "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
  proof (induction n)
    case 0 show ?case by simp
  next
    case (Suc n) thus ?case using assms by (auto simp: mono_def)
  qed
  thus ?thesis by(auto simp: chain_def assms)
qed

theorem lfp_if_cont:
  assumes "cont f" shows "lfp f = (UN n. (f^^n) {})" (is "_ = ?U")
proof
  from assms mono_if_cont
  have mono: "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
    using funpow_decreasing [of n "Suc n"] by auto
  show "lfp f \<subseteq> ?U"
  proof (rule lfp_lowerbound)
    have "f ?U = (UN n. (f^^Suc n){})"
      using chain_iterates[OF mono_if_cont[OF assms]] assms
      by(simp add: cont_def)
    also have "\<dots> = (f^^0){} \<union> \<dots>" by simp
    also have "\<dots> = ?U"
      using mono by auto (metis funpow_simps_right(2) funpow_swap1 o_apply)
    finally show "f ?U \<subseteq> ?U" by simp
  qed
next
  have "(f^^n){} \<subseteq> p" if "f p \<subseteq> p" for n p
  proof -
    show ?thesis
    proof(induction n)
      case 0 show ?case by simp
    next
      case Suc
      from monoD[OF mono_if_cont[OF assms] Suc] \<open>f p \<subseteq> p\<close>
      show ?case by simp
    qed
  qed
  thus "?U \<subseteq> lfp f" by(auto simp: lfp_def)
qed

lemma cont_W: "cont(W b r)"
by(auto simp: cont_def W_def)

subsection\<open>The denotational semantics is deterministic\<close>

lemma single_valued_UN_chain:
  assumes "chain S" "(\<And>n. single_valued (S n))"
  shows "single_valued(UN n. S n)"
proof(auto simp: single_valued_def)
  fix m n x y z assume "(x, y) \<in> S m" "(x, z) \<in> S n"
  with chain_total[OF assms(1), of m n] assms(2)
  show "y = z" by (auto simp: single_valued_def)
qed

lemma single_valued_lfp: fixes f :: "com_den \<Rightarrow> com_den"
assumes "cont f" "\<And>r. single_valued r \<Longrightarrow> single_valued (f r)"
shows "single_valued(lfp f)"
unfolding lfp_if_cont[OF assms(1)]
proof(rule single_valued_UN_chain[OF chain_iterates[OF mono_if_cont[OF assms(1)]]])
  fix n show "single_valued ((f ^^ n) {})"
  by(induction n)(auto simp: assms(2))
qed

lemma single_valued_D: "single_valued (D c)"
proof(induction c)
  case Seq thus ?case by(simp add: single_valued_relcomp)
next
  case (While b c)
  let ?f = "W (bval b) (D c)"
  have "single_valued (lfp ?f)"
  proof(rule single_valued_lfp[OF cont_W])
    show "\<And>r. single_valued r \<Longrightarrow> single_valued (?f r)"
      using While.IH by(force simp: single_valued_def W_def)
  qed
  thus ?case by simp
qed (auto simp add: single_valued_def)

end


(*  Title:      HOL/Inductive.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Knaster-Tarski Fixpoint Theorem and inductive definitions\<close>

theory Inductive
  imports Complete_Lattices Ctr_Sugar
  keywords
    "inductive" "coinductive" "inductive_cases" "inductive_simps" :: thy_defn and
    "monos" and
    "print_inductives" :: diag and
    "old_rep_datatype" :: thy_goal and
    "primrec" :: thy_defn
begin

subsection \<open>Least fixed points\<close>

context complete_lattice
begin

definition lfp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "lfp f = Inf {u. f u \<le> u}"

lemma lfp_lowerbound: "f A \<le> A \<Longrightarrow> lfp f \<le> A"
  unfolding lfp_def by (rule Inf_lower) simp

lemma lfp_greatest: "(\<And>u. f u \<le> u \<Longrightarrow> A \<le> u) \<Longrightarrow> A \<le> lfp f"
  unfolding lfp_def by (rule Inf_greatest) simp

end

lemma lfp_fixpoint:
  assumes "mono f"
  shows "f (lfp f) = lfp f"
  unfolding lfp_def
proof (rule order_antisym)
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a \<le> ?a"
  proof (rule Inf_greatest)
    fix x
    assume "x \<in> ?H"
    then have "?a \<le> x" by (rule Inf_lower)
    with \<open>mono f\<close> have "f ?a \<le> f x" ..
    also from \<open>x \<in> ?H\<close> have "f x \<le> x" ..
    finally show "f ?a \<le> x" .
  qed
  show "?a \<le> f ?a"
  proof (rule Inf_lower)
    from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
    then show "f ?a \<in> ?H" ..
  qed
qed

lemma lfp_const: "lfp (\<lambda>x. t) = t"
  by (rule lfp_unfold) (simp add: mono_def)

lemma lfp_eqI: "mono F \<Longrightarrow> F x = x \<Longrightarrow> (\<And>z. F z = z \<Longrightarrow> x \<le> z) \<Longrightarrow> lfp F = x"
  by (rule antisym) (simp_all add: lfp_lowerbound lfp_unfold[symmetric])

subsection \<open>General induction rules for least fixed points\<close>

lemma lfp_ordinal_induct [case_names mono step union]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes mono: "mono f"
    and P_f: "\<And>S. P S \<Longrightarrow> S \<le> lfp f \<Longrightarrow> P (f S)"
    and P_Union: "\<And>M. \<forall>S\<in>M. P S \<Longrightarrow> P (Sup M)"
  shows "P (lfp f)"
proof -
  let ?M = "{S. S \<le> lfp f \<and> P S}"
  from P_Union have "P (Sup ?M)" by simp
  also have "Sup ?M = lfp f"
  proof (rule antisym)
    show "Sup ?M \<le> lfp f"
      by (blast intro: Sup_least)
    then have "f (Sup ?M) \<le> f (lfp f)"
      by (rule mono [THEN monoD])
    then have "f (Sup ?M) \<le> lfp f"
      using mono [THEN lfp_unfold] by simp
    then have "f (Sup ?M) \<in> ?M"
      using P_Union by simp (intro P_f Sup_least, auto)
    then have "f (Sup ?M) \<le> Sup ?M"
      by (rule Sup_upper)
    then show "lfp f \<le> Sup ?M"
      by (rule lfp_lowerbound)
  qed
  finally show ?thesis .
qed

theorem lfp_induct:
  assumes mono: "mono f"
    and ind: "f (inf (lfp f) P) \<le> P"
  shows "lfp f \<le> P"
proof (induct rule: lfp_ordinal_induct)
  case mono
  show ?case by fact
next
  case (step S)
  then show ?case
    by (intro order_trans[OF _ ind] monoD[OF mono]) auto
next
  case (union M)
  then show ?case
    by (auto intro: Sup_least)
qed

lemma lfp_induct_set:
  assumes lfp: "a \<in> lfp f"
    and mono: "mono f"
    and hyp: "\<And>x. x \<in> f (lfp f \<inter> {x. P x}) \<Longrightarrow> P x"
  shows "P a"
  by (rule lfp_induct [THEN subsetD, THEN CollectD, OF mono _ lfp]) (auto intro: hyp)

lemma lfp_ordinal_induct_set:
  assumes mono: "mono f"
    and P_f: "\<And>S. P S \<Longrightarrow> P (f S)"
    and P_Union: "\<And>M. \<forall>S\<in>M. P S \<Longrightarrow> P (\<Union>M)"
  shows "P (lfp f)"
  using assms by (rule lfp_ordinal_induct)

text \<open>Definition forms of \<open>lfp_unfold\<close> and \<open>lfp_induct\<close>, to control unfolding.\<close>

lemma def_lfp_unfold: "h \<equiv> lfp f \<Longrightarrow> mono f \<Longrightarrow> h = f h"
  by (auto intro!: lfp_unfold)

lemma def_lfp_induct: "A \<equiv> lfp f \<Longrightarrow> mono f \<Longrightarrow> f (inf A P) \<le> P \<Longrightarrow> A \<le> P"
  by (blast intro: lfp_induct)

lemma def_lfp_induct_set:
  "A \<equiv> lfp f \<Longrightarrow> mono f \<Longrightarrow> a \<in> A \<Longrightarrow> (\<And>x. x \<in> f (A \<inter> {x. P x}) \<Longrightarrow> P x) \<Longrightarrow> P a"
  by (blast intro: lfp_induct_set)

text \<open>Monotonicity of \<open>lfp\<close>!\<close>
lemma lfp_mono: "(\<And>Z. f Z \<le> g Z) \<Longrightarrow> lfp f \<le> lfp g"
  by (rule lfp_lowerbound [THEN lfp_greatest]) (blast intro: order_trans)

subsection \<open>Greatest fixed points\<close>

context complete_lattice
begin

definition gfp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "gfp f = Sup {u. u \<le> f u}"

lemma gfp_upperbound: "X \<le> f X \<Longrightarrow> X \<le> gfp f"
  by (auto simp add: gfp_def intro: Sup_upper)

lemma gfp_least: "(\<And>u. u \<le> f u \<Longrightarrow> u \<le> X) \<Longrightarrow> gfp f \<le> X"
  by (auto simp add: gfp_def intro: Sup_least)

end

lemma lfp_le_gfp: "mono f \<Longrightarrow> lfp f \<le> gfp f"
  by (rule gfp_upperbound) (simp add: lfp_fixpoint)

lemma gfp_fixpoint:
  assumes "mono f"
  shows "f (gfp f) = gfp f"
  unfolding gfp_def
proof (rule order_antisym)
  let ?H = "{u. u \<le> f u}"
  let ?a = "\<Squnion>?H"
  show "?a \<le> f ?a"
  proof (rule Sup_least)
    fix x
    assume "x \<in> ?H"
    then have "x \<le> f x" ..
    also from \<open>x \<in> ?H\<close> have "x \<le> ?a" by (rule Sup_upper)
    with \<open>mono f\<close> have "f x \<le> f ?a" ..
    finally show "x \<le> f ?a" .
  qed
  show "f ?a \<le> ?a"
  proof (rule Sup_upper)
    from \<open>mono f\<close> and \<open>?a \<le> f ?a\<close> have "f ?a \<le> f (f ?a)" ..
    then show "f ?a \<in> ?H" ..
  qed
qed

lemma gfp_unfold: "mono f \<Longrightarrow> gfp f = f (gfp f)"
  by (rule gfp_fixpoint [symmetric])

lemma gfp_const: "gfp (\<lambda>x. t) = t"
  by (rule gfp_unfold) (simp add: mono_def)

lemma gfp_eqI: "mono F \<Longrightarrow> F x = x \<Longrightarrow> (\<And>z. F z = z \<Longrightarrow> z \<le> x) \<Longrightarrow> gfp F = x"
  by (rule antisym) (simp_all add: gfp_upperbound gfp_unfold[symmetric])

subsection \<open>Coinduction rules for greatest fixed points\<close>

text \<open>Weak version.\<close>
lemma weak_coinduct: "a \<in> X \<Longrightarrow> X \<subseteq> f X \<Longrightarrow> a \<in> gfp f"
  by (rule gfp_upperbound [THEN subsetD]) auto

lemma weak_coinduct_image: "a \<in> X \<Longrightarrow> g`X \<subseteq> f (g`X) \<Longrightarrow> g a \<in> gfp f"
  apply (erule gfp_upperbound [THEN subsetD])
  apply (erule imageI)
  done

lemma coinduct_lemma: "X \<le> f (sup X (gfp f)) \<Longrightarrow> mono f \<Longrightarrow> sup X (gfp f) \<le> f (sup X (gfp f))"
  apply (frule gfp_unfold [THEN eq_refl])
  apply (drule mono_sup)
  apply (rule le_supI)
   apply assumption
  apply (rule order_trans)
   apply (rule order_trans)
    apply assumption
   apply (rule sup_ge2)
  apply assumption
  done

text \<open>Strong version, thanks to Coen and Frost.\<close>
lemma coinduct_set: "mono f \<Longrightarrow> a \<in> X \<Longrightarrow> X \<subseteq> f (X \<union> gfp f) \<Longrightarrow> a \<in> gfp f"
  by (rule weak_coinduct[rotated], rule coinduct_lemma) blast+

lemma gfp_fun_UnI2: "mono f \<Longrightarrow> a \<in> gfp f \<Longrightarrow> a \<in> f (X \<union> gfp f)"
  by (blast dest: gfp_fixpoint mono_Un)

lemma gfp_ordinal_induct[case_names mono step union]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes mono: "mono f"
    and P_f: "\<And>S. P S \<Longrightarrow> gfp f \<le> S \<Longrightarrow> P (f S)"
    and P_Union: "\<And>M. \<forall>S\<in>M. P S \<Longrightarrow> P (Inf M)"
  shows "P (gfp f)"
proof -
  let ?M = "{S. gfp f \<le> S \<and> P S}"
  from P_Union have "P (Inf ?M)" by simp
  also have "Inf ?M = gfp f"
  proof (rule antisym)
    show "gfp f \<le> Inf ?M"
      by (blast intro: Inf_greatest)
    then have "f (gfp f) \<le> f (Inf ?M)"
      by (rule mono [THEN monoD])
    then have "gfp f \<le> f (Inf ?M)"
      using mono [THEN gfp_unfold] by simp
    then have "f (Inf ?M) \<in> ?M"
      using P_Union by simp (intro P_f Inf_greatest, auto)
    then have "Inf ?M \<le> f (Inf ?M)"
      by (rule Inf_lower)
    then show "Inf ?M \<le> gfp f"
      by (rule gfp_upperbound)
  qed
  finally show ?thesis .
qed

lemma coinduct:
  assumes mono: "mono f"
    and ind: "X \<le> f (sup X (gfp f))"
  shows "X \<le> gfp f"
proof (induct rule: gfp_ordinal_induct)
  case mono
  then show ?case by fact
next
  case (step S)
  then show ?case
    by (intro order_trans[OF ind _] monoD[OF mono]) auto
next
  case (union M)
  then show ?case
    by (auto intro: mono Inf_greatest)
qed

subsection \<open>Even Stronger Coinduction Rule, by Martin Coen\<close>

text \<open>Weakens the condition \<^term>\<open>X \<subseteq> f X\<close> to one expressed using both
  \<^term>\<open>lfp\<close> and \<^term>\<open>gfp\<close>\<close>
lemma coinduct3_mono_lemma: "mono f \<Longrightarrow> mono (\<lambda>x. f x \<union> X \<union> B)"
  by (iprover intro: subset_refl monoI Un_mono monoD)

lemma coinduct3_lemma:
  "X \<subseteq> f (lfp (\<lambda>x. f x \<union> X \<union> gfp f)) \<Longrightarrow> mono f \<Longrightarrow>
    lfp (\<lambda>x. f x \<union> X \<union> gfp f) \<subseteq> f (lfp (\<lambda>x. f x \<union> X \<union> gfp f))"
  apply (rule subset_trans)
   apply (erule coinduct3_mono_lemma [THEN lfp_unfold [THEN eq_refl]])
  apply (rule Un_least [THEN Un_least])
    apply (rule subset_refl, assumption)
  apply (rule gfp_unfold [THEN equalityD1, THEN subset_trans], assumption)
  apply (rule monoD, assumption)
  apply (subst coinduct3_mono_lemma [THEN lfp_unfold], auto)
  done

lemma coinduct3: "mono f \<Longrightarrow> a \<in> X \<Longrightarrow> X \<subseteq> f (lfp (\<lambda>x. f x \<union> X \<union> gfp f)) \<Longrightarrow> a \<in> gfp f"
  apply (rule coinduct3_lemma [THEN [2] weak_coinduct])
    apply (rule coinduct3_mono_lemma [THEN lfp_unfold, THEN ssubst])
     apply simp_all
  done

text  \<open>Definition forms of \<open>gfp_unfold\<close> and \<open>coinduct\<close>, to control unfolding.\<close>

lemma def_gfp_unfold: "A \<equiv> gfp f \<Longrightarrow> mono f \<Longrightarrow> A = f A"
  by (auto intro!: gfp_unfold)

lemma def_coinduct: "A \<equiv> gfp f \<Longrightarrow> mono f \<Longrightarrow> X \<le> f (sup X A) \<Longrightarrow> X \<le> A"
  by (iprover intro!: coinduct)

lemma def_coinduct_set: "A \<equiv> gfp f \<Longrightarrow> mono f \<Longrightarrow> a \<in> X \<Longrightarrow> X \<subseteq> f (X \<union> A) \<Longrightarrow> a \<in> A"
  by (auto intro!: coinduct_set)

lemma def_Collect_coinduct:
  "A \<equiv> gfp (\<lambda>w. Collect (P w)) \<Longrightarrow> mono (\<lambda>w. Collect (P w)) \<Longrightarrow> a \<in> X \<Longrightarrow>
    (\<And>z. z \<in> X \<Longrightarrow> P (X \<union> A) z) \<Longrightarrow> a \<in> A"
  by (erule def_coinduct_set) auto

lemma def_coinduct3: "A \<equiv> gfp f \<Longrightarrow> mono f \<Longrightarrow> a \<in> X \<Longrightarrow> X \<subseteq> f (lfp (\<lambda>x. f x \<union> X \<union> A)) \<Longrightarrow> a \<in> A"
  by (auto intro!: coinduct3)

text \<open>Monotonicity of \<^term>\<open>gfp\<close>!\<close>
lemma gfp_mono: "(\<And>Z. f Z \<le> g Z) \<Longrightarrow> gfp f \<le> gfp g"
  by (rule gfp_upperbound [THEN gfp_least]) (blast intro: order_trans)

subsection \<open>Rules for fixed point calculus\<close>

lemma lfp_rolling:
  assumes "mono g" "mono f"
  shows "g (lfp (\<lambda>x. f (g x))) = lfp (\<lambda>x. g (f x))"
proof (rule antisym)
  have *: "mono (\<lambda>x. f (g x))"
    using assms by (auto simp: mono_def)
  show "lfp (\<lambda>x. g (f x)) \<le> g (lfp (\<lambda>x. f (g x)))"
    by (rule lfp_lowerbound) (simp add: lfp_unfold[OF *, symmetric])
  show "g (lfp (\<lambda>x. f (g x))) \<le> lfp (\<lambda>x. g (f x))"
  proof (rule lfp_greatest)
    fix u
    assume u: "g (f u) \<le> u"
    then have "g (lfp (\<lambda>x. f (g x))) \<le> g (f u)"
      by (intro assms[THEN monoD] lfp_lowerbound)
    with u show "g (lfp (\<lambda>x. f (g x))) \<le> u"
      by auto
  qed
qed

lemma lfp_lfp:
  assumes f: "\<And>x y w z. x \<le> y \<Longrightarrow> w \<le> z \<Longrightarrow> f x w \<le> f y z"
  shows "lfp (\<lambda>x. lfp (f x)) = lfp (\<lambda>x. f x x)"
proof (rule antisym)
  have *: "mono (\<lambda>x. f x x)"
    by (blast intro: monoI f)
  show "lfp (\<lambda>x. lfp (f x)) \<le> lfp (\<lambda>x. f x x)"
    by (intro lfp_lowerbound) (simp add: lfp_unfold[OF *, symmetric])
  show "lfp (\<lambda>x. lfp (f x)) \<ge> lfp (\<lambda>x. f x x)" (is "?F \<ge> _")
  proof (intro lfp_lowerbound)
    have *: "?F = lfp (f ?F)"
      by (rule lfp_unfold) (blast intro: monoI lfp_mono f)
    also have "\<dots> = f ?F (lfp (f ?F))"
      by (rule lfp_unfold) (blast intro: monoI lfp_mono f)
    finally show "f ?F ?F \<le> ?F"
      by (simp add: *[symmetric])
  qed
qed

lemma gfp_rolling:
  assumes "mono g" "mono f"
  shows "g (gfp (\<lambda>x. f (g x))) = gfp (\<lambda>x. g (f x))"
proof (rule antisym)
  have *: "mono (\<lambda>x. f (g x))"
    using assms by (auto simp: mono_def)
  show "g (gfp (\<lambda>x. f (g x))) \<le> gfp (\<lambda>x. g (f x))"
    by (rule gfp_upperbound) (simp add: gfp_unfold[OF *, symmetric])
  show "gfp (\<lambda>x. g (f x)) \<le> g (gfp (\<lambda>x. f (g x)))"
  proof (rule gfp_least)
    fix u
    assume u: "u \<le> g (f u)"
    then have "g (f u) \<le> g (gfp (\<lambda>x. f (g x)))"
      by (intro assms[THEN monoD] gfp_upperbound)
    with u show "u \<le> g (gfp (\<lambda>x. f (g x)))"
      by auto
  qed
qed

lemma gfp_gfp:
  assumes f: "\<And>x y w z. x \<le> y \<Longrightarrow> w \<le> z \<Longrightarrow> f x w \<le> f y z"
  shows "gfp (\<lambda>x. gfp (f x)) = gfp (\<lambda>x. f x x)"
proof (rule antisym)
  have *: "mono (\<lambda>x. f x x)"
    by (blast intro: monoI f)
  show "gfp (\<lambda>x. f x x) \<le> gfp (\<lambda>x. gfp (f x))"
    by (intro gfp_upperbound) (simp add: gfp_unfold[OF *, symmetric])
  show "gfp (\<lambda>x. gfp (f x)) \<le> gfp (\<lambda>x. f x x)" (is "?F \<le> _")
  proof (intro gfp_upperbound)
    have *: "?F = gfp (f ?F)"
      by (rule gfp_unfold) (blast intro: monoI gfp_mono f)
    also have "\<dots> = f ?F (gfp (f ?F))"
      by (rule gfp_unfold) (blast intro: monoI gfp_mono f)
    finally show "?F \<le> f ?F ?F"
      by (simp add: *[symmetric])
  qed
qed

subsection \<open>Inductive predicates and sets\<close>

text \<open>Package setup.\<close>

lemmas basic_monos =
  subset_refl imp_refl disj_mono conj_mono ex_mono all_mono if_bool_eq_conj
  Collect_mono in_mono vimage_mono

lemma le_rel_bool_arg_iff: "X \<le> Y \<longleftrightarrow> X False \<le> Y False \<and> X True \<le> Y True"
  unfolding le_fun_def le_bool_def using bool_induct by auto

lemma imp_conj_iff: "((P \<longrightarrow> Q) \<and> P) = (P \<and> Q)"
  by blast

lemma meta_fun_cong: "P \<equiv> Q \<Longrightarrow> P a \<equiv> Q a"
  by auto

ML_file \<open>Tools/inductive.ML\<close>

lemmas [mono] =
  imp_refl disj_mono conj_mono ex_mono all_mono if_bool_eq_conj
  imp_mono not_mono
  Ball_def Bex_def
  induct_rulify_fallback

subsection \<open>The Schroeder-Bernstein Theorem\<close>

text \<open>
  See also:
  \<^item> \<^file>\<open>$ISABELLE_HOME/src/HOL/ex/Set_Theory.thy\<close>
  \<^item> \<^url>\<open>http://planetmath.org/proofofschroederbernsteintheoremusingtarskiknastertheorem\<close>
  \<^item> Springer LNCS 828 (cover page)
\<close>

theorem Schroeder_Bernstein:
  fixes f :: "'a \<Rightarrow> 'b" and g :: "'b \<Rightarrow> 'a"
    and A :: "'a set" and B :: "'b set"
  assumes inj1: "inj_on f A" and sub1: "f ` A \<subseteq> B"
    and inj2: "inj_on g B" and sub2: "g ` B \<subseteq> A"
  shows "\<exists>h. bij_betw h A B"
proof (rule exI, rule bij_betw_imageI)
  define X where "X = lfp (\<lambda>X. A - (g ` (B - (f ` X))))"
  define g' where "g' = the_inv_into (B - (f ` X)) g"
  let ?h = "\<lambda>z. if z \<in> X then f z else g' z"

  have X: "X = A - (g ` (B - (f ` X)))"
    unfolding X_def by (rule lfp_unfold) (blast intro: monoI)
  then have X_compl: "A - X = g ` (B - (f ` X))"
    using sub2 by blast

  from inj2 have inj2': "inj_on g (B - (f ` X))"
    by (rule inj_on_subset) auto
  with X_compl have *: "g' ` (A - X) = B - (f ` X)"
    by (simp add: g'_def)

  from X have X_sub: "X \<subseteq> A" by auto
  from X sub1 have fX_sub: "f ` X \<subseteq> B" by auto

  show "?h ` A = B"
  proof -
    from X_sub have "?h ` A = ?h ` (X \<union> (A - X))" by auto
    also have "\<dots> = ?h ` X \<union> ?h ` (A - X)" by (simp only: image_Un)
    also have "?h ` X = f ` X" by auto
    also from * have "?h ` (A - X) = B - (f ` X)" by auto
    also from fX_sub have "f ` X \<union> (B - f ` X) = B" by blast
    finally show ?thesis .
  qed
  show "inj_on ?h A"
  proof -
    from inj1 X_sub have on_X: "inj_on f X"
      by (rule subset_inj_on)

    have on_X_compl: "inj_on g' (A - X)"
      unfolding g'_def X_compl
      by (rule inj_on_the_inv_into) (rule inj2')

    have impossible: False if eq: "f a = g' b" and a: "a \<in> X" and b: "b \<in> A - X" for a b
    proof -
      from a have fa: "f a \<in> f ` X" by (rule imageI)
      from b have "g' b \<in> g' ` (A - X)" by (rule imageI)
      with * have "g' b \<in> - (f ` X)" by simp
      with eq fa show False by simp
    qed

    show ?thesis
    proof (rule inj_onI)
      fix a b
      assume h: "?h a = ?h b"
      assume "a \<in> A" and "b \<in> A"
      then consider "a \<in> X" "b \<in> X" | "a \<in> A - X" "b \<in> A - X"
        | "a \<in> X" "b \<in> A - X" | "a \<in> A - X" "b \<in> X"
        by blast
      then show "a = b"
      proof cases
        case 1
        with h on_X show ?thesis by (simp add: inj_on_eq_iff)
      next
        case 2
        with h on_X_compl show ?thesis by (simp add: inj_on_eq_iff)
      next
        case 3
        with h impossible [of a b] have False by simp
        then show ?thesis ..
      next
        case 4
        with h impossible [of b a] have False by simp
        then show ?thesis ..
      qed
    qed
  qed
qed

subsection \<open>Inductive datatypes and primitive recursion\<close>

text \<open>Package setup.\<close>

ML_file \<open>Tools/Old_Datatype/old_datatype_aux.ML\<close>
ML_file \<open>Tools/Old_Datatype/old_datatype_prop.ML\<close>
ML_file \<open>Tools/Old_Datatype/old_datatype_data.ML\<close>
ML_file \<open>Tools/Old_Datatype/old_rep_datatype.ML\<close>
ML_file \<open>Tools/Old_Datatype/old_datatype_codegen.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_rec_sugar_util.ML\<close>
ML_file \<open>Tools/Old_Datatype/old_primrec.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_rec_sugar.ML\<close>

text \<open>Lambda-abstractions with pattern matching:\<close>
syntax (ASCII)
  "_lam_pats_syntax" :: "cases_syn \<Rightarrow> 'a \<Rightarrow> 'b"  ("(%_)" 10)
syntax
  "_lam_pats_syntax" :: "cases_syn \<Rightarrow> 'a \<Rightarrow> 'b"  ("(\<lambda>_)" 10)
parse_translation \<open>
  let
    fun fun_tr ctxt [cs] =
      let
        val x = Syntax.free (fst (Name.variant "x" (Term.declare_term_frees cs Name.context)));
        val ft = Case_Translation.case_tr true ctxt [x, cs];
      in lambda x ft end
  in [(\<^syntax_const>\<open>_lam_pats_syntax\<close>, fun_tr)] end
\<close>

end


theory Tut4Practice
imports Main
begin

lemma "(P \<longrightarrow> (Q \<longrightarrow> R)) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R))"
proof (rule impI)+
  assume "P" "P \<longrightarrow> Q \<longrightarrow> R" then have qr: "Q \<longrightarrow> R"
    by blast
  assume "P" "P \<longrightarrow> Q" then have "Q"
    by blast
  then show "R" using qr
    by simp
qed

lemma "(\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P x \<longrightarrow> Q)"
proof
  fix a
  assume "(\<forall>x. P x \<longrightarrow> Q)" then have pq: "P a \<longrightarrow> Q"
    by blast
  then show "(\<exists>x. P x \<longrightarrow> Q)"
    by blast
qed

lemma one: assumes ex:"(\<nexists>x. P x)" shows  all:"(\<forall>x. \<not>P x)"
proof
  fix x
  show "\<not> P x"
  proof
    assume "P x" then have "\<exists>x. P x"
      by auto
    then show False
      using ex by blast
  qed
qed

lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume "\<nexists>x. \<not>P x"
  then have "\<forall>x. \<not>\<not>P x" by (rule one)
  then have "\<forall>x. P x" by simp
  from n_all this show False
    by simp
qed

lemma "(R \<longrightarrow> P) \<longrightarrow> (((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S))"
  oops

end


theory Homework4_1_sol
imports "../IMP/AExp"
begin

(*
  The objective of this homework is to compile to a register machine.

  Hint: To solve this homework, it is best to have ASM.thy
    open for reference in another window!

*)

(* We assume we have an unlimited amount of registers, register names are
  just natural numbers *)
type_synonym reg = nat

(* Instructions of our register machine *)
datatype inst =
    MOVI val reg      (* MOVI v r  -- move constant (immediate value) v to register r *)
  | LOAD vname reg    (* LOAD x r  -- load variable x to register r *)
  | ADD reg reg       (* ADD r1 r2 -- add values contained in registers r1 and r2, place the result in r1 *)

(* The state of our machine's register bank is described by a function mapping
  register names to values.
*)
type_synonym rstate = "reg \<Rightarrow> val"

(*
  Specify the semantics for executing a single instruction.
  Note: As there is no store instruction, the variable state is not modified.
*)
fun exec1 :: "inst \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(*<*)
  "exec1 (MOVI v r) s t = t(r:=v)"
| "exec1 (LOAD x r) s t = t(r:=s x)"
| "exec1 (ADD r1 r2) s t = t(r1:=t r1 + t r2)"
(*>*)

(*
  Specify the semantics of executing a list of instructions
*)
fun exec :: "inst list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(*<*)
  "exec [] s t = t"
| "exec (i#is) s t = exec is s (exec1 i s t)"
(*>*)

lemma exec_append[simp]:
  "exec (is1@is2) s t = exec is2 s (exec is1 s t)"
  (* Prove that! *)
(*<*)
apply(induction is1 arbitrary: t)
apply (auto)
done
(*>*)

(*
  In order to compile an arithmetic expression, the intermediate results must be assigned
  to intermediate registers, and it must be ensured that fresh intermediate registers are used.

  For example, when compiling a1+a2, we first generate code that compiles a1
  and places the result in some register r1, then we generate code to compile a2,
  place the result in some register r2, and finally add the two registers, the
  final result going to register r1.
  However, we must ensure that the code generated for a2 does not overwrite register r1.

  We use the following strategy: We pass an additional parameter r to the compiler,
  which is the register that should contain the result value. Additionally, all
  registers less than r must not be changed by the generated code.

  That is, to compile an expression a1 + a2 to register r, we do the following:
    1. generate code that evaluates a1 to register r, not changing registers <r
    2. generate code that evaluates a2 to register r+1, not changing registers <r+1
        (in particular, register r is not changed!)
    3. add register r and r+1, placing the result in register r

*)

hide_const (open) comp
fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> inst list" where
(*<*)
  "comp (N v) r = [MOVI v r]"
| "comp (V x) r = [LOAD x r]"
| "comp (Plus e1 e2) r = comp e1 r @ comp e2 (r+1) @ [ADD r (r+1)]"
(*>*)

(* Test case *)

value "comp (Plus (Plus (N 3) (V ''x'')) (Plus (N 1) (V ''y''))) 1 =
[MOVI 3 (Suc 0), LOAD ''x'' (Suc (Suc 0)), ADD (Suc 0) (Suc (Suc 0)), MOVI 1 (Suc (Suc 0)),
  LOAD ''y'' (Suc (Suc (Suc 0))), ADD (Suc (Suc 0)) (Suc (Suc (Suc 0))), ADD (Suc 0) (Suc (Suc 0))]
"

(* Show that the produced code does not change registers less than r! *)

end