(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header {* Representing Intensional Logic  *}

theory Intensional
imports Main
begin

text{*
  In higher-order logic, every proof rule has a corresponding tautology, i.e.
  the \emph{deduction theorem} holds. Isabelle/HOL implements this since object-level
  implication ($\longrightarrow$) and meta-level entailment ($\Longrightarrow$)
  commute, viz. the proof rule @{text "impI:"} @{thm impI}.
  However, the deduction theorem does not hold for
  most modal and temporal logics \cite[page 95]{Lamport02}\cite{Merz98}.
  For example $A \vdash \Box A$ holds, meaning that if $A$ holds in any world, then
  it always holds. However, $\vdash A \longrightarrow \Box A$, stating that
  $A$ always holds if it initially holds, is not valid.

  Merz  \cite{Merz98} overcame this problem by creating an
  @{term Intensional} logic. It exploits Isabelle's
  axiomatic type class feature  \cite{Wenzel00b} by creating a type
  class @{term world}, which provides Skolem constants to associate formulas
  with the world they hold in. The class is trivial, not requiring any axioms.
*}

class world
text {*
  @{term world} is a type class of possible worlds. It is a subclass
  of all HOL types @{term type}. No axioms are provided, since its only
  purpose is to avoid silly use of the @{term Intensional} syntax.
*}

subsection{* Abstract Syntax *}

type_synonym ('w,'a) expr = "'w \<Rightarrow> 'a"
type_synonym  'w form = "('w, bool) expr"

text {* The intention is that @{typ 'a} will be used for unlifted
types (class @{term type}), while @{typ 'w} is lifted (class @{term world}).
*}

consts
  Valid    :: "('w::world) form \<Rightarrow> bool"
  const    :: "'a \<Rightarrow> ('w::world, 'a) expr"
  lift     :: "['a \<Rightarrow> 'b, ('w::world, 'a) expr] \<Rightarrow> ('w,'b) expr"
  lift2    :: "['a \<Rightarrow> 'b \<Rightarrow> 'c, ('w::world,'a) expr, ('w,'b) expr] \<Rightarrow> ('w,'c) expr"
  lift3    :: "['a \<Rightarrow> 'b => 'c \<Rightarrow> 'd, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr] \<Rightarrow> ('w,'d) expr"
  lift4    :: "['a \<Rightarrow> 'b => 'c \<Rightarrow> 'd \<Rightarrow> 'e, ('w::world,'a) expr, ('w,'b) expr, ('w,'c) expr,('w,'d) expr] \<Rightarrow> ('w,'e) expr"

text {*
  @{term "Valid F"} asserts that the lifted formula @{term F} holds everywhere.
  @{term const} allows lifting of a constant, while @{term lift} through
  @{term lift4} allow functions with arity 1--4 to be lifted. (Note that there
  is no way to define a generic lifting operator for functions of arbitrary arity.)
*}

consts
  RAll     :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"      (binder "Rall " 10)
  REx      :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"      (binder "Rex " 10)
  REx1     :: "('a \<Rightarrow> ('w::world) form) \<Rightarrow> 'w form"      (binder "Rex! " 10)

text {*
  @{term RAll}, @{term REx} and @{term REx1} introduces ``rigid'' quantification
  over values (of non-world types) within ``intensional'' formulas. @{term RAll}
  is universal quantification, @{term REx} is existential quantifcation.
  @{term REx1} requires unique existence.
*}

subsection{* Concrete Syntax *}

nonterminal
  lift and liftargs

text{*
  The non-terminal @{term lift} represents lifted expressions. The idea is to use
  Isabelle's macro mechanism to convert between the concrete and abstract syntax.
*}

syntax
  ""            :: "id \<Rightarrow> lift"                          ("_")
  ""            :: "longid \<Rightarrow> lift"                      ("_")
  ""            :: "var \<Rightarrow> lift"                         ("_")
  "_applC"      :: "[lift, cargs] \<Rightarrow> lift"               ("(1_/ _)" [1000, 1000] 999)
  ""            :: "lift \<Rightarrow> lift"                        ("'(_')")
  "_lambda"     :: "[idts, 'a] \<Rightarrow> lift"                  ("(3%_./ _)" [0, 3] 3)
  "_constrain"  :: "[lift, type] \<Rightarrow> lift"                ("(_::_)" [4, 0] 3)
  ""            :: "lift \<Rightarrow> liftargs"                    ("_")
  "_liftargs"   :: "[lift, liftargs] \<Rightarrow> liftargs"        ("_,/ _")
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(|- _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ |= _)" [100,10] 10)

  (* Syntax for lifted expressions outside the scope of \<turnstile> or \<Turnstile>.*)
  "LIFT"        :: "lift \<Rightarrow> 'a"                          ("LIFT _")

  (* generic syntax for lifted constants and functions *)
  "_const"      :: "'a \<Rightarrow> lift"                          ("(#_)" [1000] 999)
  "_lift"       :: "['a, lift] \<Rightarrow> lift"                  ("(_<_>)" [1000] 999)
  "_lift2"      :: "['a, lift, lift] \<Rightarrow> lift"            ("(_<_,/ _>)" [1000] 999)
  "_lift3"      :: "['a, lift, lift, lift] \<Rightarrow> lift"      ("(_<_,/ _,/ _>)" [1000] 999)
  "_lift4"      :: "['a, lift, lift, lift,lift] \<Rightarrow> lift"      ("(_<_,/ _,/ _,/ _>)" [1000] 999)

  (* concrete syntax for common infix functions: reuse same symbol *)
  "_liftEqu"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ =/ _)" [50,51] 50)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ ~=/ _)" [50,51] 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("(~ _)" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ &/ _)" [36,35] 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                ("(_ |/ _)" [31,30] 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ -->/ _)" [26,25] 25)
  "_liftIf"     :: "[lift, lift, lift] \<Rightarrow> lift"          ("(if (_)/ then (_)/ else (_))" 10)
  "_liftPlus"   :: "[lift, lift] \<Rightarrow> lift"                ("(_ +/ _)" [66,65] 65)
  "_liftMinus"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ -/ _)" [66,65] 65)
  "_liftTimes"  :: "[lift, lift] \<Rightarrow> lift"                ("(_ */ _)" [71,70] 70)
  "_liftDiv"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ div _)" [71,70] 70)
  "_liftMod"    :: "[lift, lift] \<Rightarrow> lift"                ("(_ mod _)" [71,70] 70)
  "_liftLess"   :: "[lift, lift] \<Rightarrow> lift"                ("(_/ < _)"  [50, 51] 50)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ <= _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ : _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ ~: _)" [50, 51] 50)
  "_liftFinset" :: "liftargs => lift"                    ("{(_)}")
  (** TODO: syntax for lifted collection / comprehension **)
  "_liftPair"   :: "[lift,liftargs] \<Rightarrow> lift"                   ("(1'(_,/ _'))")
  (* infix syntax for list operations *)
  "_liftCons" :: "[lift, lift] \<Rightarrow> lift"                  ("(_ #/ _)" [65,66] 65)
  "_liftApp"  :: "[lift, lift] \<Rightarrow> lift"                  ("(_ @/ _)" [65,66] 65)
  "_liftList" :: "liftargs \<Rightarrow> lift"                      ("[(_)]")

  (* Rigid quantification (syntax level) *)
  "_ARAll"  :: "[idts, lift] \<Rightarrow> lift"                    ("(3! _./ _)" [0, 10] 10)
  "_AREx"   :: "[idts, lift] \<Rightarrow> lift"                    ("(3? _./ _)" [0, 10] 10)
  "_AREx1"  :: "[idts, lift] \<Rightarrow> lift"                    ("(3?! _./ _)" [0, 10] 10)
  "_RAll" :: "[idts, lift] \<Rightarrow> lift"                      ("(3ALL _./ _)" [0, 10] 10)
  "_REx"  :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX _./ _)" [0, 10] 10)
  "_REx1" :: "[idts, lift] \<Rightarrow> lift"                      ("(3EX! _./ _)" [0, 10] 10)

translations
  "_const"        \<rightleftharpoons>  "CONST const"

translations
  "_lift"         \<rightleftharpoons> "CONST lift"
  "_lift2"        \<rightleftharpoons> "CONST lift2"
  "_lift3"        \<rightleftharpoons> "CONST lift3"
  "_lift4"        \<rightleftharpoons> "CONST lift4"
  "_Valid"        \<rightleftharpoons> "CONST Valid"

translations
  "_RAll x A"     \<rightleftharpoons> "Rall x. A"
  "_REx x A"      \<rightleftharpoons> "Rex x. A"
  "_REx1 x A"     \<rightleftharpoons> "Rex! x. A"

translations
  "_ARAll"        \<rightharpoonup>  "_RAll"
  "_AREx"         \<rightharpoonup> "_REx"
  "_AREx1"        \<rightharpoonup> "_REx1"

  "w |= A"        \<rightharpoonup> "A w"
  "LIFT A"        \<rightharpoonup> "A::_\<Rightarrow>_"

translations
  "_liftEqu"      \<rightleftharpoons> "_lift2 (op =)"
  "_liftNeq u v"  \<rightleftharpoons> "_liftNot (_liftEqu u v)"
  "_liftNot"      \<rightleftharpoons> "_lift (CONST Not)"
  "_liftAnd"      \<rightleftharpoons> "_lift2 (op &)"
  "_liftOr"       \<rightleftharpoons> "_lift2 (op | )"
  "_liftImp"      \<rightleftharpoons> "_lift2 (op -->)"
  "_liftIf"       \<rightleftharpoons> "_lift3 (CONST If)"
  "_liftPlus"     \<rightleftharpoons> "_lift2 (op +)"
  "_liftMinus"    \<rightleftharpoons> "_lift2 (op -)"
  "_liftTimes"    \<rightleftharpoons> "_lift2 (op *)"
  "_liftDiv"      \<rightleftharpoons> "_lift2 (op div)"
 "_liftMod"      \<rightleftharpoons> "_lift2 (op mod)"
  "_liftLess"     \<rightleftharpoons> "_lift2 (op <)"
  "_liftLeq"      \<rightleftharpoons> "_lift2 (op <=)"
  "_liftMem"      \<rightleftharpoons> "_lift2 (op :)"
  "_liftNotMem x xs"             \<rightleftharpoons> "_liftNot (_liftMem x xs)"

translations
  "_liftFinset (_liftargs x xs)" \<rightleftharpoons> "_lift2 (CONST insert) x (_liftFinset xs)"
  "_liftFinset x"                \<rightleftharpoons> "_lift2 (CONST insert) x (_const (CONST Set.empty))"
  "_liftPair x (_liftargs y z)"  \<rightleftharpoons> "_liftPair x (_liftPair y z)"
  "_liftPair"                    \<rightleftharpoons> "_lift2 (CONST Pair)"
  "_liftCons"                    \<rightleftharpoons> "_lift2 (CONST Cons)"
  "_liftApp"                     \<rightleftharpoons> "_lift2 (op @)"
  "_liftList (_liftargs x xs)"   \<rightleftharpoons> "_liftCons x (_liftList xs)"
  "_liftList x"                  \<rightleftharpoons> "_liftCons x (_const [])"

  "w |= ~A"       \<leftharpoondown>  "_liftNot A w"
  "w |=  A & B"   \<leftharpoondown> "_liftAnd A B w"
  "w |= A | B"    \<leftharpoondown> "_liftOr A B w"
  "w |= A --> B"  \<leftharpoondown> "_liftImp A B w"
  "w |= u = v"    \<leftharpoondown> "_liftEqu u v w"
  "w |= ALL x. A" \<leftharpoondown> "_RAll x A w"
  "w |= EX x. A"  \<leftharpoondown> "_REx x A w"
  "w |= EX! x. A" \<leftharpoondown> "_REx1 x A w"

syntax (xsymbols)
  "_Valid"      :: "lift \<Rightarrow> bool"                        ("(\<turnstile> _)" 5)
  "_holdsAt"    :: "['a, lift] \<Rightarrow> bool"                  ("(_ \<Turnstile> _)" [100,10] 10)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                (infixl "\<noteq>" 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("\<not> _" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<and>" 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<or>" 30)
  "_liftImp"    :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<longrightarrow>" 25)
  "_RAll"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<forall>_./ _)" [0, 10] 10)
  "_REx"        :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>_./ _)" [0, 10] 10)
  "_REx1"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>!_./ _)" [0, 10] 10)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<le> _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<in> _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<notin> _)" [50, 51] 50)

syntax (HTML output)
  "_liftNeq"    :: "[lift, lift] \<Rightarrow> lift"                (infixl "\<noteq>" 50)
  "_liftNot"    :: "lift \<Rightarrow> lift"                        ("\<not> _" [90] 90)
  "_liftAnd"    :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<and>" 35)
  "_liftOr"     :: "[lift, lift] \<Rightarrow> lift"                (infixr "\<or>" 30)
  "_RAll"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<forall>_./ _)" [0, 10] 10)
  "_REx"        :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>_./ _)" [0, 10] 10)
  "_REx1"       :: "[idts, lift] \<Rightarrow> lift"                ("(3\<exists>!_./ _)" [0, 10] 10)
  "_liftLeq"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<le> _)" [50, 51] 50)
  "_liftMem"    :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<in> _)" [50, 51] 50)
  "_liftNotMem" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<notin> _)" [50, 51] 50)

subsection {* Definitions *}

defs
  Valid_def:   "\<turnstile> A    \<equiv>  \<forall>w. w \<Turnstile> A"
  unl_con:     "LIFT #c w  \<equiv>  c"
  unl_lift:    "(LIFT f<x>) w \<equiv> f (x w)"
  unl_lift2:   "LIFT f<x, y> w \<equiv> f (x w) (y w)"
  unl_lift3:   "LIFT f<x, y, z> w \<equiv> f (x w) (y w) (z w)"
  unl_lift4:   "LIFT f<x, y, z, zz> w \<equiv> f (x w) (y w) (z w) (zz w)"

defs
  unl_Rall:    "w \<Turnstile> \<forall>x. A x   \<equiv>  \<forall>x. (w \<Turnstile> A x)"
  unl_Rex:     "w \<Turnstile> \<exists>x. A x   \<equiv>  \<exists>x. (w \<Turnstile> A x)"
  unl_Rex1:    "w \<Turnstile> \<exists>!x. A x  \<equiv>  \<exists>! x. (w \<Turnstile> A x)"

text {*
  We declare the ``unlifting rules'' as rewrite rules that will be applied
  automatically.
*}

lemmas intensional_rews[simp] =
  unl_con unl_lift unl_lift2 unl_lift3 unl_lift4
  unl_Rall unl_Rex unl_Rex1

subsection {* Lemmas and Tactics *}

lemma intD[dest]: "\<turnstile> A \<Longrightarrow> w \<Turnstile> A"
proof -
  assume a:"\<turnstile> A"
  from a have "ALL w. w \<Turnstile> A" by (auto simp add: Valid_def)
  thus ?thesis ..
qed

lemma intI [intro!]: assumes P1:"(\<And> w. w \<Turnstile> A)" shows "\<turnstile> A"
  using assms by (auto simp: Valid_def)

text{*
  Basic unlifting introduces a parameter @{term w} and applies basic rewrites, e.g
  @{term "\<turnstile> F = G"} becomes @{term "F w = G w"} and @{term "\<turnstile> F \<longrightarrow> G"} becomes
  @{term "F w \<longrightarrow> G w"}.
*}

method_setup int_unlift = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (rtac @{thm intI} THEN' rewrite_goal_tac ctxt @{thms intensional_rews}))
*} "method to unlift and followed by intensional rewrites"

lemma inteq_reflection: assumes P1: "\<turnstile> x=y" shows  "(x \<equiv> y)"
proof -
  from P1 have P2: "ALL w. x w = y w" by (unfold Valid_def unl_lift2)
  hence P3:"x=y" by blast
  thus "x \<equiv> y" by (rule "eq_reflection")
qed

lemma int_simps:
  "\<turnstile> (x=x) = #True"
  "\<turnstile> (\<not> #True) = #False"
  "\<turnstile> (\<not> #False) = #True"
  "\<turnstile> (\<not>\<not> P) = P"
  "\<turnstile> ((\<not> P) = P) = #False"
  "\<turnstile> (P = (\<not>P)) = #False"
  "\<turnstile> (P \<noteq> Q) = (P = (\<not> Q))"
  "\<turnstile> (#True=P) = P"
  "\<turnstile> (P=#True) = P"
  "\<turnstile> (#True \<longrightarrow> P) = P"
  "\<turnstile> (#False \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #True) = #True"
  "\<turnstile> (P \<longrightarrow> P) = #True"
  "\<turnstile> (P \<longrightarrow> #False) = (\<not>P)"
  "\<turnstile> (P \<longrightarrow> ~P) = (\<not>P)"
  "\<turnstile> (P \<and> #True) = P"
  "\<turnstile> (#True \<and> P) = P"
  "\<turnstile> (P \<and> #False) = #False"
  "\<turnstile> (#False \<and> P) = #False"
  "\<turnstile> (P \<and> P) = P"
  "\<turnstile> (P \<and> ~P) = #False"
  "\<turnstile> (\<not>P \<and> P) = #False"
  "\<turnstile> (P \<or> #True) = #True"
  "\<turnstile> (#True \<or> P) = #True"
  "\<turnstile> (P \<or> #False) = P"
  "\<turnstile> (#False \<or> P) = P"
  "\<turnstile> (P \<or> P) = P"
  "\<turnstile> (P \<or> \<not>P) = #True"
  "\<turnstile> (\<not>P \<or> P) = #True"
  "\<turnstile> (\<forall> x. P) = P"
  "\<turnstile> (\<exists> x. P) = P"
  by auto

lemmas intensional_simps[simp] = int_simps[THEN inteq_reflection]

method_setup int_rewrite = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (rewrite_goal_tac ctxt @{thms intensional_simps}))
*} "rewrite method at intensional level"

lemma Not_Rall: "\<turnstile> (\<not>(\<forall> x. F x)) = (\<exists> x. \<not>F x)"
  by auto

lemma Not_Rex: "\<turnstile> (\<not>(\<exists> x. F x)) = (\<forall> x. \<not>F x)"
  by auto

lemma TrueW [simp]: "\<turnstile> #True"
  by auto

lemma int_eq: "\<turnstile> X = Y \<Longrightarrow> X = Y"
  by (auto simp: inteq_reflection)

lemma int_iffI:
  assumes "\<turnstile> F \<longrightarrow> G" and "\<turnstile> G \<longrightarrow> F"
  shows "\<turnstile> F = G"
  using assms by force

lemma int_iffD1: assumes h: "\<turnstile> F = G" shows "\<turnstile> F \<longrightarrow> G"
  using h by auto

lemma int_iffD2: assumes h: "\<turnstile> F = G" shows "\<turnstile> G \<longrightarrow> F"
  using h by auto

lemma lift_imp_trans:
  assumes "\<turnstile> A \<longrightarrow> B" and "\<turnstile> B \<longrightarrow> C"
  shows "\<turnstile> A \<longrightarrow> C"
  using assms by force

lemma lift_imp_neg: assumes "\<turnstile> A \<longrightarrow> B" shows "\<turnstile> \<not>B \<longrightarrow> \<not>A"
  using assms by auto

lemma lift_and_com:  "\<turnstile> (A \<and> B) = (B \<and> A)"
  by auto

end


(*  Title:      regular/HMLSL_Regular.thy
    Author:     Sven Linker

Defines HMLSL with regular sensors for cars.
*)
section\<open>HMLSL for Regular Sensors\<close>
text \<open>
Within this section, we instantiate HMLSL for cars with
regular sensors.
\<close>

theory HMLSL_Regular
  imports "../HMLSL" Regular_Sensors
begin

locale hmlsl_regular = regular_sensors + restriction
begin
interpretation hmlsl : hmlsl "regular :: cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
proof unfold_locales
  fix e ts c
  show " 0 < regular e ts c"
    by (metis less_add_same_cancel2 less_trans regular_def
        traffic.psGeZero traffic.sdGeZero)
qed

notation hmlsl.re ("re'(_')")
notation hmlsl.cl("cl'(_')")
notation hmlsl.len ("len")

text \<open>
The spatial atoms are dependent of the perspective of the view,
hence we cannot prove similar lemmas as for perfect sensors.

However, we can still prove
lemmas corresponding to the activity and stability rules of the
proof system for MLSL \cite{Linker2015a}.

Similar to the situation with perfect sensors, needed to instantiate the
sensor function, to ensure that the perceived length does not change
during spatial transitions.
\<close>

lemma backwards_res_act:
  "(ts \<^bold>\<midarrow>r(c) \<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> re(c)) \<longrightarrow> (ts,v \<Turnstile> re(c) \<^bold>\<or> cl(c))"
proof
  assume assm:"(ts \<^bold>\<midarrow>r(c) \<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> re(c))"
  from assm have len_eq:"len v ts c = len v ts' c"
    using create_reservation_length_stable by blast
  have "res ts c \<sqsubseteq> res ts' c" using assm traffic.create_res_subseteq1
    by auto
  hence restr_subs_res:"restrict v (res ts) c \<sqsubseteq> restrict v (res ts') c"
    using assm restriction.restrict_view by auto
  have "clm ts c \<sqsubseteq> res ts' c" using assm traffic.create_res_subseteq2
    using assm restriction.restrict_view  by auto
  hence restr_subs_clm:"restrict v (clm ts) c \<sqsubseteq> restrict v (res ts') c"
    using assm restriction.restrict_view by auto
  have "restrict v (res ts) c = \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>" by simp
  then show " ts,v \<Turnstile> (re(c) \<^bold>\<or> cl(c))"
  proof
    assume restr_res_nonempty:"restrict v (res ts) c \<noteq> \<emptyset>"
    hence restrict_one:"|restrict v (res ts) c | = 1"
      using nat_int.card_non_empty_geq_one nat_int.card_subset_le dual_order.antisym
        restr_subs_res assm by fastforce
    have "restrict v (res ts ) c \<sqsubseteq> lan v" using restr_subs_res assm by auto
    hence "restrict v (res ts)c = lan v" using restriction.restrict_eq_lan_subs
        restrict_one assm  by auto
    then show ?thesis using assm len_eq by auto
  next
    assume restr_res_empty:"restrict v (res ts) c = \<emptyset>"
    then have  clm_non_empty: "restrict v (clm ts) c \<noteq> \<emptyset>"
      by (metis assm bot.extremum inf.absorb1 inf_commute local.hmlsl.free_no_clm
          restriction.create_reservation_restrict_union restriction.restrict_def
          un_empty_absorb1)
    then  have restrict_one:"|restrict v (clm ts) c | = 1"
      using nat_int.card_non_empty_geq_one nat_int.card_subset_le dual_order.antisym
        restr_subs_clm assm by fastforce
    have "restrict v (clm ts ) c \<sqsubseteq> lan v" using restr_subs_clm assm by auto
    hence "restrict v (clm ts)c = lan v" using restriction.restrict_eq_lan_subs
        restrict_one assm   by auto
    then show ?thesis using assm len_eq by auto
  qed
qed

lemma backwards_res_act_somewhere:
  "(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> \<^bold>\<langle>re(c)\<^bold>\<rangle>) \<longrightarrow> (ts,v \<Turnstile>\<^bold>\<langle> re(c) \<^bold>\<or> cl(c)\<^bold>\<rangle> )"
  using backwards_res_act by blast

lemma backwards_res_stab:
  "(ts \<^bold>\<midarrow>r(d) \<^bold>\<rightarrow> ts') \<and>  (d \<noteq>c) \<and> (ts',v \<Turnstile> re(c)) \<longrightarrow> (ts,v \<Turnstile> re(c))"
  using regular_sensors.create_reservation_length_stable restrict_def'
    traffic.create_res_subseteq1_neq by auto

text\<open>
We now proceed to prove the \emph{reservation lemma}, which was
crucial in the manual safety proof \cite {Hilscher2011}.
\<close>
lemma reservation1: "\<Turnstile>(re(c) \<^bold>\<or> cl(c)) \<^bold>\<rightarrow> \<^bold>\<box>r(c) re(c)"
proof (rule allI| rule impI)+
  fix ts v ts'
  assume assm:"ts,v \<Turnstile>re(c) \<^bold>\<or> cl(c)" and ts'_def:"ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow>ts'"
  from assm show "ts',v \<Turnstile>  re(c)"
  proof
    assume re:"ts,v \<Turnstile>re(c)"
    then show ?thesis
      by (metis inf.absorb1 order_trans regular_sensors.create_reservation_length_stable
          restrict_def' restriction.restrict_subseteq traffic.create_res_subseteq1 ts'_def)
  next
    assume cl:"ts,v \<Turnstile>cl(c)"
    then show ?thesis
      by (metis inf.absorb1 order_trans regular_sensors.create_reservation_length_stable
          restrict_def' restriction.restrict_subseteq traffic.create_res_subseteq2 ts'_def)
  qed
qed

lemma reservation2: "\<Turnstile>(\<^bold>\<box>r(c) re(c)) \<^bold>\<rightarrow> (re(c) \<^bold>\<or> cl(c))"
  using backwards_res_act traffic.always_create_res
  by metis

lemma reservation:"\<Turnstile>(\<^bold>\<box>r(c) re(c)) \<^bold>\<leftrightarrow> (re(c) \<^bold>\<or> cl(c))"
  using reservation1 reservation2 by blast
end
end


section\<open>Some Classes of Pseudo-Hoops\<close>

theory SpecialPseudoHoops
imports PseudoHoopFilters PseudoWaisbergAlgebra
begin

class cancel_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes mult_cancel_left: "a * b = a * c \<Longrightarrow> b = c"
  and mult_cancel_right: "b * a = c * a \<Longrightarrow> b = c"
begin
lemma cancel_left_a: "b l\<rightarrow> (a * b) = a"
  apply (rule_tac a = b in mult_cancel_right)
  apply (subst inf_l_def [THEN sym])
  apply (rule order.antisym)
  by simp_all

lemma cancel_right_a: "b r\<rightarrow> (b * a) = a"
  apply (rule_tac a = b in mult_cancel_left)
  apply (subst inf_r_def [THEN sym])
  apply (rule order.antisym)
  by simp_all

end

class cancel_pseudo_hoop_algebra_2 = pseudo_hoop_algebra +
  assumes cancel_left: "b l\<rightarrow> (a * b) = a"
  and cancel_right: "b r\<rightarrow> (b * a) = a"

begin
subclass cancel_pseudo_hoop_algebra
  apply unfold_locales
  apply (subgoal_tac "b = a r\<rightarrow> (a * b) \<and> a r\<rightarrow> (a * b) = a r\<rightarrow> (a * c) \<and> a r\<rightarrow> (a * c) = c")
  apply simp
  apply (rule conjI)
  apply (subst cancel_right)
  apply simp
  apply (rule conjI)
  apply simp
  apply (subst cancel_right)
  apply simp
  apply (subgoal_tac "b = a l\<rightarrow> (b * a) \<and> a l\<rightarrow> (b * a) = a l\<rightarrow> (c * a) \<and> a l\<rightarrow> (c * a) = c")
  apply simp
  apply (rule conjI)
  apply (subst cancel_left)
  apply simp
  apply (rule conjI)
  apply simp
  apply (subst cancel_left)
  by simp

end

context cancel_pseudo_hoop_algebra
begin

lemma lemma_4_2_i: "a l\<rightarrow> b = (a * c) l\<rightarrow> (b * c)"
  apply (subgoal_tac "a l\<rightarrow> b = a l\<rightarrow> (c l\<rightarrow> (b * c)) \<and> a l\<rightarrow> (c l\<rightarrow> (b * c)) = (a * c) l\<rightarrow> (b * c)")
  apply simp
  apply (rule conjI)
  apply (simp add: cancel_left_a)
  by (simp add: left_impl_ded)

lemma lemma_4_2_ii: "a r\<rightarrow> b = (c * a) r\<rightarrow> (c * b)"
  apply (subgoal_tac "a r\<rightarrow> b = a r\<rightarrow> (c r\<rightarrow> (c * b)) \<and> a r\<rightarrow> (c r\<rightarrow> (c * b)) = (c * a) r\<rightarrow> (c * b)")
  apply simp
  apply (rule conjI)
  apply (simp add: cancel_right_a)
  by (simp add: right_impl_ded)

lemma lemma_4_2_iii: "(a * c \<le> b * c) = (a \<le> b)"
  by (simp add: left_lesseq lemma_4_2_i [THEN sym])

lemma lemma_4_2_iv: "(c * a \<le> c * b) = (a \<le> b)"
  by (simp add: right_lesseq lemma_4_2_ii [THEN sym])

end

class wajsberg_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes wajsberg1: "(a l\<rightarrow> b) r\<rightarrow> b = (b l\<rightarrow> a) r\<rightarrow> a"
  and wajsberg2: "(a r\<rightarrow> b) l\<rightarrow> b = (b r\<rightarrow> a) l\<rightarrow> a"

context wajsberg_pseudo_hoop_algebra
begin

lemma lemma_4_3_i_a: "a \<squnion>1 b = (a l\<rightarrow> b) r\<rightarrow> b"
  by (simp add: sup1_def wajsberg1)

lemma lemma_4_3_ii_a: "a \<squnion>2 b = (a r\<rightarrow> b) l\<rightarrow> b"
  by (simp add: sup2_def wajsberg2)

lemma lemma_4_3_ii_b: "a \<squnion>2 b = (b r\<rightarrow> a) l\<rightarrow> a"
  by (simp add: sup2_def wajsberg2)
end

sublocale wajsberg_pseudo_hoop_algebra < lattice1:pseudo_hoop_lattice_b "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  apply (simp add: lemma_4_3_i_a)
  by (simp add: lemma_2_5_13_b lemma_2_5_13_a)

class zero_one = zero + one

class bounded_wajsberg_pseudo_hoop_algebra = zero_one + wajsberg_pseudo_hoop_algebra +
  assumes zero_smallest [simp]: "0 \<le> a"
begin
end

sublocale wajsberg_pseudo_hoop_algebra < lattice2:pseudo_hoop_lattice_b "(\<squnion>2)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  apply (simp add: lemma_4_3_ii_a)
  by (simp add: lemma_2_5_13_b lemma_2_5_13_a)

lemma (in wajsberg_pseudo_hoop_algebra) sup1_eq_sup2: "(\<squnion>1) = (\<squnion>2)"
  apply (simp add: fun_eq_iff)
  apply safe
  apply (cut_tac a = x and b = xa in lattice1.supremum_pair)
  apply (cut_tac a = x and b = xa in lattice2.supremum_pair)
  by blast

context bounded_wajsberg_pseudo_hoop_algebra
begin
definition
  "negl a = a l\<rightarrow> 0"

definition
  "negr a = a r\<rightarrow> 0"

sublocale bounded_wajsberg_pseudo_hoop_algebra < wajsberg: pseudo_wajsberg_algebra "1"  "(l\<rightarrow>)"  "(r\<rightarrow>)"  "(\<le>)" "(<)" "0" "negl" "negr"
  apply unfold_locales
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (subst left_lesseq [THEN sym])
  apply (simp add: lemma_2_5_16)
  apply (subst right_lesseq [THEN sym])
  apply (simp add: lemma_2_5_17)
  apply (simp add: left_lesseq)
  apply (simp add: less_def)
  apply (simp_all add: negl_def negr_def)
  apply (subst left_lesseq [THEN sym])
  apply (subgoal_tac "b l\<rightarrow> a = ((b l\<rightarrow> 0) r\<rightarrow> 0) l\<rightarrow> ((a l\<rightarrow> 0) r\<rightarrow> 0)")
  apply (simp add: lemma_2_5_17)
  apply (subst wajsberg1)
  apply simp
  apply (subst wajsberg1)
  apply simp
  apply (subst left_lesseq [THEN sym])
  apply (subgoal_tac "b r\<rightarrow> a = ((b r\<rightarrow> 0) l\<rightarrow> 0) r\<rightarrow> ((a r\<rightarrow> 0) l\<rightarrow> 0)")
  apply (simp add: lemma_2_5_16)
  apply (subst wajsberg2)
  apply simp
  apply (subst wajsberg2)
  apply simp
  apply (simp add: left_impl_ded [THEN sym])
  apply (simp add: right_impl_ded [THEN sym])
  apply (simp add:  lemma_4_3_i_a [THEN sym] lemma_4_3_ii_a [THEN sym])
  apply (rule order.antisym)
  by simp_all

context pseudo_wajsberg_algebra
begin
  lemma "class.bounded_wajsberg_pseudo_hoop_algebra mult inf_a (l\<rightarrow>) (\<le>) (<) 1 (r\<rightarrow>) (0::'a)"
  apply unfold_locales
  apply (simp add: inf_a_def mult_def W6)
  apply (simp add: strict)
  apply (simp_all add: mult_def order_l strict)
  apply (simp add: zero_def [THEN sym] C3_a)
  apply (simp add: W6 inf_a_def [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add: C6 P9 [THEN sym] C5_b)
  apply (simp add: inf_b_def [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add: inf_b_def [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add: W6)
  apply (simp add: C6 [THEN sym])
  apply (simp add: P9 C5_a)
  apply (simp add: inf_b_def [THEN sym])
  apply (simp add: W6 inf_a_def [THEN sym])
  apply (rule order.antisym)
  apply simp_all
  apply (simp add: W2a)
  by (simp add: W2c)

end

class basic_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes B1: "(a l\<rightarrow> b) l\<rightarrow> c \<le> ((b l\<rightarrow> a) l\<rightarrow> c) l\<rightarrow> c"
  and B2: "(a r\<rightarrow> b) r\<rightarrow> c \<le> ((b r\<rightarrow> a) r\<rightarrow> c) r\<rightarrow> c"
begin
lemma lemma_4_5_i: "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1"
  apply (cut_tac a = a and b = b and c = "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a)" in B1)
  apply (subgoal_tac "(a l\<rightarrow> b) l\<rightarrow> (a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1 \<and> ((b l\<rightarrow> a) l\<rightarrow> (a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a)) = 1")
  apply (erule conjE)
  apply simp
  apply (rule order.antisym)
  apply simp
  apply simp
  apply safe
  apply (subst left_lesseq [THEN sym])
  apply simp
  apply (subst left_lesseq [THEN sym])
  by simp

lemma lemma_4_5_ii: "(a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a) = 1"
  apply (cut_tac a = a and b = b and c = "(a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a)" in B2)
  apply (subgoal_tac "(a r\<rightarrow> b) r\<rightarrow> (a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a) = 1 \<and> ((b r\<rightarrow> a) r\<rightarrow> (a r\<rightarrow> b) \<squnion>2 (b r\<rightarrow> a)) = 1")
  apply (erule conjE)
  apply simp
  apply (rule order.antisym)
  apply simp
  apply simp
  apply safe
  apply (subst right_lesseq [THEN sym])
  apply simp
  apply (subst right_lesseq [THEN sym])
  by simp

lemma lemma_4_5_iii: "a l\<rightarrow> b = (a \<squnion>1 b) l\<rightarrow> b"
  apply (rule order.antisym)
  apply (rule_tac y = "((a l\<rightarrow> b) r\<rightarrow> b) l\<rightarrow> b" in order_trans)
  apply (rule lemma_2_10_26)
  apply (rule lemma_2_5_13_a)
  apply (simp add: sup1_def)
  apply (rule lemma_2_5_13_a)
  by simp

lemma lemma_4_5_iv: "a r\<rightarrow> b = (a \<squnion>2 b) r\<rightarrow> b"
  apply (rule order.antisym)
  apply (rule_tac y = "((a r\<rightarrow> b) l\<rightarrow> b) r\<rightarrow> b" in order_trans)
  apply (rule lemma_2_10_24)
  apply (rule lemma_2_5_13_b)
  apply (simp add: sup2_def)
  apply (rule lemma_2_5_13_b)
  by simp

lemma lemma_4_5_v: "(a \<squnion>1 b) l\<rightarrow> c = (a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)"
  apply (rule order.antisym)
  apply simp
  apply safe
  apply (rule lemma_2_5_13_a)
  apply simp
  apply (rule lemma_2_5_13_a)
  apply simp
  apply (subst right_lesseq)
  apply (rule order.antisym)
  apply simp
  apply (rule_tac y = "(a l\<rightarrow> b) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)" in order_trans)
  apply (subst left_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iii)
  apply (subst right_residual [THEN sym])
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "b \<sqinter> c" in order_trans)
  apply (subst (2) inf_l_def)
  apply (rule_tac y = "((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)) * ((a \<squnion>1 b) \<sqinter> b)" in order_trans)
  apply (subst (3) inf_l_def)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>1 b \<sqinter> b) = b")
  apply simp
  apply (rule order.antisym, simp)
  apply simp
  apply simp
  apply (rule_tac y = "((b l\<rightarrow> a) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c)" in order_trans)
  apply (rule B1)
  apply (subgoal_tac "(b l\<rightarrow> a) l\<rightarrow> ((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c) r\<rightarrow> a \<squnion>1 b l\<rightarrow> c) = 1")
  apply simp
  apply (rule order.antisym)
  apply simp
  apply (subst left_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iii)
  apply (subst right_residual [THEN sym])
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "a \<sqinter> c" in order_trans)
  apply (subst (2) inf_l_def)
  apply (rule_tac y = "((a l\<rightarrow> c) \<sqinter> (b l\<rightarrow> c)) * ((a \<squnion>1 b) \<sqinter> a)" in order_trans)
  apply (subst (3) inf_l_def)
  apply (subst sup1.sup_comute1)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>1 b \<sqinter> a) = a")
  apply simp
  apply (rule order.antisym, simp)
  apply simp
  by simp

lemma lemma_4_5_vi: "(a \<squnion>2 b) r\<rightarrow> c = (a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c)"
  apply (rule order.antisym)
  apply simp
  apply safe
  apply (rule lemma_2_5_13_b)
  apply simp
  apply (rule lemma_2_5_13_b)
  apply simp
  apply (subst left_lesseq)
  apply (rule order.antisym)
  apply simp
  apply (rule_tac y = "(a r\<rightarrow> b) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)" in order_trans)
  apply (subst right_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iv)
  apply (subst left_residual [THEN sym])
  apply (subst right_residual [THEN sym])
  apply (rule_tac y = "b \<sqinter> c" in order_trans)
  apply (subst (2) inf_r_def)
  apply (rule_tac y = "((a \<squnion>2 b) \<sqinter> b) * ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c))" in order_trans)
  apply (subst (2) inf_r_def)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>2 b \<sqinter> b) = b")
  apply simp
  apply (rule order.antisym, simp)
  apply simp
  apply simp
  apply (rule_tac y = "((b r\<rightarrow> a) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c)" in order_trans)
  apply (rule B2)
  apply (subgoal_tac "(b r\<rightarrow> a) r\<rightarrow> ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c) l\<rightarrow> a \<squnion>2 b r\<rightarrow> c) = 1")
  apply simp
  apply (rule order.antisym)
  apply simp
  apply (subst right_residual [THEN sym])
  apply simp
  apply (subst lemma_4_5_iv)
  apply (subst left_residual [THEN sym])
  apply (subst right_residual [THEN sym])
  apply (rule_tac y = "a \<sqinter> c" in order_trans)
  apply (subst (2) inf_r_def)
  apply (rule_tac y = "((a \<squnion>2 b) \<sqinter> a) * ((a r\<rightarrow> c) \<sqinter> (b r\<rightarrow> c))" in order_trans)
  apply (subst (2) inf_r_def)
  apply (subst (2) sup2.sup_comute)
  apply (simp add: mult.assoc)
  apply (subgoal_tac "(a \<squnion>2 b \<sqinter> a) = a")
  apply simp
  apply (rule order.antisym, simp)
  apply simp
  by simp

lemma lemma_4_5_a: "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion>1 b \<le> c"
  apply (subst left_lesseq)
  apply (subst lemma_4_5_v)
  by simp

lemma lemma_4_5_b: "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion>2 b \<le> c"
  apply (subst right_lesseq)
  apply (subst lemma_4_5_vi)
  by simp

lemma lemma_4_5: "a \<squnion>1 b = a \<squnion>2 b"
  apply (rule order.antisym)
  by (simp_all add: lemma_4_5_a lemma_4_5_b)
end

sublocale basic_pseudo_hoop_algebra <  basic_lattice:lattice "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>1)"
  apply unfold_locales
  by (simp_all add: lemma_4_5_a)

context pseudo_hoop_lattice begin end

sublocale basic_pseudo_hoop_algebra <  pseudo_hoop_lattice "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp_all add: basic_lattice.sup_assoc)

class sup_assoc_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes sup1_assoc: "a \<squnion>1 (b \<squnion>1 c) = (a \<squnion>1 b) \<squnion>1 c"
  and sup2_assoc: "a \<squnion>2 (b \<squnion>2 c) = (a \<squnion>2 b) \<squnion>2 c"

sublocale sup_assoc_pseudo_hoop_algebra <  sup1_lattice: pseudo_hoop_lattice "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup1_assoc)

sublocale sup_assoc_pseudo_hoop_algebra <  sup2_lattice: pseudo_hoop_lattice "(\<squnion>2)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup2_assoc)

class sup_assoc_pseudo_hoop_algebra_1 = sup_assoc_pseudo_hoop_algebra +
  assumes union_impl: "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) = 1"
  and union_impr: "(a r\<rightarrow> b) \<squnion>1 (b r\<rightarrow> a) = 1"

lemma (in pseudo_hoop_algebra) [simp]: "infimum {a, b} = {a \<sqinter> b}"
  apply (simp add: infimum_def lower_bound_def)
  apply safe
  apply (rule order.antisym)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_impl_inf:
  "(a \<squnion> b) l\<rightarrow> c = (a l\<rightarrow> c) \<sqinter> (b l\<rightarrow>c)"
  apply (cut_tac A = "{a, b}" and a = "a \<squnion> b" and b = c in lemma_2_8_i)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_impr_inf:
  "(a \<squnion> b) r\<rightarrow> c = (a r\<rightarrow> c) \<sqinter> (b r\<rightarrow>c)"
  apply (cut_tac A = "{a, b}" and a = "a \<squnion> b" and b = c in lemma_2_8_i1)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_times:
  "a * (b \<squnion> c) = (a * b) \<squnion> (a * c)"
  apply (cut_tac A = "{b, c}" and b = "b \<squnion> c" and a = a in lemma_2_9_i)
  by simp_all

lemma (in pseudo_hoop_lattice) sup_times_right:
  "(b \<squnion> c) * a = (b * a) \<squnion> (c * a)"
  apply (cut_tac A = "{b, c}" and b = "b \<squnion> c" and a = a in lemma_2_9_i1)
  by simp_all

context basic_pseudo_hoop_algebra begin end

sublocale sup_assoc_pseudo_hoop_algebra_1 <  basic_1: basic_pseudo_hoop_algebra  "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "(a l\<rightarrow> b) \<squnion>1 (b l\<rightarrow> a) l\<rightarrow> c" in order_trans)
  apply (subst sup1_lattice.sup_impl_inf)
  apply (simp add: lemma_2_5_11)
  apply (simp add: union_impl)
   apply (subst right_residual [THEN sym])
  apply (rule_tac y = "(b r\<rightarrow> a) \<squnion>1 (a r\<rightarrow> b) r\<rightarrow> c" in order_trans)
  apply (subst sup1_lattice.sup_impr_inf)
  apply (simp add: lemma_2_5_11)
  by (simp add: union_impr)

context basic_pseudo_hoop_algebra
begin

lemma lemma_4_8_i: "a * (b \<sqinter> c) = (a * b) \<sqinter> (a * c)"
  apply (rule order.antisym)
  apply simp
  apply (subgoal_tac "a * (b \<sqinter> c) = (a * (b * (b r\<rightarrow> c))) \<squnion>1 (a * (c * (c r\<rightarrow> b)))")
  apply simp
  apply (drule drop_assumption)
  apply (rule_tac y = "(((a * b) \<sqinter> (a * c)) * (b r\<rightarrow> c)) \<squnion>1 (((a * b) \<sqinter> (a * c)) * (c r\<rightarrow> b))" in order_trans)
  apply (subst sup_times [THEN sym])
  apply (simp add: lemma_4_5 lemma_4_5_ii)
  apply (simp add: mult.assoc [THEN sym])
  apply safe
  apply (rule_tac y = "a * b * (b r\<rightarrow> c)" in order_trans)
  apply simp
  apply simp
  apply (rule_tac y = "a * c * (c r\<rightarrow> b)" in order_trans)
  apply simp
  apply simp
  apply (simp add: inf_r_def [THEN sym])
  apply (subgoal_tac "b \<sqinter> c = c \<sqinter> b")
  apply simp
  apply (rule order.antisym)
  by simp_all

lemma lemma_4_8_ii: "(b \<sqinter> c) * a = (b * a) \<sqinter> (c * a)"
  apply (rule order.antisym)
  apply simp
  apply (subgoal_tac "(b \<sqinter> c) * a = (((b l\<rightarrow> c) * b) * a) \<squnion>1 (((c l\<rightarrow> b) * c) * a)")
  apply simp
  apply (drule drop_assumption)
  apply (rule_tac y = "((b l\<rightarrow> c) * ((b * a) \<sqinter> (c * a))) \<squnion>1 ((c l\<rightarrow> b) * ((b * a) \<sqinter> (c * a)))" in order_trans)
  apply (subst sup_times_right [THEN sym])
  apply (simp add: lemma_4_5_i)
  apply (simp add: mult.assoc)
  apply safe
  apply (rule_tac y = "(b l\<rightarrow> c) * (b * a)" in order_trans)
  apply simp_all
  apply (rule_tac y = "(c l\<rightarrow> b) * (c * a)" in order_trans)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (subgoal_tac "b \<sqinter> c = c \<sqinter> b")
  apply simp
  apply (rule order.antisym)
  by simp_all

lemma lemma_4_8_iii: "(a l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = b l\<rightarrow> a"
  apply (rule order.antisym)
  apply (cut_tac a = a and b = b in lemma_4_5_i)
  apply (unfold sup1_def right_lesseq, simp)
  by (simp add: lemma_2_5_9_a)

 lemma lemma_4_8_iv: "(a r\<rightarrow> b) r\<rightarrow> (b r\<rightarrow> a) = b r\<rightarrow> a"
  apply (rule order.antisym)
  apply (cut_tac a = a and b = b in lemma_4_5_ii)
  apply (unfold sup2_def left_lesseq, simp)
  by (simp add: lemma_2_5_9_b)

end

context wajsberg_pseudo_hoop_algebra
begin
subclass sup_assoc_pseudo_hoop_algebra_1
  apply unfold_locales
  apply (simp add: lattice1.sup_assoc)
  apply (simp add: lattice2.sup_assoc)
  apply (simp add: lemma_4_3_i_a)
  apply (subgoal_tac "(a l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = b l\<rightarrow> a")
  apply simp
  apply (subst lemma_2_10_30 [THEN sym])
  apply (subst wajsberg1)
  apply (simp add: lemma_2_10_32)
  apply (subst sup1_eq_sup2)
  apply (simp add: lemma_4_3_ii_a)
  apply (subgoal_tac "(a r\<rightarrow> b) r\<rightarrow> (b r\<rightarrow> a) = b r\<rightarrow> a")
  apply simp
  apply (subst lemma_2_10_31 [THEN sym])
  apply (subst wajsberg2)
  by (simp add: lemma_2_10_33)
end

class bounded_basic_pseudo_hoop_algebra = zero_one + basic_pseudo_hoop_algebra +
  assumes zero_smallest [simp]: "0 \<le> a"

class inf_a =
  fixes inf_a :: "'a => 'a => 'a" (infixl "\<sqinter>1" 65)

class pseudo_bl_algebra = zero + sup + inf + monoid_mult + ord + left_imp + right_imp +
  assumes  bounded_lattice: "class.bounded_lattice inf (\<le>) (<) sup 0 1"
  and left_residual_bl: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"
  and right_residual_bl: "(a * x \<le> b) = (x \<le> a r\<rightarrow> b)"
  and inf_l_bl_def: "a \<sqinter> b = (a l\<rightarrow> b) * a"
  and inf_r_bl_def: "a \<sqinter> b = a * (a r\<rightarrow> b)"
  and impl_sup_bl: "(a l\<rightarrow> b) \<squnion> (b l\<rightarrow> a) = 1"
  and impr_sup_bl: "(a r\<rightarrow> b) \<squnion> (b r\<rightarrow> a) = 1"

sublocale bounded_basic_pseudo_hoop_algebra < basic: pseudo_bl_algebra 1 "(*)" "0"  "(\<sqinter>)" "(\<squnion>1)" "(l\<rightarrow>)" "(r\<rightarrow>)" "(\<le>)" "(<)"
  apply unfold_locales
  apply (rule zero_smallest)
  apply (rule left_residual)
  apply (rule right_residual)
  apply (rule inf_l_def)
  apply (simp add: inf_r_def [THEN sym])
  apply (rule lemma_4_5_i)
  apply (simp add: lemma_4_5)
  by (rule lemma_4_5_ii)

sublocale pseudo_bl_algebra < bounded_lattice: bounded_lattice "inf" "(\<le>)" "(<)" "sup" "0" "1"
  by (rule bounded_lattice)

context pseudo_bl_algebra
begin
  lemma impl_one_bl [simp]: "a l\<rightarrow> a = 1"
    apply (rule bounded_lattice.order.antisym)
    apply simp_all
    apply (subst left_residual_bl [THEN sym])
    by simp

  lemma impr_one_bl [simp]: "a r\<rightarrow> a = 1"
    apply (rule bounded_lattice.order.antisym)
    apply simp_all
    apply (subst right_residual_bl [THEN sym])
    by simp

  lemma impl_ded_bl: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
    apply (rule bounded_lattice.order.antisym)
    apply (case_tac "(a * b l\<rightarrow> c \<le> a l\<rightarrow> b l\<rightarrow> c) = ((a * b l\<rightarrow> c) * a \<le> b l\<rightarrow> c)
      \<and> ((a * b l\<rightarrow> c) * a \<le> b l\<rightarrow> c) = (((a * b l\<rightarrow> c) * a) * b \<le> c)
      \<and> (((a * b l\<rightarrow> c) * a) * b \<le> c) = ((a * b l\<rightarrow> c) * (a * b) \<le> c)
      \<and> ((a * b l\<rightarrow> c) * (a * b) \<le> c) = ((a * b l\<rightarrow> c) \<le> (a * b l\<rightarrow> c))")
    apply simp
    apply (erule notE)
    apply (rule conjI)
    apply (simp add: left_residual_bl)
    apply (rule conjI)
    apply (simp add: left_residual_bl)
    apply (rule conjI)
    apply (simp add: mult.assoc)
    apply (simp add: left_residual_bl)
    apply (simp add: left_residual_bl [THEN sym])
    apply (rule_tac y="(b l\<rightarrow> c) * b" in bounded_lattice.order_trans)
    apply (simp add: mult.assoc [THEN sym])
    apply (subst inf_l_bl_def [THEN sym])
    apply (subst bounded_lattice.inf_commute)
    apply (subst inf_l_bl_def)
    apply (subst mult.assoc)
    apply (subst left_residual_bl)
    apply simp
    apply (subst left_residual_bl)
    by simp

  lemma impr_ded_bl: "(b * a r\<rightarrow> c) = (a r\<rightarrow> (b r\<rightarrow> c))"
    apply (rule bounded_lattice.order.antisym)
    apply (case_tac "(b * a r\<rightarrow> c \<le> a r\<rightarrow> b r\<rightarrow> c) = (a * (b * a r\<rightarrow> c) \<le> b r\<rightarrow> c)
      \<and> (a * (b * a r\<rightarrow> c) \<le> b r\<rightarrow> c) = (b * (a * (b * a r\<rightarrow> c)) \<le> c)
      \<and> (b * ( a* (b * a r\<rightarrow> c)) \<le> c) = ((b * a) * (b * a r\<rightarrow> c) \<le> c)
      \<and> ((b * a) * (b * a r\<rightarrow> c) \<le> c) = ((b * a r\<rightarrow> c) \<le> (b * a r\<rightarrow> c))")
    apply simp
    apply (erule notE)
    apply (rule conjI)
    apply (simp add: right_residual_bl)
    apply (rule conjI)
    apply (simp add: right_residual_bl)
    apply (rule conjI)
    apply (simp add: mult.assoc)
    apply (simp add: right_residual_bl)
    apply (simp add: right_residual_bl [THEN sym])
    apply (rule_tac y="b * (b r\<rightarrow> c)" in bounded_lattice.order_trans)
    apply (simp add: mult.assoc)
    apply (subst inf_r_bl_def [THEN sym])
    apply (subst bounded_lattice.inf_commute)
    apply (subst inf_r_bl_def)
    apply (subst mult.assoc [THEN sym])
    apply (subst right_residual_bl)
    apply simp
    apply (subst right_residual_bl)
    by simp

  lemma lesseq_impl_bl: "(a \<le> b) = (a l\<rightarrow> b = 1)"
    apply (rule iffI)
    apply (rule  bounded_lattice.order.antisym)
    apply simp
    apply (simp add: left_residual_bl [THEN sym])
    apply (subgoal_tac "1 \<le> a l\<rightarrow> b")
    apply (subst (asm) left_residual_bl [THEN sym])
    by simp_all

end

context pseudo_bl_algebra
begin
subclass pseudo_hoop_lattice
  apply unfold_locales
  apply (rule inf_l_bl_def)
  apply (simp add: bounded_lattice.less_le_not_le)
  apply (simp add: mult_1_left)
  apply (simp add: mult_1_right)
  apply (simp add: impl_one_bl)
  apply (simp add: inf_l_bl_def [THEN sym])
  apply (rule bounded_lattice.inf_commute)
  apply (rule impl_ded_bl)
  apply (rule lesseq_impl_bl)
  apply (rule inf_r_bl_def)
  apply (simp add: impr_one_bl)
  apply (simp add: inf_r_bl_def [THEN sym])
  apply (rule bounded_lattice.inf_commute)
  apply (rule impr_ded_bl)
  apply (simp add: inf_r_bl_def [THEN sym] inf_l_bl_def [THEN sym])
  apply (rule bounded_lattice.sup_commute)
  apply simp
  apply safe
  apply (rule bounded_lattice.order.antisym)
  apply simp_all
  apply (subgoal_tac "a \<le>  a \<squnion> b")
  apply simp
  apply (drule drop_assumption)
  apply simp
  by (simp add: bounded_lattice.sup_assoc)

subclass bounded_basic_pseudo_hoop_algebra
  apply unfold_locales
  apply simp_all
  apply (simp add: left_residual [THEN sym])
  apply (rule_tac y = "((a l\<rightarrow> b) \<squnion> (b l\<rightarrow> a)) l\<rightarrow> c" in bounded_lattice.order_trans)
  apply (simp add: sup_impl_inf)
  apply (simp add: impl_sup_bl)

  apply (simp add: right_residual [THEN sym])
  apply (rule_tac y = "((a r\<rightarrow> b) \<squnion> (b r\<rightarrow> a)) r\<rightarrow> c" in bounded_lattice.order_trans)
  apply (simp add: sup_impr_inf)
  by (simp add: impr_sup_bl)

end

class product_pseudo_hoop_algebra = basic_pseudo_hoop_algebra +
  assumes P1: "b l\<rightarrow> b * b \<le> (a \<sqinter> (a l\<rightarrow> b)) l\<rightarrow> b"
  and P2: "b r\<rightarrow> b * b \<le> (a \<sqinter> (a r\<rightarrow> b)) r\<rightarrow> b"
  and P3: "((a l\<rightarrow> b) l\<rightarrow> b) * (c * a l\<rightarrow> d * a) * (c * b l\<rightarrow> d * b) \<le> c l\<rightarrow> d"
  and P4: "((a r\<rightarrow> b) r\<rightarrow> b) * (a * c r\<rightarrow> a * d) * (b * c r\<rightarrow> b * d) \<le> c r\<rightarrow> d"

class cancel_basic_pseudo_hoop_algebra = basic_pseudo_hoop_algebra + cancel_pseudo_hoop_algebra
begin
subclass product_pseudo_hoop_algebra
  apply unfold_locales
  apply (rule_tac y = "1 l\<rightarrow> b" in order_trans)
  apply (cut_tac a = 1 and b = b and c = b in lemma_4_2_i)
  apply simp
  apply (simp add: lemma_2_5_9_a)

  apply (rule_tac y = "1 r\<rightarrow> b" in order_trans)
  apply (cut_tac a = 1 and b = b and c = b in lemma_4_2_ii)
  apply simp
  apply (simp add: lemma_2_5_9_b)
  apply (simp add: lemma_4_2_i [THEN sym])
  by (simp add: lemma_4_2_ii [THEN sym])

end

class simple_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes simple: "normalfilters \<inter> properfilters = {{1}}"

class proper = one +
  assumes proper: "\<exists> a . a \<noteq> 1"

class strong_simple_pseudo_hoop_algebra = pseudo_hoop_algebra +
  assumes strong_simple: "properfilters = {{1}}"
begin

subclass proper
  apply unfold_locales
  apply (cut_tac strong_simple)
  apply (simp add: properfilters_def)
  apply (case_tac "{1} = UNIV")
  apply blast
  by blast

lemma lemma_4_12_i_ii: "a \<noteq> 1 \<Longrightarrow> filterof({a}) = UNIV"
  apply (cut_tac strong_simple)
  apply (simp add: properfilters_def)
  apply (subgoal_tac "filterof {a} \<notin> {F \<in> filters. F \<noteq> UNIV}")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply simp
  apply simp
  apply safe
  apply (subgoal_tac "a \<in> filterof {a}")
  apply simp
  apply (subst filterof_def)
  by simp

lemma lemma_4_12_i_iii: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a ^ n \<le> b)"
  apply (drule lemma_4_12_i_ii)
  apply (simp add: prop_3_2_i)
  by blast

lemma lemma_4_12_i_iv: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a l-n\<rightarrow> b = 1)"
  apply (subst lemma_2_4_7_a)
  apply (subst left_lesseq [THEN sym])
  by (simp add: lemma_4_12_i_iii)

lemma lemma_4_12_i_v: "a \<noteq> 1 \<Longrightarrow> (\<exists> n . a r-n\<rightarrow> b = 1)"
  apply (subst lemma_2_4_7_b)
  apply (subst right_lesseq [THEN sym])
  by (simp add: lemma_4_12_i_iii)

end

lemma (in pseudo_hoop_algebra) [simp]: "{1} \<in> filters"
  apply (simp add: filters_def)
  apply safe
  apply (rule order.antisym)
  by simp_all

class strong_simple_pseudo_hoop_algebra_a = pseudo_hoop_algebra + proper +
  assumes strong_simple_a: "a \<noteq> 1 \<Longrightarrow> filterof({a}) = UNIV"
begin
  subclass  strong_simple_pseudo_hoop_algebra
    apply unfold_locales
    apply (simp add: properfilters_def)
    apply safe
    apply simp_all
    apply (case_tac "xb = 1")
    apply simp
    apply (cut_tac a = xb in strong_simple_a)
    apply simp
    apply (simp add: filterof_def)
    apply blast
    apply (cut_tac proper)
    by blast
end

sublocale strong_simple_pseudo_hoop_algebra < strong_simple_pseudo_hoop_algebra_a
  apply unfold_locales
  by (simp add: lemma_4_12_i_ii)

lemma (in pseudo_hoop_algebra) power_impl: "b l\<rightarrow> a = a \<Longrightarrow> b ^ n l\<rightarrow> a = a"
  apply (induct_tac n)
  apply simp
  by (simp add: left_impl_ded)

lemma (in pseudo_hoop_algebra) power_impr: "b r\<rightarrow> a = a \<Longrightarrow> b ^ n r\<rightarrow> a = a"
  apply (induct_tac n)
  apply simp
  by (simp add: right_impl_ded)

context strong_simple_pseudo_hoop_algebra
begin

lemma lemma_4_13_i: "b l\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  apply safe
  apply (drule_tac a = b and b = a in lemma_4_12_i_iii)
  apply safe
  apply (subst (asm) left_lesseq)
  apply (drule_tac n = n in power_impl)
  by simp

lemma lemma_4_13_ii: "b r\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  apply safe
  apply (drule_tac a = b and b = a in lemma_4_12_i_iii)
  apply safe
  apply (subst (asm) right_lesseq)
  apply (drule_tac n = n in power_impr)
  by simp
end

class basic_pseudo_hoop_algebra_A = basic_pseudo_hoop_algebra +
  assumes left_impl_one: "b l\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
  and right_impl_one: "b r\<rightarrow> a = a \<Longrightarrow> a = 1 \<or> b = 1"
begin
subclass linorder
  apply unfold_locales
  apply (cut_tac a = "x" and b = "y" in lemma_4_8_iii)
  apply (drule left_impl_one)
  apply (simp add: left_lesseq)
  by blast

lemma [simp]: "(a l\<rightarrow> b) r\<rightarrow> b \<le> (b l\<rightarrow> a) r\<rightarrow> a"
  apply (case_tac "a = b")
  apply simp
  apply (cut_tac x = a and y =b in linear)
  apply safe
  apply (subst (asm) left_lesseq)
  apply (simp add: lemma_2_10_24)
  apply (subst (asm) left_lesseq)
  apply simp
  apply (subst left_lesseq)
  apply (cut_tac b = "((a l\<rightarrow> b) r\<rightarrow> b) l\<rightarrow> a" and a = "a l\<rightarrow> b" in left_impl_one)
  apply (simp add: lemma_2_10_32)
  apply (simp add: left_lesseq [THEN sym])
  apply safe
  apply (erule notE)
  by simp

end

context basic_pseudo_hoop_algebra_A begin

lemma [simp]: "(a r\<rightarrow> b) l\<rightarrow> b \<le> (b r\<rightarrow> a) l\<rightarrow> a"
  apply (case_tac "a = b")
  apply simp
  apply (cut_tac x = a and y =b in linear)
  apply safe
  apply (subst (asm) right_lesseq)
  apply simp
  apply (simp add: lemma_2_10_26)
  apply (unfold right_lesseq)
  apply (cut_tac b = "((a r\<rightarrow> b) l\<rightarrow> b) r\<rightarrow> a" and a = "a r\<rightarrow> b" in right_impl_one)
  apply (simp add: lemma_2_10_33)
  apply (simp add: right_lesseq [THEN sym])
  apply safe
  apply (erule notE)
  by simp

subclass wajsberg_pseudo_hoop_algebra
  apply unfold_locales
  apply (rule order.antisym)
  apply simp_all
  apply (rule order.antisym)
  by simp_all

end

class strong_simple_basic_pseudo_hoop_algebra = strong_simple_pseudo_hoop_algebra + basic_pseudo_hoop_algebra
begin
subclass basic_pseudo_hoop_algebra_A
  apply unfold_locales
  apply (simp add: lemma_4_13_i)
  by (simp add: lemma_4_13_ii)

subclass wajsberg_pseudo_hoop_algebra
  by unfold_locales

end

end


(*
  File: Indexed_PQueue_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of the indexed priority queue\<close>

theory Indexed_PQueue_Impl
  imports DynamicArray "../Functional/Indexed_PQueue"
begin

text \<open>
  Imperative implementation of indexed priority queue. The data structure
  is also verified in \<^cite>\<open>"Refine_Imperative_HOL-AFP"\<close> by Peter Lammich.
\<close>

datatype 'a indexed_pqueue =
  Indexed_PQueue (pqueue: "(nat \<times> 'a) dynamic_array") (index: "nat option array")
setup \<open>add_simple_datatype "indexed_pqueue"\<close>

fun idx_pqueue :: "'a::heap idx_pqueue \<Rightarrow> 'a indexed_pqueue \<Rightarrow> assn" where
  "idx_pqueue (xs, m) (Indexed_PQueue pq idx) = (dyn_array xs pq * idx \<mapsto>\<^sub>a m)"
setup \<open>add_rewrite_ent_rule @{thm idx_pqueue.simps}\<close>

subsection \<open>Basic operations\<close>

definition idx_pqueue_empty :: "nat \<Rightarrow> 'a::heap indexed_pqueue Heap" where
  "idx_pqueue_empty k = do {
    pq \<leftarrow> dyn_array_new;
    idx \<leftarrow> Array.new k None;
    return (Indexed_PQueue pq idx) }"

lemma idx_pqueue_empty_rule [hoare_triple]:
  "<emp>
   idx_pqueue_empty n
   <idx_pqueue ([], replicate n None)>" by auto2

definition idx_pqueue_nth :: "'a::heap indexed_pqueue \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) Heap" where
  "idx_pqueue_nth p i = array_nth (pqueue p) i"

lemma idx_pqueue_nth_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p * \<up>(i < length xs)>
   idx_pqueue_nth p i
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = xs ! i)>" by auto2

definition idx_nth :: "'a::heap indexed_pqueue \<Rightarrow> nat \<Rightarrow> nat option Heap" where
  "idx_nth p i = Array.nth (index p) i"

lemma idx_nth_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p * \<up>(i < length m)>
   idx_nth p i
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = m ! i)>" by auto2

definition idx_pqueue_length :: "'a indexed_pqueue \<Rightarrow> nat Heap" where
  "idx_pqueue_length a = array_length (pqueue a)"

lemma idx_pqueue_length_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p>
   idx_pqueue_length p
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = length xs)>" by auto2

definition idx_pqueue_swap ::
  "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_pqueue_swap p i j = do {
     pr_i \<leftarrow> array_nth (pqueue p) i;
     pr_j \<leftarrow> array_nth (pqueue p) j;
     Array.upd (fst pr_i) (Some j) (index p);
     Array.upd (fst pr_j) (Some i) (index p);
     array_swap (pqueue p) i j
   }"

lemma idx_pqueue_swap_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_swap p i j
   <\<lambda>_. idx_pqueue (idx_pqueue_swap_fun (xs, m) i j) p>"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

definition idx_pqueue_push :: "nat \<Rightarrow> 'a::heap \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "idx_pqueue_push k v p = do {
     len \<leftarrow> array_length (pqueue p);
     d' \<leftarrow> push_array (k, v) (pqueue p);
     Array.upd k (Some len) (index p);
     return (Indexed_PQueue d' (index p))
   }"

lemma idx_pqueue_push_rule [hoare_triple]:
  "k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_push k v p
   <idx_pqueue (idx_pqueue_push_fun k v (xs, m))>\<^sub>t"
@proof @unfold "idx_pqueue_push_fun k v (xs, m)" @qed

definition idx_pqueue_pop :: "'a::heap indexed_pqueue \<Rightarrow> ((nat \<times> 'a) \<times> 'a indexed_pqueue) Heap" where
  "idx_pqueue_pop p = do {
     (x, d') \<leftarrow> pop_array (pqueue p);
     Array.upd (fst x) None (index p);
     return (x, Indexed_PQueue d' (index p))
   }"

lemma idx_pqueue_pop_rule [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_pop p
   <\<lambda>(x, r). idx_pqueue (idx_pqueue_pop_fun (xs, m)) r * \<up>(x = last xs)>"
@proof @unfold "idx_pqueue_pop_fun (xs, m)" @qed

definition idx_pqueue_array_upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> unit Heap" where
  "idx_pqueue_array_upd i x d = array_upd i x d"

lemma array_upd_idx_pqueue_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> k = fst (xs ! i) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_array_upd i (k, v) (pqueue p)
   <\<lambda>_. idx_pqueue (list_update xs i (k, v), m) p>" by auto2

definition has_key_idx_pqueue :: "nat \<Rightarrow> 'a::{heap,linorder} indexed_pqueue \<Rightarrow> bool Heap" where
  "has_key_idx_pqueue k p = do {
    i_opt \<leftarrow> Array.nth (index p) k;
    return (i_opt \<noteq> None) }"

lemma has_key_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   has_key_idx_pqueue k p
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r \<longleftrightarrow> has_key_alist xs k)>" by auto2

setup \<open>del_prfstep_thm @{thm idx_pqueue.simps}\<close>
setup \<open>del_simple_datatype "indexed_pqueue"\<close>

subsection \<open>Bubble up and down\<close>

partial_function (heap) idx_bubble_down :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_bubble_down a k = do {
    len \<leftarrow> idx_pqueue_length a;
    (if s2 k < len then do {
      vk \<leftarrow> idx_pqueue_nth a k;
      vs1k \<leftarrow> idx_pqueue_nth a (s1 k);
      vs2k \<leftarrow> idx_pqueue_nth a (s2 k);
      (if snd vs1k \<le> snd vs2k then
         if snd vk > snd vs1k then
           do { idx_pqueue_swap a k (s1 k); idx_bubble_down a (s1 k) }
         else return ()
       else
         if snd vk > snd vs2k then
           do { idx_pqueue_swap a k (s2 k); idx_bubble_down a (s2 k) }
         else return ()) }
     else if s1 k < len then do {
       vk \<leftarrow> idx_pqueue_nth a k;
       vs1k \<leftarrow> idx_pqueue_nth a (s1 k);
       (if snd vk > snd vs1k then
          do { idx_pqueue_swap a k (s1 k); idx_bubble_down a (s1 k) }
        else return ()) }
     else return ()) }"

lemma idx_bubble_down_rule [hoare_triple]:
  "index_of_pqueue x \<Longrightarrow>
   <idx_pqueue x a>
   idx_bubble_down a k
   <\<lambda>_. idx_pqueue (idx_bubble_down_fun x k) a>"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed

partial_function (heap) idx_bubble_up :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_bubble_up a k =
    (if k = 0 then return () else do {
       len \<leftarrow> idx_pqueue_length a;
       (if k < len then do {
          vk \<leftarrow> idx_pqueue_nth a k;
          vpk \<leftarrow> idx_pqueue_nth a (par k);
          (if snd vk < snd vpk then
             do { idx_pqueue_swap a k (par k); idx_bubble_up a (par k) }
           else return ()) }
        else return ())})"

lemma idx_bubble_up_rule [hoare_triple]:
  "index_of_pqueue x \<Longrightarrow>
   <idx_pqueue x a>
   idx_bubble_up a k
   <\<lambda>_. idx_pqueue (idx_bubble_up_fun x k) a>"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed

subsection \<open>Main operations\<close>

definition delete_min_idx_pqueue :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> ((nat \<times> 'a) \<times> 'a indexed_pqueue) Heap" where
  "delete_min_idx_pqueue p = do {
     len \<leftarrow> idx_pqueue_length p;
     if len = 0 then raise STR ''delete_min''
     else do {
       idx_pqueue_swap p 0 (len - 1);
       (x', r) \<leftarrow> idx_pqueue_pop p;
       idx_bubble_down r 0;
       return (x', r)
     }
   }"

lemma delete_min_idx_pqueue_rule [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   delete_min_idx_pqueue p
   <\<lambda>(x, r). idx_pqueue (snd (delete_min_idx_pqueue_fun (xs, m))) r *
       \<up>(x = fst (delete_min_idx_pqueue_fun (xs, m)))>"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)" @qed

definition insert_idx_pqueue :: "nat \<Rightarrow> 'a::{heap,linorder} \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "insert_idx_pqueue k v p = do {
     p' \<leftarrow> idx_pqueue_push k v p;
     len \<leftarrow> idx_pqueue_length p';
     idx_bubble_up p' (len - 1);
     return p'
   }"

lemma insert_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   insert_idx_pqueue k v p
   <idx_pqueue (insert_idx_pqueue_fun k v (xs, m))>\<^sub>t"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)" @qed

definition update_idx_pqueue ::
  "nat \<Rightarrow> 'a::{heap,linorder} \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "update_idx_pqueue k v p = do {
    i_opt \<leftarrow> idx_nth p k;
    case i_opt of
      None \<Rightarrow> insert_idx_pqueue k v p
    | Some i \<Rightarrow> do {
      x \<leftarrow> idx_pqueue_nth p i;
      idx_pqueue_array_upd i (k, v) (pqueue p);
      (if snd x \<le> v then do {idx_bubble_down p i; return p}
       else do {idx_bubble_up p i; return p}) }}"

lemma update_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   update_idx_pqueue k v p
   <idx_pqueue (update_idx_pqueue_fun k v (xs, m))>\<^sub>t"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)" @qed

subsection \<open>Outer interface\<close>

text \<open>Express Hoare triples for indexed priority queue operations in terms of
  the mapping represented by the queue.\<close>
definition idx_pqueue_map :: "(nat, 'a::{heap,linorder}) map \<Rightarrow> nat \<Rightarrow> 'a indexed_pqueue \<Rightarrow> assn" where
  "idx_pqueue_map M n p = (\<exists>\<^sub>Axs m. idx_pqueue (xs, m) p *
      \<up>(index_of_pqueue (xs, m)) * \<up>(is_heap xs) * \<up>(M = map_of_alist xs) * \<up>(n = length m))"
setup \<open>add_rewrite_ent_rule @{thm idx_pqueue_map_def}\<close>

lemma heap_implies_hd_min2 [resolve]:
  "is_heap xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> (map_of_alist xs)\<langle>k\<rangle> = Some v \<Longrightarrow> snd (hd xs) \<le> v"
@proof
  @obtain i where "i < length xs" "xs ! i = (k, v)"
  @have "snd (hd xs) \<le> snd (xs ! i)"
@qed

theorem idx_pqueue_empty_map [hoare_triple]:
  "<emp>
   idx_pqueue_empty n
   <idx_pqueue_map empty_map n>" by auto2

theorem delete_min_idx_pqueue_map [hoare_triple]:
  "<idx_pqueue_map M n p * \<up>(M \<noteq> empty_map)>
   delete_min_idx_pqueue p
   <\<lambda>(x, r). idx_pqueue_map (delete_map (fst x) M) n r * \<up>(fst x < n) *
                \<up>(is_heap_min (fst x) M) * \<up>(M\<langle>fst x\<rangle> = Some (snd x))>" by auto2

theorem insert_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow> k \<notin> keys_of M \<Longrightarrow>
   <idx_pqueue_map M n p>
   insert_idx_pqueue k v p
   <idx_pqueue_map (M {k \<rightarrow> v}) n>\<^sub>t" by auto2

theorem has_key_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow>
   <idx_pqueue_map M n p>
   has_key_idx_pqueue k p
   <\<lambda>r. idx_pqueue_map M n p * \<up>(r \<longleftrightarrow> k \<in> keys_of M)>" by auto2

theorem update_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow>
   <idx_pqueue_map M n p>
   update_idx_pqueue k v p
   <idx_pqueue_map (M {k \<rightarrow> v}) n>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm idx_pqueue_map_def}\<close>

end


theory Arithmetic
imports Complex_Main
begin

(*
lemma dreiecksUngleichung : fixes x y::int shows "abs(x + y) \<le> abs x + abs y"
proof -
  assume  "abs(x + y) \<le> abs x + abs y"
  have "x^2 + 2*x*y + y^2 \<le> x^2 + 2*abs(x * y) + y^2" by auto
*)
lemma ""
term "op choose"
lemma "\<not> (\<forall>\<alpha> k .  \<alpha> choose k   = (-1)^k  * ((k - \<alpha> - 1) choose k))"
proof -
  assume a:"\<exists>\<alpha> k. \<alpha> choose k   = (-1)^k  * ((k - \<alpha> - 1) choose k)"
  {
    assume "\<And> alpha. \<exists>k . alpha choose k = (-1)^k * ((k - alpha - 1) choose k)"
    {
      assume "\<And>alpha ka . alpha choose ka = (-1)^ka * ((ka - alpha - 1) choose ka)"
      hence "\<And>ka. 1 choose ka = (-1)^ka * ((ka - 1 - 1) choose ka)" by
    }
      thm exE
      with b have False by (rule exE)

lemma "vals = set ls \<Longrightarrow> length ls = card (set ls)  \<Longrightarrow>  \<Sum>vals =  sum_list ls"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume a:"vals = set ls \<Longrightarrow> length ls = card (set ls) \<Longrightarrow> \<Sum>vals = sum_list ls"
  assume b:"vals = set (a # ls)"
  assume c:"length (a # ls) = card (set (a # ls))"
  show ?case
qed

lemma "(a::nat) + (b + c) = (a + b) + c"
proof (induct a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  then show ?case
qed


chapter \<open>The Instantiation\<close>

(*<*)
theory Instance
  imports Goedel_Incompleteness.Abstract_Second_Goedel Quote Goedel_I
begin
(*>*)

definition "Fvars t = {a :: name. \<not> atom a \<sharp> t}"

lemma Fvars_tm_simps[simp]:
  "Fvars Zero = {}"
  "Fvars (Var a) = {a}"
  "Fvars (Eats x y) = Fvars x \<union> Fvars y"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_tm[simp]:
  fixes t :: tm
  shows "finite (Fvars t)"
  by (induct t rule: tm.induct) auto

lemma Fvars_fm_simps[simp]:
  "Fvars (x IN y) = Fvars x \<union> Fvars y"
  "Fvars (x EQ y) = Fvars x \<union> Fvars y"
  "Fvars (A OR B) = Fvars A \<union> Fvars B"
  "Fvars (A AND B) = Fvars A \<union> Fvars B"
  "Fvars (A IMP B) = Fvars A \<union> Fvars B"
  "Fvars Fls = {}"
  "Fvars (Neg A) = Fvars A"
  "Fvars (Ex a A) = Fvars A - {a}"
  "Fvars (All a A) = Fvars A - {a}"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_fm[simp]:
  fixes A :: fm
  shows "finite (Fvars A)"
  by (induct A rule: fm.induct) auto

lemma subst_tm_subst_tm[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> subst y u (subst x t v) = subst x (subst y u t) (subst y u v)"
  by (induct v rule: tm.induct) auto

lemma subst_fm_subst_fm[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> (A(x::=t))(y::=u) = (A(y::=u))(x::=subst y u t)"
  by (nominal_induct A avoiding: x t y u rule: fm.strong_induct) auto

lemma Fvars_ground_aux: "Fvars t \<subseteq> B \<Longrightarrow> ground_aux t (atom ` B)"
  by (induct t rule: tm.induct) auto

lemma ground_Fvars: "ground t \<longleftrightarrow> Fvars t = {}"
  apply (rule iffI)
   apply (auto simp only: Fvars_def ground_fresh) []
  apply (auto intro: Fvars_ground_aux[of t "{}", simplified])
  done

lemma Fvars_ground_fm_aux: "Fvars A \<subseteq> B \<Longrightarrow> ground_fm_aux A (atom ` B)"
  apply (induct A arbitrary: B rule: fm.induct)
      apply (auto simp: Diff_subset_conv Fvars_ground_aux)
  apply (drule meta_spec, drule meta_mp, assumption)
  apply auto
  done

lemma ground_fm_Fvars: "ground_fm A \<longleftrightarrow> Fvars A = {}"
  apply (rule iffI)
   apply (auto simp only: Fvars_def ground_fresh) []
  apply (auto intro: Fvars_ground_fm_aux[of A "{}", simplified])
  done

interpretation Generic_Syntax where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal for t by (induct t rule: tm.induct) auto
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def fresh_subst_fm_if by auto
  subgoal unfolding Fvars_def by auto
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp
  done

lemma coding_tm_Fvars_empty[simp]: "coding_tm t \<Longrightarrow> Fvars t = {}"
  by (induct t rule: coding_tm.induct) (auto simp: Fvars_def)

lemma Fvars_empty_ground[simp]: "Fvars t = {} \<Longrightarrow> ground t"
  by (induct t rule: tm.induct) auto

interpretation Syntax_with_Numerals where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  apply unfold_locales
  subgoal by (auto intro!: exI[of _ Zero])
  subgoal by simp
  subgoal by (simp add: ground_Fvars)
  (*subgoal by simp*)
  done

declare FvarsT_num[simp del]

interpretation Deduct2_with_False where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal using MP_null by blast
  subgoal by blast
  subgoal for A B C
    apply (rule Imp_I)+
    apply (rule MP_same[of _ B])
     apply (rule MP_same[of _ C])
      apply (auto intro: Neg_D)
    done
  subgoal by blast
  subgoal by blast
  subgoal by blast
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal by (auto intro: All_D)
  subgoal by (auto intro: Ex_I)
  subgoal by simp
  subgoal by (metis Conj_E2 Iff_def Imp_I Var_Eq_subst_Iff)
  subgoal by blast
  subgoal by simp
  done

interpretation HBL1 where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by (simp add: quot_fm_coding)
  subgoal by simp
  subgoal unfolding Fvars_def by (auto simp: fresh_at_base(2))
  subgoal by (auto simp: proved_imp_proved_PfP)
  done

interpretation Goedel_Form where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by simp
  subgoal unfolding Fvars_def by (auto simp: fresh_at_base(2))
  subgoal
    unfolding Let_def
    by (subst psubst_eq_rawpsubst2)
      (auto simp: quot_fm_coding prove_KRP Fvars_def)
  subgoal
    unfolding Let_def
    by (subst (1 2) psubst_eq_rawpsubst2)
      (auto simp: quot_fm_coding KRP_unique[THEN Sym] Fvars_def)
  done

interpretation g2: Goedel_Second_Assumptions where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by (auto simp: PP_def intro: PfP_implies_ModPon_PfP_quot)
  subgoal by (auto simp: PP_def quot_fm_coding Provability)
  done

theorem "\<not> {} \<turnstile> Fls \<Longrightarrow> \<not> {} \<turnstile> neg (PfP (quot Fls))"
  by (rule g2.goedel_second[unfolded consistent_def PP_def PfP_subst subst.simps simp_thms if_True])

(*<*)
end
(*>*)


theory SINVAR_Subnets2
imports"../TopoS_Helper"
begin

(*EXPERIMENTAL!!*)

subsection {* SecurityInvariant Subnets2 *}

text{*Warning, This is just a test. Please look at @{file "SINVAR_Subnets.thy"}.
This security invariant has the following changes, compared to @{file "SINVAR_Subnets.thy"}:
A new BorderRouter' is introduced which can send to the members of its subnet.
A new InboundRouter is accessible by anyone. It can access all other routers and the outside.
*}

datatype subnets = Subnet nat | BorderRouter nat | BorderRouter' nat | InboundRouter | Unassigned

definition default_node_properties :: "subnets"
  where "default_node_properties \<equiv> Unassigned"

fun allowed_subnet_flow :: "subnets \<Rightarrow> subnets \<Rightarrow> bool" where
  "allowed_subnet_flow (Subnet s1) (Subnet s2) = (s1 = s2)" |
  "allowed_subnet_flow (Subnet s1) (BorderRouter s2) = (s1 = s2)" |
  "allowed_subnet_flow (Subnet s1) (BorderRouter' s2) = (s1 = s2)" |
  "allowed_subnet_flow (Subnet _) _ = True" |
  "allowed_subnet_flow (BorderRouter _) (Subnet _) = False" |
  "allowed_subnet_flow (BorderRouter _) _ = True" |
  "allowed_subnet_flow (BorderRouter' s1) (Subnet s2) = (s1 = s2)" |
  "allowed_subnet_flow (BorderRouter' _) _ = True" |
  "allowed_subnet_flow InboundRouter (Subnet _) = False" |
  "allowed_subnet_flow InboundRouter _ = True" |
  "allowed_subnet_flow Unassigned Unassigned  = True" |
  "allowed_subnet_flow Unassigned InboundRouter  = True" |
  "allowed_subnet_flow Unassigned _  = False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> subnets) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. allowed_subnet_flow (nP e1) (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation = False"

text{*Only members of the same subnet or their @{const BorderRouter'} can access them.*}
lemma "allowed_subnet_flow a (Subnet s1) \<Longrightarrow> a = (BorderRouter' s1) \<or> a = (Subnet s1)"
  apply(cases a)
      apply(simp_all)
  done

subsubsection {*Preliminaries*}

subsubsection{*ENF*}
  lemma All_to_Unassigned: "\<forall> e1. allowed_subnet_flow e1 Unassigned"
    by (rule allI, case_tac e1, simp_all)
  lemma Unassigned_default_candidate: "\<forall> nP e1 e2. \<not> allowed_subnet_flow (nP e1) (nP e2) \<longrightarrow> \<not> allowed_subnet_flow Unassigned (nP e2)"
    apply(intro allI)
    apply(case_tac "nP e2")
       apply simp_all
     apply(case_tac "nP e1")
         apply simp_all
    by(simp add: All_to_Unassigned)
  lemma allowed_subnet_flow_refl: "\<forall> e. allowed_subnet_flow e e"
    by(rule allI, case_tac e, simp_all)
  lemma Subnets_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar allowed_subnet_flow"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma Subnets_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar allowed_subnet_flow"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: Subnets_ENF)
    apply(simp add: allowed_subnet_flow_refl)
  done

  definition Subnets_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> subnets) \<Rightarrow> ('v \<times> 'v) set set" where
  "Subnets_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> allowed_subnet_flow (nP e1) (nP e2)} })"
  lemma Subnets_offending_set:
  "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Subnets_offending_set"
    apply(simp only: fun_eq_iff ENF_offending_set[OF Subnets_ENF] Subnets_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation Subnets: SecurityInvariant_ACS
where default_node_properties = SINVAR_Subnets2.default_node_properties
and sinvar = SINVAR_Subnets2.sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Subnets_offending_set"
  unfolding SINVAR_Subnets2.default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF Subnets_ENF_refl Unassigned_default_candidate])[1]
     apply(simp_all)[2]
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
      apply(rename_tac mysubnetcase)
      apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter mysubnetcase)" in exI, simp)
      apply(rule_tac x="vertex_1" in exI, simp)
      apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
     apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter whatever)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter whatever)" in exI, simp)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter whatever)" in exI, simp)
   apply(rule_tac x="vertex_1" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(fact Subnets_offending_set)
 done

  lemma TopoS_Subnets2: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar receiver_violation default_node_properties

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_30
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

theorem property0 :
  "((rev (x (rev y) (nil2))) = y)"
  oops

end


theory VCSTVCL_Poly
  imports "../TSTSC_Poly" VC_Set_To_VC_List
begin

subsection\<open>The reduction from \<open>VC_Set\<close> to \<open>VC_List\<close> is polynomial\<close>
subsubsection\<open>Definitions\<close>

definition "size_VC_List = (\<lambda>(E,k). length E)"
definition "vcs_to_vcl_space n  = n"

definition "mop_set_to_list_2 S = SPEC (\<lambda>xs. xs = (SOME L. (set L = S  \<and> distinct L))) (\<lambda>_. card S)"

definition "vcs_to_vcl = (\<lambda>(E,k).
  do {
    b \<leftarrow> mop_check_ugraph E;
    V  \<leftarrow> mop_get_vertices E;
    cV \<leftarrow> mop_set_card V;
    if b \<and> k \<le> cV then
      do {
        es \<leftarrow> mop_set_to_list_2 E;
        RETURNT (es, k)
      }
    else RETURNT ( [], 1 )
  } )"

definition "vcs_vcl_time n = 1+ (2 * n + 1) + 1 + n"

subsubsection\<open>Proofs\<close>

lemma vcs_to_vcl_size: "size_VC_List (vc_set_to_vc_list (E, k)) \<le> vcs_to_vcl_space (size_VC (E, k))"
  apply(simp add: size_VC_List_def vc_set_to_vc_list_def vcs_to_vcl_space_def size_VC_def
          set_to_list_def)
  by (metis (mono_tags, lifting) distinct_size eq_imp_le finite_UnionD
      finite_distinct_list tfl_some ugraph_vertex_set_finite)

lemma vcs_to_vcl_reifnes:
  "vcs_to_vcl (E, k) \<le> SPEC (\<lambda>y. y = (vc_set_to_vc_list (E, k))) (\<lambda>_. vcs_vcl_time (size_VC (E, k)))"
  unfolding SPEC_def
  unfolding vcs_to_vcl_def vc_set_to_vc_list_def
    mop_check_ugraph_def  mop_get_vertices_def mop_set_card_def
    mop_set_to_list_2_def set_to_list_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC )
  by(auto simp: vcs_vcl_time_def size_VC_def set_set_to_list distinct_set_to_list
      one_enat_def)

theorem cnf_sat_to_clique_ispolyred:
  "ispolyred vcs_to_vcl vertex_cover vertex_cover_list size_VC size_VC_List"
  unfolding ispolyred_def
  apply(rule exI[where x=vc_set_to_vc_list])
  apply(rule exI[where x=vcs_vcl_time])
  apply(rule exI[where x=vcs_to_vcl_space])
  apply(safe)
  subgoal using vcs_to_vcl_reifnes by blast
  subgoal using vcs_to_vcl_size by blast
  subgoal unfolding poly_def vcs_vcl_time_def apply(intro exI[where x=2]) by auto
  subgoal unfolding poly_def vcs_to_vcl_space_def apply(intro exI[where x=2]) by auto
  subgoal using is_reduction_vc .
  done

end