theory NQueens_CSP
imports Main CSP
begin

(* The general problem *)

definition board0 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "board0 n b = (n\<ge>0 \<and> b \<subseteq> {1..n}\<times>{1..n} \<and> (int (card b) = n))"

definition safe0 :: "int \<Rightarrow> int \<Rightarrow> int rel \<Rightarrow> bool" where
  "safe0 p q b = (\<forall>i. i\<noteq>0 \<longrightarrow> (p+i,q)\<notin>b \<and> (p,q+i)\<notin>b \<and> (p+i,q+i)\<notin>b \<and> (p+i,q-i)\<notin>b)"

definition nqueens0 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "nqueens0 n b = (board0 n b \<and> (\<forall>p q. (p,q)\<in>b \<longrightarrow> safe0 p q b))"

(* The problem with all queens preassigned to different columns, *)
(* that is, no queen can vertically attack another. *)
(* This makes b an array! *)

definition board1 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "board1 n b = (n\<ge>0 \<and> array n n b)"

definition safe1 :: "int \<Rightarrow> int \<Rightarrow> int rel \<Rightarrow> bool" where
  "safe1 p q b = (\<forall>i. i\<noteq>0 \<longrightarrow> (p+i,q)\<notin>b \<and> (p+i,q+i)\<notin>b \<and> (p+i,q-i)\<notin>b)"

definition nqueens1 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "nqueens1 n b = (board1 n b \<and> (\<forall>p q. (p,q)\<in>b \<longrightarrow> safe1 p q b))"

lemma from0to1: "nqueens1 n b \<Longrightarrow> nqueens0 n b"
apply (simp add: nqueens1_def nqueens0_def safe1_def safe0_def board1_def board0_def)
by (smt Domain.intros Range.RangeI array_def arraycard mem_Sigma_iff subrelI subsetCE)

(* The safety constraints split. *)
(* Constraint a: No queen can horizontally attack another. *)
(* Constraint 2: No queen can diagonally attack another. *)

definition board2 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "board2 n b = board1 n b"

definition safe2a :: "int rel \<Rightarrow> bool" where
  "safe2a b = allDifferent b"

definition safe2b :: "int rel \<Rightarrow> bool" where
  "safe2b b = (\<forall>p q r s. (p,q)\<in>b \<and> (r,s)\<in>b \<and> p\<noteq>r \<longrightarrow> abs (p-r) \<noteq> abs (q-s))"

definition safe2b_impl :: "int rel \<Rightarrow> bool" where
  "safe2b_impl b = (\<forall>p r. p\<in>Domain b \<and> r\<in>Domain b \<and> p\<noteq>r \<longrightarrow> abs (p-r) \<noteq> abs ((valof b p)-(valof b r)))"

lemma safe2bimpl: "array n n b \<Longrightarrow> (safe2b b \<longleftrightarrow> safe2b_impl b)"
apply (simp add: safe2b_def safe2b_impl_def)
by (metis Domain.DomainI valofarr valofarrev)

definition nqueens2 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "nqueens2 n b = (board2 n b \<and> safe2a b \<and> safe2b b)"

lemma nqueens2_impl: "nqueens2 n b \<longleftrightarrow> (board2 n b \<and> safe2a b \<and> safe2b_impl b)"
using board1_def board2_def nqueens2_def safe2bimpl by blast

lemma safe1dcmp: "\<lbrakk>\<forall>p q. (p, q) \<in> b \<longrightarrow> (\<forall>i. i\<noteq>0 \<longrightarrow> (p+i,q)\<notin>b); \<forall>p q. (p, q) \<in> b \<longrightarrow> (\<forall>i. i\<noteq>0 \<longrightarrow> (p+i,q+i)\<notin>b); \<forall>p q. (p, q) \<in> b \<longrightarrow> (\<forall>i. i\<noteq>0 \<longrightarrow> (p+i,q-i)\<notin>b)\<rbrakk> \<Longrightarrow> (\<forall>p q. (p, q) \<in> b \<longrightarrow> safe1 p q b)"
by (simp add: safe1_def)

lemma from1to2: "nqueens2 n b \<longrightarrow> nqueens1 n b"
proof (simp add: nqueens2_def nqueens1_def board2_def, standard)
  {
  fix p q
  assume b1: "board1 n b"
     and s1: "safe2a b"
     and s2: "safe2b b"
     and b2: "(p, q) \<in> b"
  hence "\<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q \<noteq> s"
  by (simp add: safe2a_def allDifferent_def)
  hence s3: "\<forall>i. i \<noteq> 0 \<longrightarrow> (p + i, q) \<notin> b" using b2 by force
  have s4: "\<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> \<bar>p - r\<bar> \<noteq> \<bar>q - s\<bar>"
  using s2 safe2b_def by blast
  hence "\<forall>i. i \<noteq> 0 \<longrightarrow> (p + i, q) \<notin> b \<and> (p + i, q + i) \<notin> b \<and> (p + i, q - i) \<notin> b"
  using s3 using b2 by fastforce
  hence "safe1 p q b" by (simp add: safe1_def)
  }
  thus "board1 n b \<and> safe2a b \<and> safe2b b \<Longrightarrow> \<forall>p q. (p, q) \<in> b \<longrightarrow> safe1 p q b" by blast
qed

definition board3 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "board3 n b = board2 n b"

definition safe3a :: "int rel \<Rightarrow> bool" where
  "safe3a b = safe2a b"

definition safe3b :: "int rel \<Rightarrow> bool" where
  "safe3b b = (\<forall>p q r s. (p,q)\<in>b \<and> (r,s)\<in>b \<and> p\<noteq>r \<longrightarrow> q+p\<noteq>s+r)"

lemma safead3b: "safe3b b \<longleftrightarrow> allDifferent {(x,y). \<exists>z. (x,z)\<in>b \<and> y=z+x}"
proof (simp add: safe3b_def allDifferent_def array_def, standard)
show "\<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q + p \<noteq> s + r \<Longrightarrow>
    \<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = z + x) \<and> (\<exists>z. (y, z) \<in> b \<and> q = z + y) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q"
by smt
next
  {
  fix p q r s
  assume h2: "\<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = x + z) \<and> (\<exists>z. (y, z) \<in> b \<and> q = y + z) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q"
     and h3: "(p, q) \<in> b"
     and h4: "(r, s) \<in> b"
     and h5: "p \<noteq> r"
  hence "\<forall>p0 q0. (\<exists>z. (p, z) \<in> b \<and> p0 = p + z) \<and> (\<exists>z. (r, z) \<in> b \<and> q0 = r + z) \<and> p \<noteq> r \<longrightarrow> p0 \<noteq> q0" by blast
  hence "\<forall>p0 q0. ((p, q) \<in> b \<and> p0 = p + q) \<and> ((r, s) \<in> b \<and> q0 = r + s) \<and> p \<noteq> r \<longrightarrow> p0 \<noteq> q0" by blast
  hence "(p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> p+q \<noteq> r+s" by blast
  hence "p + q \<noteq> r + s" using h3 h4 h5 by blast
  }
  thus "\<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = z + x) \<and> (\<exists>z. (y, z) \<in> b \<and> q = z + y) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q \<Longrightarrow>
    \<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q + p \<noteq> s + r" by blast
qed

definition safe3c :: "int rel \<Rightarrow> bool" where
  "safe3c b = (\<forall>p q r s. (p,q)\<in>b \<and> (r,s)\<in>b \<and> p\<noteq>r \<longrightarrow> q-p\<noteq>s-r)"

lemma safead3c: "safe3c b \<longleftrightarrow> allDifferent {(x,y). \<exists>z. (x,z)\<in>b \<and> y=z-x}"
proof (simp add: safe3c_def allDifferent_def array_def, standard)
show "\<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q - p \<noteq> s - r \<Longrightarrow>
    \<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = z - x) \<and> (\<exists>z. (y, z) \<in> b \<and> q = z - y) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q"
by smt
next
  {
  fix p q r s
  assume h2: "\<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = z - x) \<and> (\<exists>z. (y, z) \<in> b \<and> q = z - y) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q"
     and h3: "(p, q) \<in> b"
     and h4: "(r, s) \<in> b"
     and h5: "p \<noteq> r"
  hence "\<forall>p0 q0. (\<exists>z. (p, z) \<in> b \<and> p0 = z - p) \<and> (\<exists>z. (r, z) \<in> b \<and> q0 = z - r) \<and> p \<noteq> r \<longrightarrow> p0 \<noteq> q0" by blast
  hence "\<forall>p0 q0. ((p, q) \<in> b \<and> p0 = q - p) \<and> ((r, s) \<in> b \<and> q0 = s - r) \<and> p \<noteq> r \<longrightarrow> p0 \<noteq> q0" by blast
  hence "(p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q-p \<noteq> s-r" by blast
  hence "q-p \<noteq> s-r" using h3 h4 h5 by blast
  }
  thus "\<forall>x y p q. (\<exists>z. (x, z) \<in> b \<and> p = z - x) \<and> (\<exists>z. (y, z) \<in> b \<and> q = z - y) \<and> x \<noteq> y \<longrightarrow> p \<noteq> q \<Longrightarrow>
    \<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> q - p \<noteq> s - r" by blast
qed

definition nqueens3 :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "nqueens3 n b = (board3 n b \<and> safe3a b \<and> safe3b b \<and> safe3c b)"

lemma from2to3: "nqueens3 n b \<longrightarrow> nqueens2 n b"
proof (simp add: nqueens3_def nqueens2_def board3_def safe3a_def, standard)
  {
  assume b1:"board2 n b"
     and s1: "safe2a b"
     and s2: "safe3b b"
     and s3: "safe3c b"
     hence "\<forall>p q r s. (p, q) \<in> b \<and> (r, s) \<in> b \<and> p \<noteq> r \<longrightarrow> \<bar>p - r\<bar> \<noteq> \<bar>q - s\<bar>" by (smt s3 safe3b_def safe3c_def)
     hence "safe2b b" by (simp add: safe2b_def)
  }
  thus "board2 n b \<and> safe2a b \<and> safe3b b \<and> safe3c b \<Longrightarrow> safe2b b" by blast
qed

definition nqueens3i :: "int \<Rightarrow> int rel \<Rightarrow> bool" where
  "nqueens3i n b = (n\<ge>0 \<and> array n n b \<and>
                    allDifferent b \<and>
                    allDifferent {(x,y). \<exists>z. (x,z)\<in>b \<and> y=z+x} \<and>
                    allDifferent {(x,y). \<exists>z. (x,z)\<in>b \<and> y=z-x})"

lemma impl3: "nqueens3i n b \<longleftrightarrow> nqueens3 n b"
by (simp add: nqueens3_def board3_def board2_def board1_def safe3a_def safe2a_def safead3b safead3c nqueens3i_def)

lemma arrplus: "array n n b \<Longrightarrow> {(x, y). \<exists>z. (x, z) \<in> b \<and> y = z + x} = {(x, y). x\<in>Domain b \<and> y = valof b x + x}"
using valofarr valofarrev Collect_cong Domain.DomainI Pair_inject case_prodE case_prodI2 by blast

lemma arrminus: "array n n b \<Longrightarrow> {(x, y). \<exists>z. (x, z) \<in> b \<and> y = z - x} = {(x, y). x\<in>Domain b \<and> y = valof b x - x}"
using valofarr valofarrev Collect_cong Domain.DomainI Pair_inject case_prodE case_prodI2 by blast

lemma implNotation: "nqueens3i n b \<longleftrightarrow> (n\<ge>0 \<and> array n n b \<and>
                    allDifferent b \<and>
                    allDifferent {(x,y). x\<in>Domain b \<and> y=(valof b x)+x} \<and>
                    allDifferent {(x,y). x\<in>Domain b \<and> y=(valof b x)-x})"
apply (simp_all add: nqueens3i_def arrplus arrminus)
apply (auto)
by (simp_all add: nqueens3i_def arrplus arrminus)


(*
  File:     Power_By_Squaring.thy
  Author:   Manuel Eberl, TU München

  Fast computing of funpow (applying some functon n times) for weakly associative binary
  functions using exponentiation by squaring. Yields efficient exponentiation algorithms on
  monoid_mult and for modular exponentiation "b ^ e mod m" (and thus also for "cong")
*)
section \<open>Exponentiation by Squaring\<close>
theory Power_By_Squaring
  imports MainRLT
begin

context
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
begin

function efficient_funpow :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "efficient_funpow y x 0 = y"
| "efficient_funpow y x (Suc 0) = f x y"
| "n \<noteq> 0 \<Longrightarrow> even n \<Longrightarrow> efficient_funpow y x n = efficient_funpow y (f x x) (n div 2)"
| "n \<noteq> 1 \<Longrightarrow> odd n \<Longrightarrow> efficient_funpow y x n = efficient_funpow (f x y) (f x x) (n div 2)"
  by force+
termination by (relation "measure (snd \<circ> snd)") (auto elim: oddE)

lemma efficient_funpow_code [code]:
  "efficient_funpow y x n =
     (if n = 0 then y
      else if n = 1 then f x y
      else if even n then efficient_funpow y (f x x) (n div 2)
      else efficient_funpow (f x y) (f x x) (n div 2))"
  by (induction y x n rule: efficient_funpow.induct) auto

end

lemma efficient_funpow_correct:
  assumes f_assoc: "\<And>x z. f x (f x z) = f (f x x) z"
  shows "efficient_funpow f y x n = (f x ^^ n) y"
proof -
  have [simp]: "f ^^ 2 = (\<lambda>x. f (f x))" for f :: "'a \<Rightarrow> 'a"
    by (simp add: eval_nat_numeral o_def)
  show ?thesis
    by (induction y x n rule: efficient_funpow.induct[of _ f])
       (auto elim!: evenE oddE simp: funpow_mult [symmetric] funpow_Suc_right f_assoc
             simp del: funpow.simps(2))
qed

(*
  TODO: This could be used as a code_unfold rule or something like that but the
  implications are not quite clear. Would this be a good default implementation
  for powers?
*)
context monoid_mult
begin

lemma power_by_squaring: "efficient_funpow (*) (1 :: 'a) = (^)"
proof (intro ext)
  fix x :: 'a and n
  have "efficient_funpow (*) 1 x n = ((*) x ^^ n) 1"
    by (subst efficient_funpow_correct) (simp_all add: mult.assoc)
  also have "\<dots> = x ^ n"
    by (induction n) simp_all
  finally show "efficient_funpow (*) 1 x n = x ^ n" .
qed

end

end


section "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname ⇒ val"

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval :: "aexp ⇒ state ⇒ val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a⇩1 a⇩2) s = aval a⇩1 s + aval a⇩2 s"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (λx. if x = ''x'' then 7 else 0)"

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

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

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

text {* \noindent
  We can now write a series of updates to the function @{text "λx. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

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

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

text{* Note that this @{text"<…>"} syntax works for any function space
@{text"τ⇩1 ⇒ τ⇩2"} where @{text "τ⇩2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp ⇒ aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a⇩1 a⇩2) =
  (case (asimp_const a⇩1, asimp_const a⇩2) of
    (N n⇩1, N n⇩2) ⇒ N(n⇩1+n⇩2) |
    (b⇩1,b⇩2) ⇒ Plus b⇩1 b⇩2)"
text_raw{*}%endsnip*}

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

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

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp ⇒ aexp ⇒ aexp" where
  "plus (N i⇩1) (N i⇩2) = N(i⇩1+i⇩2)" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus a⇩1 a⇩2 = Plus a⇩1 a⇩2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  (* apply(induction a1 a2 rule: plus.induct) Original. The 'a1 a2' is extraneous. *)
  apply(induction rule: plus.induct)
    (* apply(induction a1) apply(induction a2)  Does not work*)
              apply simp_all (* just for a change from auto *)
  done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp ⇒ aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a⇩1 a⇩2) = plus (asimp a⇩1) (asimp a⇩2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

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

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
  apply(induction a)
  apply simp_all
  done

    (* exercise 3.1 *)

fun is_N :: "aexp ⇒ bool" where
  "is_N (N _) = True"|
  "is_N _ = False"

  (* check that expression does not contain any unoptimized sub-expressions,
      i.e. Plus (N i) (N j) *)
fun optimal :: "aexp ⇒ bool" where
  (* TODO why won't this, the ∧ function, work? *)
  (* "optimal (Plus e1 e2) = (is_N e1) ∧ (is_N e2)" | *)
  (* definition conj :: "[bool, bool] ⇒ bool"  (infixr "∧" 35) *)
  "optimal (Plus e1 e2) = Not(conj (is_N e1) (is_N e2))" |
  "optimal _ = True"

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

    (* Sum all N's found in expression. Change all values of (N x) to (N 0) in expression.
Assume that asimp will be run later to cleanup expressions like (Plus (N 0) (V v))
Because the only operator is '+' , we can blindly sum all N's.
helper for full_asimp *)
fun sum_Ns :: "aexp ⇒ int ⇒ (aexp × int)" where
  "sum_Ns (N n) s = (Plus (N 0) (N 0), s+n)"|
  "sum_Ns (V v) s = (V v, s)"|
  "sum_Ns (Plus e⇩1 e⇩2) s =
    (let (re⇩1, s⇩1) = sum_Ns e⇩1 0;
         (re⇩2, s⇩2) = sum_Ns e⇩2 0
      in (Plus re⇩1 re⇩2, s⇩1 + s⇩2))"

(* When all variables are 0, aval = sum_Ns *)
lemma aval_sum_Ns:"aval e <> = snd (sum_Ns e 0)"
  apply(induction e)
    apply(auto)
   apply (simp add: null_state_def)
  by (simp add: case_prod_beta)

(* constant folding for aexp where we sum up all constants, even if they are not next to
each other. For example, Plus (N 1) (Plus (V x ) (N 2)) becomes Plus (V x ) (N 3). *)
fun full_asimp :: "aexp ⇒ aexp" where
   "full_asimp e⇩1 = (
      let (e⇩2, s) = sum_Ns e⇩1 0;
           e⇩3 = Plus (N s) e⇩2
      in  asimp e⇩3)"

value "full_asimp (Plus (N 1) (Plus (V x ) (N 2)))"

theorem aval_full_asimp[simp]:
  "aval (full_asimp e) s = aval e s"
  apply(induction e)
    apply(auto)
  by (simp add: case_prod_beta)
    (* by (simp add: case_prod_unfold) *)

(* Define a substitution function
subst :: vname ⇒ aexp ⇒ aexp ⇒ aexp
such that
subst x a e
is the result of replacing every
occurrence of variable x by a in e *)
fun subst :: "vname ⇒ aexp ⇒ aexp ⇒ aexp" where
  "subst matchMe replaceWith (V vname) =
      (if matchMe = vname
      then replaceWith
      else V vname)"|
  "subst matchMe replaceWith (N n) = N n"|
  "subst matchMe replaceWith (Plus e⇩1 e⇩2) =
      Plus (subst matchMe replaceWith e⇩1) (subst matchMe replaceWith e⇩2)"

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

(*   Prove the so-called substitution lemma that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
aval (subst x a e) s = aval e (s(x := aval a s)). As a consequence prove
aval a1 s = aval a2 s =⇒ aval (subst x a1 e) s = aval (subst x a2 e) s. *)
lemma substitution:"aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
  by auto

theorem foo:
  "aval a⇩1 s = aval a⇩2 s
  ⟹ aval (subst x a⇩1 e) s = aval (subst x a⇩2 e) s"
  apply(induction e)
  by auto

end


theory R02Sol

imports Complex_Main
begin

text {* Relación 2 *}

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.1. [Plegados sobre árboles]

  Definir el tipo de dato arbolH para representar los árboles binarios
  que sólo tienen valores en las hojas. Por ejemplo, el árbol
       ·
      / \
     3   ·
        / \
       5   7
  se representa por
     Nodo (Hoja 3) (Nodo (Hoja 5) (Hoja 7))
  ------------------------------------------------------------------- *}

datatype 'a arbolH =
  Hoja 'a
| Nodo "'a arbolH" "'a arbolH"

abbreviation ejArbolH1 :: "int arbolH"
where
  "ejArbolH1 \<equiv> Nodo (Hoja (3::int)) (Nodo (Hoja 5) (Hoja 7))"

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.2. Definir la función
     infijo :: "'a arbolH \<Rightarrow> 'a list"
  tal que (infijo x) es el recorrido infijo del árbol hoja x. Por
  ejemplo,
     infijo ejArbolH1 = [3,5,7]
  ------------------------------------------------------------------- *}

fun infijo :: "'a arbolH \<Rightarrow> 'a list"
where
  "infijo (Hoja x)   = [x]"
| "infijo (Nodo i d) = infijo i @ infijo d"

value "infijo ejArbolH1"
lemma "infijo ejArbolH1 = [3,5,7]" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.3. Consultar la definición de la función fold de plegado
  de listas.
  ------------------------------------------------------------------- *}

-- "Una forma de consultarlo es"
thm fold.simps

text {*
  El resultado es
     fold ?f []         = id
     fold ?f (?x # ?xs) = fold ?f ?xs \<circ> ?f ?x
  *}

-- "Otra forma de consultarlo es"
thm fold_simps

text {*
  El resultado es
     fold ?f [] ?s         = ?s
     fold ?f (?x # ?xs) ?s = fold ?f ?xs (?f ?x ?s)
  *}

-- "Se puede comprobar la definición"
lemma
  "fold f [] s     = s"
  "fold f (x#xs) s = fold f xs (f x s)"
by simp_all

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.4. Definir la función
     fold_arbolH :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a arbolH \<Rightarrow> 'b \<Rightarrow> 'b"
  tal que (fold_arbolH f x y) es plegado del árbol hoja x con la
  operación f y el valor inicial x. Por ejemplo,
     fold_arbolH op+ ejArbolH1 0 = 15
     fold_arbolH op* ejArbolH1 1 = 105
  ------------------------------------------------------------------- *}

fun fold_arbolH :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a arbolH \<Rightarrow> 'b \<Rightarrow> 'b"
where
  "fold_arbolH f (Hoja x) y   = f x y"
| "fold_arbolH f (Nodo i d) y = fold_arbolH f d (fold_arbolH f i y)"

value "fold_arbolH op+ ejArbolH1 0"
lemma "fold_arbolH op+ ejArbolH1 0 = 15" by simp
value "fold_arbolH op* ejArbolH1 1"
lemma "fold_arbolH op* ejArbolH1 1 = 105" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.5. Demostrar que
     fold_arbolH f x y = fold f (infijo x) y
  ------------------------------------------------------------------- *}

lemma "fold_arbolH f x y = fold f (infijo x) y"
by (induction x arbitrary: y) auto

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.6. Definir la función
     espejo :: "'a arbolH \<Rightarrow> 'a arbolH"
  tal que (espejo x) es la imagen especular del árbol x. Por ejemplo,
     espejo ejArbolH1 = Nodo (Nodo (Hoja 7) (Hoja 5)) (Hoja 3)
  ------------------------------------------------------------------- *}

fun espejo :: "'a arbolH \<Rightarrow> 'a arbolH"
where
  "espejo (Hoja x)   = Hoja x"
| "espejo (Nodo i d) = Nodo (espejo d) (espejo i)"

value "espejo ejArbolH1"
lemma "espejo ejArbolH1 = Nodo (Nodo (Hoja 7) (Hoja 5)) (Hoja 3)"
  by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 1.7. Demostrar que
     infijo (espejo t) = rev (infijo t)
  ------------------------------------------------------------------- *}

lemma "infijo (espejo t) = rev (infijo t)"
by (induction t) auto

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.1. [Alineamientos de lista]
  Un alineamiento de dos lista xs e ys es una lista cuyos elementos son
  los de xs e ys consevando su orden original. Por ejemplo, un
  alineamiento de [a,b] y [c,d,e] es [a,c,d,b,e] y otro es [c,a,d,e,b].

  Definir la función
     alineamientos :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  tal que (alineamientos xs ys) es la lista de los alineamientos de xs e
  ys. Por ejemplo,
     alineamientos [a,b] [c,d,e]
     = [[a,b,c,d,e],[a,c,b,d,e],[a,c,d,b,e],[a,c,d,e,b],[c,a,b,d,e],
        [c,a,d,b,e],[c,a,d,e,b],[c,d,a,b,e],[c,d,a,e,b],[c,d,e,a,b]]
  ------------------------------------------------------------------- *}

fun alineamientos :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
where
  "alineamientos xs []         = [xs]"
| "alineamientos [] ys         = [ys]"
| "alineamientos (x#xs) (y#ys) =
    map (op # x) (alineamientos xs (y#ys)) @
    map (op # y) (alineamientos (x#xs) ys)"

value "alineamientos [a,b] [c,d,e]"
lemma "alineamientos [a,b] [c,d,e] =
       [[a,b,c,d,e],[a,c,b,d,e],[a,c,d,b,e],[a,c,d,e,b],[c,a,b,d,e],
        [c,a,d,b,e],[c,a,d,e,b],[c,d,a,b,e],[c,d,a,e,b],[c,d,e,a,b]]"
  by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.2. Demostrar que la longitud de cualquier alineamiento de
  las listas xs e ys es la suma de las longitudes de los alineamientos
  de xs e ys.
  ------------------------------------------------------------------- *}

lemma "zs \<in> set (alineamientos xs ys) \<Longrightarrow>
       length zs = length xs + length ys"
apply (induction xs ys arbitrary: zs rule: alineamientos.induct)
apply auto
done

text {* Nota. La función set convierte una lista en el conjunto de sus
  elementos. Por ejemplo, el resultado de
     value "set [a,b,c]"
  es
     "{a, b, c}"
      :: "'a set"
  *}

text {*
  ----------------------------------------------------------------------
  Ejercicio 3.1. [Plegado de listas]

  Definir, por recursión, la función
     suma1 :: "int list \<Rightarrow> int"
  tal que (suma1 xs) es la suma de los elementos de la lista xs. Por
  ejemplo,
     suma1 [3,1,4] = 8
  ------------------------------------------------------------------- *}

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

value "suma1 [3,1,4]"
lemma "suma1 [3,1,4] = 8" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 3.2. Definir, por plegado, la función
     suma2 :: "int list \<Rightarrow> int"
  tal que (suma2 xs) es la suma de los elementos de la lista xs. Por
  ejemplo,
     suma2 [3,1,4] = 8
  ------------------------------------------------------------------- *}

definition suma2 :: "int list \<Rightarrow> int"
where
  "suma2 xs \<equiv> fold op+ xs 0"

text {*
  ----------------------------------------------------------------------
  Ejercicio 3.3. Demostrar que las funciones suma1 y suma2 son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux: "fold op+ xs a = suma1 xs + a"
by (induction xs arbitrary: a) auto

lemma "suma1 xs = suma2 xs"
by (simp add: aux suma2_def)

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.1. [Lista con elementos distintos]

  Definir, por recursión, la función
     pertenece :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  tal que (pertenece x ys) se verifica si x es un elemento de ys. Por
  ejemplo,
     pertenece 2 [7,2,5] = True
     pertenece 4 [7,2,5] = False
  ------------------------------------------------------------------- *}

fun pertenece :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "pertenece x []     = False"
| "pertenece x (y#ys) = (x = y \<or> pertenece x ys)"

value "pertenece 4 [7,2,(5::nat)]"
lemma "pertenece 4 [7,2,(5::nat)] = False" by simp
value "pertenece 2 [7,2,(5::nat)]"
lemma "pertenece 2 [7,2,(5::nat)] = True" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.2. Definir la función
     distintos :: "'a list \<Rightarrow> bool
  tal que (distintos xs) se verifica si la lista xs no tiene elementos
  repetidos. Por ejemplo,
     distintos [7,2,5] = True
     distintos [7,2,7] = False
  ------------------------------------------------------------------- *}

fun distintos :: "'a list \<Rightarrow> bool"
where
  "distintos []     = True"
| "distintos (x#xs) = (\<not>(pertenece x xs) \<and> distintos xs)"

value "distintos [7,2,(5::nat)]"
lemma "distintos [7,2,(5::nat)] = True" by simp
value "distintos [7,2,(7::nat)]"
lemma "distintos [7,2,(7::nat)] = False" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.3. Demostrar que la inversa de una lista no tiene
  repeticiones si, y sólo si, la lista original no tiene repeticiones.
  ------------------------------------------------------------------- *}

lemma pertenece_conc:
  "pertenece x (ys @ zs) = (pertenece x ys \<or> pertenece x zs)"
by (induction ys) simp_all

lemma pertenece_rev:
  "pertenece x (rev ys) = pertenece x ys"
by (induction ys) (auto simp add: pertenece_conc)

lemma distintos_conc:
  "distintos (xs @ [y]) = ( \<not>(pertenece y xs) \<and> distintos xs)"
by (induction xs) (auto simp add: pertenece_conc)

lemma "distintos (rev xs) = distintos xs"
by (induction xs) (auto simp add: distintos_conc pertenece_rev)

text {*
  ----------------------------------------------------------------------
  Ejercicio 5.1. [Plegados de listas por la derecha y por la izquierda]

  Consultar las definidiciones de fold y foldr
  ------------------------------------------------------------------- *}

thm fold.simps
thm foldr.simps

text {*
  El resultado es
    fold ?f []         = id
    fold ?f (?x # ?xs) = fold ?f ?xs \<circ> ?f ?x

    foldr ?f []         = id
    foldr ?f (?x # ?xs) = ?f ?x \<circ> foldr ?f ?xs
*}

lemma "fold  f [a,b,c] d = f c (f b (f a d))" by simp
lemma "foldr f [a,b,c] d = f a (f b (f c d))" by simp

lemma "foldr (op-) [1,2,3::int] 7 = (1 - (2 - (3 - 7)))" by auto
lemma "fold  (op-) [1,2,3::int] 7 = 3 - (2 - (1 - 7)) " by auto

text {*
  ----------------------------------------------------------------------
  Ejercicio 5.2. Definir, usando fold, la función
     longitud1 :: "'a list \<Rightarrow> nat"
  tal que (longitud1 xs) es la longitud de la lista xs. Por ejemplo,
     longitud1 [a,b,c] = 3
  ------------------------------------------------------------------- *}

definition longitud1 :: "'a list \<Rightarrow> nat"
where
  "longitud1 xs = fold (\<lambda>x. Suc) xs 0"

value "longitud1 [a,b,c]"
lemma "longitud1 [a,b,c] = 3" by (simp add: longitud1_def)

text {*
  ----------------------------------------------------------------------
  Ejercicio 5.3. Definir, usando fold, la función
     longitud2 :: "'a list \<Rightarrow> nat"
  tal que (longitud2 xs) es la longitud de la lista xs. Por ejemplo,
     longitud2 [a,b,c] = 3
  ------------------------------------------------------------------- *}

definition longitud2 :: "'a list \<Rightarrow> nat"
where
  "longitud2 xs = foldr (\<lambda>x. Suc) xs 0"

value "longitud2 [a,b,c]"
lemma "longitud2 [a,b,c] = 3" by (simp add: longitud2_def)

text {*
  ----------------------------------------------------------------------
  Ejercicio 5.4. Demostrar que las funciones longitud1 y length son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux_fold:
  "fold (\<lambda>x. Suc) xs y  = y + length xs"
by (induction xs arbitrary: y) auto

lemma "longitud1 xs = length xs"
by (simp add: longitud1_def aux_fold)

text {*
  ----------------------------------------------------------------------
  Ejercicio 5.5. Demostrar que las funciones longitud2 y length son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux_foldr:
  "foldr (\<lambda>x. Suc) xs y  = y + length xs"
by (induction xs arbitrary: y) auto

lemma "longitud2 xs = length xs"
by (simp add: longitud2_def aux_foldr)

text {*
  ----------------------------------------------------------------------
  Ejercicio 6.1. [Cortes de listas]

  Dada una lista xs, el corte de xs de longitud menor o igual que m con
  inicio en i es la lista formada por el elemento de xs en la posición i
  y en las m-1 siguientes posiciones (si existen dichos elementos).

  Definir la función
     corte :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
  tal que (corte xs i m) es el corte de xs de longitud menor o igual que
  m que empieza en la posición i. Por ejemplo,
     "corte [0,1,2,3,4,5,6] 2 3 = [2,3,4]
     "corte [0,1,2,3,4,5,6] 2 9 = [2,3,4,5,6]
     "corte [0,1,2,3,4,5,6] 9 9 = []
  ------------------------------------------------------------------- *}

definition corte :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "corte xs i m = take m (drop i xs)"

declare corte_def [simp]

lemma "corte [0,1,2,3,4,5,6 ::int] 2 3 = [2,3,4]" by simp
lemma "corte [0,1,2,3,4,5,6 ::int] 2 9 = [2,3,4,5,6]" by simp
lemma "corte [0,1,2,3,4,5,6 ::int] 9 9 = []" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 6.2. Demostrar que la concatenación de dos cortes adyacentes
  se puede expresar como un único corte.
  ------------------------------------------------------------------- *}

lemma "corte xs i m1 @ corte xs (i + m1) m2 = corte xs i (m1 + m2)"
by (induction xs) (auto simp add: take_add add.commute)

text {*
  Los lemas utilizados son
  + take_add:    take (i + j) xs = take i xs @ take j (drop i xs)
  + add.commute: a + b = b + a
*}

text {*
  ----------------------------------------------------------------------
  Ejercicio 6.3. Demostrar que los cortes en listas de elementos no
  repetidos no tienen elementos repetidos.
  ------------------------------------------------------------------- *}

lemma pertenece_take:
  "pertenece a (take n xs) \<Longrightarrow> pertenece a xs"
by (metis append_take_drop_id pertenece_conc)

lemma distintos_take:
  "distintos xs \<Longrightarrow> distintos (take n xs)"
apply (induction xs arbitrary: n)
apply simp
apply (case_tac n)
  apply (auto simp add: pertenece_take)
done

lemma pertenece_drop:
  "pertenece a (drop n xs) \<Longrightarrow> pertenece a xs"
by (metis append_take_drop_id pertenece_conc)

lemma distintos_drop:
  "distintos xs \<Longrightarrow> distintos (drop n xs)"
apply (induction xs arbitrary: n)
apply simp
apply (case_tac n)
  apply (auto simp add: pertenece_drop)
done

lemma "distintos xs \<Longrightarrow> distintos (corte xs i m)"
by (induct xs) (auto simp add: distintos_take distintos_drop)

end


(*
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)

section \<open>Some useful lemmas in topology\<close>

theory Missing_Topology imports "HOL-Analysis.Multivariate_Analysis"
begin

subsection \<open>Misc\<close>

lemma open_times_image:
  fixes S::"'a::real_normed_field set"
  assumes "open S" "c\<noteq>0"
  shows "open (((*) c) ` S)"
proof -
  let ?f = "\<lambda>x. x/c" and ?g="((*) c)"
  have "continuous_on UNIV ?f" using \<open>c\<noteq>0\<close> by (auto intro:continuous_intros)
  then have "open (?f -` S)" using \<open>open S\<close> by (auto elim:open_vimage)
  moreover have "?g ` S = ?f -` S" using \<open>c\<noteq>0\<close>
    using image_iff by fastforce
  ultimately show ?thesis by auto
qed

lemma image_linear_greaterThan:
  fixes x::"'a::linordered_field"
  assumes "c\<noteq>0"
  shows "((\<lambda>x. c*x+b) ` {x<..}) = (if c>0 then {c*x+b <..} else {..< c*x+b})"
using \<open>c\<noteq>0\<close>
  apply (auto simp add:image_iff field_simps)
  subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
  subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
done

lemma image_linear_lessThan:
  fixes x::"'a::linordered_field"
  assumes "c\<noteq>0"
  shows "((\<lambda>x. c*x+b) ` {..<x}) = (if c>0 then {..<c*x+b} else {c*x+b<..})"
using \<open>c\<noteq>0\<close>
  apply (auto simp add:image_iff field_simps)
  subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
  subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
done

lemma continuous_on_neq_split:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "\<forall>x\<in>s. f x\<noteq>y" "continuous_on s f" "connected s"
  shows "(\<forall>x\<in>s. f x>y) \<or> (\<forall>x\<in>s. f x<y)"
  by (smt (verit) assms connectedD_interval connected_continuous_image imageE image_eqI leI)

lemma
  fixes f::"'a::linorder_topology \<Rightarrow> 'b::topological_space"
  assumes "continuous_on {a..b} f" "a<b"
  shows continuous_on_at_left:"continuous (at_left b) f"
    and continuous_on_at_right:"continuous (at_right a) f"
  using assms continuous_on_Icc_at_leftD continuous_within apply blast
  using assms continuous_on_Icc_at_rightD continuous_within by blast

subsection \<open>More about @{term eventually}\<close>

lemma eventually_comp_filtermap:
    "eventually (P o f) F \<longleftrightarrow> eventually P (filtermap f F)"
  unfolding comp_def using eventually_filtermap by auto

lemma eventually_at_infinityI:
  fixes P::"'a::real_normed_vector \<Rightarrow> bool"
  assumes "\<And>x. c \<le> norm x \<Longrightarrow> P x"
  shows "eventually P at_infinity"
unfolding eventually_at_infinity using assms by auto

lemma eventually_at_bot_linorderI:
  fixes c::"'a::linorder"
  assumes "\<And>x. x \<le> c \<Longrightarrow> P x"
  shows "eventually P at_bot"
  using assms by (auto simp: eventually_at_bot_linorder)

subsection \<open>More about @{term filtermap}\<close>

lemma filtermap_linear_at_within:
  assumes "bij f" and cont: "isCont f a" and open_map: "\<And>S. open S \<Longrightarrow> open (f`S)"
  shows "filtermap f (at a within S) = at (f a) within f`S"
  unfolding filter_eq_iff
proof safe
  fix P
  assume "eventually P (filtermap f (at a within S))"
  then obtain T where "open T" "a \<in> T" and impP:"\<forall>x\<in>T. x\<noteq>a \<longrightarrow> x\<in>S\<longrightarrow> P (f x)"
    by (auto simp: eventually_filtermap eventually_at_topological)
  then show "eventually P (at (f a) within f ` S)"
    unfolding eventually_at_topological
    apply (intro exI[of _ "f`T"])
    using \<open>bij f\<close> open_map by (metis bij_pointE imageE imageI)
next
  fix P
  assume "eventually P (at (f a) within f ` S)"
  then obtain T1 where "open T1" "f a \<in> T1" and impP:"\<forall>x\<in>T1. x\<noteq>f a \<longrightarrow> x\<in>f`S\<longrightarrow> P (x)"
    unfolding eventually_at_topological by auto
  then obtain T2 where "open T2" "a \<in> T2" "(\<forall>x'\<in>T2. f x' \<in> T1)"
    using cont[unfolded continuous_at_open,rule_format,of T1] by blast
  then have "\<forall>x\<in>T2. x\<noteq>a \<longrightarrow> x\<in>S\<longrightarrow> P (f x)"
    using impP by (metis assms(1) bij_pointE imageI)
  then show "eventually P (filtermap f (at a within S))"
    unfolding eventually_filtermap eventually_at_topological
    apply (intro exI[of _ T2])
    using \<open>open T2\<close> \<open>a \<in> T2\<close> by auto
qed

lemma filtermap_at_bot_linear_eq:
  fixes c::"'a::linordered_field"
  assumes "c\<noteq>0"
  shows "filtermap (\<lambda>x. x * c + b) at_bot = (if c>0 then at_bot else at_top)"
proof (cases "c>0")
  case True
  then have "filtermap (\<lambda>x. x * c + b) at_bot = at_bot"
    apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
    subgoal unfolding eventually_at_bot_linorder filterlim_at_bot
      by (auto simp add: field_simps)
    subgoal unfolding eventually_at_bot_linorder filterlim_at_bot
      by (metis mult.commute real_affinity_le)
    by auto
  then show ?thesis using \<open>c>0\<close> by auto
next
  case False
  then have "c<0" using \<open>c\<noteq>0\<close> by auto
  then have "filtermap (\<lambda>x. x * c + b) at_bot = at_top"
    apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
    subgoal unfolding eventually_at_top_linorder filterlim_at_bot
      by (meson le_diff_eq neg_divide_le_eq)
    subgoal unfolding eventually_at_bot_linorder filterlim_at_top
      using \<open>c < 0\<close> by (meson False diff_le_eq le_divide_eq)
    by auto
  then show ?thesis using \<open>c<0\<close> by auto
qed

lemma filtermap_linear_at_left:
  fixes c::"'a::{linordered_field,linorder_topology,real_normed_field}"
  assumes "c\<noteq>0"
  shows "filtermap (\<lambda>x. c*x+b) (at_left x) = (if c>0 then at_left (c*x+b) else at_right (c*x+b))"
proof -
  let ?f = "\<lambda>x. c*x+b"
  have "filtermap (\<lambda>x. c*x+b) (at_left x) = (at (?f x) within ?f ` {..<x})"
  proof (subst filtermap_linear_at_within)
    show "bij ?f" using \<open>c\<noteq>0\<close>
      by (auto intro!: o_bij[of "\<lambda>x. (x-b)/c"])
    show "isCont ?f x" by auto
    show "\<And>S. open S \<Longrightarrow> open (?f ` S)"
      using open_times_image[OF _ \<open>c\<noteq>0\<close>,THEN open_translation,of _ b]
      by (simp add:image_image add.commute)
    show "at (?f x) within ?f ` {..<x} = at (?f x) within ?f ` {..<x}" by simp
  qed
  moreover have "?f ` {..<x} =  {..<?f x}" when "c>0"
    using image_linear_lessThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
  moreover have "?f ` {..<x} =  {?f x<..}" when "\<not> c>0"
    using image_linear_lessThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
  ultimately show ?thesis by auto
qed

lemma filtermap_linear_at_right:
  fixes c::"'a::{linordered_field,linorder_topology,real_normed_field}"
  assumes "c\<noteq>0"
  shows "filtermap (\<lambda>x. c*x+b) (at_right x) = (if c>0 then at_right (c*x+b) else at_left (c*x+b))"
proof -
  let ?f = "\<lambda>x. c*x+b"
  have "filtermap ?f (at_right x) = (at (?f x) within ?f ` {x<..})"
  proof (subst filtermap_linear_at_within)
    show "bij ?f" using \<open>c\<noteq>0\<close>
      by (auto intro!: o_bij[of "\<lambda>x. (x-b)/c"])
    show "isCont ?f x" by auto
    show "\<And>S. open S \<Longrightarrow> open (?f ` S)"
      using open_times_image[OF _ \<open>c\<noteq>0\<close>,THEN open_translation,of _ b]
      by (simp add:image_image add.commute)
    show "at (?f x) within ?f ` {x<..} = at (?f x) within ?f ` {x<..}" by simp
  qed
  moreover have "?f ` {x<..} =  {?f x<..}" when "c>0"
    using image_linear_greaterThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
  moreover have "?f ` {x<..} =  {..<?f x}" when "\<not> c>0"
    using image_linear_greaterThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
  ultimately show ?thesis by auto
qed

lemma filtermap_at_top_linear_eq:
  fixes c::"'a::linordered_field"
  assumes "c\<noteq>0"
  shows "filtermap (\<lambda>x. x * c + b) at_top = (if c>0 then at_top else at_bot)"
proof (cases "c>0")
  case True
  then have "filtermap (\<lambda>x. x * c + b) at_top = at_top"
    apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
    subgoal unfolding eventually_at_top_linorder filterlim_at_top
      by (meson le_diff_eq pos_le_divide_eq)
    subgoal unfolding eventually_at_top_linorder filterlim_at_top
      apply auto
      by (metis mult.commute real_le_affinity)
    by auto
  then show ?thesis using \<open>c>0\<close> by auto
next
  case False
  then have "c<0" using \<open>c\<noteq>0\<close> by auto
  then have "filtermap (\<lambda>x. x * c + b) at_top = at_bot"
    apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
    subgoal unfolding eventually_at_bot_linorder filterlim_at_top
      by (auto simp add: field_simps)
    subgoal unfolding eventually_at_top_linorder filterlim_at_bot
      by (meson le_diff_eq neg_divide_le_eq)
    by auto
  then show ?thesis using \<open>c<0\<close> by auto
qed

subsection \<open>More about @{term filterlim}\<close>

lemma filterlim_at_top_linear_iff:
  fixes f::"'a::linordered_field \<Rightarrow> 'b"
  assumes "c\<noteq>0"
  shows "(LIM x at_top. f (x * c + b) :> F2) \<longleftrightarrow> (if c>0 then (LIM x at_top. f x :> F2)
            else (LIM x at_bot. f x :> F2))"
  unfolding filterlim_def
  apply (subst filtermap_filtermap[of f "\<lambda>x. x * c + b",symmetric])
  using assms by (auto simp add:filtermap_at_top_linear_eq)

lemma filterlim_at_bot_linear_iff:
  fixes f::"'a::linordered_field \<Rightarrow> 'b"
  assumes "c\<noteq>0"
  shows "(LIM x at_bot. f (x * c + b) :> F2) \<longleftrightarrow> (if c>0 then (LIM x at_bot. f x :> F2)
            else (LIM x at_top. f x :> F2)) "
  unfolding filterlim_def
  apply (subst filtermap_filtermap[of f "\<lambda>x. x * c + b",symmetric])
  using assms by (auto simp add:filtermap_at_bot_linear_eq)

lemma filterlim_tendsto_add_at_top_iff:
  assumes f: "(f \<longlongrightarrow> c) F"
  shows "(LIM x F. (f x + g x :: real) :> at_top) \<longleftrightarrow> (LIM x F. g x :> at_top)"
proof
  assume "LIM x F. f x + g x :> at_top"
  moreover have "((\<lambda>x. - f x) \<longlongrightarrow> - c) F"
    using f by (intro tendsto_intros,simp)
  ultimately show "filterlim g at_top F" using filterlim_tendsto_add_at_top
    by fastforce
qed (auto simp add:filterlim_tendsto_add_at_top[OF f])

lemma filterlim_tendsto_add_at_bot_iff:
  fixes c::real
  assumes f: "(f \<longlongrightarrow> c) F"
  shows "(LIM x F. f x + g x :> at_bot) \<longleftrightarrow> (LIM x F. g x :> at_bot)"
proof -
  have "(LIM x F. f x + g x :> at_bot)
        \<longleftrightarrow>  (LIM x F. - f x + (- g x)  :> at_top)"
    apply (subst filterlim_uminus_at_top)
    by (rule filterlim_cong,auto)
  also have "... = (LIM x F. - g x  :> at_top)"
    apply (subst filterlim_tendsto_add_at_top_iff[of _ "-c"])
    by (auto intro:tendsto_intros simp add:f)
  also have "... = (LIM x F. g x  :> at_bot)"
    apply (subst filterlim_uminus_at_top)
    by (rule filterlim_cong,auto)
  finally show ?thesis .
qed

lemma tendsto_inverse_0_at_infinity:
    "LIM x F. f x :> at_infinity \<Longrightarrow> ((\<lambda>x. inverse (f x) :: real) \<longlongrightarrow> 0) F"
  by (metis filterlim_at filterlim_inverse_at_iff)

(*
lemma filterlim_at_top_tendsto[elim]:
  fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
  assumes top:"filterlim f at_top F" and tendsto: "(f \<longlongrightarrow> c) F"
          and "F\<noteq>bot"
  shows False
proof -
  obtain cc where "cc>c" using gt_ex by blast
  have "\<forall>\<^sub>F x in F. cc < f x"
    using top unfolding filterlim_at_top_dense by auto
  moreover have "\<forall>\<^sub>F x in F. f x < cc"
    using tendsto order_tendstoD(2)[OF _ \<open>cc>c\<close>] by auto
  ultimately have "\<forall>\<^sub>F x in F. cc < f x \<and> f x < cc"
    using eventually_conj by auto
  then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
  then show False using \<open>F\<noteq>bot\<close> by auto
qed

lemma filterlim_at_bot_tendsto[elim]:
  fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
  assumes top:"filterlim f at_bot F" and tendsto: "(f \<longlongrightarrow> c) F"
          and "F\<noteq>bot"
  shows False
proof -
  obtain cc where "cc<c" using lt_ex by blast
  have "\<forall>\<^sub>F x in F. cc > f x"
    using top unfolding filterlim_at_bot_dense by auto
  moreover have "\<forall>\<^sub>F x in F. f x > cc"
    using tendsto order_tendstoD(1)[OF _ \<open>cc<c\<close>] by auto
  ultimately have "\<forall>\<^sub>F x in F. cc < f x \<and> f x < cc"
    using eventually_conj by auto
  then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
  then show False using \<open>F\<noteq>bot\<close> by auto
qed
*)

end


(*  Author:     Steven Obua, TU Muenchen *)

section \<open>Various algebraic structures combined with a lattice\<close>

theory Lattice_Algebras
  imports Complex_Main
begin

class semilattice_inf_ab_group_add = ordered_ab_group_add + semilattice_inf
begin

lemma add_inf_distrib_left: "a + inf b c = inf (a + b) (a + c)"
  apply (rule order.antisym)
   apply (simp_all add: le_infI)
  apply (rule add_le_imp_le_left [of "uminus a"])
  apply (simp only: add.assoc [symmetric], simp add: diff_le_eq add.commute)
  done

lemma add_inf_distrib_right: "inf a b + c = inf (a + c) (b + c)"
proof -
  have "c + inf a b = inf (c + a) (c + b)"
    by (simp add: add_inf_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class semilattice_sup_ab_group_add = ordered_ab_group_add + semilattice_sup
begin

lemma add_sup_distrib_left: "a + sup b c = sup (a + b) (a + c)"
  apply (rule order.antisym)
   apply (rule add_le_imp_le_left [of "uminus a"])
   apply (simp only: add.assoc [symmetric], simp)
   apply (simp add: le_diff_eq add.commute)
  apply (rule le_supI)
   apply (rule add_le_imp_le_left [of "a"], simp only: add.assoc[symmetric], simp)+
  done

lemma add_sup_distrib_right: "sup a b + c = sup (a + c) (b + c)"
proof -
  have "c + sup a b = sup (c+a) (c+b)"
    by (simp add: add_sup_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class lattice_ab_group_add = ordered_ab_group_add + lattice
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

lemma inf_eq_neg_sup: "inf a b = - sup (- a) (- b)"
proof (rule inf_unique)
  fix a b c :: 'a
  show "- sup (- a) (- b) \<le> a"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  show "- sup (-a) (-b) \<le> b"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  assume "a \<le> b" "a \<le> c"
  then show "a \<le> - sup (-b) (-c)"
    by (subst neg_le_iff_le [symmetric]) (simp add: le_supI)
qed

lemma sup_eq_neg_inf: "sup a b = - inf (- a) (- b)"
proof (rule sup_unique)
  fix a b c :: 'a
  show "a \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "b \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "- inf (- a) (- b) \<le> c" if "a \<le> c" "b \<le> c"
    using that by (subst neg_le_iff_le [symmetric]) (simp add: le_infI)
qed

lemma neg_inf_eq_sup: "- inf a b = sup (- a) (- b)"
  by (simp add: inf_eq_neg_sup)

lemma diff_inf_eq_sup: "a - inf b c = a + sup (- b) (- c)"
  using neg_inf_eq_sup [of b c, symmetric] by simp

lemma neg_sup_eq_inf: "- sup a b = inf (- a) (- b)"
  by (simp add: sup_eq_neg_inf)

lemma diff_sup_eq_inf: "a - sup b c = a + inf (- b) (- c)"
  using neg_sup_eq_inf [of b c, symmetric] by simp

lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
proof -
  have "0 = - inf 0 (a - b) + inf (a - b) 0"
    by (simp add: inf_commute)
  then have "0 = sup 0 (b - a) + inf (a - b) 0"
    by (simp add: inf_eq_neg_sup)
  then have "0 = (- a + sup a b) + (inf a b + (- b))"
    by (simp only: add_sup_distrib_left add_inf_distrib_right) simp
  then show ?thesis
    by (simp add: algebra_simps)
qed

subsection \<open>Positive Part, Negative Part, Absolute Value\<close>

definition nprt :: "'a \<Rightarrow> 'a"
  where "nprt x = inf x 0"

definition pprt :: "'a \<Rightarrow> 'a"
  where "pprt x = sup x 0"

lemma pprt_neg: "pprt (- x) = - nprt x"
proof -
  have "sup (- x) 0 = sup (- x) (- 0)"
    by (simp only: minus_zero)
  also have "\<dots> = - inf x 0"
    by (simp only: neg_inf_eq_sup)
  finally have "sup (- x) 0 = - inf x 0" .
  then show ?thesis
    by (simp only: pprt_def nprt_def)
qed

lemma nprt_neg: "nprt (- x) = - pprt x"
proof -
  from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
  then have "pprt x = - nprt (- x)" by simp
  then show ?thesis by simp
qed

lemma prts: "a = pprt a + nprt a"
  by (simp add: pprt_def nprt_def flip: add_eq_inf_sup)

lemma zero_le_pprt[simp]: "0 \<le> pprt a"
  by (simp add: pprt_def)

lemma nprt_le_zero[simp]: "nprt a \<le> 0"
  by (simp add: nprt_def)

lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  show ?rhs
    by (rule add_le_imp_le_right[of _ "uminus b" _]) (simp add: add.assoc \<open>?lhs\<close>)
next
  assume ?rhs
  show ?lhs
    by (rule add_le_imp_le_right[of _ "b" _]) (simp add: \<open>?rhs\<close>)
qed

lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)

lemma pprt_eq_id [simp, no_atp]: "0 \<le> x \<Longrightarrow> pprt x = x"
  by (simp add: pprt_def sup_absorb1)

lemma nprt_eq_id [simp, no_atp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
  by (simp add: nprt_def inf_absorb1)

lemma pprt_eq_0 [simp, no_atp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
  by (simp add: pprt_def sup_absorb2)

lemma nprt_eq_0 [simp, no_atp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
  by (simp add: nprt_def inf_absorb2)

lemma sup_0_imp_0:
  assumes "sup a (- a) = 0"
  shows "a = 0"
proof -
  have pos: "0 \<le> a" if "sup a (- a) = 0" for a :: 'a
  proof -
    from that have "sup a (- a) + a = a"
      by simp
    then have "sup (a + a) 0 = a"
      by (simp add: add_sup_distrib_right)
    then have "sup (a + a) 0 \<le> a"
      by simp
    then show ?thesis
      by (blast intro: order_trans inf_sup_ord)
  qed
  from assms have **: "sup (-a) (-(-a)) = 0"
    by (simp add: sup_commute)
  from pos[OF assms] pos[OF **] show "a = 0"
    by simp
qed

lemma inf_0_imp_0: "inf a (- a) = 0 \<Longrightarrow> a = 0"
  apply (simp add: inf_eq_neg_sup)
  apply (simp add: sup_commute)
  apply (erule sup_0_imp_0)
  done

lemma inf_0_eq_0 [simp, no_atp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule inf_0_imp_0)
  apply simp
  done

lemma sup_0_eq_0 [simp, no_atp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule sup_0_imp_0)
  apply simp
  done

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have a: "inf (a + a) 0 = 0"
      by (simp add: inf_commute inf_absorb1)
    have "inf a 0 + inf a 0 = inf (inf (a + a) 0) a"  (is "?l = _")
      by (simp add: add_sup_inf_distribs inf_aci)
    then have "?l = 0 + inf a 0"
      by (simp add: a, simp add: inf_commute)
    then have "inf a 0 = 0"
      by (simp only: add_right_cancel)
    then show ?thesis
      unfolding le_iff_inf by (simp add: inf_commute)
  qed
  show ?lhs if ?rhs
    by (simp add: add_mono[OF that that, simplified])
qed

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
  using add_nonneg_eq_0_iff order.eq_iff by auto

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
  by (meson le_less_trans less_add_same_cancel2 less_le_not_le
      zero_le_double_add_iff_zero_le_single_add)

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)"
    by (subst le_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a \<le> 0"
    by (simp only: minus_add_distrib zero_le_double_add_iff_zero_le_single_add) simp
  ultimately show ?thesis
    by blast
qed

lemma double_add_less_zero_iff_single_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)"
    by (subst less_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a < 0"
    by (simp only: minus_add_distrib zero_less_double_add_iff_zero_less_single_add) simp
  ultimately show ?thesis
    by blast
qed

declare neg_inf_eq_sup [simp]
  and neg_sup_eq_inf [simp]
  and diff_inf_eq_sup [simp]
  and diff_sup_eq_inf [simp]

lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
proof -
  from add_le_cancel_left [of "uminus a" "plus a a" zero]
  have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
    using add_le_cancel_left [of "uminus a" zero "plus a a"]
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma pprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
  unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])

lemma nprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
  unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])

end

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

class lattice_ab_group_add_abs = lattice_ab_group_add + abs +
  assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
begin

lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
proof -
  have "0 \<le> \<bar>a\<bar>"
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show ?thesis
      by (rule add_mono [OF a b, simplified])
  qed
  then have "0 \<le> sup a (- a)"
    unfolding abs_lattice .
  then have "sup (sup a (- a)) 0 = sup a (- a)"
    by (rule sup_absorb1)
  then show ?thesis
    by (simp add: add_sup_inf_distribs ac_simps pprt_def nprt_def abs_lattice)
qed

subclass ordered_ab_group_add_abs
proof
  have abs_ge_zero [simp]: "0 \<le> \<bar>a\<bar>" for a
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show "0 \<le> \<bar>a\<bar>"
      by (rule add_mono [OF a b, simplified])
  qed
  have abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" for a b
    by (simp add: abs_lattice le_supI)
  fix a b
  show "0 \<le> \<bar>a\<bar>"
    by simp
  show "a \<le> \<bar>a\<bar>"
    by (auto simp add: abs_lattice)
  show "\<bar>-a\<bar> = \<bar>a\<bar>"
    by (simp add: abs_lattice sup_commute)
  show "- a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" if "a \<le> b"
    using that by (rule abs_leI)
  show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
  proof -
    have g: "\<bar>a\<bar> + \<bar>b\<bar> = sup (a + b) (sup (- a - b) (sup (- a + b) (a + (- b))))"
      (is "_ = sup ?m ?n")
      by (simp add: abs_lattice add_sup_inf_distribs ac_simps)
    have a: "a + b \<le> sup ?m ?n"
      by simp
    have b: "- a - b \<le> ?n"
      by simp
    have c: "?n \<le> sup ?m ?n"
      by simp
    from b c have d: "- a - b \<le> sup ?m ?n"
      by (rule order_trans)
    have e: "- a - b = - (a + b)"
      by simp
    from a d e have "\<bar>a + b\<bar> \<le> sup ?m ?n"
      apply -
      apply (drule abs_leI)
       apply (simp_all only: algebra_simps minus_add)
      apply (metis add_uminus_conv_diff d sup_commute uminus_add_conv_diff)
      done
    with g[symmetric] show ?thesis by simp
  qed
qed

end

lemma sup_eq_if:
  fixes a :: "'a::{lattice_ab_group_add,linorder}"
  shows "sup a (- a) = (if a < 0 then - a else a)"
  using add_le_cancel_right [of a a "- a", symmetric, simplified]
    and add_le_cancel_right [of "-a" a a, symmetric, simplified]
  by (auto simp: sup_max max.absorb1 max.absorb2)

lemma abs_if_lattice:
  fixes a :: "'a::{lattice_ab_group_add_abs,linorder}"
  shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
  by auto

lemma estimate_by_abs:
  fixes a b c :: "'a::lattice_ab_group_add_abs"
  assumes "a + b \<le> c"
  shows "a \<le> c + \<bar>b\<bar>"
proof -
  from assms have "a \<le> c + (- b)"
    by (simp add: algebra_simps)
  have "- b \<le> \<bar>b\<bar>"
    by (rule abs_ge_minus_self)
  then have "c + (- b) \<le> c + \<bar>b\<bar>"
    by (rule add_left_mono)
  with \<open>a \<le> c + (- b)\<close> show ?thesis
    by (rule order_trans)
qed

class lattice_ring = ordered_ring + lattice_ab_group_add_abs
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

end

lemma abs_le_mult:
  fixes a b :: "'a::lattice_ring"
  shows "\<bar>a * b\<bar> \<le> \<bar>a\<bar> * \<bar>b\<bar>"
proof -
  let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
  let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
  have a: "\<bar>a\<bar> * \<bar>b\<bar> = ?x"
    by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
  have bh: "u = a \<Longrightarrow> v = b \<Longrightarrow>
            u * v = pprt a * pprt b + pprt a * nprt b +
                    nprt a * pprt b + nprt a * nprt b" for u v :: 'a
    apply (subst prts[of u], subst prts[of v])
    apply (simp add: algebra_simps)
    done
  note b = this[OF refl[of a] refl[of b]]
  have xy: "- ?x \<le> ?y"
    apply simp
    apply (metis (full_types) add_increasing add_uminus_conv_diff
      lattice_ab_group_add_class.minus_le_self_iff minus_add_distrib mult_nonneg_nonneg
      mult_nonpos_nonpos nprt_le_zero zero_le_pprt)
    done
  have yx: "?y \<le> ?x"
    apply simp
    apply (metis (full_types) add_nonpos_nonpos add_uminus_conv_diff
      lattice_ab_group_add_class.le_minus_self_iff minus_add_distrib mult_nonneg_nonpos
      mult_nonpos_nonneg nprt_le_zero zero_le_pprt)
    done
  have i1: "a * b \<le> \<bar>a\<bar> * \<bar>b\<bar>"
    by (simp only: a b yx)
  have i2: "- (\<bar>a\<bar> * \<bar>b\<bar>) \<le> a * b"
    by (simp only: a b xy)
  show ?thesis
    apply (rule abs_leI)
    apply (simp add: i1)
    apply (simp add: i2[simplified minus_le_iff])
    done
qed

instance lattice_ring \<subseteq> ordered_ring_abs
proof
  fix a b :: "'a::lattice_ring"
  assume a: "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
  show "\<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
  proof -
    have s: "(0 \<le> a * b) \<or> (a * b \<le> 0)"
      apply auto
      apply (rule_tac split_mult_pos_le)
      apply (rule_tac contrapos_np[of "a * b \<le> 0"])
      apply simp
      apply (rule_tac split_mult_neg_le)
      using a
      apply blast
      done
    have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
      by (simp flip: prts)
    show ?thesis
    proof (cases "0 \<le> a * b")
      case True
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        using a
        apply (auto simp add:
          algebra_simps
          iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
          iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
        apply(drule (1) mult_nonneg_nonpos[of a b], simp)
        apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
        done
    next
      case False
      with s have "a * b \<le> 0"
        by simp
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        apply (insert a)
        apply (auto simp add: algebra_simps)
        apply(drule (1) mult_nonneg_nonneg[of a b],simp)
        apply(drule (1) mult_nonpos_nonpos[of a b],simp)
        done
    qed
  qed
qed

lemma mult_le_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<le>
    pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    by (subst prts[symmetric])+ simp
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b \<le> pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b \<le> pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b \<le> pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 \<le> pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b \<le> nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b \<le> nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b \<le> nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b \<le> nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b \<le> nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 \<le> nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_ge_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<ge>
    nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
proof -
  from assms have a1: "- a2 \<le> -a"
    by auto
  from assms have a2: "- a \<le> -a1"
    by auto
  from mult_le_prts[of "- a2" "- a" "- a1" "b1" b "b2",
    OF a1 a2 assms(3) assms(4), simplified nprt_neg pprt_neg]
  have le: "- (a * b) \<le>
    - nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
    - pprt a1 * pprt b1 + - pprt a2 * nprt b1"
    by simp
  then have "- (- nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
      - pprt a1 * pprt b1 + - pprt a2 * nprt b1) \<le> a * b"
    by (simp only: minus_le_iff)
  then show ?thesis
    by (simp add: algebra_simps)
qed

instance int :: lattice_ring
proof
  show "\<bar>k\<bar> = sup k (- k)" for k :: int
    by (auto simp add: sup_int_def)
qed

instance real :: lattice_ring
proof
  show "\<bar>a\<bar> = sup a (- a)" for a :: real
    by (auto simp add: sup_real_def)
qed

end


theory Walk
  imports
    Graph
    "Misc"
begin

section \<open>Walks\<close>

text \<open>
A walk is an alternating sequence v_0, e_1, v_2, ..., e_k, v_k of vertices v_i and edges e_i
such that the endpoints of e_i are v_{i-1} and v_i for every i = 1, ..., k.
We represent a walk by the sequence of its vertices.
\<close>

type_synonym 'a walk = "'a list"

(* Adapted from the formalization of undirected graphs by Mohammad Abdulaziz. *)
inductive consistent_seq where
  consistent_seq_Nil: "consistent_seq G []" |
  consistent_seq_Cons: "v \<in> vertices G \<Longrightarrow> consistent_seq G [v]" |
  consistent_seq_Cons_Cons: "\<lbrakk> {v, v'} \<in> edges G; consistent_seq G (v' # vs) \<rbrakk> \<Longrightarrow>
    consistent_seq G (v # v' # vs)"

declare consistent_seq_Nil [simp]
inductive_simps consistent_seq_Cons [simp]: "consistent_seq G [v]"
inductive_simps consistent_seq_Cons_Cons [simp]: "consistent_seq G (v # v' # vs)"

definition walk :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a walk \<Rightarrow> 'a \<Rightarrow> bool" where
  "walk G u p v \<equiv> p \<noteq> [] \<and> u = hd p \<and> v = last p \<and> consistent_seq G p"

text \<open>A walk is closed if its endpoints are the same.\<close>

abbreviation closed_walk :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a walk \<Rightarrow> bool" where
  "closed_walk G v c \<equiv> walk G v c v \<and> Suc 0 < length c"

(* Adapted from the formalization of undirected graphs by Mohammad Abdulaziz. *)
fun walk_edges :: "'a walk \<Rightarrow> 'a set list" where
  "walk_edges [] = []" |
  "walk_edges [v] = []" |
  "walk_edges (v # v' # vs) = {v, v'} # (walk_edges (v' # vs))"

lemmas walk_induct = walk_edges.induct

text \<open>The length of a walk is the number of its edges.\<close>

abbreviation walk_length :: "'a walk \<Rightarrow> nat" where
  "walk_length p \<equiv> length (walk_edges p)"

subsection \<open>Basic Lemmas\<close>

lemma Cons_Cons_walk_iff:
  shows "walk G u (v # v' # vs) w \<longleftrightarrow> u = v \<and> {v, v'} \<in> edges G \<and> walk G v' (v' # vs) w"
  by (auto simp add: walk_def)

lemma singleton_is_walk:
  assumes "v \<in> vertices G"
  shows "walk G v [v] v"
  using assms
  by (simp add: walk_def)

lemma (in graph) edge_is_walk:
  assumes "{u, v} \<in> edges G"
  shows "walk G u [u, v] v"
proof -
  have "{u, v} \<subseteq> vertices G"
    using assms
    by (rule edge_subset_vertices)
  hence "v \<in> vertices G"
    by simp
  hence "walk G v [v] v"
    by (simp add: walk_def)
  thus ?thesis
    using assms
    by (simp add: Cons_Cons_walk_iff)
qed

lemma (in graph) edge_iff_walk:
  shows "{u, v} \<in> edges G = walk G u [u, v] v"
proof
  assume "{u, v} \<in> edges G"
  thus "walk G u [u, v] v"
    by (rule edge_is_walk)
next
  assume "walk G u [u, v] v"
  thus "{u, v} \<in> edges G"
    by (simp add: Cons_Cons_walk_iff)
qed

lemma walk_length:
  assumes "p \<noteq> []"
  shows "length p = Suc (walk_length p)"
  using assms
  by (induction p rule: walk_induct) simp+

(**)
subsection \<open>\<close>

lemma (in graph) walk_in_vertices:
  assumes "walk G u p v"
  assumes "w \<in> set p"
  shows "w \<in> vertices G"
  using assms
proof (induction p arbitrary: u rule: walk_induct)
  case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by (simp add: walk_def)
next
  case (3 _ _ _)
  thus ?case
    using Union_edges_subset_vertices
    by (auto simp add: walk_def)
qed

lemma (in graph) walk_hd_in_vertices:
  assumes "walk G u p v"
  shows "u \<in> vertices G"
  using assms
  by (intro walk_in_vertices) (simp add: walk_def)+

lemma (in graph) walk_last_in_vertices:
  assumes "walk G u p v"
  shows "v \<in> vertices G"
  using assms
  by (intro walk_in_vertices) (simp add: walk_def)+

lemma walk_hd_neq_last_implies_edges_non_empty:
  assumes "walk G u p v"
  assumes "u \<noteq> v"
  shows "edges G \<noteq> {}"
  using assms
  by (induction p rule: walk_induct) (auto simp add: walk_def)

lemma walk_edges_in_edges:
  assumes "walk G u p w"
  shows "set (walk_edges p) \<subseteq> edges G"
  using assms
proof (induction p arbitrary: u rule: walk_induct)
  case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by simp
next
  case (3 v v' vs)
  have "walk G v' (v' # vs) w"
    using "3.prems"
    by (simp add: Cons_Cons_walk_iff)
  hence "set (walk_edges (v' # vs)) \<subseteq> edges G"
    by (rule "3.IH")
  moreover have "{v, v'} \<in> edges G"
    using "3.prems"
    by (simp add: Cons_Cons_walk_iff)
  ultimately show ?case
    by simp
qed

subsection \<open>Prefixes/suffixes of walks\<close>

lemma (in graph) walk_prefix_is_walk:
  assumes "p \<noteq> []"
  assumes "walk G u (p @ q) w"
  shows "walk G u p (last p)"
  using assms
proof (induction p arbitrary: u rule: walk_induct)
  case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by (auto simp add: walk_def intro: walk_in_vertices)
next
  case (3 _ _ _)
  thus ?case
    by (simp add: walk_def)
qed

lemma tl_consistent_seq:
  assumes "consistent_seq G p"
  shows "consistent_seq G (tl p)"
  using assms
  by (induction p rule: walk_induct) simp+

lemma suffix_consistent_seq:
  assumes "consistent_seq G (p @ q)"
  shows "consistent_seq G q"
  using assms
proof (induction p rule: walk_induct)
  case 1
  thus ?case
    by simp
next
  case (2 v)
  hence "consistent_seq G (v # q)"
    by simp
  hence "consistent_seq G (tl (v # q))"
    by (rule tl_consistent_seq)
  thus ?case
    by simp
next
  case (3 _ _ _)
  thus ?case
    by simp
qed

lemma (in graph) walk_suffix_is_walk:
  assumes "q \<noteq> []"
  assumes "walk G u (p @ q) w"
  shows "walk G (hd q) q w"
  using assms
proof (induction q arbitrary: u rule: walk_induct)
  case 1
  thus ?case
    by simp
next
  case (2 v)
  have "v \<in> vertices G"
    using "2.prems"(2)
    by (rule walk_in_vertices) simp
  thus ?case
    using "2.prems"(2)
    by (simp add: walk_def)
next
  case (3 v v' vs)
  have "consistent_seq G (p @ v # v' # vs)"
    using "3.prems"(2)
    by (simp add: walk_def)
  hence "consistent_seq G (v # v' # vs)"
    by (rule suffix_consistent_seq)
  thus ?case
    using "3.prems"(2)
    by (simp add: walk_def)
qed

subsection \<open>Appending walks\<close>

lemma append_consistent_seq:
  assumes "consistent_seq G p"
  assumes q_consistent_seq: "consistent_seq G q"
  assumes "{last p, hd q} \<in> edges G"
  shows "consistent_seq G (p @ q)"
  using assms(1, 3)
proof (induction p rule: walk_induct)
case 1
  show ?case
    using q_consistent_seq
    by simp
next
  case (2 _)
  show ?case
  proof (cases q)
    case Nil
    thus ?thesis
      using "2.prems"(1)
      by simp
  next
    case (Cons _ _)
    thus ?thesis
      using "2.prems"(2) q_consistent_seq
      by simp
  qed
next
  case (3 _ _ _)
  thus ?case
    by simp
qed

lemma append_consistent_seq_2:
  assumes p_consistent_seq: "consistent_seq G p"
  assumes q_consistent_seq: "consistent_seq G q"
  assumes "last p = hd q"
  shows "consistent_seq G (p @ tl q)"
proof (cases "tl q")
  case Nil
  thus ?thesis
    using p_consistent_seq
    by simp
next
  case (Cons _ _)
  hence "q \<noteq> []"
    by auto
  hence "q = hd q # tl q"
    by (rule hd_Cons_tl[symmetric])
  hence "consistent_seq G (hd q # tl q)"
    using q_consistent_seq
    by simp
  hence "{hd q, hd (tl q)} \<in> edges G"
    using q_consistent_seq
    by (simp add: Cons)
  thus ?thesis
    using assms
    by (intro tl_consistent_seq append_consistent_seq) simp+
qed

lemma walk_append_is_walk:
  notes walk_def [simp]
  assumes p_walk: "walk G u p v"
  assumes q_walk: "walk G v q w"
  shows "walk G u (p @ tl q) w"
proof -
  have "q = v # tl q"
    using q_walk
    by simp
  hence "w = last (p @ tl q)"
    using assms
    by (cases "tl q") simp+
  moreover have "consistent_seq G (p @ tl q)"
    using assms
    by (intro append_consistent_seq_2) simp+
  ultimately show ?thesis
    using p_walk
    by simp
qed

lemma walk_append_append_is_walk:
  assumes p_walk: "walk G u p v"
  assumes q_walk: "walk G v q w"
  assumes r_walk: "walk G w r x"
  shows "walk G u (p @ tl q @ tl r) x"
proof -
  have "walk G u (p @ tl q) w"
    using p_walk q_walk
    by (rule walk_append_is_walk)
  from walk_append_is_walk[OF this r_walk]
  show ?thesis
    by simp
qed

lemma walk_edges_append:
  assumes "p \<noteq> []"
  shows "walk_edges (p @ q) = walk_edges p @ walk_edges ([last p] @ q)"
  using assms
  by (induction p rule: walk_induct) simp+

lemma walk_edges_append_2:
  assumes "q \<noteq> []"
  shows "walk_edges (p @ q) = walk_edges (p @ [hd q]) @ walk_edges q"
  using assms walk_edges_append[of "p @ [hd q]" "tl q"]
  by simp

subsection \<open>Reversing walks\<close>

lemma (in graph) rev_consistent_seq:
  assumes "consistent_seq G p"
  shows "consistent_seq G (rev p)"
  using assms
proof (induction p rule: walk_induct)
case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by simp
next
  case (3 v v' vs)
  have "consistent_seq G (rev (v' # vs))"
    using "3.prems"
    by (intro "3.IH") simp
  moreover have "consistent_seq G [v]"
    using "3.prems" Union_edges_subset_vertices
    by auto
  moreover have "{last (rev (v' # vs)), hd [v]} \<in> edges G"
    using "3.prems"
    by (simp add: insert_commute)
  ultimately have "consistent_seq G (rev (v' # vs) @ [v])"
    by (rule append_consistent_seq)
  thus ?case
    by simp
qed

lemma (in graph) walk_rev_is_walk:
  notes walk_def [simp]
  assumes "walk G u p v"
  shows "walk G v (rev p) u"
proof -
  have "(rev p) \<noteq> []"
    using assms
    by simp
  moreover have "v = hd (rev p)"
    using assms
    by (auto intro: hd_rev[symmetric])
  moreover have "u = last (rev p)"
    using assms
    by (auto intro: last_rev[symmetric])
  moreover have "consistent_seq G (rev p)"
    using assms
    by (intro rev_consistent_seq) simp
  ultimately show ?thesis
    by simp
qed

lemma (in graph) walk_rev:
  shows "walk G v (rev p) u = walk G u p v"
proof
  assume "walk G v (rev p) u"
  from walk_rev_is_walk[OF this]
  show "walk G u p v"
    by simp
next
  assume "walk G u p v"
  from walk_rev_is_walk[OF this]
  show "walk G v (rev p) u"
    by simp
qed

lemma walk_edges_rev:
  shows "rev (walk_edges p) = walk_edges (rev p)"
proof (induction p rule: walk_induct)
case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by simp
next
  case (3 v v' vs)
  have "rev (walk_edges (v # v' # vs)) = rev ({v, v'} # walk_edges (v' # vs))"
    by simp
  also have "... = rev (walk_edges (v' # vs)) @ [{v, v'}]"
    by simp
  also have "... = walk_edges (rev (v' # vs)) @ [{v, v'}]"
    by (simp add: "3.IH")
  also have "... = walk_edges (rev (v' # vs)) @ walk_edges ([last (rev (v' # vs))] @ [v])"
    by (simp add: insert_commute)
  also have "... = walk_edges (rev (v' # vs) @ [v])"
    by (intro walk_edges_append[symmetric]) simp
  finally show ?case
    by simp
qed

subsection \<open>Decomposing walks\<close>

subsubsection \<open>Splitting a walk at a vertex\<close>

fun is_walk_vertex_decomp :: "'a graph \<Rightarrow> 'a walk \<Rightarrow> 'a \<Rightarrow> 'a walk \<times> 'a walk \<Rightarrow> bool" where
  "is_walk_vertex_decomp G p v (q, r) \<longleftrightarrow> p = q @ tl r \<and> (\<exists>u w. walk G u q v \<and> walk G v r w)"

definition walk_vertex_decomp :: "'a graph \<Rightarrow> 'a walk \<Rightarrow> 'a \<Rightarrow> 'a walk \<times> 'a walk" where
  "walk_vertex_decomp G p v \<equiv> SOME qr. is_walk_vertex_decomp G p v qr"

lemma (in graph) walk_vertex_decompE:
  assumes p_walk: "walk G u p v"
  assumes p_decomp: "p = xs @ y # ys"
  obtains q r where
    "p = q @ tl r"
    "q = xs @ [y]"
    "r = y # ys"
    "walk G u q y"
    "walk G y r v"
proof
  define q r where
    "q = xs @ [y]" and
    "r = y # ys"
  thus
    "p = q @ tl r"
    "q = xs @ [y]"
    "r = y # ys"
    by (simp add: p_decomp)+
  thus "walk G u q y"
    using p_walk walk_prefix_is_walk[where ?p = q]
    by simp
  show "walk G y r v"
    using p_walk walk_suffix_is_walk[where ?q = r]
    by (simp add: p_decomp r_def)
qed

lemma (in graph) walk_vertex_decomp_is_walk_vertex_decomp:
  assumes p_walk: "walk G u p w"
  assumes v_in_p: "v \<in> set p"
  shows "is_walk_vertex_decomp G p v (walk_vertex_decomp G p v)"
proof -
  obtain xs ys where
    "p = xs @ v # ys"
    using v_in_p
    by (auto simp add: in_set_conv_decomp)
  with p_walk
  obtain q r where
    "p = q @ tl r"
    "walk G u q v"
    "walk G v r w"
    by (blast elim: walk_vertex_decompE)
  hence "is_walk_vertex_decomp G p v (q, r)"
    using p_walk
    by (simp add: walk_def)
  hence "\<exists>qr. is_walk_vertex_decomp G p v qr"
    by blast
  thus ?thesis
    unfolding walk_vertex_decomp_def
    ..
qed

lemma (in graph) walk_vertex_decompE_2:
  assumes p_walk: "walk G u p w"
  assumes v_in_p: "v \<in> set p"
  assumes qr_def: "walk_vertex_decomp G p v = (q, r)"
  obtains
    "p = q @ tl r"
    "walk G u q v"
    "walk G v r w"
proof
  have "is_walk_vertex_decomp G p v (q, r)"
    unfolding qr_def[symmetric]
    using p_walk v_in_p
    by (rule walk_vertex_decomp_is_walk_vertex_decomp)
  then obtain u' w' where
    p_decomp: "p = q @ tl r" and
    q_walk: "walk G u' q v" and
    r_walk: "walk G v r w'"
    by auto
  hence "walk G u' p w'"
    by (blast intro: walk_append_is_walk)
  hence
    "u' = u"
    "w' = w"
    using p_walk
    by (simp add: walk_def)+
  thus
    "p = q @ tl r"
    "walk G u q v"
    "walk G v r w"
    using p_decomp q_walk r_walk
    by simp+
qed

(**)
subsubsection \<open>\<close>

(* This subsubsection is largely based on the formalization of directed graphs (Graph_Theory). *)

fun is_walk_closed_walk_decomp :: "'a graph \<Rightarrow> 'a walk \<Rightarrow> 'a walk \<times> 'a walk \<times> 'a walk \<Rightarrow> bool" where
  "is_walk_closed_walk_decomp G p (q, r, s) \<longleftrightarrow>
    p = q @ tl r @ tl s \<and>
    (\<exists>u v w. walk G u q v \<and> closed_walk G v r \<and> walk G v s w) \<and>
    distinct q"

definition walk_closed_walk_decomp :: "'a graph \<Rightarrow> 'a walk \<Rightarrow> 'a walk \<times> 'a walk \<times> 'a walk" where
  "walk_closed_walk_decomp G p \<equiv> SOME qrs. is_walk_closed_walk_decomp G p qrs"

lemma (in graph) walk_closed_walk_decompE:
  assumes p_walk: "walk G u p v"
  assumes p_decomp: "p = xs @ y # ys @ y # zs"
  obtains q r s where
    "p = q @ tl r @ tl s"
    "q = xs @ [y]"
    "r = y # ys @ [y]"
    "s = y # zs"
    "walk G u q y"
    "walk G y r y"
    "walk G y s v"
proof -
  have "p = (xs @ y # ys) @ y # zs"
    using p_decomp
    by simp
  with p_walk
  obtain qr s where
    "p = qr @ tl s"
    "qr = xs @ y # ys @ [y]"
    "s = y # zs"
    "walk G u qr y"
    "walk G y s v"
    by (rule walk_vertex_decompE) simp
  moreover from this(4, 2)
  obtain q r where
    "qr = q @ tl r"
    "q = xs @ [y]"
    "r = y # ys @ [y]"
    "walk G u q y"
    "walk G y r y"
    by (erule walk_vertex_decompE)
  ultimately show ?thesis
    by (auto intro!: that)
qed

lemma (in graph) walk_closed_walk_decomp_is_walk_closed_walk_decomp:
  assumes p_walk: "walk G u p v"
  assumes p_not_distinct: "\<not> distinct p"
  shows "is_walk_closed_walk_decomp G p (walk_closed_walk_decomp G p)"
proof -
  obtain xs y ys zs where
    "p = xs @ y # ys @ y # zs" and
    xs_distinct: "distinct xs" and
    y_not_in_xs: "y \<notin> set xs"
    using p_not_distinct not_distinct_decomp
    by blast
  from p_walk this(1)
  obtain q r s where
    "p = q @ tl r @ tl s"
    "q = xs @ [y]"
    "r = y # ys @ [y]"
    "s = y # zs"
    "walk G u q y"
    "walk G y r y"
    "walk G y s v"
    by (erule walk_closed_walk_decompE)
  moreover hence
    "distinct q"
    "Suc 0 < length r"
    using xs_distinct y_not_in_xs
    by simp+
  ultimately have
    "\<exists>q r s.
      p = q @ tl r @ tl s \<and>
      (\<exists>u v w. walk G u q v \<and> closed_walk G v r \<and> walk G v s w) \<and>
      distinct q"
    by blast
  hence "\<exists>qrs. is_walk_closed_walk_decomp G p qrs"
    by simp
  thus ?thesis
    unfolding walk_closed_walk_decomp_def
    ..
qed

lemma (in graph) walk_closed_walk_decompE_2:
  assumes p_walk: "walk G u p v"
  assumes p_not_distinct: "\<not> distinct p"
  assumes qrs_def: "walk_closed_walk_decomp G p = (q, r, s)"
  obtains
    "p = q @ tl r @ tl s"
    "\<exists>w. walk G u q w \<and> closed_walk G w r \<and> walk G w s v"
    "distinct q"
proof -
  have "is_walk_closed_walk_decomp G p (q, r, s)"
    unfolding qrs_def[symmetric]
    using p_walk p_not_distinct
    by (rule walk_closed_walk_decomp_is_walk_closed_walk_decomp)
  then obtain u' w' v' where
    p_decomp: "p = q @ tl r @ tl s" and
    q_distinct: "distinct q" and
    walks: "walk G u' q w'"
    "closed_walk G w' r"
    "walk G w' s v'"
    by auto
  hence "walk G u' p v'"
    by (auto simp add: p_decomp intro: walk_append_append_is_walk)
  hence "u' = u" "v' = v"
    using p_walk
    by (simp add: walk_def)+
  hence "\<exists>w. walk G u q w \<and> closed_walk G w r \<and> walk G w s v"
    using walks
    by blast
  with p_decomp
  show ?thesis
    using q_distinct
    by (rule that)
qed

subsection \<open>Walks in subgraphs/supergraphs\<close>

lemma (in subgraph) consistent_seq_in_subgraph_implies_consistent_seq_in_supergraph:
  assumes "consistent_seq H p"
  shows "consistent_seq G p"
  using assms vertices_subset edges_subset
  by (induction p rule: walk_induct) auto

lemma (in subgraph) walk_subgraph_is_walk_supergraph:
  assumes "walk H u p v"
  shows "walk G u p v"
  using assms
  by (auto simp add: walk_def intro: consistent_seq_in_subgraph_implies_consistent_seq_in_supergraph)

lemma (in induced_subgraph) walk_supergraph_is_walk_subgraph:
  assumes "walk G u p w"
  assumes "set p \<subseteq> V"
  shows "walk H u p w"
  using assms
  by (induction p arbitrary: u rule: walk_induct) (auto simp add: walk_def induced)

section \<open>Trails\<close>

text \<open>A trail is a walk in which all edges are distinct.\<close>

definition trail :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a walk \<Rightarrow> 'a \<Rightarrow> bool" where
  "trail G u p v \<equiv> walk G u p v \<and> distinct (walk_edges p)"

text \<open>A trail is closed if its endpoints are the same.\<close>

abbreviation closed_trail :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a walk \<Rightarrow> bool" where
  "closed_trail G v c \<equiv> trail G v c v \<and> Suc 0 < length c"

subsection \<open>Basic Lemmas\<close>

lemma closed_trail_implies_Cons:
  assumes "closed_trail G v c"
  shows "c = v # tl c"
  using assms
  by (simp add: trail_def walk_def)

lemma closed_trail_implies_tl_non_empty:
  assumes "closed_trail G v c"
  shows "tl c \<noteq> []"
  using assms
  by (simp add: tl_non_empty_conv)

(**)
subsection \<open>\<close>

lemma (in graph) trail_in_vertices:
  assumes "trail G u p v"
  assumes "w \<in> set p"
  shows "w \<in> vertices G"
  using assms
  by (auto simp add: trail_def intro: walk_in_vertices)

lemma (in graph) trail_hd_in_vertices:
  assumes "trail G u p v"
  shows "u \<in> vertices G"
  using assms
  by (auto simp add: trail_def intro: walk_hd_in_vertices)

lemma (in graph) trail_last_in_vertices:
  assumes "trail G u p v"
  shows "v \<in> vertices G"
  using assms
  by (auto simp add: trail_def intro: walk_last_in_vertices)

lemma (in graph) closed_trail_tl_hd_in_vertices:
  assumes "closed_trail G v c"
  shows "hd (tl c) \<in> vertices G"
proof -
  have "hd (tl c) \<in> set (tl c)"
    using assms
    by (intro closed_trail_implies_tl_non_empty hd_in_set)
  hence "hd (tl c) \<in> set c"
    by (auto intro: closed_trail_implies_tl_non_empty list.set_sel(2))
  with assms
  show ?thesis
    by (blast intro: trail_in_vertices)
qed

subsection \<open>Prefixes/suffixes of trails\<close>

lemma (in graph) trail_prefix_is_trail:
  notes trail_def [simp]
  assumes p_non_empty: "p \<noteq> []"
  assumes p_append_q_trail: "trail G u (p @ q) v"
  shows "trail G u p (last p)"
proof -
  have "walk G u p (last p)"
    using assms
    by (auto intro: walk_prefix_is_walk)
  moreover have "distinct (walk_edges p)"
    using p_append_q_trail p_non_empty
    by (simp add: walk_edges_append)
  ultimately show ?thesis
    by simp
qed

lemma (in graph) trail_suffix_is_trail:
  notes trail_def [simp]
  assumes q_non_empty: "q \<noteq> []"
  assumes p_append_q_trail: "trail G u (p @ q) v"
  shows "trail G (hd q) q v"
proof -
  have "walk G (hd q) q v"
    using assms
    by (auto intro: walk_suffix_is_walk)
  moreover have "distinct (walk_edges q)"
    using p_append_q_trail
    by (simp add: walk_edges_append_2[OF q_non_empty])
  ultimately show ?thesis
    by simp
qed

subsection \<open>Reversing trails\<close>

lemma (in graph) trail_rev_is_trail:
  assumes "trail G u p v"
  shows "trail G v (rev p) u"
proof -
  have "walk_edges (rev p) = rev (walk_edges p)"
    using walk_edges_rev[symmetric]
    .
  moreover have "distinct ..."
    using assms
    by (simp add: trail_def)
  ultimately have "distinct (walk_edges (rev p))"
    by simp
  moreover have "walk G v (rev p) u"
    using assms
    by (intro walk_rev_is_walk) (simp add: trail_def)
  ultimately show ?thesis
    by (simp add: trail_def)
qed

lemma (in graph) closed_trail_rev_is_closed_trail:
  assumes "closed_trail G v c"
  shows "closed_trail G v (rev c)"
proof -
  have "trail G v (rev c) v"
    using assms
    by (intro trail_rev_is_trail) simp
  moreover have "Suc 0 < length (rev c)"
    using assms
    by simp
  ultimately show ?thesis
    by simp
qed

subsection \<open>Convenience Lemmas\<close>

lemma (in graph) closed_trail_hd_tl_hd_is_trail:
  assumes "closed_trail G v c"
  shows "trail G v [v, hd (tl c)] (hd (tl c))"
proof -
  have "c = [v, hd (tl c)] @ tl (tl c)"
    using assms closed_trail_implies_tl_non_empty
    by (fastforce simp add: closed_trail_implies_Cons)
  hence "trail G v ([v, hd (tl c)] @ tl (tl c)) v"
    using assms
    by simp
  from trail_prefix_is_trail[OF _ this]
  show ?thesis
    by simp
qed

lemma (in graph) closed_trail_tl_rev_is_trail:
  assumes "closed_trail G v c"
  shows "trail G v (rev (tl c)) (hd (tl c))"
proof -
  have "c = [v] @ tl c"
    using assms
    by (auto simp add: closed_trail_implies_Cons)
  hence "trail G v ([v] @ tl c) v"
    using assms
    by simp
  hence "trail G (hd (tl c)) (tl c) v"
    using assms
    by (intro closed_trail_implies_tl_non_empty trail_suffix_is_trail)
  thus ?thesis
    by (rule trail_rev_is_trail)
qed

lemma (in graph) closed_trail_hd_tl_hd_neq_tl_rev:
  assumes "closed_trail G v c"
  shows "[v, hd (tl c)] \<noteq> rev (tl c)"
proof (rule ccontr)
  define u where
    "u = hd (tl c)"
  assume "\<not> [v, u] \<noteq> rev (tl c)"
  hence "rev [u, v] = rev (tl c)"
    by simp
  hence "[u, v] = tl c"
    by blast
  hence "c = [v, u, v]"
    using assms
    by (auto simp add: closed_trail_implies_Cons)
  hence "\<not> distinct (walk_edges c)"
    by auto
  hence "\<not> trail G v c v"
    by (simp add: trail_def)
  thus "False"
    using assms
    by simp
qed

section \<open>Paths\<close>

(* This section is largely based on the formalization of directed graphs (Graph_Theory). *)

text \<open>A path is a walk in which all vertices are distinct.\<close>

definition path :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a walk \<Rightarrow> 'a \<Rightarrow> bool" where
  "path G u p v \<equiv> walk G u p v \<and> distinct p"

(**)
subsection \<open>\<close>

lemma (in finite_graph) path_length_le_card_vertices:
  assumes "path G u p v"
  shows "length p \<le> card (vertices G)"
proof -
  have "length p = card (set p)"
    using assms
    by (intro distinct_card[symmetric]) (simp add: path_def)
  also have "... \<le> card (vertices G)"
    using vertices_finite assms
    by (auto simp add: path_def intro: walk_in_vertices card_mono)
  finally show ?thesis
    .
qed

lemma (in finite_graph) path_triples_finite:
  shows "finite {(u, p, v). path G u p v}"
proof (rule finite_subset)
  have "\<And>u p v. walk G u p v \<Longrightarrow> distinct p \<Longrightarrow> length p \<le> card (vertices G)"
    by (intro path_length_le_card_vertices) (simp add: path_def)
  thus
    "{(u, p, v). path G u p v} \<subseteq>
      vertices G \<times> {p. set p \<subseteq> vertices G \<and> length p \<le> card (vertices G)} \<times> vertices G"
    by (auto simp add: path_def intro: walk_hd_in_vertices walk_in_vertices walk_last_in_vertices)
  show "finite ..."
    using vertices_finite
    by (intro finite_lists_length_le finite_cartesian_product)
qed

lemma (in finite_graph) paths_finite:
  shows "finite {p. path G u p v}"
proof -
  have "{p. path G u p v} \<subseteq> (fst \<circ> snd) ` {(u, p, v). path G u p v}"
    by (auto simp add: image_def)
  with path_triples_finite
  show ?thesis
    by (rule finite_surj)
qed

subsection \<open>Transforming walks into paths\<close>

function (in graph) walk_to_path :: "'a walk \<Rightarrow> 'a walk" where
  "walk_to_path p =
    (if (\<exists>u v. walk G u p v) \<and> \<not> distinct p
     then let (q, r, s) = walk_closed_walk_decomp G p in walk_to_path (q @ tl s)
     else p)"
  by auto

termination (in graph) walk_to_path
proof (relation "measure length")
  fix p qrs rs q r s
  assume
    p_not_path: "(\<exists>u v. walk G u p v) \<and> \<not> distinct p" and
    assms: "qrs = walk_closed_walk_decomp G p"
    "(q, rs) = qrs"
    "(r, s) = rs"
  then obtain u v where
    p_walk: "walk G u p v"
    by blast
  hence "(q, r, s) = walk_closed_walk_decomp G p"
    using assms
    by simp
  then obtain
    "p = q @ tl r @ tl s"
    "Suc 0 < length r"
    using p_walk p_not_path
    by (elim walk_closed_walk_decompE_2) auto
  thus "(q @ tl s, p) \<in> measure length"
    by auto
qed simp

lemma (in graph) walk_to_path_induct [consumes 1, case_names path decomp]:
  assumes "walk G u p v"
  assumes distinct: "\<And>p. \<lbrakk> walk G u p v; distinct p \<rbrakk> \<Longrightarrow> P p"
  assumes
    decomp: "\<And>p q r s. \<lbrakk> walk G u p v; \<not> distinct p;
      walk_closed_walk_decomp G p = (q, r, s); P (q @ tl s) \<rbrakk> \<Longrightarrow> P p"
  shows "P p"
  using assms(1)
proof (induct "length p" arbitrary: p rule: less_induct)
  case less
  show ?case
  proof (cases "distinct p")
    case True
    with less.prems
    show ?thesis
      by (rule distinct)
  next
    case False
    obtain q r s where
      qrs_def: "walk_closed_walk_decomp G p = (q, r, s)"
      by (cases "walk_closed_walk_decomp G p")
    with less.prems False
    obtain
      "p = q @ tl r @ tl s"
      "\<exists>w. walk G u q w \<and> closed_walk G w r \<and> walk G w s v"
      by (elim walk_closed_walk_decompE_2)
    hence
      "length (q @ tl s) < length p"
      "walk G u (q @ tl s) v"
      by (auto simp add: tl_non_empty_conv intro: walk_append_is_walk)
    hence "P (q @ tl s)"
      by (rule less.hyps)
    with less.prems False qrs_def
    show ?thesis
      by (rule decomp)
  qed
qed

lemma (in graph) walk_to_path_is_path:
  assumes "walk G u p v"
  shows "path G u (walk_to_path p) v"
  using assms
  by (induction rule: walk_to_path_induct) (auto simp add: path_def)

section \<open>Reachability\<close>

definition reachable :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "reachable G u v \<equiv> \<exists>p. walk G u p v"

definition connected :: "'a graph \<Rightarrow> bool" where
  "connected G \<equiv> \<forall>u\<in>vertices G. \<forall>v\<in>vertices G. reachable G u v"

lemma reachable_trans:
  assumes "reachable G u v"
  assumes "reachable G v w"
  shows "reachable G u w"
proof -
  obtain p q where
    "walk G u p v"
    "walk G v q w"
    using assms
    by (auto simp add: reachable_def)
  hence "walk G u (p @ (tl q)) w"
    by (rule walk_append_is_walk)
  thus ?thesis
    by (auto simp add: reachable_def)
qed

lemma (in graph) reachable_symmetric:
  assumes "reachable G u v"
  shows "reachable G v u"
proof -
  obtain p where
    "walk G u p v"
    using assms
    by (auto simp add: reachable_def)
  hence "walk G v (rev p) u"
    by (rule walk_rev_is_walk)
  thus ?thesis
    by (auto simp add: reachable_def)
qed

lemma (in graph) not_reachable_if_not_in_vertices:
  assumes "u \<notin> vertices G \<or> v \<notin> vertices G"
  shows "\<not> reachable G u v"
proof (rule ccontr)
  assume "\<not> \<not> reachable G u v"
  then obtain p where
    "walk G u p v"
    by (auto simp add: reachable_def)
  hence
    "u \<in> vertices G"
    "v \<in> vertices G"
    by (auto intro: walk_hd_in_vertices walk_last_in_vertices)
  thus "False"
    using assms
    by simp
qed

lemma (in subgraph) not_reachable_in_subgraph_if_not_reachable_in_supergraph:
  assumes "\<not> reachable G u v"
  shows "\<not> reachable H u v"
  using assms
  by (auto simp add: reachable_def intro: walk_subgraph_is_walk_supergraph)

lemmas (in induced_subgraph) not_reachable_in_subgraph_if_not_reachable_in_supergraph =
  not_reachable_in_subgraph_if_not_reachable_in_supergraph

end


(*
Title:  Allen's qualitative temporal calculus
Author:  Fadoua Ghourabi (fadouaghourabi@gmail.com)
Affiliation: Ochanomizu University, Japan
*)

theory xor_cal

imports

  Main

begin
definition xor::"bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "\<oplus>" 60)
where "xor A B \<equiv> (A \<and> \<not>B) \<or> (\<not>A \<and> B)"

declare xor_def [simp]

interpretation bool:semigroup "(\<oplus>) "
proof
{ fix a b c show "a \<oplus> b \<oplus> c = a \<oplus> (b \<oplus> c)" by auto}
qed

lemma xor_distr_L [simp]:"A \<oplus> (B \<oplus> C) = (A\<and>\<not>B\<and>\<not>C)\<or>(A\<and>B\<and>C)\<or>(\<not>A\<and>B\<and>\<not>C)\<or>(\<not>A\<and>\<not>B\<and>C)"
by auto

lemma xor_distr_R [simp]:"(A \<oplus> B) \<oplus> C = A \<oplus> (B \<oplus> C)"
by auto

end