section \<open> Function.thy \<close>

theory Function
  imports Main
begin

(* Types *)

record ('x, 'y) Function =
  cod :: "'y set"
  func :: "('x \<times> 'y) set"

definition dom :: "('x, 'y) Function \<Rightarrow> 'x set" where
 "dom f \<equiv> {x. \<exists>y. (x, y) \<in> func f}"

definition valid_map :: "('x, 'y) Function \<Rightarrow> bool" where
"valid_map f \<equiv>
  let
      welldefined = \<forall>x y. (x, y) \<in> func f \<longrightarrow> y \<in> cod f;
      deterministic = \<forall>x y y'. (x, y) \<in> func f \<and> (x, y') \<in> func f \<longrightarrow> y = y';
      total = (\<forall>x. x \<in> dom f \<longrightarrow> (\<exists>y. (x, y) \<in> func f))

  in welldefined \<and> deterministic \<and> total"

(* Validity *)

lemma dom : "(x, y) \<in> func f \<Longrightarrow> x \<in> dom f"
  unfolding dom_def
  by blast

lemma valid_map_welldefined : "valid_map f \<Longrightarrow> (x, y) \<in> func f \<Longrightarrow> y \<in> cod f"
  by (simp add: valid_map_def)

lemma valid_map_deterministic : "valid_map f \<Longrightarrow> (x, y) \<in> func f \<Longrightarrow> (x, y') \<in> func f \<Longrightarrow> y = y'"
  by (simp add: valid_map_def)

lemma valid_map_total : "valid_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> \<exists>y. (x, y) \<in> func f"
  by (simp add: valid_map_def)

lemma valid_mapI [intro] : "((\<And>x y. (x, y) \<in> func f \<Longrightarrow>  x \<in> dom f \<and> y \<in> cod f) \<Longrightarrow>
                   (\<And>x y y'. (x, y) \<in> func f \<Longrightarrow> (x, y') \<in> func f \<Longrightarrow> y = y') \<Longrightarrow>
                   (\<And>x. x \<in> dom f \<Longrightarrow> (\<exists>y. (x, y) \<in> func f))
                   \<Longrightarrow> valid_map f) "
  by (metis valid_map_def)

lemma valid_map_eqI: "cod f = cod g \<Longrightarrow> dom f = dom g \<Longrightarrow> func f = func g \<Longrightarrow> (f :: ('x, 'y) Function) = g"
  by simp

(* Function application *)

definition "Function_app_undefined_arg_not_in_domain _ \<equiv> undefined"

definition app :: "('x, 'y) Function \<Rightarrow> 'x \<Rightarrow> 'y" (infixr "\<cdot>" 998) where
"app f x \<equiv>
   if x \<in> dom f
   then  (THE y. (x, y) \<in> func f)
  else Function_app_undefined_arg_not_in_domain x"

lemma fun_app : "valid_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> (x, f \<cdot> x) \<in> func f"
  by (metis (no_types, lifting) app_def theI' valid_map_def)

lemma fun_app2 : "valid_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> f \<cdot> x  \<in> cod f"
  by (meson fun_app valid_map_welldefined)

lemma fun_app3 [simp] : "x \<in> dom f \<Longrightarrow> f \<cdot> x = (THE y. (x, y) \<in> func f) "
  by (simp add: app_def)

lemma fun_ext_raw : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And>x. x \<in> dom f \<Longrightarrow> f \<cdot> x = g \<cdot> x) \<Longrightarrow> func f = func g"
  by (metis dom fun_app pred_equals_eq2 valid_map_deterministic)

lemma fun_ext : "valid_map f \<Longrightarrow> valid_map g \<Longrightarrow> dom f = dom g \<Longrightarrow> cod f = cod g \<Longrightarrow> (\<And>x. x \<in> dom f \<Longrightarrow> f \<cdot> x = g \<cdot> x) \<Longrightarrow> f = g"
  by (metis (full_types) equality fun_ext_raw old.unit.exhaust)

lemma fun_app_iff : "valid_map f \<Longrightarrow> (x, y) \<in> func f \<Longrightarrow> (f \<cdot> x) = y"
  by (meson valid_map_deterministic fun_app dom)

(* Composition of functions *)

definition "Function_compose_undefined_incomposable _ _ \<equiv> undefined"

definition compose :: "('y, 'z) Function \<Rightarrow> ('x, 'y) Function \<Rightarrow> ('x, 'z) Function"  (infixl "\<bullet>" 55)
  where
  "compose g f \<equiv>
    if dom g = cod f
    then \<lparr> cod = cod g, func = relcomp (func f) (func g) \<rparr>
    else Function_compose_undefined_incomposable g f"

lemma compose_welldefined_cod : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> y \<in> cod g"
  by (metis compose_def relcompEpair select_convs(2) valid_map_def)

lemma compose_welldefined_dom : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> x \<in> dom f"
  by (metis compose_def dom relcomp.cases select_convs(2))

lemma compose_welldefined : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> x \<in> dom f \<and> y \<in> cod g"
  by (simp add: compose_welldefined_cod compose_welldefined_dom)

lemma compose_deterministic : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> (x, y) \<in> func (g \<bullet> f) \<Longrightarrow> (x, y') \<in> func (g \<bullet> f) \<Longrightarrow> y = y'"
  by (smt (verit, ccfv_threshold) compose_def valid_map_deterministic relcomp.simps select_convs(2))

lemma compose_total : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> x \<in> dom f \<Longrightarrow> \<exists>y. (x, y) \<in> func (g \<bullet> f)"
  by (metis (no_types, opaque_lifting) compose_def relcomp.simps select_convs(2) valid_map_total valid_map_welldefined)

lemma compose_valid : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> valid_map (g \<bullet> f)"
  by (smt (verit) CollectD Function.dom_def compose_def compose_deterministic compose_welldefined_cod select_convs(1) valid_map_def)

lemma cod_compose [simp] : "dom g = cod f \<Longrightarrow> cod (g \<bullet> f) = cod g"
  by (simp add: compose_def)

lemma dom_compose [simp] : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom g = cod f \<Longrightarrow> dom (g \<bullet> f) = dom f"
  by (smt (verit) Collect_cong Function.dom_def compose_total compose_welldefined_dom mem_Collect_eq)

lemma compose_assoc : "valid_map h \<Longrightarrow> valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> dom h = cod g \<Longrightarrow> dom g = cod f \<Longrightarrow> (h \<bullet> g) \<bullet> f = h \<bullet> (g \<bullet> f)"
  by (smt (verit, ccfv_SIG) O_assoc cod_compose cod_compose compose_def compose_def compose_def compose_def dom_compose select_convs(2) select_convs(2))

lemma compose_app [simp] : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> (x, y) \<in> func f \<Longrightarrow> dom g = cod f \<Longrightarrow> (y, z) \<in> func g
 \<Longrightarrow> (g \<bullet> f) \<cdot> x = z"
  unfolding valid_map_def compose_def dom_def app_def
  apply (simp add: Let_def)
  apply clarsimp
  apply safe
  apply (smt (verit) relcomp.simps the_equality)
  by (meson relcomp.relcompI)

lemma compose_app_assoc : "valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> dom g = cod f \<Longrightarrow> (g \<bullet> f) \<cdot> x = g \<cdot> (f \<cdot> x)"
  by (metis compose_app fun_app fun_app2)

(* Properties *)

abbreviation is_surjective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_surjective f \<equiv> \<forall> y . y \<in> cod f \<longrightarrow> (\<exists> x . x \<in> dom f \<and> f \<cdot> x = y)"

abbreviation is_injective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_injective f \<equiv> \<forall>x x' . x \<in> dom f \<longrightarrow> x' \<in> dom f \<longrightarrow> f \<cdot> x = f \<cdot> x' \<longrightarrow> x = x'"

abbreviation is_bijective :: "('x, 'y) Function \<Rightarrow> bool" where
"is_bijective f \<equiv> is_surjective f \<and> is_injective f"

lemma surjection_is_right_cancellative : "valid_map h \<Longrightarrow> valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> is_surjective f \<Longrightarrow> cod f = dom g \<Longrightarrow> cod f = dom h
 \<Longrightarrow> g \<bullet> f = h \<bullet> f \<Longrightarrow> g = h"
  by (metis cod_compose compose_app_assoc fun_ext)

lemma injection_is_left_cancellative : "valid_map h \<Longrightarrow> valid_map g \<Longrightarrow> valid_map f \<Longrightarrow> is_injective f \<Longrightarrow> cod g = dom f \<Longrightarrow> cod h = dom f
 \<Longrightarrow> f \<bullet> g = f \<bullet> h \<Longrightarrow> g = h"
  by (metis compose_app_assoc dom_compose fun_app2 fun_ext)

(* Identity functions *)

definition ident :: "'x set \<Rightarrow> ('x, 'x) Function" where
"ident X \<equiv>  \<lparr> cod = X, func = Id_on X \<rparr>"

lemma ident_valid : "valid_map (ident X)"
  by (simp add: Function.dom_def Id_on_iff ident_def valid_map_def)

lemma ident_dom [simp] : "dom (ident X) = X"
  by (simp add: Id_on_iff dom_def ident_def)

lemma ident_cod [simp] : "cod (ident X) = X"
  by (simp add: ident_def)

lemma ident_app [simp] : "x \<in> X \<Longrightarrow> ident X \<cdot> x = x"
  by (metis Id_onI fun_app_iff ident_def ident_valid select_convs(2))

lemma compose_ident_left [simp] : "valid_map f \<Longrightarrow> ident (cod f) \<bullet> f = f"
  by (smt (verit) cod_compose compose_app_assoc compose_valid dom_compose fun_app2 fun_ext ident_app ident_cod ident_dom ident_valid)

lemma compose_ident_right [simp] : "valid_map f \<Longrightarrow> f \<bullet> ident (dom f) = f"
  by (smt (verit, best) cod_compose compose_app_assoc compose_def compose_ident_left compose_valid dom_compose ext_inject fun_ext ident_app ident_def ident_dom ident_valid)

(* Constant functions *)

definition "Function_const_undefined_arg_not_in_codomain _ \<equiv> undefined"

definition const :: "'x set \<Rightarrow>  'y set  \<Rightarrow> 'y \<Rightarrow>  ('x, 'y) Function" where
"const X Y y \<equiv>
  if y \<in> Y
  then \<lparr> cod = Y, func = { (x, y) | x. x \<in> X }\<rparr>
  else Function_const_undefined_arg_not_in_codomain y"

lemma const_dom [simp] : "y \<in> Y \<Longrightarrow> dom (const X Y y) = X"
  by (simp add: const_def dom_def)

lemma const_cod [simp] : "y \<in> Y \<Longrightarrow> cod (const X Y y) = Y"
  by (simp add: const_def)

lemma const_app [simp] : "x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> (const X Y y) \<cdot> x = y"
  by (smt (verit) Pair_inject const_cod const_def const_dom fun_app mem_Collect_eq select_convs(2) valid_mapI)

lemma const_valid : "x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> valid_map (const X Y y)"
  unfolding valid_map_def const_def
  apply clarsimp
  by (simp add: Function.dom_def)

lemma const_func : "y \<in> Y \<Longrightarrow> func (const X Y y) = {(x, y) | x . x \<in> X }"
  by (simp add: const_def)

end


theory Int_Pair_State_Fib
imports
  Main
  "~~/src/HOL/Library/State_Monad"

begin
type_synonym 'a pair = "'a \<times> 'a"

definition return:: "'a \<Rightarrow> ('b, 'a) state" where "return = State_Monad.return"
definition get:: "('a pair, 'a pair) state" where "get = State (\<lambda>x. (x,x))"
definition put:: "'a pair \<Rightarrow> ('a pair, unit) state" where "put x = State (\<lambda>_. ((),x))"
definition get_fst:: "('a pair, 'a) state" where "get_fst = do { x \<leftarrow> get; return (fst x) }"
definition get_snd:: "('a pair, 'a) state" where "get_snd = do { x \<leftarrow> get; return (snd x) }"
definition set_fst:: "'a pair \<Rightarrow> 'a \<Rightarrow> 'a pair" where "set_fst v x = (x, snd v)"
definition set_snd:: "'a pair \<Rightarrow> 'a \<Rightarrow> 'a pair" where "set_snd v x = (fst v, x)"
definition put_fst:: "'a \<Rightarrow> ('a pair, unit) state" where "put_fst x = do { v \<leftarrow> get; put (set_fst v x) }"
definition put_snd:: "'a \<Rightarrow> ('a pair, unit) state" where "put_snd x = do { v \<leftarrow> get; put (set_snd v x) }"
definition skip:: "('a pair, unit) state" where "skip = State (\<lambda>x. ((),x))"

(*
definition return:: "nat \<Rightarrow> ('b, nat) state" where "return = State_Monad.return"
definition get:: "(nat pair, nat pair) state" where "get = State (\<lambda>x. (x,x))"
definition put:: "nat pair \<Rightarrow> (nat pair, unit) state" where "put x = State (\<lambda>_. ((),x))"
definition get_fst:: "(nat pair, nat) state" where "get_fst = do { x \<leftarrow> get; return (fst x) }"
definition get_snd:: "(nat pair, nat) state" where "get_snd = do { x \<leftarrow> get; return (snd x) }"
definition set_fst:: "nat pair \<Rightarrow> nat \<Rightarrow> nat pair" where "set_fst v x = (x, snd v)"
definition set_snd:: "nat pair \<Rightarrow> nat \<Rightarrow> nat pair" where "set_snd v x = (fst v, x)"
definition put_fst:: "nat \<Rightarrow> (nat pair, unit) state" where "put_fst x = do { v \<leftarrow> get; put (set_fst v x) }"
definition put_snd:: "nat \<Rightarrow> (nat pair, unit) state" where "put_snd x = do { v \<leftarrow> get; put (set_snd v x) }"
definition skip:: "(nat pair, unit) state" where "skip = State (\<lambda>x. ((),x))"
*)

fun fibacc :: "nat \<Rightarrow> nat => nat \<Rightarrow> nat" where
fa1: "fibacc 0 a b = a"|
fa2: "fibacc (Suc 0) a b = b"|
fa3: "fibacc (Suc (Suc n)) a b = fibacc (Suc n) b (a+b)"

definition fib_wrap:: "nat \<Rightarrow> nat" where
"fib_wrap n = fibacc n 0 1"

fun fib :: "nat => nat" where
  "fib 0 = 0"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc x)) = fib x + fib (Suc x)"

text\<open>Experiment with finding a pattern to extract in the proof\<close>
value \<open>fibacc 2 (fib 7) (fib 8)\<close>
value \<open>fibacc 8 (fib 1) (fib 2)\<close>
value \<open>fibacc 6 (fib 1) (fib 2)\<close>
value \<open>fib 5 + fibacc (Suc 5) 0 1 = fib 7\<close>
value \<open>fibacc (Suc 5) 0 (fibacc 5 0 1) = fibacc (Suc( Suc 5)) 0 1\<close>
value \<open>fibacc (Suc 5) 0 1 =  fibacc (Suc (Suc 5)) 0 1 - fibacc 5 0 1\<close>
value \<open>fibacc 5 0 (fibacc 5 0 1)\<close>
value \<open>fibacc 5 (fib 1) (fib 2)\<close>
value\<open>fib 7\<close>

lemma fib_aux: "fibacc n b (a + b) = fibacc (Suc n) a b"
  apply(induction n)
   apply(simp_all)
  done

lemma fib_aux1: "fibacc (Suc (Suc n)) a b = fibacc n a b + fibacc (Suc n) a b"
  apply(induct n arbitrary: a b)
  apply(simp_all)
  apply(simp only: fib_aux)
  done

lemma fib_main1: "fib n = fibacc n 0 1"
  apply(induction n rule: fib.induct)
    apply(simp)
    apply(simp)
    apply (simp only: fib_aux1)
  by (simp)

lemma fibwrap_main: "fib_wrap n = fibacc n 0 1"
  apply(induction n rule: nat.induct)
   apply(simp_all add: fib_wrap_def)
  done

lemma fib_main: "fib_wrap n = fib n"
  apply(induction n rule: fib.induct)
   apply(simp_all add: fib_main1 fibwrap_main)
  done

text\<open>The fibonacci function does always return the result at the fst value of the pair. The initial state passed in should be (0,1)\<close>
fun monfib:: "nat \<Rightarrow> (nat pair, unit) state" where
  "monfib 0 = skip" |
  "monfib (Suc 0) = do {b \<leftarrow> get_snd; put_fst b}" |
  "monfib (Suc (Suc n)) = do { a \<leftarrow> get_fst; b \<leftarrow> get_snd; put (b,(a + b)); monfib (Suc n)}"

text\<open>Stefan do you - know why I can't run any of these examples?\<close>
value \<open>fst(snd(run_state (monfib 5) (fst((0,1), ()))))\<close>
value \<open>fst(snd(run_state (monfib 5) (0,1)))\<close>

value "fst(snd (run_state (monfib 6) x))"

lemma monfib_aux: "fst(snd (run_state (monfib n) (b, (a + b)))) = fst(snd (run_state (monfib (Suc n)) (a, b)))"
  apply(induction n rule: nat.induct)
   apply(simp_all add: skip_def snd_def fst_def get_fst_def get_snd_def put_def put_fst_def get_def return_def set_fst_def)
  done

value "fst(snd (run_state (monfib (Suc (Suc 4))) x))
        = fst(snd (run_state (monfib 4) x)) + fst(snd (run_state (monfib (Suc 4)) x))"

lemma monfib_aux1: "fst(snd (run_state (monfib (Suc (Suc n))) x))
      = fst(snd (run_state (monfib n) x)) + fst(snd (run_state (monfib (Suc n)) x))"
  apply (induction n arbitrary: x rule: nat.induct)
   apply (simp_all add: skip_def get_snd_def return_def snd_def get_def put_fst_def set_fst_def put_def get_fst_def fst_def)
  by (simp add: case_prod_beta' monfib_aux)

lemma fib_mon_basic: "fst(snd(run_state (monfib n) (a,b))) = fibacc n a b"
  apply (induction n arbitrary: a b)
  apply(simp_all add: skip_def snd_def fst_def get_fst_def get_snd_def put_def put_fst_def)
  by (metis case_prod_beta' fib_aux monfib_aux)

lemma fib_m_main: "fst(snd(run_state (monfib n) (0,1))) = fib n"
  apply (induction n rule:fib.induct)
  apply(simp_all add: skip_def snd_def fst_def get_fst_def get_snd_def put_def put_fst_def get_def return_def set_fst_def)
  by (metis One_nat_def add.commute case_prod_beta' monfib_aux monfib_aux1 plus_1_eq_Suc)

lemma fib_basic_aux: "fst(snd(run_state (monfib n) (0,1))) = fibacc n 0 1"
apply (induction n)
apply(simp_all add: skip_def snd_def fst_def)
  by (metis One_nat_def case_prod_beta' fib_m_main fib_main1)

end


(* Title:      Pseudocomplemented Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Pseudocomplemented Algebras\<close>

text \<open>
This theory expands lattices with a pseudocomplement operation.
In particular, we consider the following algebraic structures:
\begin{itemize}
\item pseudocomplemented lattices (p-algebras)
\item pseudocomplemented distributive lattices (distributive p-algebras)
\item Stone algebras
\item Heyting semilattices
\item Heyting lattices
\item Heyting algebras
\item Heyting-Stone algebras
\item Brouwer algebras
\item Boolean algebras
\end{itemize}
Most of these structures and many results in this theory are discussed in \cite{BalbesDwinger1974,Birkhoff1967,Blyth2005,Curry1977,Graetzer1971,Maddux1996}.
\<close>

theory P_Algebras

imports Lattice_Basics

begin

subsection \<open>P-Algebras\<close>

text \<open>
In this section we add a pseudocomplement operation to lattices and to distributive lattices.
\<close>

subsubsection \<open>Pseudocomplemented Lattices\<close>

text \<open>
The pseudocomplement of an element \<open>y\<close> is the greatest element whose meet with \<open>y\<close> is the least element of the lattice.
\<close>

class p_algebra = bounded_lattice + uminus +
  assumes pseudo_complement: "x \<sqinter> y = bot \<longleftrightarrow> x \<le> -y"
begin

subclass sup_inf_top_bot_uminus_ord .

text \<open>
Regular elements and dense elements are frequently used in pseudocomplemented algebras.
\<close>

abbreviation "regular x \<equiv> x = --x"
abbreviation "dense x \<equiv> -x = bot"
abbreviation "complemented x \<equiv> \<exists>y . x \<sqinter> y = bot \<and> x \<squnion> y = top"
abbreviation "in_p_image x \<equiv> \<exists>y . x = -y"
abbreviation "selection s x \<equiv> s = --s \<sqinter> x"

abbreviation "dense_elements \<equiv> { x . dense x }"
abbreviation "regular_elements \<equiv> { x . in_p_image x }"

lemma p_bot [simp]:
  "-bot = top"
  using inf_top.left_neutral pseudo_complement top_unique by blast

lemma p_top [simp]:
  "-top = bot"
  by (metis eq_refl inf_top.comm_neutral pseudo_complement)

text \<open>
The pseudocomplement satisfies the following half of the requirements of a complement.
\<close>

lemma inf_p [simp]:
  "x \<sqinter> -x = bot"
  using inf.commute pseudo_complement by fastforce

lemma p_inf [simp]:
  "-x \<sqinter> x = bot"
  by (simp add: inf_commute)

lemma pp_inf_p:
  "--x \<sqinter> -x = bot"
  by simp

text \<open>
The double complement is a closure operation.
\<close>

lemma pp_increasing:
  "x \<le> --x"
  using inf_p pseudo_complement by blast

lemma ppp [simp]:
  "---x = -x"
  by (metis antisym inf.commute order_trans pseudo_complement pp_increasing)

lemma pp_idempotent:
  "----x = --x"
  by simp

lemma regular_in_p_image_iff:
  "regular x \<longleftrightarrow> in_p_image x"
  by auto

lemma pseudo_complement_pp:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<le> -y"
  by (metis inf_commute pseudo_complement ppp)

lemma p_antitone:
  "x \<le> y \<Longrightarrow> -y \<le> -x"
  by (metis inf_commute order_trans pseudo_complement pp_increasing)

lemma p_antitone_sup:
  "-(x \<squnion> y) \<le> -x"
  by (simp add: p_antitone)

lemma p_antitone_inf:
  "-x \<le> -(x \<sqinter> y)"
  by (simp add: p_antitone)

lemma p_antitone_iff:
  "x \<le> -y \<longleftrightarrow> y \<le> -x"
  using order_lesseq_imp p_antitone pp_increasing by blast

lemma pp_isotone:
  "x \<le> y \<Longrightarrow> --x \<le> --y"
  by (simp add: p_antitone)

lemma pp_isotone_sup:
  "--x \<le> --(x \<squnion> y)"
  by (simp add: p_antitone)

lemma pp_isotone_inf:
  "--(x \<sqinter> y) \<le> --x"
  by (simp add: p_antitone)

text \<open>
One of De Morgan's laws holds in pseudocomplemented lattices.
\<close>

lemma p_dist_sup [simp]:
  "-(x \<squnion> y) = -x \<sqinter> -y"
  apply (rule antisym)
  apply (simp add: p_antitone)
  using inf_le1 inf_le2 le_sup_iff p_antitone_iff by blast

lemma p_supdist_inf:
  "-x \<squnion> -y \<le> -(x \<sqinter> y)"
  by (simp add: p_antitone)

lemma pp_dist_pp_sup [simp]:
  "--(--x \<squnion> --y) = --(x \<squnion> y)"
  by simp

lemma p_sup_p [simp]:
  "-(x \<squnion> -x) = bot"
  by simp

lemma pp_sup_p [simp]:
  "--(x \<squnion> -x) = top"
  by simp

lemma dense_pp:
  "dense x \<longleftrightarrow> --x = top"
  by (metis p_bot p_top ppp)

lemma dense_sup_p:
  "dense (x \<squnion> -x)"
  by simp

lemma regular_char:
  "regular x \<longleftrightarrow> (\<exists>y . x = -y)"
  by auto

lemma pp_inf_bot_iff:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> y = bot"
  by (simp add: pseudo_complement_pp)

text \<open>
Weak forms of the shunting property hold.
Most require a pseudocomplemented element on the right-hand side.
\<close>

lemma p_shunting_swap:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<sqinter> z \<le> -y"
  by (metis inf_assoc inf_commute pseudo_complement)

lemma pp_inf_below_iff:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> --x \<sqinter> y \<le> -z"
  by (simp add: inf_commute p_shunting_swap)

lemma p_inf_pp [simp]:
  "-(x \<sqinter> --y) = -(x \<sqinter> y)"
  apply (rule antisym)
  apply (simp add: inf.coboundedI2 p_antitone pp_increasing)
  using inf_commute p_antitone_iff pp_inf_below_iff by auto

lemma p_inf_pp_pp [simp]:
  "-(--x \<sqinter> --y) = -(x \<sqinter> y)"
  by (simp add: inf_commute)

lemma regular_closed_inf:
  "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<sqinter> y)"
  by (metis p_dist_sup ppp)

lemma regular_closed_p:
  "regular (-x)"
  by simp

lemma regular_closed_pp:
  "regular (--x)"
  by simp

lemma regular_closed_bot:
  "regular bot"
  by simp

lemma regular_closed_top:
  "regular top"
  by simp

lemma pp_dist_inf [simp]:
  "--(x \<sqinter> y) = --x \<sqinter> --y"
  by (metis p_dist_sup p_inf_pp_pp ppp)

lemma inf_import_p [simp]:
  "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
  apply (rule antisym)
  using p_shunting_swap apply fastforce
  using inf.sup_right_isotone p_antitone by auto

text \<open>
Pseudocomplements are unique.
\<close>

lemma p_unique:
  "(\<forall>x . x \<sqinter> y = bot \<longleftrightarrow> x \<le> z) \<Longrightarrow> z = -y"
  using inf.eq_iff pseudo_complement by auto

lemma maddux_3_5:
  "x \<squnion> x = x \<squnion> -(y \<squnion> -y)"
  by simp

lemma shunting_1_pp:
  "x \<le> --y \<longleftrightarrow> x \<sqinter> -y = bot"
  by (simp add: pseudo_complement)

lemma pp_pp_inf_bot_iff:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> --y = bot"
  by (simp add: pseudo_complement_pp)

lemma inf_pp_semi_commute:
  "x \<sqinter> --y \<le> --(x \<sqinter> y)"
  using inf.eq_refl p_antitone_iff p_inf_pp by presburger

lemma inf_pp_commute:
  "--(--x \<sqinter> y) = --x \<sqinter> --y"
  by simp

lemma sup_pp_semi_commute:
  "x \<squnion> --y \<le> --(x \<squnion> y)"
  by (simp add: p_antitone_iff)

lemma regular_sup:
  "regular z \<Longrightarrow> (x \<le> z \<and> y \<le> z \<longleftrightarrow> --(x \<squnion> y) \<le> z)"
  apply (rule iffI)
  apply (metis le_supI pp_isotone)
  using dual_order.trans sup_ge2 pp_increasing pp_isotone_sup by blast

lemma dense_closed_inf:
  "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<sqinter> y)"
  by (simp add: dense_pp)

lemma dense_closed_sup:
  "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<squnion> y)"
  by simp

lemma dense_closed_pp:
  "dense x \<Longrightarrow> dense (--x)"
  by simp

lemma dense_up_closed:
  "dense x \<Longrightarrow> x \<le> y \<Longrightarrow> dense y"
  using dense_pp top_le pp_isotone by auto

lemma regular_dense_top:
  "regular x \<Longrightarrow> dense x \<Longrightarrow> x = top"
  using p_bot by blast

lemma selection_char:
  "selection s x \<longleftrightarrow> (\<exists>y . s = -y \<sqinter> x)"
  by (metis inf_import_p inf_commute regular_closed_p)

lemma selection_closed_inf:
  "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<sqinter> t) x"
  by (metis inf_assoc inf_commute inf_idem pp_dist_inf)

lemma selection_closed_pp:
  "regular x \<Longrightarrow> selection s x \<Longrightarrow> selection (--s) x"
  by (metis pp_dist_inf)

lemma selection_closed_bot:
  "selection bot x"
  by simp

lemma selection_closed_id:
  "selection x x"
  using inf.le_iff_sup pp_increasing by auto

text \<open>
Conjugates are usually studied for Boolean algebras, however, some of their properties generalise to pseudocomplemented algebras.
\<close>

lemma conjugate_unique_p:
  assumes "conjugate f g"
      and "conjugate f h"
    shows "uminus \<circ> g = uminus \<circ> h"
proof -
  have "\<forall>x y . x \<sqinter> g y = bot \<longleftrightarrow> x \<sqinter> h y = bot"
    using assms conjugate_def inf.commute by simp
  hence "\<forall>x y . x \<le> -(g y) \<longleftrightarrow> x \<le> -(h y)"
    using inf.commute pseudo_complement by simp
  hence "\<forall>y . -(g y) = -(h y)"
    using eq_iff by blast
  thus ?thesis
    by auto
qed

lemma conjugate_symmetric:
  "conjugate f g \<Longrightarrow> conjugate g f"
  by (simp add: conjugate_def inf_commute)

lemma additive_isotone:
  "additive f \<Longrightarrow> isotone f"
  by (metis additive_def isotone_def le_iff_sup)

lemma dual_additive_antitone:
  assumes "dual_additive f"
    shows "isotone (uminus \<circ> f)"
proof -
  have "\<forall>x y . f (x \<squnion> y) \<le> f x"
    using assms dual_additive_def by simp
  hence "\<forall>x y . x \<le> y \<longrightarrow> f y \<le> f x"
    by (metis sup_absorb2)
  hence "\<forall>x y . x \<le> y \<longrightarrow> -(f x) \<le> -(f y)"
    by (simp add: p_antitone)
  thus ?thesis
    by (simp add: isotone_def)
qed

lemma conjugate_dual_additive:
  assumes "conjugate f g"
    shows "dual_additive (uminus \<circ> f)"
proof -
  have 1: "\<forall>x y z . -z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
  proof (intro allI)
    fix x y z
    have "(-z \<le> -(f (x \<squnion> y))) = (f (x \<squnion> y) \<sqinter> -z = bot)"
      by (simp add: p_antitone_iff pseudo_complement)
    also have "... = ((x \<squnion> y) \<sqinter> g(-z) = bot)"
      using assms conjugate_def by auto
    also have "... = (x \<squnion> y \<le> -(g(-z)))"
      by (simp add: pseudo_complement)
    also have "... = (x \<le> -(g(-z)) \<and> y \<le> -(g(-z)))"
      by (simp add: le_sup_iff)
    also have "... = (x \<sqinter> g(-z) = bot \<and> y \<sqinter> g(-z) = bot)"
      by (simp add: pseudo_complement)
    also have "... = (f x \<sqinter> -z = bot \<and> f y \<sqinter> -z = bot)"
      using assms conjugate_def by auto
    also have "... = (-z \<le> -(f x) \<and> -z \<le> -(f y))"
      by (simp add: p_antitone_iff pseudo_complement)
    finally show "-z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
      by simp
  qed
  have "\<forall>x y . -(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
  proof (intro allI)
    fix x y
    have "-(f x) \<sqinter> -(f y) = --(-(f x) \<sqinter> -(f y))"
      by simp
    hence "-(f x) \<sqinter> -(f y) \<le> -(f (x \<squnion> y))"
      using 1 by (metis inf_le1 inf_le2)
    thus "-(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
      using 1 antisym by fastforce
  qed
  thus ?thesis
    using dual_additive_def by simp
qed

lemma conjugate_isotone_pp:
  "conjugate f g \<Longrightarrow> isotone (uminus \<circ> uminus \<circ> f)"
  by (simp add: comp_assoc conjugate_dual_additive dual_additive_antitone)

lemma conjugate_char_1_pp:
  "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x)"
proof
  assume 1: "conjugate f g"
  show "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
  proof (intro allI)
    fix x y
    have 2: "f(x \<sqinter> -(g y)) \<le> -y"
      using 1 by (simp add: conjugate_def pseudo_complement)
    have "f(x \<sqinter> -(g y)) \<le> --f(x \<sqinter> -(g y))"
      by (simp add: pp_increasing)
    also have "... \<le> --f x"
      using 1 conjugate_isotone_pp isotone_def by simp
    finally have 3: "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y"
      using 2 by simp
    have 4: "isotone (uminus \<circ> uminus \<circ> g)"
      using 1 conjugate_isotone_pp conjugate_symmetric by auto
    have 5: "g(y \<sqinter> -(f x)) \<le> -x"
      using 1 by (metis conjugate_def inf.cobounded2 inf_commute pseudo_complement)
    have "g(y \<sqinter> -(f x)) \<le> --g(y \<sqinter> -(f x))"
      by (simp add: pp_increasing)
    also have "... \<le> --g y"
      using 4 isotone_def by auto
    finally have "g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
      using 5 by simp
    thus "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
      using 3 by simp
  qed
next
  assume 6: "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
  hence 7: "\<forall>x y . f x \<sqinter> y = bot \<longrightarrow> x \<sqinter> g y = bot"
    by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
  have "\<forall>x y . x \<sqinter> g y = bot \<longrightarrow> f x \<sqinter> y = bot"
    using 6 by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
  thus "conjugate f g"
    using 7 conjugate_def by auto
qed

lemma conjugate_char_1_isotone:
  "conjugate f g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x"
  by (simp add: conjugate_char_1_pp ord.isotone_def)

lemma dense_lattice_char_1:
  "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . x \<noteq> bot \<longrightarrow> dense x)"
  by (metis inf_top.left_neutral p_bot p_inf pp_inf_bot_iff)

lemma dense_lattice_char_2:
  "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . regular x \<longrightarrow> x = bot \<or> x = top)"
  by (metis dense_lattice_char_1 inf_top.left_neutral p_inf regular_closed_p regular_closed_top)

lemma restrict_below_Rep_eq:
  "x \<sqinter> --y \<le> z \<Longrightarrow> x \<sqinter> y = x \<sqinter> z \<sqinter> y"
  by (metis inf.absorb2 inf.commute inf.left_commute pp_increasing)

(*
lemma p_inf_sup_below: "-x \<sqinter> (x \<squnion> y) \<le> y" nitpick [expect=genuine] oops
lemma complement_p: "x \<sqinter> y = bot \<and> x \<squnion> y = top \<longrightarrow> -x = y" nitpick [expect=genuine] oops
lemma complemented_regular: "complemented x \<longrightarrow> regular x" nitpick [expect=genuine] oops
*)

end

text \<open>
The following class gives equational axioms for the pseudocomplement operation.
\<close>

class p_algebra_eq = bounded_lattice + uminus +
  assumes p_bot_eq: "-bot = top"
      and p_top_eq: "-top = bot"
      and inf_import_p_eq: "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
begin

lemma inf_p_eq:
  "x \<sqinter> -x = bot"
  by (metis inf_bot_right inf_import_p_eq inf_top_right p_top_eq)

subclass p_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis inf.orderI inf_import_p_eq inf_top.right_neutral p_bot_eq)
  by (metis (full_types) inf.left_commute inf.orderE inf_bot_right inf_commute inf_p_eq)

end

subsubsection \<open>Pseudocomplemented Distributive Lattices\<close>

text \<open>
We obtain further properties if we assume that the lattice operations are distributive.
\<close>

class pd_algebra = p_algebra + bounded_distrib_lattice
begin

lemma p_inf_sup_below:
  "-x \<sqinter> (x \<squnion> y) \<le> y"
  by (simp add: inf_sup_distrib1)

lemma pp_inf_sup_p [simp]:
  "--x \<sqinter> (x \<squnion> -x) = x"
  using inf.absorb2 inf_sup_distrib1 pp_increasing by auto

lemma complement_p:
  "x \<sqinter> y = bot \<Longrightarrow> x \<squnion> y = top \<Longrightarrow> -x = y"
  by (metis pseudo_complement inf.commute inf_top.left_neutral sup.absorb_iff1 sup.commute sup_bot.right_neutral sup_inf_distrib2 p_inf)

lemma complemented_regular:
  "complemented x \<Longrightarrow> regular x"
  using complement_p inf.commute sup.commute by fastforce

lemma regular_inf_dense:
  "\<exists>y z . regular y \<and> dense z \<and> x = y \<sqinter> z"
  by (metis pp_inf_sup_p dense_sup_p ppp)

lemma maddux_3_12 [simp]:
  "(x \<squnion> -y) \<sqinter> (x \<squnion> y) = x"
  by (metis p_inf sup_bot_right sup_inf_distrib1)

lemma maddux_3_13 [simp]:
  "(x \<squnion> y) \<sqinter> -x = y \<sqinter> -x"
  by (simp add: inf_sup_distrib2)

lemma maddux_3_20:
  "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
proof -
  have "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -(v \<sqinter> y)"
    by (meson inf.cobounded1 inf_absorb1 le_infI1 p_antitone_iff)
  also have "... = v \<sqinter> w \<sqinter> -y"
    using inf.sup_relative_same_increasing inf_import_p inf_le1 by blast
  finally have 1: "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -y"
    .
  have "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -(-v \<sqinter> z)"
    by (simp add: inf.absorb1 le_infI1 p_antitone_inf)
  also have "... = -v \<sqinter> x \<sqinter> -z"
    by (simp add: inf.assoc inf_left_commute)
  finally have 2: "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -z"
    .
  have "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z)) \<squnion> (-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z))"
    by (simp add: inf_assoc inf_sup_distrib2)
  also have "... = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
    using 1 2 by simp
  finally show ?thesis
    .
qed

lemma order_char_1:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> -x"
  by (metis inf.sup_left_isotone inf_sup_absorb le_supI1 maddux_3_12 sup_commute)

lemma order_char_2:
  "x \<le> y \<longleftrightarrow> x \<squnion> -x \<le> y \<squnion> -x"
  using order_char_1 by auto

(*
lemma pp_dist_sup [simp]: "--(x \<squnion> y) = --x \<squnion> --y" nitpick [expect=genuine] oops
lemma regular_closed_sup: "regular x \<and> regular y \<longrightarrow> regular (x \<squnion> y)" nitpick [expect=genuine] oops
lemma regular_complemented_iff: "regular x \<longleftrightarrow> complemented x" nitpick [expect=genuine] oops
lemma selection_closed_sup: "selection s x \<and> selection t x \<longrightarrow> selection (s \<squnion> t) x" nitpick [expect=genuine] oops
lemma stone [simp]: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
*)

end

subsection \<open>Stone Algebras\<close>

text \<open>
A Stone algebra is a distributive lattice with a pseudocomplement that satisfies the following equation.
We thus obtain the other half of the requirements of a complement at least for the regular elements.
\<close>

class stone_algebra = pd_algebra +
  assumes stone [simp]: "-x \<squnion> --x = top"
begin

text \<open>
As a consequence, we obtain both De Morgan's laws for all elements.
\<close>

lemma p_dist_inf [simp]:
  "-(x \<sqinter> y) = -x \<squnion> -y"
proof (rule p_unique[THEN sym], rule allI, rule iffI)
  fix w
  assume "w \<sqinter> (x \<sqinter> y) = bot"
  hence "w \<sqinter> --x \<sqinter> y = bot"
    using inf_commute inf_left_commute pseudo_complement by auto
  hence 1: "w \<sqinter> --x \<le> -y"
    by (simp add: pseudo_complement)
  have "w = (w \<sqinter> -x) \<squnion> (w \<sqinter> --x)"
    using distrib_imp2 sup_inf_distrib1 by auto
  thus "w \<le> -x \<squnion> -y"
    using 1 by (metis inf_le2 sup.mono)
next
  fix w
  assume "w \<le> -x \<squnion> -y"
  thus "w \<sqinter> (x \<sqinter> y) = bot"
    using order_trans p_supdist_inf pseudo_complement by blast
qed

lemma pp_dist_sup [simp]:
  "--(x \<squnion> y) = --x \<squnion> --y"
  by simp

lemma regular_closed_sup:
  "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<squnion> y)"
  by simp

text \<open>
The regular elements are precisely the ones having a complement.
\<close>

lemma regular_complemented_iff:
  "regular x \<longleftrightarrow> complemented x"
  by (metis inf_p stone complemented_regular)

lemma selection_closed_sup:
  "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<squnion> t) x"
  by (simp add: inf_sup_distrib2)

lemma huntington_3_pp [simp]:
  "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
  by (metis p_dist_inf p_inf sup.commute sup_bot_left sup_inf_distrib1)

lemma maddux_3_3 [simp]:
  "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
  by (simp add: sup_commute sup_inf_distrib1)

lemma maddux_3_11_pp:
  "(x \<sqinter> -y) \<squnion> (x \<sqinter> --y) = x"
  by (metis inf_sup_distrib1 inf_top_right stone)

lemma maddux_3_19_pp:
  "(-x \<sqinter> y) \<squnion> (--x \<sqinter> z) = (--x \<squnion> y) \<sqinter> (-x \<squnion> z)"
proof -
  have "(--x \<squnion> y) \<sqinter> (-x \<squnion> z) = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z)"
    by (simp add: inf.commute inf_sup_distrib1 sup.assoc)
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> (-x \<squnion> --x))"
    by simp
  also have "... = (--x \<sqinter> z) \<squnion> ((y \<sqinter> -x) \<squnion> (y \<sqinter> -x \<sqinter> z)) \<squnion> (y \<sqinter> z \<sqinter> --x)"
    using inf_sup_distrib1 sup_assoc inf_commute inf_assoc by presburger
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> --x)"
    by simp
  also have "... = ((--x \<sqinter> z) \<squnion> (--x \<sqinter> z \<sqinter> y)) \<squnion> (y \<sqinter> -x)"
    by (simp add: inf_assoc inf_commute sup.left_commute sup_commute)
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x)"
    by simp
  finally show ?thesis
    by (simp add: inf_commute sup_commute)
qed

lemma compl_inter_eq_pp:
  "--x \<sqinter> y = --x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
  by (metis inf_commute inf_p inf_sup_distrib1 inf_top.right_neutral p_bot p_dist_inf)

lemma maddux_3_21_pp [simp]:
  "--x \<squnion> (-x \<sqinter> y) = --x \<squnion> y"
  by (simp add: sup.commute sup_inf_distrib1)

lemma shunting_2_pp:
  "x \<le> --y \<longleftrightarrow> -x \<squnion> --y = top"
  by (metis inf_top_left p_bot p_dist_inf pseudo_complement)

lemma shunting_p:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<le> -z \<squnion> -y"
  by (metis inf.assoc p_dist_inf p_shunting_swap pseudo_complement)

text \<open>
The following weak shunting property is interesting as it does not require the element \<open>z\<close> on the right-hand side to be regular.
\<close>

lemma shunting_var_p:
  "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> --y"
proof
  assume "x \<sqinter> -y \<le> z"
  hence "z \<squnion> --y = --y \<squnion> (z \<squnion> x \<sqinter> -y)"
    by (simp add: sup.absorb1 sup.commute)
  thus "x \<le> z \<squnion> --y"
    by (metis inf_commute maddux_3_21_pp sup.commute sup.left_commute sup_left_divisibility)
next
  assume "x \<le> z \<squnion> --y"
  thus "x \<sqinter> -y \<le> z"
    by (metis inf.mono maddux_3_12 sup_ge2)
qed

(* Whether conjugate_char_2_pp can be proved in pd_algebra or in p_algebra is unknown. *)
lemma conjugate_char_2_pp:
  "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
proof
  assume 1: "conjugate f g"
  hence 2: "dual_additive (uminus \<circ> g)"
    using conjugate_symmetric conjugate_dual_additive by auto
  show "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
  proof (intro conjI)
    show "f bot = bot"
      using 1 by (metis conjugate_def inf_idem inf_bot_left)
  next
    show "g bot = bot"
      using 1 by (metis conjugate_def inf_idem inf_bot_right)
  next
    show "\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
    proof (intro allI)
      fix x y
      have 3: "y \<le> -(f(x \<sqinter> -(g y)))"
        using 1 by (simp add: conjugate_def pseudo_complement inf_commute)
      have 4: "x \<le> -(g(y \<sqinter> -(f x)))"
        using 1 conjugate_def inf.commute pseudo_complement by fastforce
      have "y \<sqinter> -(f(x \<sqinter> --(g y))) = y \<sqinter> -(f(x \<sqinter> -(g y))) \<sqinter> -(f(x \<sqinter> --(g y)))"
        using 3 by (simp add: inf.le_iff_sup inf_commute)
      also have "... = y \<sqinter> -(f((x \<sqinter> -(g y)) \<squnion> (x \<sqinter> --(g y))))"
        using 1 conjugate_dual_additive dual_additive_def inf_assoc by auto
      also have "... = y \<sqinter> -(f x)"
        by (simp add: maddux_3_11_pp)
      also have "... \<le> -(f x)"
        by simp
      finally have 5: "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y)))"
        by (simp add: inf_commute p_shunting_swap)
      have "x \<sqinter> -(g(y \<sqinter> --(f x))) = x \<sqinter> -(g(y \<sqinter> -(f x))) \<sqinter> -(g(y \<sqinter> --(f x)))"
        using 4 by (simp add: inf.le_iff_sup inf_commute)
      also have "... = x \<sqinter> -(g((y \<sqinter> -(f x)) \<squnion> (y \<sqinter> --(f x))))"
        using 2 by (simp add: dual_additive_def inf_assoc)
      also have "... = x \<sqinter> -(g y)"
        by (simp add: maddux_3_11_pp)
      also have "... \<le> -(g y)"
        by simp
      finally have "g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
        by (simp add: inf_commute p_shunting_swap)
      thus "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
        using 5 by simp
    qed
  qed
next
  assume "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
  thus "conjugate f g"
    by (unfold conjugate_def, metis inf_commute le_bot pp_inf_bot_iff regular_closed_bot)
qed

lemma conjugate_char_2_pp_additive:
  assumes "conjugate f g"
      and "additive f"
      and "additive g"
    shows "f x \<sqinter> y \<le> f(x \<sqinter> --(g y)) \<and> g y \<sqinter> x \<le> g(y \<sqinter> --(f x))"
proof -
  have "f x \<sqinter> y = f ((x \<sqinter> --g y) \<squnion> (x \<sqinter> -g y)) \<sqinter> y"
    by (simp add: sup.commute sup_inf_distrib1)
  also have "... = (f (x \<sqinter> --g y) \<sqinter> y) \<squnion> (f (x \<sqinter> -g y) \<sqinter> y)"
    using assms(2) additive_def inf_sup_distrib2 by auto
  also have "... = f (x \<sqinter> --g y) \<sqinter> y"
    by (metis assms(1) conjugate_def inf_le2 pseudo_complement sup_bot.right_neutral)
  finally have 2: "f x \<sqinter> y \<le> f (x \<sqinter> --g y)"
    by simp
  have "g y \<sqinter> x = g ((y \<sqinter> --f x) \<squnion> (y \<sqinter> -f x)) \<sqinter> x"
    by (simp add: sup.commute sup_inf_distrib1)
  also have "... = (g (y \<sqinter> --f x) \<sqinter> x) \<squnion> (g (y \<sqinter> -f x) \<sqinter> x)"
    using assms(3) additive_def inf_sup_distrib2 by auto
  also have "... = g (y \<sqinter> --f x) \<sqinter> x"
    by (metis assms(1) conjugate_def inf.cobounded2 pseudo_complement sup_bot.right_neutral inf_commute)
  finally have "g y \<sqinter> x \<le> g (y \<sqinter> --f x)"
    by simp
  thus ?thesis
    using 2 by simp
qed

(*
lemma compl_le_swap2_iff: "-x \<le> y \<longleftrightarrow> -y \<le> x" nitpick [expect=genuine] oops
lemma huntington_3: "x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> y)" nitpick [expect=genuine] oops
lemma maddux_3_1: "x \<squnion> -x = y \<squnion> -y" nitpick [expect=genuine] oops
lemma maddux_3_4: "x \<squnion> (y \<squnion> -y) = z \<squnion> -z" nitpick [expect=genuine] oops
lemma maddux_3_11: "x = (x \<sqinter> y) \<squnion> (x \<sqinter> -y)" nitpick [expect=genuine] oops
lemma maddux_3_19: "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)" nitpick [expect=genuine] oops
lemma compl_inter_eq: "x \<sqinter> y = x \<sqinter> z \<and> -x \<sqinter> y = -x \<sqinter> z \<longrightarrow> y = z" nitpick [expect=genuine] oops
lemma maddux_3_21: "x \<squnion> y = x \<squnion> (-x \<sqinter> y)" nitpick [expect=genuine] oops
lemma shunting_1: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot" nitpick [expect=genuine] oops
lemma shunting_2: "x \<le> y \<longleftrightarrow> -x \<squnion> y = top" nitpick [expect=genuine] oops
lemma conjugate_unique: "conjugate f g \<and> conjugate f h \<longrightarrow> g = h" nitpick [expect=genuine] oops
lemma conjugate_isotone_pp: "conjugate f g \<longrightarrow> isotone f" nitpick [expect=genuine] oops
lemma conjugate_char_1: "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)" nitpick [expect=genuine] oops
lemma conjugate_char_2: "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))" nitpick [expect=genuine] oops
lemma shunting: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y" nitpick [expect=genuine] oops
lemma shunting_var: "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y" nitpick [expect=genuine] oops
lemma sup_compl_top: "x \<squnion> -x = top" nitpick [expect=genuine] oops
lemma selection_closed_p: "selection s x \<longrightarrow> selection (-s) x" nitpick [expect=genuine] oops
lemma selection_closed_pp: "selection s x \<longrightarrow> selection (--s) x" nitpick [expect=genuine] oops
*)

end

abbreviation stone_algebra_isomorphism :: "('a::stone_algebra \<Rightarrow> 'b::stone_algebra) \<Rightarrow> bool"
  where "stone_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f"

text \<open>
Every bounded linear order can be expanded to a Stone algebra.
The pseudocomplement takes \<open>bot\<close> to the \<open>top\<close> and every other element to \<open>bot\<close>.
\<close>

class linorder_stone_algebra_expansion = linorder_lattice_expansion + uminus +
  assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
begin

subclass stone_algebra
  apply unfold_locales
  using bot_unique min_def top_le by auto

text \<open>
The regular elements are the least and greatest elements.
All elements except the least element are dense.
\<close>

lemma regular_bot_top:
  "regular x \<longleftrightarrow> x = bot \<or> x = top"
  by simp

lemma not_bot_dense:
  "x \<noteq> bot \<Longrightarrow> --x = top"
  by simp

end

subsection \<open>Heyting Algebras\<close>

text \<open>
In this section we add a relative pseudocomplement operation to semilattices and to lattices.
\<close>

subsubsection \<open>Heyting Semilattices\<close>

text \<open>
The pseudocomplement of an element \<open>y\<close> relative to an element \<open>z\<close> is the least element whose meet with \<open>y\<close> is below \<open>z\<close>.
This can be stated as a Galois connection.
Specialising \<open>z = bot\<close> gives (non-relative) pseudocomplements.
Many properties can already be shown if the underlying structure is just a semilattice.
\<close>

class implies =
  fixes implies :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leadsto>" 65)

class heyting_semilattice = semilattice_inf + implies +
  assumes implies_galois: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> y \<leadsto> z"
begin

lemma implies_below_eq [simp]:
  "y \<sqinter> (x \<leadsto> y) = y"
  using implies_galois inf.absorb_iff1 inf.cobounded1 by blast

lemma implies_increasing:
  "x \<le> y \<leadsto> x"
  by (simp add: inf.orderI)

lemma implies_galois_swap:
  "x \<le> y \<leadsto> z \<longleftrightarrow> y \<le> x \<leadsto> z"
  by (metis implies_galois inf_commute)

lemma implies_galois_var:
  "x \<sqinter> y \<le> z \<longleftrightarrow> y \<le> x \<leadsto> z"
  by (simp add: implies_galois_swap implies_galois)

lemma implies_galois_increasing:
  "x \<le> y \<leadsto> (x \<sqinter> y)"
  using implies_galois by blast

lemma implies_galois_decreasing:
  "(y \<leadsto> x) \<sqinter> y \<le> x"
  using implies_galois by blast

lemma implies_mp_below:
  "x \<sqinter> (x \<leadsto> y) \<le> y"
  using implies_galois_decreasing inf_commute by auto

lemma implies_isotone:
  "x \<le> y \<Longrightarrow> z \<leadsto> x \<le> z \<leadsto> y"
  using implies_galois order_trans by blast

lemma implies_antitone:
  "x \<le> y \<Longrightarrow> y \<leadsto> z \<le> x \<leadsto> z"
  by (meson implies_galois_swap order_lesseq_imp)

lemma implies_isotone_inf:
  "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
  by (simp add: implies_isotone)

lemma implies_antitone_inf:
  "x \<leadsto> z \<le> (x \<sqinter> y) \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_curry:
  "x \<leadsto> (y \<leadsto> z) = (x \<sqinter> y) \<leadsto> z"
  by (metis implies_galois_decreasing implies_galois inf_assoc antisym)

lemma implies_curry_flip:
  "x \<leadsto> (y \<leadsto> z) = y \<leadsto> (x \<leadsto> z)"
  by (simp add: implies_curry inf_commute)

lemma triple_implies [simp]:
  "((x \<leadsto> y) \<leadsto> y) \<leadsto> y = x \<leadsto> y"
  using implies_antitone implies_galois_swap eq_iff by auto

lemma implies_mp_eq [simp]:
  "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
  by (metis implies_below_eq implies_mp_below inf_left_commute inf.absorb2)

lemma implies_dist_implies:
  "x \<leadsto> (y \<leadsto> z) \<le> (x \<leadsto> y) \<leadsto> (x \<leadsto> z)"
  using implies_curry implies_curry_flip by auto

lemma implies_import_inf [simp]:
  "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
  by (metis implies_curry implies_mp_eq inf_commute)

lemma implies_dist_inf:
  "x \<leadsto> (y \<sqinter> z) = (x \<leadsto> y) \<sqinter> (x \<leadsto> z)"
proof -
  have "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<sqinter> x \<le> y \<sqinter> z"
    by (simp add: implies_galois)
  hence "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<le> x \<leadsto> (y \<sqinter> z)"
    using implies_galois by blast
  thus ?thesis
    by (simp add: implies_isotone eq_iff)
qed

lemma implies_itself_top:
  "y \<le> x \<leadsto> x"
  by (simp add: implies_galois_swap implies_increasing)

lemma inf_implies_top:
  "z \<le> (x \<sqinter> y) \<leadsto> x"
  using implies_galois_var le_infI1 by blast

lemma inf_inf_implies [simp]:
  "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
  by (simp add: inf_implies_top inf_absorb1)

lemma le_implies_top:
  "x \<le> y \<Longrightarrow> z \<le> x \<leadsto> y"
  using implies_antitone implies_itself_top order.trans by blast

lemma le_iff_le_implies:
  "x \<le> y \<longleftrightarrow> x \<le> x \<leadsto> y"
  using implies_galois inf_idem by force

lemma implies_inf_isotone:
  "x \<leadsto> y \<le> (x \<sqinter> z) \<leadsto> (y \<sqinter> z)"
  by (metis implies_curry implies_galois_increasing implies_isotone)

lemma implies_transitive:
  "(x \<leadsto> y) \<sqinter> (y \<leadsto> z) \<le> x \<leadsto> z"
  using implies_dist_implies implies_galois_var implies_increasing order_lesseq_imp by blast

lemma implies_inf_absorb [simp]:
  "x \<leadsto> (x \<sqinter> y) = x \<leadsto> y"
  using implies_dist_inf implies_itself_top inf.absorb_iff2 by auto

lemma implies_implies_absorb [simp]:
  "x \<leadsto> (x \<leadsto> y) = x \<leadsto> y"
  by (simp add: implies_curry)

lemma implies_inf_identity:
  "(x \<leadsto> y) \<sqinter> y = y"
  by (simp add: inf_commute)

lemma implies_itself_same:
  "x \<leadsto> x = y \<leadsto> y"
  by (simp add: le_implies_top eq_iff)

end

text \<open>
The following class gives equational axioms for the relative pseudocomplement operation (inequalities can be written as equations).
\<close>

class heyting_semilattice_eq = semilattice_inf + implies +
  assumes implies_mp_below: "x \<sqinter> (x \<leadsto> y) \<le> y"
      and implies_galois_increasing: "x \<le> y \<leadsto> (x \<sqinter> y)"
      and implies_isotone_inf: "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
begin

subclass heyting_semilattice
  apply unfold_locales
  apply (rule iffI)
  apply (metis implies_galois_increasing implies_isotone_inf inf.absorb2 order_lesseq_imp)
  by (metis implies_mp_below inf_commute order_trans inf_mono order_refl)

end

text \<open>
The following class allows us to explicitly give the pseudocomplement of an element relative to itself.
\<close>

class bounded_heyting_semilattice = bounded_semilattice_inf_top + heyting_semilattice
begin

lemma implies_itself [simp]:
  "x \<leadsto> x = top"
  using implies_galois inf_le2 top_le by blast

lemma implies_order:
  "x \<le> y \<longleftrightarrow> x \<leadsto> y = top"
  by (metis implies_galois inf_top.left_neutral top_unique)

lemma inf_implies [simp]:
  "(x \<sqinter> y) \<leadsto> x = top"
  using implies_order inf_le1 by blast

lemma top_implies [simp]:
  "top \<leadsto> x = x"
  by (metis implies_mp_eq inf_top.left_neutral)

end

subsubsection \<open>Heyting Lattices\<close>

text \<open>
We obtain further properties if the underlying structure is a lattice.
In particular, the lattice operations are automatically distributive in this case.
\<close>

class heyting_lattice = lattice + heyting_semilattice
begin

lemma sup_distrib_inf_le:
  "(x \<squnion> y) \<sqinter> (x \<squnion> z) \<le> x \<squnion> (y \<sqinter> z)"
proof -
  have "x \<squnion> z \<le> y \<leadsto> (x \<squnion> (y \<sqinter> z))"
    using implies_galois_var implies_increasing sup.bounded_iff sup.cobounded2 by blast
  hence "x \<squnion> y \<le> (x \<squnion> z) \<leadsto> (x \<squnion> (y \<sqinter> z))"
    using implies_galois_swap implies_increasing le_sup_iff by blast
  thus ?thesis
    by (simp add: implies_galois)
qed

subclass distrib_lattice
  apply unfold_locales
  using distrib_sup_le eq_iff sup_distrib_inf_le by auto

lemma implies_isotone_sup:
  "x \<leadsto> y \<le> x \<leadsto> (y \<squnion> z)"
  by (simp add: implies_isotone)

lemma implies_antitone_sup:
  "(x \<squnion> y) \<leadsto> z \<le> x \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_sup:
  "x \<leadsto> z \<le> (y \<leadsto> z) \<leadsto> ((x \<squnion> y) \<leadsto> z)"
proof -
  have "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> y \<le> z"
    by (simp add: implies_galois)
  hence "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> (x \<squnion> y) \<le> z"
    using implies_galois_swap implies_galois_var by fastforce
  thus ?thesis
    by (simp add: implies_galois)
qed

lemma implies_dist_sup:
  "(x \<squnion> y) \<leadsto> z = (x \<leadsto> z) \<sqinter> (y \<leadsto> z)"
  apply (rule antisym)
  apply (simp add: implies_antitone)
  by (simp add: implies_sup implies_galois)

lemma implies_antitone_isotone:
  "(x \<squnion> y) \<leadsto> (x \<sqinter> y) \<le> x \<leadsto> y"
  by (simp add: implies_antitone_sup implies_dist_inf le_infI2)

lemma implies_antisymmetry:
  "(x \<leadsto> y) \<sqinter> (y \<leadsto> x) = (x \<squnion> y) \<leadsto> (x \<sqinter> y)"
  by (metis implies_dist_sup implies_inf_absorb inf.commute)

lemma sup_inf_implies [simp]:
  "(x \<squnion> y) \<sqinter> (x \<leadsto> y) = y"
  by (simp add: inf_sup_distrib2 sup.absorb2)

lemma implies_subdist_sup:
  "(x \<leadsto> y) \<squnion> (x \<leadsto> z) \<le> x \<leadsto> (y \<squnion> z)"
  by (simp add: implies_isotone)

lemma implies_subdist_inf:
  "(x \<leadsto> z) \<squnion> (y \<leadsto> z) \<le> (x \<sqinter> y) \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_sup_absorb:
  "(x \<leadsto> y) \<squnion> z \<le> (x \<squnion> z) \<leadsto> (y \<squnion> z)"
  by (metis implies_dist_sup implies_isotone_sup implies_increasing inf_inf_implies le_sup_iff sup_inf_implies)

lemma sup_below_implies_implies:
  "x \<squnion> y \<le> (x \<leadsto> y) \<leadsto> y"
  by (simp add: implies_dist_sup implies_galois_swap implies_increasing)

end

class bounded_heyting_lattice = bounded_lattice + heyting_lattice
begin

subclass bounded_heyting_semilattice ..

lemma implies_bot [simp]:
  "bot \<leadsto> x = top"
  using implies_galois top_unique by fastforce

end

subsubsection \<open>Heyting Algebras\<close>

text \<open>
The pseudocomplement operation can be defined in Heyting algebras, but it is typically not part of their signature.
We add the definition as an axiom so that we can use the class hierarchy, for example, to inherit results from the class \<open>pd_algebra\<close>.
\<close>

class heyting_algebra = bounded_heyting_lattice + uminus +
  assumes uminus_eq: "-x = x \<leadsto> bot"
begin

subclass pd_algebra
  apply unfold_locales
  using bot_unique implies_galois uminus_eq by auto

lemma boolean_implies_below:
  "-x \<squnion> y \<le> x \<leadsto> y"
  by (simp add: implies_increasing implies_isotone uminus_eq)

lemma negation_implies:
  "-(x \<leadsto> y) = --x \<sqinter> -y"
proof (rule antisym)
  show "-(x \<leadsto> y) \<le> --x \<sqinter> -y"
    using boolean_implies_below p_antitone by auto
next
  have "x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
    by (metis implies_mp_eq inf_p inf_bot_left inf_commute inf_left_commute)
  hence "--x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
    using pp_inf_bot_iff inf_assoc by auto
  thus "--x \<sqinter> -y \<le> -(x \<leadsto> y)"
    by (simp add: pseudo_complement)
qed

lemma double_negation_dist_implies:
  "--(x \<leadsto> y) = --x \<leadsto> --y"
  apply (rule antisym)
  apply (metis pp_inf_below_iff implies_galois_decreasing implies_galois negation_implies ppp)
  by (simp add: p_antitone_iff negation_implies)

(*
lemma stone: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
*)

end

text \<open>
The following class gives equational axioms for Heyting algebras.
\<close>

class heyting_algebra_eq = bounded_lattice + implies + uminus +
  assumes implies_mp_eq: "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
      and implies_import_inf: "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
      and inf_inf_implies: "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
      and uminus_eq_eq: "-x = x \<leadsto> bot"
begin

subclass heyting_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis implies_import_inf inf.sup_left_divisibility inf_inf_implies le_iff_inf)
  apply (metis implies_mp_eq inf.commute inf.le_sup_iff inf.sup_right_isotone)
  by (simp add: uminus_eq_eq)

end

text \<open>
A relative pseudocomplement is not enough to obtain the Stone equation, so we add it in the following class.
\<close>

class heyting_stone_algebra = heyting_algebra +
  assumes heyting_stone: "-x \<squnion> --x = top"
begin

subclass stone_algebra
  by unfold_locales (simp add: heyting_stone)

(*
lemma pre_linear: "(x \<leadsto> y) \<squnion> (y \<leadsto> x) = top" nitpick [expect=genuine] oops
*)

end

subsubsection \<open>Brouwer Algebras\<close>

text \<open>
Brouwer algebras are dual to Heyting algebras.
The dual pseudocomplement of an element \<open>y\<close> relative to an element \<open>x\<close> is the least element whose join with \<open>y\<close> is above \<open>x\<close>.
We can now use the binary operation provided by Boolean algebras in Isabelle/HOL because it is compatible with dual relative pseudocomplements (not relative pseudocomplements).
\<close>

class brouwer_algebra = bounded_lattice + minus + uminus +
  assumes minus_galois: "x \<le> y \<squnion> z \<longleftrightarrow> x - y \<le> z"
      and uminus_eq_minus: "-x = top - x"
begin

sublocale brouwer: heyting_algebra where inf = sup and less_eq = greater_eq and less = greater and sup = inf and bot = top and top = bot and implies = "\<lambda>x y . y - x"
  apply unfold_locales
  apply simp
  apply simp
  apply simp
  apply simp
  apply (metis minus_galois sup_commute)
  by (simp add: uminus_eq_minus)

lemma curry_minus:
  "x - (y \<squnion> z) = (x - y) - z"
  by (simp add: brouwer.implies_curry sup_commute)

lemma minus_subdist_sup:
  "(x - z) \<squnion> (y - z) \<le> (x \<squnion> y) - z"
  by (simp add: brouwer.implies_dist_inf)

lemma inf_sup_minus:
  "(x \<sqinter> y) \<squnion> (x - y) = x"
  by (simp add: inf.absorb1 brouwer.inf_sup_distrib2)

end

subsection \<open>Boolean Algebras\<close>

text \<open>
This section integrates Boolean algebras in the above hierarchy.
In particular, we strengthen several results shown above.
\<close>

context boolean_algebra
begin

text \<open>
Every Boolean algebra is a Stone algebra, a Heyting algebra and a Brouwer algebra.
\<close>

subclass stone_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis compl_sup_top inf.orderI inf_bot_right inf_sup_distrib1 inf_top_right sup_inf_absorb)
  using inf.commute inf.sup_right_divisibility apply fastforce
  by simp

sublocale heyting: heyting_algebra where implies = "\<lambda>x y . -x \<squnion> y"
  apply unfold_locales
  apply (rule iffI)
  using shunting_var_p sup_commute apply fastforce
  using shunting_var_p sup_commute apply force
  by simp

subclass brouwer_algebra
  apply unfold_locales
  apply (simp add: diff_eq shunting_var_p sup.commute)
  by (simp add: diff_eq)

lemma huntington_3 [simp]:
  "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = x"
  using huntington_3_pp by auto

lemma maddux_3_1:
  "x \<squnion> -x = y \<squnion> -y"
  by simp

lemma maddux_3_4:
  "x \<squnion> (y \<squnion> -y) = z \<squnion> -z"
  by simp

lemma maddux_3_11 [simp]:
  "(x \<sqinter> y) \<squnion> (x \<sqinter> -y) = x"
  using brouwer.maddux_3_12 sup.commute by auto

lemma maddux_3_19:
  "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)"
  using maddux_3_19_pp by auto

lemma compl_inter_eq:
  "x \<sqinter> y = x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
  by (metis inf_commute maddux_3_11)

lemma maddux_3_21 [simp]:
  "x \<squnion> (-x \<sqinter> y) = x \<squnion> y"
  by (simp add: sup_inf_distrib1)

lemma shunting_1:
  "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot"
  by (simp add: pseudo_complement)

lemma uminus_involutive:
  "uminus \<circ> uminus = id"
  by auto

lemma uminus_injective:
  "uminus \<circ> f = uminus \<circ> g \<Longrightarrow> f = g"
  by (metis comp_assoc id_o minus_comp_minus)

lemma conjugate_unique:
  "conjugate f g \<Longrightarrow> conjugate f h \<Longrightarrow> g = h"
  using conjugate_unique_p uminus_injective by blast

lemma dual_additive_additive:
  "dual_additive (uminus \<circ> f) \<Longrightarrow> additive f"
  by (metis additive_def compl_eq_compl_iff dual_additive_def p_dist_sup o_def)

lemma conjugate_additive:
  "conjugate f g \<Longrightarrow> additive f"
  by (simp add: conjugate_dual_additive dual_additive_additive)

lemma conjugate_isotone:
  "conjugate f g \<Longrightarrow> isotone f"
  by (simp add: conjugate_additive additive_isotone)

lemma conjugate_char_1:
  "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)"
  by (simp add: conjugate_char_1_pp)

lemma conjugate_char_2:
  "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))"
  by (simp add: conjugate_char_2_pp)

lemma shunting:
  "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y"
  by (simp add: heyting.implies_galois sup.commute)

lemma shunting_var:
  "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y"
  by (simp add: shunting)

end

class non_trivial_stone_algebra = non_trivial_bounded_order + stone_algebra

class non_trivial_boolean_algebra = non_trivial_stone_algebra + boolean_algebra

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Multisets\<close>

theory Card_Multisets
imports
  "HOL-Library.Multiset"
begin

subsection \<open>Additions to Multiset Theory\<close>

lemma mset_set_set_mset_subseteq:
  "mset_set (set_mset M) \<subseteq># M"
proof (induct M)
  case empty
  show ?case by simp
next
  case (add x M)
  from this show ?case
  proof (cases "x \<in># M")
    assume "x \<in># M"
    from this have "mset_set (set_mset (M + {#x#})) = mset_set (set_mset M)"
      by (simp add: insert_absorb)
    from this add.hyps show ?thesis
      using subset_mset.trans by fastforce
  next
    assume "\<not> x \<in># M"
    from this add.hyps have "{#x#} + mset_set (set_mset M) \<subseteq># M + {#x#}"
      by (simp add: insert_subset_eq_iff)
    from this \<open>\<not> x \<in># M\<close> show ?thesis by simp
  qed
qed

lemma size_mset_set_eq_card:
  assumes "finite A"
  shows "size (mset_set A) = card A"
using assms by (induct A) auto

lemma card_set_mset_leq:
  "card (set_mset M) \<le> size M"
by (induct M) (auto simp add: card_insert_le_m1)

subsection \<open>Lemma to Enumerate Sets of Multisets\<close>

lemma set_of_multisets_eq:
  assumes "x \<notin> A"
  shows "{M. set_mset M \<subseteq> insert x A \<and> size M = Suc k} =
    {M. set_mset M \<subseteq> A \<and> size M = Suc k} \<union>
    (\<lambda>M. M + {#x#}) ` {M. set_mset M \<subseteq> insert x A \<and> size M = k}"
proof -
  from \<open>x \<notin> A\<close> have "{M. set_mset M \<subseteq> insert x A \<and> size M = Suc k} =
    {M. set_mset M \<subseteq> A \<and> size M = Suc k} \<union>
    {M. set_mset M \<subseteq> insert x A \<and> size M = Suc k \<and> x \<in># M}"
    by auto
  moreover have "{M. set_mset M \<subseteq> insert x A \<and> size M = Suc k \<and> x \<in># M} =
    (\<lambda>M. M + {#x#}) ` {M. set_mset M \<subseteq> insert x A \<and> size M = k}" (is "?S = ?T")
  proof
    show "?S \<subseteq> ?T"
    proof
      fix M
      assume "M \<in> ?S"
      from this have "M = M - {#x#} + {#x#}" by auto
      moreover have "M - {#x#} \<in> {M. set_mset M \<subseteq> insert x A \<and> size M = k}"
      proof -
        have "set_mset (M - {#x#} + {#x#}) \<subseteq> insert x A"
          using \<open>M \<in> ?S\<close> by force
        moreover have "size (M - {#x#} + {#x#}) = Suc k \<and> x \<in># M - {#x#} + {#x#}"
          using \<open>M \<in> ?S\<close> by force
        ultimately show ?thesis by force
      qed
      ultimately show "M \<in> ?T" by auto
    qed
  next
    show "?T \<subseteq> ?S" by force
  qed
  ultimately show ?thesis by auto
qed

subsection \<open>Derivation of Suitable Induction Rule\<close>

context
begin

private inductive R :: "'a set \<Rightarrow> nat \<Rightarrow> bool"
where
  "finite A \<Longrightarrow> R A 0"
| "R {} k"
| "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> R A (Suc k) \<Longrightarrow> R (insert x A) k \<Longrightarrow> R (insert x A) (Suc k)"

private lemma R_eq_finite:
  "R A k \<longleftrightarrow> finite A"
proof
  assume "R A k"
  from this show "finite A" by cases auto
next
  assume "finite A"
  from this show "R A k"
  proof (induct A)
    case empty
    from this show ?case by (rule R.intros(2))
  next
    case insert
    from this show ?case
    proof (induct k)
      case 0
      from this show ?case
        by (intro R.intros(1) finite.insertI)
    next
      case Suc
      from this show ?case
        by (metis R.simps Zero_neq_Suc diff_Suc_1)
    qed
  qed
qed

lemma finite_set_and_nat_induct[consumes 1, case_names zero empty step]:
  assumes "finite A"
  assumes "\<And>A. finite A \<Longrightarrow> P A 0"
  assumes "\<And>k. P {} k"
  assumes "\<And>A k x. finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> P A (Suc k) \<Longrightarrow> P (insert x A) k \<Longrightarrow> P (insert x A) (Suc k)"
  shows "P A k"
proof -
  from \<open>finite A\<close> have "R A k" by (subst R_eq_finite)
  from this assms(2-4) show ?thesis by (induct A k) auto
qed

end

subsection \<open>Finiteness of Sets of Multisets\<close>

lemma finite_multisets:
  assumes "finite A"
  shows "finite {M. set_mset M \<subseteq> A \<and> size M = k}"
using assms
proof (induct A k rule: finite_set_and_nat_induct)
  case zero
  from this show ?case by auto
next
  case empty
  from this show ?case by auto
next
  case (step A k x)
  from this show ?case
    using set_of_multisets_eq[OF \<open>x \<notin> A\<close>] by simp
qed

subsection \<open>Cardinality of Multisets\<close>

lemma card_multisets:
  assumes "finite A"
  shows "card {M. set_mset M \<subseteq> A \<and> size M = k} = (card A + k - 1) choose k"
using assms
proof (induct A k rule: finite_set_and_nat_induct)
  case (zero A)
  assume "finite (A :: 'a set)"
  have "{M. set_mset M \<subseteq> A \<and> size M = 0} = {{#}}" by auto
  from this show "card {M. set_mset M \<subseteq> A \<and> size M = 0} = card A + 0 - 1 choose 0"
    by simp
next
  case (empty k)
  show "card {M. set_mset M \<subseteq> {} \<and> size M = k} = card {} + k - 1 choose k"
    by (cases k) (auto simp add: binomial_eq_0)
next
  case (step A k x)
  let ?S\<^sub>1 = "{M. set_mset M \<subseteq> A \<and> size M = Suc k}"
  and ?S\<^sub>2 = "{M. set_mset M \<subseteq> insert x A \<and> size M = k}"
  assume hyps1: "card ?S\<^sub>1 = card A + Suc k - 1 choose Suc k"
  assume hyps2: "card ?S\<^sub>2 = card (insert x A) + k - 1 choose k"
  have finite_sets: "finite ?S\<^sub>1" "finite ((\<lambda>M. M + {#x#}) ` ?S\<^sub>2)"
    using \<open>finite A\<close> by (auto simp add: finite_multisets)
  have inj: "inj_on (\<lambda>M. M + {#x#}) ?S\<^sub>2" by (rule inj_onI) auto
  have "card {M. set_mset M \<subseteq> insert x A \<and> size M = Suc k} =
    card (?S\<^sub>1 \<union> (\<lambda>M. M + {#x#}) ` ?S\<^sub>2)"
    using set_of_multisets_eq \<open>x \<notin> A\<close> by fastforce
  also have "\<dots> = card ?S\<^sub>1 + card ((\<lambda>M. M + {#x#}) ` ?S\<^sub>2)"
    using finite_sets \<open>x \<notin> A\<close> by (subst card_Un_disjoint) auto
  also have "\<dots> = card ?S\<^sub>1 + card ?S\<^sub>2"
    using inj by (auto intro: card_image)
  also have "\<dots> = card A + Suc k - 1 choose Suc k + (card (insert x A) + k - 1 choose k)"
    using hyps1 hyps2 by simp
  also have "\<dots> = card (insert x A) + Suc k - 1 choose Suc k"
    using \<open>x \<notin> A\<close> \<open>finite A\<close> by simp
  finally show ?case .
qed

lemma card_too_small_multisets_covering_set:
  assumes "finite A"
  assumes "k < card A"
  shows "card {M. set_mset M = A \<and> size M = k} = 0"
proof -
  from \<open>k < card A\<close> have eq: "{M. set_mset M = A \<and> size M = k} = {}"
    using card_set_mset_leq Collect_empty_eq leD by auto
  from this show ?thesis by (metis card.empty)
qed

lemma card_multisets_covering_set:
  assumes "finite A"
  assumes "card A \<le> k"
  shows "card {M. set_mset M = A \<and> size M = k} = (k - 1) choose (k - card A)"
proof -
  have "{M. set_mset M = A \<and> size M = k} = (\<lambda>M. M + mset_set A) `
    {M. set_mset M \<subseteq> A \<and> size M = k - card A}" (is "?S = ?f ` ?T")
  proof
    show "?S \<subseteq> ?f ` ?T"
    proof
      fix M
      assume "M \<in> ?S"
      from this have "M = M - mset_set A + mset_set A"
        by (auto simp add: mset_set_set_mset_subseteq subset_mset.diff_add)
      moreover from \<open>M \<in> ?S\<close> have "M - mset_set A \<in> ?T"
        by (auto simp add: mset_set_set_mset_subseteq size_Diff_submset size_mset_set_eq_card in_diffD)
      ultimately show "M \<in> ?f ` ?T" by auto
    qed
  next
    from \<open>finite A\<close> \<open>card A \<le> k\<close> show "?f ` ?T \<subseteq> ?S"
      by (auto simp add: size_mset_set_eq_card)+
  qed
  moreover have "inj_on ?f ?T" by (rule inj_onI) auto
  ultimately have "card ?S = card ?T" by (simp add: card_image)
  also have "\<dots> = card A + (k - card A) - 1 choose (k - card A)"
    using \<open>finite A\<close> by (simp only: card_multisets)
  also have "\<dots> = (k - 1) choose (k - card A)"
    using \<open>card A \<le> k\<close> by auto
  finally show ?thesis .
qed

end


section \<open>ListUtilities\<close>

text \<open>
  \file{ListUtilities} defines a (proper) prefix relation for lists, and proves some
  additional lemmata, mostly about lists.
\<close>

theory ListUtilities
imports Main
begin

context begin

subsection \<open>List Prefixes\<close>

inductive prefixList ::
  "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "prefixList [] (x # xs)"
| "prefixList xa xb \<Longrightarrow> prefixList (x # xa) (x # xb)"

lemma PrefixListHasTail:
fixes
  l1 :: "'a list" and
  l2 :: "'a list"
assumes
  "prefixList l1 l2"
shows
  "\<exists> l . l2 = l1 @ l \<and> l \<noteq> []"
  using assms by (induct rule: prefixList.induct, auto)

lemma PrefixListMonotonicity:
fixes
  l1 :: "'a list" and
  l2 :: "'a list"
assumes
  "prefixList l1 l2"
shows
  "length l1 < length l2"
using assms by (induct rule: prefixList.induct, auto)

lemma TailIsPrefixList :
fixes
  l1 :: "'a list" and
  tail :: "'a list"
assumes "tail \<noteq> []"
shows "prefixList l1 (l1 @ tail)"
using assms
proof (induct l1, auto)
  have "\<exists> x xs . tail = x # xs"
    using assms by (metis neq_Nil_conv)
  thus "prefixList [] tail"
    using assms  by (metis prefixList.intros(1))
next
  fix a l1
  assume "prefixList l1 (l1 @ tail)"
  thus "prefixList (a # l1) (a # l1 @ tail)"
    by (metis prefixList.intros(2))
qed

lemma PrefixListTransitive:
fixes
  l1 :: "'a list" and
  l2 :: "'a list" and
  l3 :: "'a list"
assumes
  "prefixList l1 l2"
  "prefixList l2 l3"
shows
  "prefixList l1 l3"
using assms
proof -
  from assms(1) have "\<exists> l12 . l2 = l1 @ l12 \<and> l12 \<noteq> []"
    using PrefixListHasTail by auto
  then obtain l12 where Extend1: "l2 = l1 @ l12 \<and> l12 \<noteq> []" by blast
  from assms(2) have Extend2: "\<exists> l23 . l3 = l2 @ l23 \<and> l23 \<noteq> []"
    using PrefixListHasTail by auto
  then obtain l23 where Extend2: "l3 = l2 @ l23 \<and> l23 \<noteq> []" by blast
  have "l3 = l1 @ (l12 @ l23) \<and> (l12 @ l23) \<noteq> []"
    using Extend1 Extend2 by simp
  hence "\<exists> l . l3 = l1 @ l \<and> l \<noteq> []" by blast
  thus "prefixList l1 l3" using TailIsPrefixList by auto
qed

subsection \<open>Lemmas for lists and nat predicates\<close>

lemma NatPredicateTippingPoint:
  assumes
    P0: "P 0" and NotPN2: "\<not>P n2"
  shows
    "\<exists>n<n2. P n \<and> \<not>P (Suc n)"
  by (metis NotPN2 P0 dec_induct zero_le)

lemma MinPredicate:
fixes
  P::"nat \<Rightarrow> bool"
assumes
  "\<exists> n . P n"
shows
  "(\<exists> n0 . (P n0) \<and> (\<forall> n' . (P n') \<longrightarrow> (n' \<ge> n0)))"
using assms
by (metis LeastI2_wellorder Suc_n_not_le_n)

text \<open>
  The lemma \isb{MinPredicate2} describes one case of \isb{MinPredicate}
  where the aforementioned smallest element is zero.
\<close>

lemma MinPredicate2:
fixes
  P::"nat \<Rightarrow> bool"
assumes
 "\<exists> n . P n"
shows
  "\<exists> n0 . (P n0) \<and> (n0 = 0 \<or> \<not> P (n0 - 1))"
using assms MinPredicate
by (metis add_diff_cancel_right' diff_is_0_eq diff_mult_distrib mult_eq_if)

text \<open>
  \isb{PredicatePairFunction} allows to obtain functions mapping two arguments
  to pairs from 4-ary predicates which are left-total on their first
  two arguments.
\<close>

private
lemma PredicatePairFunction:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
shows
  "\<exists>f . \<forall>x1 x2 . \<exists>y1 y2 .
    (f x1 x2) = (y1, y2)
    \<and> (P x1 x2 (fst (f x1 x2)) (snd (f x1 x2)))"
proof -
  define P' where "P'==\<lambda>x y . P (fst x) (snd x) (fst y) (snd y)"
  hence "\<forall>x . \<exists>y . (P' x  y)" using A1 by auto
  hence A3: "\<exists>f . \<forall>x . P' x (f x)" by metis
  then obtain f where "\<forall>x . P' x (f x)" by blast
  moreover define f' where  "f'==\<lambda>x1 x2. f (x1, x2)"
  ultimately have "\<forall>x . P' x (f' (fst x) (snd x))" by auto
  hence "\<exists>f' . \<forall>x . P' x (f' (fst x) (snd x))" by blast
  thus ?thesis using P'_def by auto
qed

lemma PredicatePairFunctions2:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
obtains f1 f2  where
  "\<forall>x1 x2 . \<exists>y1 y2 .
    (f1 x1 x2) = y1 \<and> (f2 x1 x2) = y2
    \<and> (P x1 x2 (f1 x1 x2) (f2 x1 x2))"
proof (cases thesis, auto)
  assume ass: "\<And>f1 f2. \<forall>x1 x2. P x1 x2 (f1 x1 x2) (f2 x1 x2) \<Longrightarrow> False"
  obtain f where F: "\<forall>x1 x2. \<exists>y1 y2. f x1 x2 = (y1, y2) \<and> P x1 x2 (fst (f x1 x2)) (snd (f x1 x2))"
    using PredicatePairFunction[OF A1] by blast
  define f1 where "f1 \<equiv> \<lambda>x1 x2 . fst (f x1 x2)"
  define f2 where "f2 \<equiv> \<lambda>x1 x2 . snd (f x1 x2)"
  show False
    using ass[of f1 f2] F unfolding f1_def f2_def by auto
qed

lemma PredicatePairFunctions2Inv:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
obtains f1 f2  where
  "\<forall>x1 x2 . (P x1 x2 (f1 x1 x2) (f2 x1 x2))"
using PredicatePairFunctions2[OF A1] by auto

lemma SmallerMultipleStepsWithLimit:
fixes
  k A limit
assumes
  "\<forall> n \<ge> limit . (A (Suc n)) < (A n)"
shows
  "\<forall> n \<ge> limit . (A (n + k)) \<le> (A n) - k"
proof(induct k,auto)
  fix n k
  assume IH: "\<forall>n\<ge>limit. A (n + k) \<le> A n - k" "limit \<le> n"
  hence "A (Suc (n + k)) < A (n + k)" using assms by simp
  hence "A (Suc (n + k)) < A n - k" using IH by auto
  thus "A (Suc (n + k)) \<le> A n - Suc k"
    by (metis Suc_lessI add_Suc_right add_diff_cancel_left'
       less_diff_conv less_or_eq_imp_le add.commute)
qed

lemma PrefixSameOnLow:
fixes
  l1 l2
assumes
  "prefixList l1 l2"
shows
  "\<forall> index < length l1 . l1 ! index = l2 ! index"
using assms
proof(induct rule: prefixList.induct, auto)
  fix xa xb ::"'a list" and x index
  assume AssumpProof: "prefixList xa xb"
        "\<forall>index < length xa. xa ! index = xb ! index"
        "prefixList l1 l2" "index < Suc (length xa)"
  show "(x # xa) ! index = (x # xb) ! index" using AssumpProof
  proof(cases "index = 0", auto)
  qed
qed

lemma KeepProperty:
fixes
  P Q low
assumes
  "\<forall> i \<ge> low . P i \<longrightarrow> (P (Suc i) \<and> Q i)" "P low"
shows
  "\<forall> i \<ge> low . Q i"
using assms
proof(clarify)
  fix i
  assume Assump:
    "\<forall>i\<ge>low. P i \<longrightarrow> P (Suc i) \<and> Q i"
    "P low"
    "low \<le> i"
  hence "\<forall>i\<ge>low. P i \<longrightarrow> P (Suc i)" by blast
  hence "\<forall> i \<ge> low . P i" using Assump(2) by (metis dec_induct)
  hence "P i" using Assump(3) by blast
  thus "Q i" using Assump by blast
qed

lemma ListLenDrop:
fixes
  i la lb
assumes
  "i < length lb"
  "i \<ge> la"
shows
  "lb ! i \<in> set (drop la lb)"
using assms
by (metis Cons_nth_drop_Suc in_set_member member_rec(1)
       set_drop_subset_set_drop set_rev_mp)

private
lemma DropToShift:
fixes
  l i list
assumes
  "l + i < length list"
shows
  "(drop l list) ! i = list ! (l + i)"
using assms
by (induct l, auto)

lemma SetToIndex:
fixes
  a and liste::"'a list"
assumes
  AssumpSetToIndex: "a \<in> set liste"
shows
  "\<exists> index < length liste . a = liste ! index"
  by (metis assms in_set_conv_nth)

private
lemma DropToIndex:
fixes
  a::"'a" and l liste
assumes
  AssumpDropToIndex: "a \<in> set (drop l liste)"
shows
  "\<exists> i \<ge> l . i < length liste \<and> a = liste ! i"
proof-
  have "\<exists> index < length (drop l liste) . a = (drop l liste) ! index"
    using AssumpDropToIndex SetToIndex[of "a" "drop l liste"] by blast
  then obtain index where Index: "index < length (drop l liste)"
    "a = (drop l liste) ! index" by blast
  have "l + index < length liste" using Index(1)
    by (metis length_drop less_diff_conv add.commute)
  hence "a = liste ! (l + index)"
    using DropToShift[of "l" "index"] Index(2) by blast
  thus "\<exists>i\<ge>l. i < length liste \<and> a = liste ! i"
    by (metis \<open>l + index < length liste\<close> le_add1)
qed

end

end


theory ex_4_2
  imports Main
begin

lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof -
  let ?l_zs = "length xs div 2"
  let ?l_ys = "length xs - ?l_zs"

  have "?l_ys \<le> length xs" by simp

  let ?ys = "take ?l_ys xs"
  let ?zs = "drop ?l_ys xs"
  have concat:"xs = ?ys @ ?zs" by simp
  hence "length xs = length ?ys + length ?zs" by simp
  moreover from `?l_ys \<le> length xs` have l_ys:"length ?ys = ?l_ys" by simp
  ultimately have l_zs:"length ?zs = ?l_zs" by simp

  have "xs = ?ys @ ?zs \<and> (length ?ys = length ?zs \<or> length ?ys = length ?zs + 1)"
  proof cases
    assume "?l_ys = ?l_zs"
    with concat l_ys l_zs show ?thesis by auto
  next
    assume "?l_ys \<noteq> ?l_zs"
    hence "?l_ys = ?l_zs + 1" by auto
    with concat l_ys l_zs show ?thesis by auto
  qed
  thus ?thesis by blast
qed
end