section\<open>Examples of Classical Reasoning\<close>

theory FOL_examples imports FOL begin

lemma "EX y. ALL x. P(y)-->P(x)"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule exCI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule allI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule impI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule allE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
txt\<open>see below for \<open>allI\<close> combined with \<open>swap\<close>\<close>
apply (erule allI [THEN [2] swap])
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule impI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule notE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
done

text \<open>
@{thm[display] allI [THEN [2] swap]}
\<close>

lemma "EX y. ALL x. P(y)-->P(x)"
by blast

end


theory Examples
imports MainRLT "HOL-Library.Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 480.0]]

section \<open>Formal Languages\<close>

subsection \<open>General Context Free Grammars\<close>

text \<open>a contribution by Aditi Barthwal\<close>

datatype ('nts,'ts) symbol = NTS 'nts
                            | TS 'ts

datatype ('nts,'ts) rule = rule 'nts "('nts,'ts) symbol list"

type_synonym ('nts,'ts) grammar = "('nts,'ts) rule set * 'nts"

fun rules :: "('nts,'ts) grammar => ('nts,'ts) rule set"
where
  "rules (r, s) = r"

definition derives
where
"derives g = { (lsl,rsl). \<exists>s1 s2 lhs rhs.
                         (s1 @ [NTS lhs] @ s2 = lsl) \<and>
                         (s1 @ rhs @ s2) = rsl \<and>
                         (rule lhs rhs) \<in> fst g }"

definition derivesp ::
  "(('nts, 'ts) rule => bool) * 'nts => ('nts, 'ts) symbol list => ('nts, 'ts) symbol list => bool"
where
  "derivesp g = (\<lambda> lhs rhs. (lhs, rhs) \<in> derives (Collect (fst g), snd g))"

lemma [code_pred_def]:
  "derivesp g = (\<lambda> lsl rsl. \<exists>s1 s2 lhs rhs.
                         (s1 @ [NTS lhs] @ s2 = lsl) \<and>
                         (s1 @ rhs @ s2) = rsl \<and>
                         (fst g) (rule lhs rhs))"
unfolding derivesp_def derives_def by auto

abbreviation "example_grammar ==
({ rule ''S'' [NTS ''A'', NTS ''B''],
   rule ''S'' [TS ''a''],
  rule ''A'' [TS ''b'']}, ''S'')"

definition "example_rules ==
(%x. x = rule ''S'' [NTS ''A'', NTS ''B''] \<or>
   x = rule ''S'' [TS ''a''] \<or>
  x = rule ''A'' [TS ''b''])"

code_pred [inductify, skip_proof] derivesp .

thm derivesp.equation

definition "testp = (% rhs. derivesp (example_rules, ''S'') [NTS ''S''] rhs)"

code_pred (modes: o \<Rightarrow> bool) [inductify] testp .
thm testp.equation

values "{rhs. testp rhs}"

declare rtranclp.intros(1)[code_pred_def] converse_rtranclp_into_rtranclp[code_pred_def]

code_pred [inductify] rtranclp .

definition "test2 = (\<lambda> rhs. rtranclp (derivesp (example_rules, ''S'')) [NTS ''S''] rhs)"

code_pred [inductify, skip_proof] test2 .

values "{rhs. test2 rhs}"

subsection \<open>Some concrete Context Free Grammars\<close>

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

code_pred [inductify] S\<^sub>1p .
code_pred [random_dseq inductify] S\<^sub>1p .
thm S\<^sub>1p.equation
thm S\<^sub>1p.random_dseq_equation

values [random_dseq 5, 5, 5] 5 "{x. S\<^sub>1p x}"

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

code_pred [random_dseq inductify] S\<^sub>2p .
thm S\<^sub>2p.random_dseq_equation
thm A\<^sub>2p.random_dseq_equation
thm B\<^sub>2p.random_dseq_equation

values [random_dseq 5, 5, 5] 10 "{x. S\<^sub>2p x}"

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

code_pred [inductify, skip_proof] S\<^sub>3p .
thm S\<^sub>3p.equation

values 10 "{x. S\<^sub>3p x}"

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

code_pred (expected_modes: o => bool, i => bool) S\<^sub>4p .

hide_const a b

section \<open>Semantics of programming languages\<close>

subsection \<open>IMP\<close>

type_synonym var = nat
type_synonym state = "int list"

datatype com =
  Skip |
  Ass var "state => int" |
  Seq com com |
  IF "state => bool" com com |
  While "state => bool" com

inductive exec :: "com => state => state => bool" where
"exec Skip s s" |
"exec (Ass x e) s (s[x := e(s)])" |
"exec c1 s1 s2 ==> exec c2 s2 s3 ==> exec (Seq c1 c2) s1 s3" |
"b s ==> exec c1 s t ==> exec (IF b c1 c2) s t" |
"~b s ==> exec c2 s t ==> exec (IF b c1 c2) s t" |
"~b s ==> exec (While b c) s s" |
"b s1 ==> exec c s1 s2 ==> exec (While b c) s2 s3 ==> exec (While b c) s1 s3"

code_pred exec .

values "{t. exec
 (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))))
 [3,5] t}"

subsection \<open>Lambda\<close>

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs type dB

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = None"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
where
  "nth_el' (x # xs) 0 x"
| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"

inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "nth_el' env x T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs T s) k = Abs T (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"

code_pred (expected_modes: i => i => o => bool, i => i => i => bool) typing .
thm typing.equation

code_pred (modes: i => i => bool,  i => o => bool as reduce') beta .
thm beta.equation

values "{x. App (Abs (Atom 0) (Var 0)) (Var 1) \<rightarrow>\<^sub>\<beta> x}"

definition "reduce t = Predicate.the (reduce' t)"

value "reduce (App (Abs (Atom 0) (Var 0)) (Var 1))"

code_pred [dseq] typing .
code_pred [random_dseq] typing .

values [random_dseq 1,1,5] 10 "{(\<Gamma>, t, T). \<Gamma> \<turnstile> t : T}"

subsection \<open>A minimal example of yet another semantics\<close>

text \<open>thanks to Elke Salecker\<close>

type_synonym vname = nat
type_synonym vvalue = int
type_synonym var_assign = "vname \<Rightarrow> vvalue"  \<comment> \<open>variable assignment\<close>

datatype ir_expr =
  IrConst vvalue
| ObjAddr vname
| Add ir_expr ir_expr

datatype val =
  IntVal  vvalue

record  configuration =
  Env :: var_assign

inductive eval_var ::
  "ir_expr \<Rightarrow> configuration \<Rightarrow> val \<Rightarrow> bool"
where
  irconst: "eval_var (IrConst i) conf (IntVal i)"
| objaddr: "\<lbrakk> Env conf n = i \<rbrakk> \<Longrightarrow> eval_var (ObjAddr n) conf (IntVal i)"
| plus: "\<lbrakk> eval_var l conf (IntVal vl); eval_var r conf (IntVal vr) \<rbrakk> \<Longrightarrow>
    eval_var (Add l r) conf (IntVal (vl+vr))"

code_pred eval_var .
thm eval_var.equation

values "{val. eval_var (Add (IrConst 1) (IrConst 2)) (| Env = (\<lambda>x. 0)|) val}"

subsection \<open>Another semantics\<close>

type_synonym name = nat \<comment> \<open>For simplicity in examples\<close>
type_synonym state' = "name \<Rightarrow> nat"

datatype aexp = N nat | V name | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state' \<Rightarrow> nat" where
"aval (N n) _ = n" |
"aval (V x) st = st x" |
"aval (Plus e\<^sub>1 e\<^sub>2) st = aval e\<^sub>1 st + aval e\<^sub>2 st"

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

primrec bval :: "bexp \<Rightarrow> state' \<Rightarrow> bool" where
"bval (B b) _ = b" |
"bval (Not b) st = (\<not> bval b st)" |
"bval (And b1 b2) st = (bval b1 st \<and> bval b2 st)" |
"bval (Less a\<^sub>1 a\<^sub>2) st = (aval a\<^sub>1 st < aval a\<^sub>2 st)"

datatype
  com' = SKIP
      | Assign name aexp         ("_ ::= _" [1000, 61] 61)
      | Semi   com'  com'          ("_; _"  [60, 61] 60)
      | If     bexp com' com'     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com'         ("WHILE _ DO _"  [0, 61] 61)

inductive
  big_step :: "com' * state' \<Rightarrow> state' \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
  Skip:    "(SKIP,s) \<Rightarrow> s"
| Assign:  "(x ::= a,s) \<Rightarrow> s(x := aval a s)"

| Semi:    "(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2  \<Longrightarrow>  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3  \<Longrightarrow> (c\<^sub>1;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3"

| IfTrue:  "bval b s  \<Longrightarrow>  (c\<^sub>1,s) \<Rightarrow> t  \<Longrightarrow>  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"
| IfFalse: "\<not>bval b s  \<Longrightarrow>  (c\<^sub>2,s) \<Rightarrow> t  \<Longrightarrow>  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"

| WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s"
| WhileTrue:  "bval b s\<^sub>1  \<Longrightarrow>  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2  \<Longrightarrow>  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3
               \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

code_pred big_step .

thm big_step.equation

definition list :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list" where
  "list s n = map s [0 ..< n]"

values [expected "{[42::nat, 43]}"] "{list s 2|s. (SKIP, nth [42, 43]) \<Rightarrow> s}"

subsection \<open>CCS\<close>

text\<open>This example formalizes finite CCS processes without communication or
recursion. For simplicity, labels are natural numbers.\<close>

datatype proc = nil | pre nat proc | or proc proc | par proc proc

inductive step :: "proc \<Rightarrow> nat \<Rightarrow> proc \<Rightarrow> bool" where
"step (pre n p) n p" |
"step p1 a q \<Longrightarrow> step (or p1 p2) a q" |
"step p2 a q \<Longrightarrow> step (or p1 p2) a q" |
"step p1 a q \<Longrightarrow> step (par p1 p2) a (par q p2)" |
"step p2 a q \<Longrightarrow> step (par p1 p2) a (par p1 q)"

code_pred step .

inductive steps where
"steps p [] p" |
"step p a q \<Longrightarrow> steps q as r \<Longrightarrow> steps p (a#as) r"

code_pred steps .

values 3
 "{as . steps (par (or (pre 0 nil) (pre 1 nil)) (pre 2 nil)) as (par nil nil)}"

values 5
 "{as . steps (par (or (pre 0 nil) (pre 1 nil)) (pre 2 nil)) as (par nil nil)}"

values 3 "{(a,q). step (par nil nil) a q}"

end


theory sse_boolean_algebra
  imports Main
begin

declare[[syntax_ambiguity_warning=false]]
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Shallow embedding of a Boolean algebra of propositions\<close>

text\<open>\noindent{In this section we present a shallow semantical embedding (SSE, cf. \<^cite>\<open>J41\<close> and \<^cite>\<open>J23\<close>)
for a family of logics whose semantics is based upon extensions of (complete and atomic) Boolean algebras.
The range of such logics is indeed very wide, including, as we will see, quantified paraconsistent and
paracomplete (e.g. intuitionistic) logics. Aside from illustrating how the SSE approach works in practice
we show how it allows us to effectively harness theorem provers, model finders and `hammers' for reasoning
with quantified non-classical logics. Proof reconstructions have deliberately been avoided.
Most of the proofs (in fact, all one-liners) have been found using Sledgehammer.}\<close>

text\<open>\noindent{Two notions play a fundamental role in this work: propositions and propositional functions.
Propositions, qua sentence denotations, are modeled as objects of type @{text "w\<Rightarrow>bool"} (shortened as @{text "\<sigma>"}).
Propositional functions, as the name indicates, are basically anything with a (parametric) type @{text "'t\<Rightarrow>\<sigma>"}.}\<close>

text\<open>\noindent{We introduce a type @{text "w"} for the domain of points (aka. 'worlds', 'states', etc.).
@{text "\<sigma>"} is a type alias for sets of points (i.e. propositions) encoded as characteristic functions.}\<close>
typedecl w
type_synonym \<sigma> = "w\<Rightarrow>bool"

text\<open>\noindent{In the sequel, we introduce the following naming convention for variables:

(i) Latin letters (A, b, M, P, q, X, y, etc.) denote in general propositions (type @{text "\<sigma>"});
however, we reserve letters D and S to denote sets of propositions (aka. domains/spaces) and
the letters u, v and w to denote worlds/points.

(ii) Greek letters (in particular @{text "\<pi>"}) denote propositional functions (type @{text "'t\<Rightarrow>\<sigma>"});
among the latter we may employ the letters @{text "\<phi>"}, @{text "\<psi>"} and @{text "\<eta>"} to explicitly
name those corresponding to unary connectives/operations (type @{text "\<sigma>\<Rightarrow>\<sigma>"}).}\<close>

subsection \<open>Encoding Boolean operations\<close>

text\<open>\noindent{We start with an ordered algebra,}\<close>
abbreviation sequ::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<approx>" 45) where "A \<^bold>\<approx> B \<equiv> \<forall>w. (A w) \<longleftrightarrow> (B w)"
abbreviation subs::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<preceq>" 45) where "A \<^bold>\<preceq> B \<equiv> \<forall>w. (A w) \<longrightarrow> (B w)"
abbreviation sups::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<succeq>" 45) where "B \<^bold>\<succeq> A \<equiv> A \<^bold>\<preceq> B"

text\<open>\noindent{define meet and join by reusing HOL metalogical conjunction and disjunction,}\<close>
definition meet::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<and>" 54) where "A \<^bold>\<and> B \<equiv> \<lambda>w. (A w) \<and> (B w)"
definition join::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<or>" 53) where "A \<^bold>\<or> B \<equiv> \<lambda>w. (A w) \<or> (B w)"

text\<open>\noindent{and introduce further operations to obtain a Boolean 'algebra of propositions'.}\<close>
definition top::"\<sigma>" ("\<^bold>\<top>")    where "\<^bold>\<top> \<equiv> \<lambda>w. True"
definition bottom::"\<sigma>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
definition impl::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<rightarrow>" 51) where "A \<^bold>\<rightarrow> B \<equiv> \<lambda>w. (A w)\<longrightarrow>(B w)"
definition dimp::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<leftrightarrow>" 51) where "A \<^bold>\<leftrightarrow> B \<equiv> \<lambda>w. (A w)\<longleftrightarrow>(B w)"
definition diff::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<leftharpoonup>" 51) where "A \<^bold>\<leftharpoonup> B \<equiv> \<lambda>w. (A w) \<and> \<not>(B w)"
definition compl::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<midarrow>_" [57]58) where "\<^bold>\<midarrow>A  \<equiv> \<lambda>w. \<not>(A w)"

named_theorems conn (*algebraic connectives*)
declare meet_def[conn] join_def[conn] top_def[conn] bottom_def[conn]
        impl_def[conn] dimp_def[conn] diff_def[conn] compl_def[conn]

text\<open>\noindent{Quite trivially, we can verify that the algebra satisfies some essential lattice properties.}\<close>
lemma "a \<^bold>\<or> a \<^bold>\<approx> a" unfolding conn by simp
lemma "a \<^bold>\<and> a \<^bold>\<approx> a" unfolding conn by simp
lemma "a \<^bold>\<preceq> a \<^bold>\<or> b" unfolding conn by simp
lemma "a \<^bold>\<and> b \<^bold>\<preceq> a" unfolding conn by simp
lemma "(a \<^bold>\<and> b) \<^bold>\<or> b \<^bold>\<approx> b" unfolding conn by auto (*absorption 1*)
lemma "a \<^bold>\<and> (a \<^bold>\<or> b) \<^bold>\<approx> a" unfolding conn by auto (*absorption 2*)
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> c \<Longrightarrow> a \<^bold>\<or> b \<^bold>\<preceq> c" unfolding conn by simp
lemma "c \<^bold>\<preceq> a \<Longrightarrow> c \<^bold>\<preceq> b \<Longrightarrow> c \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
lemma "a \<^bold>\<preceq> b \<equiv> (a \<^bold>\<or> b) \<^bold>\<approx> b" unfolding conn by smt
lemma "b \<^bold>\<preceq> a \<equiv> (a \<^bold>\<and> b) \<^bold>\<approx> b" unfolding conn by smt
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> d \<Longrightarrow> (a \<^bold>\<or> b) \<^bold>\<preceq> (c \<^bold>\<or> d)" unfolding conn by simp
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> d \<Longrightarrow> (a \<^bold>\<and> b) \<^bold>\<preceq> (c \<^bold>\<and> d)" unfolding conn by simp

subsection \<open>Second-order operations and fixed-points\<close>

text\<open>\noindent{We define equality for propositional functions as follows.}\<close>
definition equal_op::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>bool" (infix "\<^bold>\<equiv>" 60) where "\<phi> \<^bold>\<equiv> \<psi> \<equiv> \<forall>X. \<phi> X \<^bold>\<approx> \<psi> X"

text\<open>\noindent{Moreover, we define some useful Boolean (2nd-order) operations on propositional functions,}\<close>
abbreviation unionOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" (infixr "\<^bold>\<squnion>" 61) where "\<phi> \<^bold>\<squnion> \<psi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<or> \<psi> X"
abbreviation interOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" (infixr "\<^bold>\<sqinter>" 62) where "\<phi> \<^bold>\<sqinter> \<psi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<and> \<psi> X"
abbreviation compOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" ("(_\<^sup>c)") where "\<phi>\<^sup>c \<equiv> \<lambda>X. \<^bold>\<midarrow>\<phi> X"
text\<open>\noindent{some of them explicitly targeting operations,}\<close>
definition dual::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("(_\<^sup>d)") where "\<phi>\<^sup>d \<equiv> \<lambda>X. \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>X))"
text\<open>\noindent{and also define an useful operation (for technical purposes).}\<close>
definition id::"\<sigma>\<Rightarrow>\<sigma>" ("id") where "id A \<equiv> A"

text\<open>\noindent{We now prove some useful lemmas (some of them may help the provers in their hard work).}\<close>
lemma comp_symm: "\<phi>\<^sup>c = \<psi> \<Longrightarrow> \<phi> = \<psi>\<^sup>c" unfolding conn by blast
lemma comp_invol: "\<phi>\<^sup>c\<^sup>c = \<phi>" unfolding conn by blast
lemma dual_symm: "(\<phi> \<equiv> \<psi>\<^sup>d) \<Longrightarrow> (\<psi> \<equiv> \<phi>\<^sup>d)" unfolding dual_def conn by simp
lemma dual_comp: "\<phi>\<^sup>d\<^sup>c = \<phi>\<^sup>c\<^sup>d" unfolding dual_def by simp

lemma "id\<^sup>d \<^bold>\<equiv> id"  by (simp add: id_def dual_def equal_op_def conn)
lemma "id\<^sup>c \<^bold>\<equiv> compl"  by (simp add: id_def dual_def equal_op_def conn)
lemma "(A \<^bold>\<squnion> B)\<^sup>d \<^bold>\<equiv> (A\<^sup>d) \<^bold>\<sqinter> (B\<^sup>d)" by (simp add: dual_def equal_op_def conn)
lemma "(A \<^bold>\<squnion> B)\<^sup>c \<^bold>\<equiv> (A\<^sup>c) \<^bold>\<sqinter> (B\<^sup>c)" by (simp add: equal_op_def conn)
lemma "(A \<^bold>\<sqinter> B)\<^sup>d \<^bold>\<equiv> (A\<^sup>d) \<^bold>\<squnion> (B\<^sup>d)" by (simp add: dual_def equal_op_def conn)
lemma "(A \<^bold>\<sqinter> B)\<^sup>c \<^bold>\<equiv> (A\<^sup>c) \<^bold>\<squnion> (B\<^sup>c)" by (simp add: equal_op_def conn)

text\<open>\noindent{The notion of a fixed point is a fundamental one. We speak of propositions being fixed points of
operations. For a given operation we define in the usual way a fixed-point predicate for propositions.}\<close>
abbreviation fixedpoint::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>bool)" ("fp") where "fp \<phi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<approx> X"

text\<open>\noindent{Indeed, we can 'operationalize' this predicate by defining a fixed-point operator as follows:}\<close>
abbreviation fixedpoint_op::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("(_\<^sup>f\<^sup>p)") where "\<phi>\<^sup>f\<^sup>p  \<equiv> \<lambda>X. (\<phi> X) \<^bold>\<leftrightarrow> X"

lemma ofp_c: "(\<phi>\<^sup>c)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>c" unfolding conn equal_op_def by auto
lemma ofp_d: "(\<phi>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>d\<^sup>c" unfolding dual_def equal_op_def conn by auto
lemma ofp_dc:"(\<phi>\<^sup>d\<^sup>c)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>d" unfolding dual_def equal_op_def conn by auto
lemma ofp_decomp: "\<phi>\<^sup>f\<^sup>p \<^bold>\<equiv> (id \<^bold>\<sqinter> \<phi>) \<^bold>\<squnion> ((id \<^bold>\<squnion> \<phi>)\<^sup>c)" unfolding equal_op_def id_def conn by auto
lemma ofp_invol: "(\<phi>\<^sup>f\<^sup>p)\<^sup>f\<^sup>p \<^bold>\<equiv> \<phi>" unfolding conn equal_op_def by auto

text\<open>\noindent{Fixed-point predicate and fixed-point operator are closely related.}\<close>
lemma fp_rel: "((fp \<phi>) X) = (\<phi>\<^sup>f\<^sup>p X \<^bold>\<approx> \<^bold>\<top>)" unfolding conn by auto
lemma fp_d_rel:  "((fp \<phi>\<^sup>d) X) = (\<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>X) \<^bold>\<approx> \<^bold>\<top>)" unfolding dual_def conn by auto
lemma fp_c_rel: "((fp \<phi>\<^sup>c) X) = (\<phi>\<^sup>f\<^sup>p  X  \<^bold>\<approx> \<^bold>\<bottom>)" unfolding conn by auto
lemma fp_dc_rel: "((fp \<phi>\<^sup>d\<^sup>c) X) = (\<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>X) \<^bold>\<approx> \<^bold>\<bottom>)" unfolding dual_def conn by auto

subsection \<open>Equality and atomicity\<close>

text\<open>\noindent{We prove some facts about equality (which may help improve prover's performance).}\<close>
lemma eq_ext: "a \<^bold>\<approx> b \<Longrightarrow>  a = b" using ext by blast
lemma eq_ext': "a \<^bold>\<equiv> b \<Longrightarrow>  a = b" using ext unfolding equal_op_def by blast
lemma meet_char: "a \<^bold>\<preceq> b \<longleftrightarrow> a \<^bold>\<and> b \<^bold>\<approx> a" unfolding conn by blast
lemma join_char: "a \<^bold>\<preceq> b \<longleftrightarrow> a \<^bold>\<or> b \<^bold>\<approx> b" unfolding conn  by blast

text\<open>\noindent{We can verify indeed that the algebra is atomic (in three different ways) by relying on the
presence of primitive equality in HOL. A more general class of Boolean algebras could in principle
be obtained in systems without primitive equality or by suitably restricting quantification over
propositions (e.g. defining a topology and restricting quantifiers to open/closed sets).}\<close>
definition "atom a \<equiv> \<not>(a \<^bold>\<approx> \<^bold>\<bottom>) \<and> (\<forall>p. a \<^bold>\<preceq> p \<or> a \<^bold>\<preceq> \<^bold>\<midarrow>p)"
lemma atomic1: "\<forall>w. \<exists>q. q w \<and> (\<forall>p. p w \<longrightarrow> q \<^bold>\<preceq> p)" using the_sym_eq_trivial by (metis (full_types))
lemma atomic2: "\<forall>w. \<exists>q. q w \<and> atom(q)" using the_sym_eq_trivial by (metis (full_types) atom_def compl_def bottom_def)
lemma atomic3: "\<forall>p. \<not>(p \<^bold>\<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p)" proof - (*using atom_def unfolding conn by fastforce*)
  { fix p
    { assume "\<not>(p \<^bold>\<approx> \<^bold>\<bottom>)"
      hence "\<exists>v. p v" unfolding conn by simp
      then obtain w where 1:"p w" by (rule exE)
      let ?q="\<lambda>v. v = w" (*using HOL primitive equality*)
      have 2: "atom ?q" unfolding atom_def unfolding conn by simp
      have "\<forall>v. ?q v \<longrightarrow> p v" using 1 by simp
      hence 3: "?q \<^bold>\<preceq> p" by simp
      from 2 3 have "\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p" by blast
    } hence "\<not>(p \<^bold>\<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p)" by (rule impI)
  } thus ?thesis by (rule allI)
qed

end


section \<open> Connectivity \<close>
text \<open>This theory defines concepts around the connectivity of a graph and its vertices, as well as
graph properties that depend on connectivity definitions, such as shortest path, radius, diameter,
and eccentricity \<close>

theory Connectivity imports Undirected_Graph_Walks
begin

context ulgraph
begin

subsection \<open>Connecting Walks and Paths \<close>

definition connecting_walk :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
"connecting_walk u v xs \<equiv> is_walk xs \<and> hd xs= u \<and> last xs = v"

lemma connecting_walk_rev: "connecting_walk u v xs \<longleftrightarrow> connecting_walk v u (rev xs)"
  unfolding connecting_walk_def using is_walk_rev
  by (auto simp add: hd_rev last_rev)

lemma connecting_walk_wf: "connecting_walk u v xs \<Longrightarrow> u \<in> V \<and> v \<in> V"
  using is_walk_wf_hd is_walk_wf_last by (auto simp add: connecting_walk_def)

lemma connecting_walk_self: "u \<in> V \<Longrightarrow> connecting_walk u u [u] = True"
  unfolding connecting_walk_def by (simp add: is_walk_singleton)

text \<open> We define two definitions of connecting paths. The first uses the @{term "gen_path"} definition, which
allows for trivial paths and cycles, the second uses the stricter definition of a path which requires
it to be an open walk \<close>
definition connecting_path :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
"connecting_path u v xs \<equiv> is_gen_path xs \<and> hd xs = u \<and> last xs = v"

definition connecting_path_str :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
"connecting_path_str u v xs \<equiv> is_path xs \<and> hd xs = u \<and> last xs = v"

lemma connecting_path_rev: "connecting_path u v xs \<longleftrightarrow> connecting_path v u (rev xs)"
  unfolding connecting_path_def using is_gen_path_rev
  by (auto simp add: hd_rev last_rev)

lemma connecting_path_walk: "connecting_path u v xs \<Longrightarrow> connecting_walk u v xs"
  unfolding connecting_path_def connecting_walk_def using is_gen_path_def by auto

lemma connecting_path_str_gen: "connecting_path_str u v xs \<Longrightarrow> connecting_path u v xs"
  unfolding connecting_path_def connecting_path_str_def is_gen_path_def is_path_def
  by (simp add: is_open_walk_def)

lemma connecting_path_gen_str: "connecting_path u v xs \<Longrightarrow> (\<not> is_cycle xs) \<Longrightarrow> walk_length xs > 0 \<Longrightarrow> connecting_path_str u v xs"
  unfolding connecting_path_def connecting_path_str_def using is_gen_path_path by auto

lemma connecting_path_alt_def: "connecting_path u v xs \<longleftrightarrow> connecting_walk u v xs \<and> is_gen_path xs"
proof -
  have "is_gen_path xs \<Longrightarrow> is_walk xs"
    by (simp add: is_gen_path_def)
  then have "(is_walk xs \<and> hd xs = u \<and> last xs = v) \<and> is_gen_path xs \<longleftrightarrow> (hd xs = u \<and> last xs = v) \<and> is_gen_path xs"
    by blast
  thus ?thesis
    by (auto simp add: connecting_path_def connecting_walk_def)
qed

lemma connecting_path_length_bound: "u \<noteq> v \<Longrightarrow> connecting_path u v p \<Longrightarrow> walk_length p \<ge> 1"
  using walk_length_def
  by (metis connecting_path_def is_gen_path_def is_walk_not_empty2 last_ConsL le_refl length_0_conv
less_one list.exhaust_sel  nat_less_le nat_neq_iff neq_Nil_conv walk_edges.simps(3))

lemma connecting_path_self: "u \<in> V \<Longrightarrow> connecting_path u u [u] = True"
  unfolding connecting_path_alt_def using connecting_walk_self
  by (simp add: is_gen_path_def is_walk_singleton)

lemma connecting_path_singleton: "connecting_path u v xs \<Longrightarrow> length xs = 1 \<Longrightarrow> u = v"
  by (metis  cancel_comm_monoid_add_class.diff_cancel connecting_path_def fact_1 fact_nonzero
      last_rev length_0_conv neq_Nil_conv singleton_rev_conv walk_edges.simps(3) walk_length_conv walk_length_def)

lemma connecting_walk_path:
  assumes "connecting_walk u v xs"
  shows "\<exists> ys . connecting_path u v ys \<and> walk_length ys \<le> walk_length xs"
proof (cases "u = v")
  case True
  then show ?thesis
    using assms connecting_path_self connecting_walk_wf
    by (metis bot_nat_0.extremum list.size(3) walk_edges.simps(2) walk_length_def)
next
  case False
  then have "walk_length xs \<noteq> 0" using assms connecting_walk_def is_walk_def
    by (metis last_ConsL length_0_conv list.distinct(1) list.exhaust_sel walk_edges.simps(3) walk_length_def)
  then show ?thesis using assms False proof (induct "walk_length xs" arbitrary: xs rule: less_induct)
    fix xs assume IH: "(\<And>xsa. walk_length xsa < walk_length xs \<Longrightarrow> walk_length xsa \<noteq> 0 \<Longrightarrow>
      connecting_walk u v xsa \<Longrightarrow> u \<noteq> v \<Longrightarrow> \<exists>ys. connecting_path u v ys \<and> walk_length ys \<le> walk_length xsa)"
    assume assm: "connecting_walk u v xs" and ne: "u \<noteq> v" and n0: "walk_length xs \<noteq> 0"
    then show "\<exists>ys. connecting_path u v ys \<and> walk_length ys \<le> walk_length xs"
    proof (cases "walk_length xs \<le> 1") \<comment> \<open> Base Cases \<close>
      case True
      then have "walk_length xs = 1"
        using n0 by auto
      then show ?thesis using ne assm cancel_comm_monoid_add_class.diff_cancel connecting_path_alt_def connecting_walk_def
            distinct_length_2_or_more distinct_singleton hd_Cons_tl is_gen_path_def is_walk_def last_ConsL
            last_ConsR length_0_conv length_tl walk_length_conv
        by (metis True)
    next
      case False
      then show ?thesis
      proof (cases "distinct xs")
        case True
        then show ?thesis
          using assm connecting_path_alt_def connecting_walk_def is_gen_path_def by auto
      next
        case False
        then obtain ws ys zs y where xs_decomp: "xs = ws@[y]@ys@[y]@zs" using not_distinct_decomp
          by blast
        let ?rs = "ws@[y]@zs"
        have hd: "hd ?rs = u" using xs_decomp assm connecting_walk_def
          by (metis hd_append list.distinct(1))
        have lst: "last ?rs = v" using xs_decomp assm connecting_walk_def by simp
        have wl: "walk_length ?rs \<noteq> 0" using hd lst ne walk_length_conv by auto
        have "set ?rs \<subseteq> V" using assm connecting_walk_def is_walk_def xs_decomp by auto
        have cw: "connecting_walk u v ?rs" unfolding connecting_walk_def is_walk_decomp
          using assm connecting_walk_def hd is_walk_decomp lst xs_decomp by blast
        have "ys@[y] \<noteq> []"by simp
        then have "length ?rs < length xs" using xs_decomp length_list_decomp_lt by auto
        have "walk_length ?rs < walk_length xs" using walk_length_conv xs_decomp by force
        then show ?thesis using IH[of ?rs] using cw ne wl le_trans less_or_eq_imp_le by blast
      qed
    qed
  qed
qed

lemma connecting_walk_split:
  assumes "connecting_walk u v xs" assumes "connecting_walk v z ys"
  shows "connecting_walk u z (xs @ (tl ys))"
  using connecting_walk_def is_walk_append
  by (metis append.right_neutral assms(1) assms(2) connecting_walk_self connecting_walk_wf hd_append2 is_walk_not_empty last_appendR last_tl list.collapse)

lemma connecting_path_split:
  assumes "connecting_path u v xs" "connecting_path v z ys"
  obtains p where "connecting_path u z p" and "walk_length p \<le> walk_length (xs @ (tl ys))"
  using connecting_walk_split connecting_walk_path connecting_path_walk assms(1) assms(2) by blast

lemma connecting_path_split_length:
  assumes "connecting_path u v xs" "connecting_path v z ys"
  obtains p where "connecting_path u z p" and "walk_length p \<le> walk_length xs + walk_length ys"
proof -
  have "connecting_walk u z (xs @ (tl ys))"
    using connecting_walk_split assms connecting_path_walk by blast
  have "walk_length (xs @ (tl ys)) \<le> walk_length xs + walk_length ys"
    using walk_length_app_ineq
    by (simp add: le_diff_conv walk_length_conv)
  thus ?thesis using connecting_path_split
    by (metis (full_types) assms(1) assms(2) dual_order.trans that)
qed

subsection \<open> Vertex Connectivity \<close>
text \<open>Two vertices are defined to be connected if there exists a connecting path. Note that the more
general version of a connecting path is again used as a vertex should be considered as connected to itself \<close>
definition vert_connected :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"vert_connected u v \<equiv> \<exists> xs . connecting_path u v xs"

lemma vert_connected_rev: "vert_connected u v \<longleftrightarrow> vert_connected v u"
  unfolding vert_connected_def using connecting_path_rev by auto

lemma vert_connected_id: "u \<in> V \<Longrightarrow> vert_connected u u = True"
  unfolding vert_connected_def using connecting_path_self by auto

lemma vert_connected_trans: "vert_connected u v \<Longrightarrow> vert_connected v z \<Longrightarrow> vert_connected u z"
  unfolding vert_connected_def using connecting_path_split
  by meson

lemma vert_connected_wf: "vert_connected u v \<Longrightarrow> u \<in> V \<and> v \<in> V"
  using vert_connected_def connecting_path_walk connecting_walk_wf by blast

definition vert_connected_n :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> bool" where
"vert_connected_n u v n \<equiv> \<exists> p. connecting_path u v p \<and> walk_length p = n"

lemma vert_connected_n_imp: "vert_connected_n u v n \<Longrightarrow> vert_connected u v"
  by (auto simp add: vert_connected_def vert_connected_n_def)

lemma vert_connected_n_rev: "vert_connected_n u v n \<longleftrightarrow> vert_connected_n v u n"
  unfolding vert_connected_n_def using  walk_length_rev
  by (metis connecting_path_rev)

definition connecting_paths :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list set" where
"connecting_paths u v \<equiv> {xs . connecting_path u v xs}"

lemma connecting_paths_self: "u \<in> V \<Longrightarrow> [u] \<in> connecting_paths u u"
  unfolding connecting_paths_def using connecting_path_self by auto

lemma connecting_paths_empty_iff: "vert_connected u v \<longleftrightarrow> connecting_paths u v \<noteq> {}"
  unfolding connecting_paths_def vert_connected_def by auto

lemma elem_connecting_paths: "p \<in> connecting_paths u v \<Longrightarrow> connecting_path u v p"
  using connecting_paths_def by blast

lemma connecting_paths_ss_gen: "connecting_paths u v \<subseteq> gen_paths"
  unfolding connecting_paths_def gen_paths_def connecting_path_def by auto

lemma connecting_paths_sym: "xs \<in> connecting_paths u v \<longleftrightarrow> rev xs \<in> connecting_paths v u"
  unfolding connecting_paths_def using connecting_path_rev by simp

text \<open>A set is considered to be connected, if all the vertices within that set are pairwise connected \<close>
definition is_connected_set :: "'a set \<Rightarrow> bool" where
"is_connected_set V' \<equiv> (\<forall> u v . u \<in> V' \<longrightarrow> v \<in> V' \<longrightarrow> vert_connected u v)"

lemma is_connected_set_empty: "is_connected_set {}"
  unfolding is_connected_set_def by simp

lemma is_connected_set_singleton: "x \<in> V \<Longrightarrow> is_connected_set {x}"
  unfolding is_connected_set_def by (auto simp add: vert_connected_id)

lemma is_connected_set_wf: "is_connected_set V' \<Longrightarrow> V' \<subseteq> V"
  unfolding is_connected_set_def
  by (meson connecting_path_walk connecting_walk_wf subsetI vert_connected_def)

lemma is_connected_setD: "is_connected_set V' \<Longrightarrow> u \<in> V' \<Longrightarrow> v \<in> V' \<Longrightarrow> vert_connected u v"
  by (simp add: is_connected_set_def)

lemma not_connected_set: "\<not> is_connected_set V' \<Longrightarrow> u \<in> V' \<Longrightarrow> \<exists> v \<in> V' . \<not> vert_connected u v"
  using is_connected_setD by (meson is_connected_set_def vert_connected_rev vert_connected_trans)

subsection \<open>Graph Properties on Connectivity \<close>

text \<open>The shortest path is defined to be the infinum of the set of connecting path walk lengths.
Drawing inspiration from \<^cite>\<open>"noschinski_2012"\<close>, we use the infinum and enats as this enables more
natural reasoning in a non-finite setting, while also being useful for proofs of a more probabilistic
or analysis nature\<close>

definition shortest_path :: "'a \<Rightarrow> 'a \<Rightarrow> enat" where
"shortest_path u v \<equiv> INF p\<in> connecting_paths u v. enat (walk_length p)"

lemma shortest_path_walk_length: "shortest_path u v = n \<Longrightarrow> p \<in> connecting_paths u v \<Longrightarrow> walk_length p \<ge> n"
  using shortest_path_def INF_lower[of p "connecting_paths u v" "\<lambda> p . enat (walk_length p)"]
  by auto

lemma shortest_path_lte: "\<And> p . p \<in> connecting_paths u v \<Longrightarrow> shortest_path u v \<le> walk_length p"
  unfolding shortest_path_def by (simp add: Inf_lower)

lemma shortest_path_obtains:
  assumes "shortest_path u v = n"
  assumes "n \<noteq> top"
  obtains p where "p \<in> connecting_paths u v" and "walk_length p = n"
  using enat_in_INF shortest_path_def by (metis assms(1) assms(2) the_enat.simps)

lemma shortest_path_intro:
  assumes "n \<noteq> top"
  assumes "(\<exists> p \<in> connecting_paths u v . walk_length p = n)"
  assumes "(\<And> p. p \<in> connecting_paths u v \<Longrightarrow> n \<le> walk_length p)"
  shows "shortest_path u v = n"
proof (rule ccontr)
  assume a: "shortest_path u v \<noteq> enat n"
  then have "shortest_path u v < n"
    by (metis antisym_conv2 assms(2) shortest_path_lte)
  then have "\<exists> p \<in> connecting_paths u v .walk_length p < n"
    using shortest_path_def by (simp add: INF_less_iff)
  thus False using assms(3)
    using le_antisym less_imp_le_nat by blast
qed

lemma shortest_path_self:
  assumes "u \<in> V"
  shows "shortest_path u u = 0"
proof -
  have "[u] \<in> connecting_paths u u"
    using connecting_paths_self by (simp add: assms)
  then have "walk_length [u] = 0"
    using walk_length_def walk_edges.simps by auto
  thus ?thesis using shortest_path_def
    by (metis \<open>[u] \<in> connecting_paths u u\<close> le_zero_eq shortest_path_lte zero_enat_def)
qed

lemma connecting_paths_sym_length: "i \<in> connecting_paths u v \<Longrightarrow> \<exists>j\<in>connecting_paths v u. (walk_length j) = (walk_length i)"
  using connecting_paths_sym by (metis walk_length_rev)

lemma shortest_path_sym: "shortest_path u v = shortest_path v u"
  unfolding shortest_path_def
  by (intro INF_eq)(metis add.right_neutral le_iff_add connecting_paths_sym_length)+

lemma shortest_path_inf:  "\<not> vert_connected u v \<Longrightarrow> shortest_path u v = \<infinity>"
  using connecting_paths_empty_iff shortest_path_def by (simp add: top_enat_def)

lemma shortest_path_not_inf:
  assumes "vert_connected u v"
  shows "shortest_path u v \<noteq> \<infinity>"
proof -
  have "\<And> p. connecting_path u v p \<Longrightarrow> enat (walk_length p) \<noteq> \<infinity>"
    using connecting_path_def is_gen_path_def by auto
  thus ?thesis unfolding shortest_path_def connecting_paths_def
    by (metis assms connecting_paths_def infinity_ileE mem_Collect_eq shortest_path_def shortest_path_lte vert_connected_def)
qed

lemma shortest_path_obtains2:
  assumes "vert_connected u v"
  obtains p where "p \<in> connecting_paths u v" and "walk_length p = shortest_path u v"
proof -
  have "connecting_paths u v \<noteq> {}" using assms connecting_paths_empty_iff by auto
  have "shortest_path u v \<noteq> \<infinity>" using assms shortest_path_not_inf by simp
  thus ?thesis using shortest_path_def enat_in_INF
    by (metis that top_enat_def)
qed

lemma shortest_path_split: "shortest_path x y \<le> shortest_path x z + shortest_path z y"
proof (cases "vert_connected x y \<and> vert_connected x z")
  case True
  show ?thesis
  proof (rule ccontr)
    assume " \<not> shortest_path x y \<le> shortest_path x z + shortest_path z y"
    then have c: "shortest_path x y > shortest_path x z + shortest_path z y" by simp
    have "vert_connected z y" using True vert_connected_trans vert_connected_rev by blast
    then obtain p1 p2 where "connecting_path x z p1" and "connecting_path z y p2" and
      s1: "shortest_path x z = walk_length p1" and s2: "shortest_path z y = walk_length p2"
      using True shortest_path_obtains2 connecting_paths_def elem_connecting_paths by metis
    then obtain p3 where cp: "connecting_path x y p3" and "walk_length p1 + walk_length p2 \<ge> walk_length p3"
      using connecting_path_split_length by blast
    then have "shortest_path x z + shortest_path z y \<ge> walk_length p3" using s1 s2 by simp
    then have lt: "shortest_path x y > walk_length p3" using c by auto
    have "p3 \<in> connecting_paths x y" using cp connecting_paths_def by auto
    then show False using shortest_path_def shortest_path_obtains2
      by (metis True enat_ord_simps(1) enat_ord_simps(2) le_Suc_ex lt not_add_less1 shortest_path_lte)
  qed
next
  case False
  then show ?thesis
    by (metis enat_ord_code(3) plus_enat_simps(2) plus_enat_simps(3) shortest_path_inf vert_connected_trans)
qed

lemma shortest_path_invalid_v: "v \<notin> V \<or> u \<notin> V \<Longrightarrow> shortest_path u v = \<infinity>"
  using shortest_path_inf vert_connected_wf by blast

lemma shortest_path_lb:
  assumes "u \<noteq> v"
  assumes "vert_connected u v"
  shows "shortest_path u v > 0"
proof -
  have "\<And> p. connecting_path u v p  \<Longrightarrow>  enat (walk_length p) > 0"
    using connecting_path_length_bound assms by fastforce
  thus ?thesis unfolding shortest_path_def
    by (metis elem_connecting_paths shortest_path_def shortest_path_obtains2 assms(2))
qed

text \<open>Eccentricity of a vertex v is the furthest distance between it and a (different) vertex \<close>
definition eccentricity :: "'a \<Rightarrow> enat" where
"eccentricity v \<equiv> SUP u \<in> V - {v}. shortest_path v u"

lemma eccentricity_empty_vertices: "V = {} \<Longrightarrow> eccentricity v = 0"
  "V = {v} \<Longrightarrow> eccentricity v = 0"
  unfolding eccentricity_def using bot_enat_def by simp_all

lemma eccentricity_bot_iff: "eccentricity v = 0 \<longleftrightarrow> V = {} \<or> V = {v}"
proof (intro iffI)
  assume a: "eccentricity v = 0"
  show "V = {} \<or> V = {v}"
  proof (rule ccontr, simp)
    assume a2: "V \<noteq> {} \<and> V \<noteq> {v}"
    have eq0: "\<forall> u \<in> V - {v} . shortest_path v u = 0"
      using SUP_bot_conv(1)[of "\<lambda> u. shortest_path v u" "V - {v}"] a eccentricity_def bot_enat_def by simp
    have nc: "\<forall> u \<in> V - {v} . \<not> vert_connected v u \<longrightarrow> shortest_path v u = \<infinity>"
      using shortest_path_inf by simp
    have "\<forall> u \<in> V - {v} . vert_connected v u \<longrightarrow> shortest_path v u > 0"
      using shortest_path_lb by auto
    then show False using eq0 a2 nc
      by auto
  qed
next
  show "V = {} \<or> V = {v} \<Longrightarrow> eccentricity v = 0" using eccentricity_empty_vertices by auto
qed

lemma eccentricity_invalid_v:
  assumes "v \<notin> V"
  assumes "V \<noteq> {}"
  shows "eccentricity v = \<infinity>"
proof -
  have "\<And> u. shortest_path v u = \<infinity>" using assms shortest_path_invalid_v by blast
  have "V - {v} = V" using assms by simp
  then have "eccentricity v = (SUP u \<in> V . shortest_path v u)" by (simp add: eccentricity_def)
  thus ?thesis using eccentricity_def shortest_path_invalid_v assms by simp
qed

lemma eccentricity_gt_shortest_path:
  assumes "u \<in> V"
  shows "eccentricity v \<ge> shortest_path v u"
proof (cases "u \<in> V - {v}")
  case True
  then show ?thesis unfolding eccentricity_def by (simp add: SUP_upper)
next
  case f1: False
  then have "u = v" using assms by auto
  then have "shortest_path u v = 0" using shortest_path_self assms by auto
  then show ?thesis by (simp add: \<open>u = v\<close>)
qed

lemma eccentricity_disconnected_graph:
  assumes "\<not> is_connected_set V"
  assumes "v \<in> V"
  shows "eccentricity v = \<infinity>"
proof -
  obtain u where uin: "u \<in> V" and nvc: "\<not> vert_connected v u"
    using not_connected_set assms by auto
  then have "u \<noteq> v" using vert_connected_id by auto
  then have "u \<in> V - {v}" using uin by simp
  moreover have "shortest_path v u = \<infinity>" using nvc shortest_path_inf by auto
  thus ?thesis using eccentricity_gt_shortest_path
    by (metis enat_ord_simps(5) uin)
qed

text \<open>The diameter is the largest distance between any two vertices \<close>
definition diameter :: "enat" where
"diameter \<equiv> SUP v \<in> V . eccentricity v"

lemma diameter_gt_eccentricity: "v \<in> V \<Longrightarrow> diameter \<ge> eccentricity v"
  using diameter_def by (simp add: SUP_upper)

lemma diameter_disconnected_graph:
  assumes "\<not> is_connected_set V"
  shows "diameter = \<infinity>"
  unfolding diameter_def using eccentricity_disconnected_graph
  by (metis SUP_eq_const assms is_connected_set_empty)

lemma diameter_empty: "V = {} \<Longrightarrow> diameter = 0"
  unfolding diameter_def using Sup_empty bot_enat_def by simp

lemma diameter_singleton: "V = {v} \<Longrightarrow> diameter = eccentricity v"
  unfolding diameter_def by simp

text \<open>The radius is the smallest "shortest" distance between any two vertices \<close>
definition radius :: "enat" where
"radius \<equiv> INF v \<in> V . eccentricity v"

lemma radius_lt_eccentricity: "v \<in> V \<Longrightarrow> radius \<le> eccentricity v"
  using radius_def by (simp add: INF_lower)

lemma radius_disconnected_graph: "\<not> is_connected_set V \<Longrightarrow> radius = \<infinity>"
  unfolding radius_def using eccentricity_disconnected_graph
  by (metis INF_eq_const is_connected_set_empty)

lemma radius_empty: "V = {} \<Longrightarrow> radius = \<infinity>"
  unfolding radius_def using Inf_empty top_enat_def by simp

lemma radius_singleton: "V = {v} \<Longrightarrow> radius = eccentricity v"
  unfolding radius_def by simp

text \<open>The centre of the graph is all vertices whose eccentricity equals the radius \<close>
definition centre :: "'a set" where
"centre \<equiv> {v \<in> V. eccentricity v = radius }"

lemma centre_disconnected_graph: "\<not> is_connected_set V \<Longrightarrow> centre = V"
  unfolding centre_def using radius_disconnected_graph eccentricity_disconnected_graph by auto

end

lemma (in fin_ulgraph) fin_connecting_paths: "finite (connecting_paths u v)"
  using connecting_paths_ss_gen finite_gen_paths finite_subset by fastforce

subsection \<open>We define a connected graph as a non-empty graph (the empty set is not usually considered
connected by convention), where the vertex set is connected \<close>
locale connected_ulgraph = ulgraph + ne_graph_system +
  assumes connected: "is_connected_set V"
begin

lemma vertices_connected: "u \<in> V \<Longrightarrow> v \<in> V \<Longrightarrow> vert_connected u v"
  using is_connected_set_def connected by auto

lemma vertices_connected_path: "u \<in> V \<Longrightarrow> v \<in> V \<Longrightarrow> \<exists> p. connecting_path u v p"
  using vertices_connected by (simp add: vert_connected_def)

lemma connecting_paths_not_empty: "u \<in> V \<Longrightarrow> v \<in> V \<Longrightarrow> connecting_paths u v \<noteq> {}"
  using connected not_empty connecting_paths_empty_iff is_connected_setD by blast

lemma min_shortest_path: assumes "u \<in> V" "v \<in> V" "u \<noteq> v"
  shows "shortest_path u v > 0"
  using shortest_path_lb assms vertices_connected by auto

text \<open>The eccentricity, diameter, radius, and centre definitions tend to be only used in a connected context,
as otherwise they are the INF/SUP value. In these contexts, we can obtain the vertex responsible \<close>
lemma eccentricity_obtains_inf:
  assumes "V \<noteq> {v}"
  shows "eccentricity v = \<infinity> \<or> (\<exists> u \<in> (V - {v}) . shortest_path v u = eccentricity v)"
proof (cases "finite ((\<lambda> u. shortest_path v u) ` (V - {v}))")
  case True
  then have e: "eccentricity v = Max ((\<lambda> u. shortest_path v u) ` (V - {v}))" unfolding eccentricity_def using Sup_enat_def
    using assms not_empty by auto
  have "(V - {v}) \<noteq> {}" using assms not_empty by auto
  then have "((\<lambda> u. shortest_path v u) ` (V - {v})) \<noteq> {}" by simp
  then obtain n where "n \<in> ((\<lambda> u. shortest_path v u) ` (V - {v}))" and "n = eccentricity v"
    using Max_in e True by auto
  then obtain u where "u \<in> (V - {v})" and "shortest_path v u = eccentricity v"
    by blast
  then show ?thesis by auto
next
  case False
  then have "eccentricity v = \<infinity>" unfolding eccentricity_def using Sup_enat_def
    by (metis (mono_tags, lifting) cSup_singleton empty_iff finite_insert insert_iff)
  then show ?thesis by simp
qed

lemma diameter_obtains: "diameter = \<infinity> \<or> (\<exists> v \<in> V . eccentricity v = diameter)"
proof (cases "is_singleton V")
  case True
  then obtain v where "V = {v}"
    using is_singletonE by auto
  then show ?thesis using diameter_singleton
    by simp
next
  case f1: False
  then show ?thesis proof (cases "finite ((\<lambda> v. eccentricity v) ` V)")
    case True
    then have "diameter = Max ((\<lambda> v. eccentricity v) ` V)" unfolding diameter_def using Sup_enat_def not_empty
      by simp
    then obtain n where "n \<in>((\<lambda> v. eccentricity v) ` V)" and "diameter = n" using Max_in True
      using not_empty by auto
    then obtain u where "u \<in> V" and "eccentricity u = diameter"
      by fastforce
    then show ?thesis by auto
  next
    case False
    then have "diameter = \<infinity>" unfolding diameter_def using Sup_enat_def by auto
    then show ?thesis by simp
  qed
qed

lemma radius_diameter_singleton_eq: assumes "card V = 1" shows "radius = diameter"
proof -
  obtain v where "V = {v}" using assms card_1_singletonE by auto
  thus ?thesis unfolding radius_def diameter_def by auto
qed

end

locale fin_connected_ulgraph = connected_ulgraph + fin_ulgraph
begin

text \<open> In a finite context the supremum/infinum are equivalent to the Max/Min of the sets respectively.
This can make reasoning easier \<close>
lemma shortest_path_Min_alt:
  assumes "u \<in> V" "v \<in> V"
  shows "shortest_path u v = Min ((\<lambda> p. enat (walk_length p)) ` (connecting_paths u v))" (is "shortest_path u v = Min ?A")
proof -
  have ne: "?A \<noteq> {}"
    using connecting_paths_not_empty assms by auto
  have "finite (connecting_paths u v)"
    by (simp add: fin_connecting_paths)
  then have fin: "finite ?A"
    by simp
  have "shortest_path u v = Inf ?A" unfolding shortest_path_def by simp
  thus ?thesis using Min_Inf ne
    by (metis fin)
qed

lemma eccentricity_Max_alt:
  assumes "v \<in> V"
  assumes "V \<noteq> {v}"
  shows "eccentricity v = Max ((\<lambda> u. shortest_path v u) ` (V - {v}))"
  unfolding eccentricity_def using assms Sup_enat_def finV not_empty
  by auto

lemma diameter_Max_alt: "diameter = Max ((\<lambda> v. eccentricity v) ` V)"
  unfolding diameter_def using Sup_enat_def finV not_empty by auto

lemma radius_Min_alt: "radius = Min ((\<lambda> v. eccentricity v) ` V)"
  unfolding radius_def using Min_Inf finV not_empty
  by (metis (no_types, opaque_lifting) empty_is_image finite_imageI)

lemma eccentricity_obtains:
  assumes "v \<in> V"
  assumes "V \<noteq> {v}"
  obtains u where "u \<in> V" and "u \<noteq> v" and "shortest_path u v = eccentricity v"
proof -
  have ni: "\<And> u. u \<in> V - {v} \<Longrightarrow> u \<noteq> v \<and> u \<in> V" by auto
  have ne: "V - {v} \<noteq> {}" using assms not_empty by auto
  have "eccentricity v = Max ((\<lambda> u. shortest_path v u) ` (V - {v}))" using eccentricity_Max_alt assms by simp
  then obtain u where ui: "u \<in> V - {v}" and eq: "shortest_path v u = eccentricity v"
    using obtains_MAX assms finV ne by (metis finite_Diff)
  then have neq: "u \<noteq> v" by blast
  have uin: "u \<in> V" using ui by auto
  thus ?thesis using neq eq that[of u] shortest_path_sym by simp
qed

lemma radius_obtains:
  obtains v where "v \<in> V" and "radius = eccentricity v"
proof -
  have "radius = Min ((\<lambda> v. eccentricity v) ` V)" using radius_Min_alt by simp
  then obtain v where "v \<in> V" and "radius = eccentricity v"
    using obtains_MIN[of V "(\<lambda> v . eccentricity v)"] not_empty finV by auto
  thus ?thesis
    by (simp add: that)
qed

lemma radius_obtains_path_vertices:
  assumes "card V \<ge> 2"
  obtains u v where "u \<in> V" and "v \<in> V" and "u \<noteq> v" and "radius = shortest_path u v"
proof -
  obtain v where vin: "v \<in> V" and e: "radius = eccentricity v"
    using radius_obtains by blast
  then have "V \<noteq> {v}" using assms by auto
  then obtain u where "u \<in> V" and "u \<noteq> v" and "shortest_path u v = radius"
    using eccentricity_obtains vin e by auto
  thus ?thesis using vin
    by (simp add: that)
qed

lemma diameter_obtains:
  obtains v where "v \<in> V" and "diameter = eccentricity v"
proof -
  have "diameter = Max ((\<lambda> v. eccentricity v) ` V)" using diameter_Max_alt by simp
  then obtain v where "v \<in> V" and "diameter = eccentricity v"
    using obtains_MAX[of V "(\<lambda> v . eccentricity v)"] not_empty finV by auto
  thus ?thesis
    by (simp add: that)
qed

lemma diameter_obtains_path_vertices:
  assumes "card V \<ge> 2"
  obtains u v where "u \<in> V" and "v \<in> V" and "u \<noteq> v" and "diameter = shortest_path u v"
proof -
  obtain v where vin: "v \<in> V" and e: "diameter = eccentricity v"
    using diameter_obtains by blast
  then have "V \<noteq> {v}" using assms by auto
  then obtain u where "u \<in> V" and "u \<noteq> v" and "shortest_path u v = diameter"
    using eccentricity_obtains vin e by auto
  thus ?thesis using vin
    by (simp add: that)
qed

lemma radius_diameter_bounds:
  shows "radius \<le> diameter" "diameter \<le> 2 * radius"
proof -
  show "radius \<le> diameter" unfolding radius_def diameter_def
    by (simp add: INF_le_SUP not_empty)
next
  show "diameter \<le> 2 * radius"
  proof (cases "card V \<ge> 2")
    case True
    then obtain x y where xin: "x \<in> V" and yin: "y \<in> V" and d: "shortest_path x y = diameter"
      using diameter_obtains_path_vertices by metis
    obtain z where zin: "z \<in> V" and e: "eccentricity z = radius" using radius_obtains
      by metis
    have "shortest_path x z \<le> eccentricity z"
      using eccentricity_gt_shortest_path xin shortest_path_sym by simp
    have "shortest_path x y \<le> shortest_path x z + shortest_path z y" using shortest_path_split by simp
    also have "... \<le> eccentricity z + eccentricity z"
      using eccentricity_gt_shortest_path shortest_path_sym zin xin yin by (simp add: add_mono)
    also have "... \<le> radius + radius" using e by simp
    finally  show ?thesis using d by (simp add: mult_2)
  next
    case False
    have "card V \<noteq> 0" using not_empty finV by auto
    then have "card V = 1" using False by simp
    then show ?thesis using radius_diameter_singleton_eq by (simp add: mult_2)
  qed
qed

end

text \<open> We define various subclasses of the general connected graph, using the functor locale pattern\<close>
locale connected_sgraph = sgraph + ne_graph_system +
  assumes connected: "is_connected_set V"

sublocale connected_sgraph \<subseteq> connected_ulgraph
  by (unfold_locales) (simp add: connected)

locale fin_connected_sgraph = connected_sgraph + fin_sgraph

sublocale fin_connected_sgraph \<subseteq> fin_connected_ulgraph
  by (unfold_locales)

end


(*  Title:      ZF/Induct/Brouwer.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Infinite branching datatype definitions\<close>

theory Brouwer imports ZFC begin

subsection \<open>The Brouwer ordinals\<close>

consts
  brouwer :: i

datatype \<subseteq> "Vfrom(0, csucc(nat))"
    "brouwer" = Zero | Suc ("b \<in> brouwer") | Lim ("h \<in> nat -> brouwer")
  monos Pi_mono
  type_intros inf_datatype_intros

lemma brouwer_unfold: "brouwer = {0} + brouwer + (nat -> brouwer)"
  by (fast intro!: brouwer.intros [unfolded brouwer.con_defs]
    elim: brouwer.cases [unfolded brouwer.con_defs])

lemma brouwer_induct2 [consumes 1, case_names Zero Suc Lim]:
  assumes b: "b \<in> brouwer"
    and cases:
      "P(Zero)"
      "!!b. [| b \<in> brouwer;  P(b) |] ==> P(Suc(b))"
      "!!h. [| h \<in> nat -> brouwer;  \<forall>i \<in> nat. P(h`i) |] ==> P(Lim(h))"
  shows "P(b)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using b
  apply induct
    apply (rule cases(1))
   apply (erule (1) cases(2))
  apply (rule cases(3))
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

subsection \<open>The Martin-Löf wellordering type\<close>

consts
  Well :: "[i, i => i] => i"

datatype \<subseteq> "Vfrom(A \<union> (\<Union>x \<in> A. B(x)), csucc(nat \<union> |\<Union>x \<in> A. B(x)|))"
    \<comment> \<open>The union with \<open>nat\<close> ensures that the cardinal is infinite.\<close>
  "Well(A, B)" = Sup ("a \<in> A", "f \<in> B(a) -> Well(A, B)")
  monos Pi_mono
  type_intros le_trans [OF UN_upper_cardinal le_nat_Un_cardinal] inf_datatype_intros

lemma Well_unfold: "Well(A, B) = (\<Sum>x \<in> A. B(x) -> Well(A, B))"
  by (fast intro!: Well.intros [unfolded Well.con_defs]
    elim: Well.cases [unfolded Well.con_defs])

lemma Well_induct2 [consumes 1, case_names step]:
  assumes w: "w \<in> Well(A, B)"
    and step: "!!a f. [| a \<in> A;  f \<in> B(a) -> Well(A,B);  \<forall>y \<in> B(a). P(f`y) |] ==> P(Sup(a,f))"
  shows "P(w)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using w
  apply induct
  apply (assumption | rule step)+
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

lemma Well_bool_unfold: "Well(bool, \<lambda>x. x) = 1 + (1 -> Well(bool, \<lambda>x. x))"
  \<comment> \<open>In fact it's isomorphic to \<open>nat\<close>, but we need a recursion operator\<close>
  \<comment> \<open>for \<open>Well\<close> to prove this.\<close>
  apply (rule Well_unfold [THEN trans])
  apply (simp add: Sigma_bool succ_def)
  done

end


theory msupOrd
  imports OrdRec_Model_Base
begin

context OrdRec_Model
begin

lemma msupord_eq :
  assumes "x : mSetOf mOrd"
  shows "msupOrd x = <ord, supOrd {snd b | b \<in> snd x}>"
  unfolding msupOrd_def msupOrd'_def
  using assms
  by auto

lemma msupord_thm :
  assumes x : "x : mSetOf mOrd"
  shows "msupOrd x : mOrd"
    and "i m x \<Longrightarrow> i \<lless> msucc (msupOrd x)"
proof -
  obtain x' where
    x' : "x' : SetOf mOrd" and x_eq :"x = <set,x'>"
    using msetofE[OF x] by auto
  hence eq:"msupOrd x = <ord, supOrd {snd b | b \<in> x'}>"
    unfolding msupord_eq[OF x]
    using mset_snd_eq[OF msetof_mset] x by auto
  have setof_ord : "{snd b | b \<in> x'} : SetOf Ord"
  proof (rule repfun_setof[OF setof_set[OF x']], rule mem_funI)
    fix b assume "b \<in> x'"
    thus "snd b : Ord"
      using mord_snd_ord[OF setof_mem[OF x']]
      by auto
  qed
  show "msupOrd x : mOrd"
    unfolding eq
    by (rule mordI, rule supord_ord[OF setof_ord])

  assume "i m x"
  hence "i \<in> x'"
    using mmemD x_eq by auto
  moreover then obtain i' where
    i' : "i' : Ord" and i_eq: "i = <ord, i'>"
    using mordE[OF setof_mem[OF x']] by metis
  ultimately have
    "i' \<in> {snd b | b \<in> x'}"
    using repfunI[of x' i snd,OF setof_set[OF x'] _
      ord_setmem[OF mord_snd_ord[OF setof_mem[OF x']]]]
    unfolding ord_snd_eq[OF i' i_eq]
    by auto
  hence "i' < succ (supOrd {snd b | b \<in> x'})"
    using supord_iff[OF setof_ord] by auto
  hence "i \<lless> <ord, succ (supOrd {snd b | b \<in> x'})>"
    using mltI[OF i' succ_ord[OF supord_ord[OF setof_ord]]]
    unfolding i_eq by auto
  thus "i \<lless> msucc (msupOrd x)"
    unfolding eq msucc_eq[OF supord_ord[OF setof_ord]] .
qed

lemmas msupordI = msupord_thm(2)
   and msupord_mord = msupord_thm(1)

theorem msupord_rsp :
  "msupOrd x : M"
  using mord_m[OF msupord_mord]
   OrdRec_Model_mdefault_m
  unfolding msupOrd_def
  by auto

end
end


theory LookAheadSim imports Main
begin

inductive eventually :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)"
  for rel :: "'a \<Rightarrow> bool" and step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<Rightarrow>" 50)
  where
    nowI[intro] : "rel x \<Longrightarrow> eventually rel step x"
  | laterI : "x \<Rightarrow> x' \<Longrightarrow> (\<And> x'. x \<Rightarrow> x' \<Longrightarrow> eventually rel step x') \<Longrightarrow> eventually rel step x"

lemma later_uniqueI:
  fixes step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<Rightarrow>" 50)
  shows  "x \<Rightarrow> x' \<Longrightarrow> (\<And> x''. x \<Rightarrow> x'' \<Longrightarrow> x'' = x') \<Longrightarrow> eventually rel step x' \<Longrightarrow> eventually rel step x"
  by (erule laterI) auto

lemma later_svI:
  fixes step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<Rightarrow>" 50)
  shows  "single_valuedP (op \<Rightarrow>) \<Longrightarrow> x \<Rightarrow> x' \<Longrightarrow> eventually rel step x' \<Longrightarrow> eventually rel step x"
  by (rule later_uniqueI) (auto dest: single_valuedD)

context
  fixes rel :: "'a \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<triangleright>" 50)
  fixes step1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<Rightarrow>\<^sub>1" 50)
  fixes step2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<Rightarrow>\<^sub>2" 50)
  assumes single_step: "\<And> x x' y . x \<Rightarrow>\<^sub>1 x' \<Longrightarrow> x \<triangleright> y \<Longrightarrow> \<exists> y'. op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y' \<and> eventually (\<lambda>x. x \<triangleright> y') step1 x'"
begin

lemma simulate_with_later:
  assumes "x \<Rightarrow>\<^sub>1 x'"
  assumes "eventually (\<lambda>x. x \<triangleright> y) step1 x"
  shows "\<exists> y'. op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y' \<and>  eventually (\<lambda>x. x \<triangleright> y') step1 x'"
using assms(2)
proof(cases)
  case nowI
  thus ?thesis by (rule single_step[OF `x \<Rightarrow>\<^sub>1 x'`])
next
  case laterI
  from laterI(2)[OF assms(1)]
  show ?thesis by blast
qed

lemma simulate_with_later_to_end:
  assumes "op \<Rightarrow>\<^sub>1\<^sup>*\<^sup>* x x'"
  assumes "\<not> Domainp step1 x'"
  assumes "x \<triangleright> y"
  shows "\<exists> y'. op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y' \<and> x' \<triangleright> y'"
proof-
  from `x \<triangleright> y`
  have "eventually (\<lambda>x. x \<triangleright> y) step1 x"..

  from `op \<Rightarrow>\<^sub>1\<^sup>*\<^sup>* x x'` and this
  have "\<exists> y'. op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y' \<and>  eventually (\<lambda>x. x \<triangleright> y') step1 x'"
  proof(induction)
    case base thus ?case by blast
  next
    case (step x' x'')
    then obtain y' where "op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y'" and " eventually (\<lambda>x. x \<triangleright> y') op \<Rightarrow>\<^sub>1 x'" by auto

    from `x' \<Rightarrow>\<^sub>1 x''` and `eventually (\<lambda>x. x \<triangleright> y') op \<Rightarrow>\<^sub>1 x'`
    have "\<exists>y''. op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y' y'' \<and>  eventually (\<lambda>x. x \<triangleright> y'') op \<Rightarrow>\<^sub>1 x''" by (rule simulate_with_later)
    with `op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y'`
    show ?case by (metis rtranclpD tranclp_into_rtranclp tranclp_rtranclp_tranclp)
  qed
  then obtain y' where "op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y'" and " eventually (\<lambda>x. x \<triangleright> y') step1 x'" by auto
  from ` eventually (\<lambda>x. x \<triangleright> y') step1 x'` and `\<not> Domainp step1 x'`
  have "x' \<triangleright> y'" by cases auto
  with `op \<Rightarrow>\<^sub>2\<^sup>*\<^sup>* y y'`
  show ?thesis by auto
qed

end

subsection {* Example *}

locale LookAheadSimExample
begin

inductive rel :: "nat \<Rightarrow> nat \<Rightarrow> bool" (infix "\<triangleright>" 50)
  where relI: "rel (3 * n) (2 * n)"
inductive step (infix "\<Rightarrow>" 50)
  where stepI: "n \<le> 299 \<Longrightarrow> step n (Suc n)"

lemma sv_step: "single_valuedP step"
  by (auto intro!: single_valuedI elim: step.cases)

lemma "\<exists> y'. op \<Rightarrow>\<^sup>*\<^sup>* 0 y' \<and> 300 \<triangleright> y'"
proof-
  { fix n
    have "n \<le> 300 \<Longrightarrow> op \<Rightarrow>\<^sup>*\<^sup>* 0 n"
      apply (induction n rule: nat_induct)
      apply (auto)
      by (metis rtranclp.rtrancl_into_rtrancl step.intros)
  }
  hence "op \<Rightarrow>\<^sup>*\<^sup>* 0 300" by auto
  moreover
  have "\<not> Domainp op \<Rightarrow> 300" by (auto elim!: step.cases)
  moreover
  have "0 \<triangleright> 0" using relI[of 0] by auto
  ultimately
  show ?thesis
  proof (rule simulate_with_later_to_end[rotated])
    fix x x' y
    assume "x \<Rightarrow> x'"
    hence "x \<le> 299" and "x' = Suc x" by (auto elim: step.cases)

    assume "x \<triangleright> y"
    then obtain n where "x = 3*n" and "y = 2*n" by (auto elim: rel.cases)

    from `x \<le> 299` and `x = 3*n` have "x < 298" by arith

    from `x' = Suc x` and `x < 298` have "x' \<le> 299" and "Suc x' \<le> 299" by auto
    hence "x' \<Rightarrow> Suc x'" and "Suc x' \<Rightarrow> Suc (Suc x')" by (auto intro: stepI)

    have "Suc (Suc x') \<triangleright> Suc (Suc y)"
      unfolding `x' = Suc x` `x = 3*n` `y = 2*n`
      using relI[of "Suc n"] by (metis Suc3_eq_add_3 add_2_eq_Suc mult_Suc_right)
    hence "eventually (\<lambda>x. x \<triangleright> Suc (Suc y)) op \<Rightarrow> (Suc (Suc x'))"..
    with `Suc x' \<Rightarrow> Suc (Suc x')`
    have  "eventually (\<lambda>x. x \<triangleright> Suc (Suc y)) op \<Rightarrow> (Suc x')" by(rule later_svI[OF sv_step])
    with `x' \<Rightarrow> Suc x'`
    have  "eventually (\<lambda>x. x \<triangleright> Suc (Suc y)) op \<Rightarrow> x'" by (rule later_svI[OF sv_step])
    moreover
    from `x \<le> 299` and `x = 3*n` and `y = 2*n` have "y < 298" by arith

    hence "y \<le> 299" and "Suc y \<le> 299" by auto
    hence "y \<Rightarrow> Suc y" and "Suc y \<Rightarrow> Suc (Suc y)" by (auto intro: stepI)
    hence "op \<Rightarrow>\<^sup>*\<^sup>* y (Suc (Suc y))" by auto
    ultimately
    show "\<exists>y'. op \<Rightarrow>\<^sup>*\<^sup>* y y' \<and> eventually (\<lambda>x. x \<triangleright> y') op \<Rightarrow> x'" by auto
  qed
qed
end

end


section {* Refinement Kleene Algebra with Tests *}

text {* In the future this will be build directly on the KAT libraries. *}

theory RKAT
  imports "AVC_KAT/VC_KAT"

begin

text {* A refinement KAT is a KAT expanded by Morgan's specification statement. *}

class rkat = kat +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes spec_def:  "x \<le> R p q \<longleftrightarrow> H p x q"

begin

text {* First we derive two characteristic properties. *}

lemma R1: "H p (R p q) q"
  using spec_def by blast

lemma R2: "H p x q \<Longrightarrow> x \<le> R p q"
  by (simp add: spec_def)

text {* Next we derive refinement laws step by step. *}

lemma R_skip: "1 \<le> R p p"
proof -
  have "H p 1 p"
    by (simp add: H_skip)
  thus ?thesis
    by (rule R2)
qed

lemma R_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> R p' q' \<le> R p q"
proof -
  assume h1: "t p \<le> t p'" and h2: "t q' \<le> t q"
  have "H p' (R p' q') q'"
    by (simp add: R1)
  hence "H p (R p' q') q"
    using h1 h2 H_cons_1 H_cons_2 by blast
  thus ?thesis
    by (rule R2)
qed

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
proof -
  have "H p (R p r) r" and "H r (R r q) q"
    by (simp add: R1)+
  hence "H p ((R p r) \<cdot> (R r q)) q"
    by (rule H_seq_swap)
  thus ?thesis
    by (rule R2)
qed

lemma R_cond: "if v then (R (t v \<cdot> t p) q) else (R (n v \<cdot> t p) q) fi \<le> R p q"
proof -
  have "H (t v \<cdot> t p) (R (t v \<cdot> t p) q) q" and "H (n v \<cdot> t p) (R (n v \<cdot> t p) q) q"
    by (simp add: R1)+
  hence "H p (if v then (R (t v \<cdot> t p) q) else (R (n v \<cdot> t p) q) fi) q"
    by (simp add: local.H_cond local.n_mult_comm)
 thus ?thesis
    by (rule R2)
qed

lemma R_loop: "while q do (R (t p \<cdot> t q) p) od \<le> R p (t p \<cdot> n q)"
proof -
  have "H (t p \<cdot> t q) (R (t p \<cdot> t q) p)  p"
    by (simp_all add: R1)
  hence "H p (while q do (R (t p \<cdot> t q) p) od) (t p \<cdot> n q)"
    by (simp add: H_loop)
  thus ?thesis
    by (rule R2)
  qed

lemma R_zero_one: "x \<le> R 0 1"
proof -
  have "H 0 x 1"
    by (simp add: H_def)
  thus ?thesis
    by (rule R2)
qed

lemma R_one_zero: "R 1 0 = 0"
proof -
  have "H 1 (R 1 0) 0"
    by (simp add: R1)
  thus ?thesis
    by (simp add: H_def join.le_bot)
qed

end

end


theory MonoStrictPredicateTransformers
  imports PredicateTransformers
begin

section {* Monotonic predicate transformers *}

declare [[coercion_enabled]]

text {* Closed operations *}

lemma mono_skip [simp,intro]: "mono id \<and> id \<bottom> = \<bottom>"
  by (auto intro: order_class.monoI)

lemma mono_ex [simp]: "\<exists>f :: 'a :: order \<Rightarrow> 'a. mono f"
  by (rule_tac x=id in exI) simp

lemma mono_comp_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F o G)"
  by (auto simp: order_class.mono_def intro!: order_class.monoI)

lemma mono_magic [simp,intro]: "mono \<top>"
  by (simp add: order_class.mono_def)

lemma mono_abort [simp,intro]: "mono \<bottom>"
  by (simp add: order_class.mono_def)

lemma mono_sup_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F + G)"
  by (auto simp: order_class.mono_def intro: sup.coboundedI1 sup.coboundedI2)

lemma mono_inf_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F \<sqinter> G)"
  by (auto simp: order_class.mono_def intro: inf.coboundedI1 inf.coboundedI2)

text {* The lifting of * is not isotonic closed  *}
lemma mono_inf_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F * G)"
  (* nitpick[show_all] *) oops

lemma mono_Sup_clos [intro]: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f \<Longrightarrow> mono (\<Squnion> F)"
  by (auto simp: order_class.mono_def, rule SUP_mono) auto

lemma mono_Inf_clos [intro]: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f \<Longrightarrow> mono (\<Sqinter> F)"
  by (auto simp: order_class.mono_def, rule INF_mono) auto

text {* Type of monotonic predicate transformers *}

typedef 'a mtran = "{F :: 'a :: bbi \<Rightarrow> 'a. mono F \<and> F \<bottom> = \<bottom>}" by auto
setup_lifting type_definition_mtran

declare [[coercion Rep_mtran]]

text {* It forms a monoid on respect to function aplication *}
instantiation mtran :: (bbi) monoid_mult
begin
  lift_definition one_mtran :: "'a mtran" is id ..
  lift_definition times_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> 'a mtran" is "op o" by auto
  instance
    by default (transfer, auto)+
end

text {* It forms a complete lattice *}
instantiation mtran :: (bbi) bounded_semilattice_sup_bot
begin
lift_definition bot_mtran :: "'a mtran" is \<bottom>  by auto
lift_definition sup_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> 'a mtran" is sup  by auto
lift_definition less_eq_mtran:: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> bool" is "op \<le>" .
lift_definition less_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> bool" is "op <" .
instance
  by default (transfer, auto)+
end

instantiation mtran :: (bbi) Sup
begin
lift_definition Sup_mtran :: "'a mtran set \<Rightarrow> 'a mtran" is Sup by auto
instance ..
end

instantiation mtran :: (bbi) complete_lattice
begin
definition "\<Sqinter>(F :: 'a mtran set) \<equiv> \<Squnion>{g. \<forall>f \<in> F. g \<le> f}"
definition "\<top> :: 'a mtran \<equiv> \<Sqinter>{}"
definition "(F :: 'a mtran) \<sqinter> G \<equiv> \<Sqinter>{F, G}"
instance
  apply (default, simp_all add: inf_mtran_def Inf_mtran_def top_mtran_def)
  by (transfer, auto intro: Sup_least Sup_upper Inf_greatest Inf_lower)+
end

text {* It doesn't form a distributivity lattice *}
instance mtran :: (bbi) complete_distrib_lattice
  apply default defer (* nitpick *) oops

text {* It forms a pre quantale on respect to function aplication, but not a full quantale *}

instance mtran :: (bbi) near_quantale_unital
  by default (transfer, auto)

lemma mono_qSup_subdistl: "mono (f :: 'a :: complete_lattice \<Rightarrow> 'a) \<Longrightarrow> \<Squnion>((\<lambda>g. f o g) ` G) \<le> f \<circ> \<Squnion>G"
  by (rule Sup_least) (auto intro!: le_funI order_class.monoD[of "\<lambda>x. f x"] SUP_upper)

instance mtran :: (bbi) pre_quantale
  by default (transfer, simp only: mono_qSup_subdistl)

instance mtran :: (bbi) quantale_unital
  apply default
  apply transfer
  apply (rule le_funI)

  apply simp
  apply (rule SUP_upper)
  apply auto

  (* nitpick, it needs to be strict monotone *) oops

end


theory mSucc
  imports mlt
begin

context Ordinal_Model
begin

end

theorem mzero_mord :
  "m0 : mOrd"
  unfolding mzero_def
  using mordI[OF zero_ord] .

lemma msucc'_mord :
  assumes j : "j : mOrd"
  shows "msucc' j : mOrd"
  unfolding msucc'_def
  using mordI[OF succ_ord[OF mord_snd_ord[OF j]]] .

lemma msucc_mord :
  assumes j : "j : mOrd"
  shows "msucc j : mOrd"
  unfolding msucc_def
  using msucc'_mord[OF j] j by auto

end