(* 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_sort_HSort2Count
  imports "../../Test_Base"
begin

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

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (hsort2 xs)) = (count x xs))"
  oops

end


(*  Title:      FOL/ex/Locale_Test/Locale_Test1.thy
    Author:     Clemens Ballarin, TU Muenchen

Test environment for the locale implementation.
*)

theory Locale_Test1
imports FOL
begin

typedecl int
instance int :: \<open>term\<close> ..

consts plus :: \<open>int => int => int\<close> (infixl \<open>+\<close> 60)
  zero :: \<open>int\<close> (\<open>0\<close>)
  minus :: \<open>int => int\<close> (\<open>- _\<close>)

axiomatization where
  int_assoc: \<open>(x + y::int) + z = x + (y + z)\<close> and
  int_zero: \<open>0 + x = x\<close> and
  int_minus: \<open>(-x) + x = 0\<close> and
  int_minus2: \<open>-(-x) = x\<close>

section \<open>Inference of parameter types\<close>

locale param1 = fixes p
print_locale! param1

locale param2 = fixes p :: \<open>'b\<close>
print_locale! param2

(*
locale param_top = param2 r for r :: "'b :: {}"
  Fails, cannot generalise parameter.
*)

locale param3 = fixes p (infix \<open>..\<close> 50)
print_locale! param3

locale param4 = fixes p :: \<open>'a => 'a => 'a\<close> (infix \<open>..\<close> 50)
print_locale! param4

subsection \<open>Incremental type constraints\<close>

locale constraint1 =
  fixes  prod (infixl \<open>**\<close> 65)
  assumes l_id: \<open>x ** y = x\<close>
  assumes assoc: \<open>(x ** y) ** z = x ** (y ** z)\<close>
print_locale! constraint1

locale constraint2 =
  fixes p and q
  assumes \<open>p = q\<close>
print_locale! constraint2

section \<open>Inheritance\<close>

locale semi =
  fixes prod (infixl \<open>**\<close> 65)
  assumes assoc: \<open>(x ** y) ** z = x ** (y ** z)\<close>
print_locale! semi thm semi_def

locale lgrp = semi +
  fixes one and inv
  assumes lone: \<open>one ** x = x\<close>
    and linv: \<open>inv(x) ** x = one\<close>
print_locale! lgrp thm lgrp_def lgrp_axioms_def

locale add_lgrp = semi \<open>(++)\<close> for sum (infixl \<open>++\<close> 60) +
  fixes zero and neg
  assumes lzero: \<open>zero ++ x = x\<close>
    and lneg: \<open>neg(x) ++ x = zero\<close>
print_locale! add_lgrp thm add_lgrp_def add_lgrp_axioms_def

locale rev_lgrp = semi \<open>%x y. y ++ x\<close> for sum (infixl \<open>++\<close> 60)
print_locale! rev_lgrp thm rev_lgrp_def

locale hom = f: semi \<open>f\<close> + g: semi \<open>g\<close> for f and g
print_locale! hom thm hom_def

locale perturbation = semi + d: semi \<open>%x y. delta(x) ** delta(y)\<close> for delta
print_locale! perturbation thm perturbation_def

locale pert_hom = d1: perturbation \<open>f\<close> \<open>d1\<close> + d2: perturbation \<open>f\<close> \<open>d2\<close> for f d1 d2
print_locale! pert_hom thm pert_hom_def

text \<open>Alternative expression, obtaining nicer names in \<open>semi f\<close>.\<close>
locale pert_hom' = semi \<open>f\<close> + d1: perturbation \<open>f\<close> \<open>d1\<close> + d2: perturbation \<open>f\<close> \<open>d2\<close> for f d1 d2
print_locale! pert_hom' thm pert_hom'_def

section \<open>Syntax declarations\<close>

locale logic =
  fixes land (infixl \<open>&&\<close> 55)
    and lnot (\<open>-- _\<close> [60] 60)
  assumes assoc: \<open>(x && y) && z = x && (y && z)\<close>
    and notnot: \<open>-- (-- x) = x\<close>
begin

definition lor (infixl \<open>||\<close> 50) where
  \<open>x || y = --(-- x && -- y)\<close>

end
print_locale! logic

locale use_decl = l: logic + semi \<open>(||)\<close>
print_locale! use_decl thm use_decl_def

locale extra_type =
  fixes a :: \<open>'a\<close>
    and P :: \<open>'a => 'b => o\<close>
begin

definition test :: \<open>'a => o\<close>
  where \<open>test(x) \<longleftrightarrow> (\<forall>b. P(x, b))\<close>

end

term \<open>extra_type.test\<close> thm extra_type.test_def

interpretation var?: extra_type \<open>0\<close> \<open>%x y. x = 0\<close> .

thm var.test_def

text \<open>Under which circumstances notation remains active.\<close>

ML \<open>
  fun check_syntax ctxt thm expected =
    let
      val obtained =
        Print_Mode.setmp [] (Thm.string_of_thm (Config.put show_markup false ctxt)) thm;
    in
      if obtained <> expected
      then error ("Theorem syntax '" ^ obtained ^ "' obtained, but '" ^ expected ^ "' expected.")
      else ()
    end;
\<close>

declare [[show_hyps]]

locale "syntax" =
  fixes p1 :: \<open>'a => 'b\<close>
    and p2 :: \<open>'b => o\<close>
begin

definition d1 :: \<open>'a => o\<close> (\<open>D1'(_')\<close>) where \<open>d1(x) \<longleftrightarrow> \<not> p2(p1(x))\<close>
definition d2 :: \<open>'b => o\<close> (\<open>D2'(_')\<close>) where \<open>d2(x) \<longleftrightarrow> \<not> p2(x)\<close>

thm d1_def d2_def

end

thm syntax.d1_def syntax.d2_def

locale syntax' = "syntax" \<open>p1\<close> \<open>p2\<close> for p1 :: \<open>'a => 'a\<close> and p2 :: \<open>'a => o\<close>
begin

thm d1_def d2_def  (* should print as "D1(?x) <-> ..." and "D2(?x) <-> ..." *)

ML \<open>
  check_syntax \<^context> @{thm d1_def} "D1(?x) \<longleftrightarrow> \<not> p2(p1(?x))";
  check_syntax \<^context> @{thm d2_def} "D2(?x) \<longleftrightarrow> \<not> p2(?x)";
\<close>

end

locale syntax'' = "syntax" \<open>p3\<close> \<open>p2\<close> for p3 :: \<open>'a => 'b\<close> and p2 :: \<open>'b => o\<close>
begin

thm d1_def d2_def
  (* should print as "d1(?x) <-> ..." and "D2(?x) <-> ..." *)

ML \<open>
  check_syntax \<^context> @{thm d1_def} "d1(?x) \<longleftrightarrow> \<not> p2(p3(?x))";
  check_syntax \<^context> @{thm d2_def} "D2(?x) \<longleftrightarrow> \<not> p2(?x)";
\<close>

end

section \<open>Foundational versions of theorems\<close>

thm logic.assoc
thm logic.lor_def

section \<open>Defines\<close>

locale logic_def =
  fixes land (infixl \<open>&&\<close> 55)
    and lor (infixl \<open>||\<close> 50)
    and lnot (\<open>-- _\<close> [60] 60)
  assumes assoc: \<open>(x && y) && z = x && (y && z)\<close>
    and notnot: \<open>-- (-- x) = x\<close>
  defines \<open>x || y == --(-- x && -- y)\<close>
begin

thm lor_def

lemma \<open>x || y = --(-- x && --y)\<close>
  by (unfold lor_def) (rule refl)

end

(* Inheritance of defines *)

locale logic_def2 = logic_def
begin

lemma \<open>x || y = --(-- x && --y)\<close>
  by (unfold lor_def) (rule refl)

end

section \<open>Notes\<close>

(* A somewhat arcane homomorphism example *)

definition semi_hom where
  \<open>semi_hom(prod, sum, h) \<longleftrightarrow> (\<forall>x y. h(prod(x, y)) = sum(h(x), h(y)))\<close>

lemma semi_hom_mult:
  \<open>semi_hom(prod, sum, h) \<Longrightarrow> h(prod(x, y)) = sum(h(x), h(y))\<close>
  by (simp add: semi_hom_def)

locale semi_hom_loc = prod: semi \<open>prod\<close> + sum: semi \<open>sum\<close>
  for prod and sum and h +
  assumes semi_homh: \<open>semi_hom(prod, sum, h)\<close>
  notes semi_hom_mult = semi_hom_mult [OF semi_homh]

thm semi_hom_loc.semi_hom_mult
(* unspecified, attribute not applied in backgroud theory !!! *)

lemma (in semi_hom_loc) \<open>h(prod(x, y)) = sum(h(x), h(y))\<close>
  by (rule semi_hom_mult)

(* Referring to facts from within a context specification *)

lemma
  assumes x: \<open>P \<longleftrightarrow> P\<close>
  notes y = x
  shows \<open>True\<close> ..

section \<open>Theorem statements\<close>

lemma (in lgrp) lcancel:
  \<open>x ** y = x ** z \<longleftrightarrow> y = z\<close>
proof
  assume \<open>x ** y = x ** z\<close>
  then have \<open>inv(x) ** x ** y = inv(x) ** x ** z\<close> by (simp add: assoc)
  then show \<open>y = z\<close> by (simp add: lone linv)
qed simp
print_locale! lgrp

locale rgrp = semi +
  fixes one and inv
  assumes rone: \<open>x ** one = x\<close>
    and rinv: \<open>x ** inv(x) = one\<close>
begin

lemma rcancel:
  \<open>y ** x = z ** x \<longleftrightarrow> y = z\<close>
proof
  assume \<open>y ** x = z ** x\<close>
  then have \<open>y ** (x ** inv(x)) = z ** (x ** inv(x))\<close>
    by (simp add: assoc [symmetric])
  then show \<open>y = z\<close> by (simp add: rone rinv)
qed simp

end
print_locale! rgrp

subsection \<open>Patterns\<close>

lemma (in rgrp)
  assumes \<open>y ** x = z ** x\<close> (is \<open>?a\<close>)
  shows \<open>y = z\<close> (is \<open>?t\<close>)
proof -
  txt \<open>Weird proof involving patterns from context element and conclusion.\<close>
  {
    assume \<open>?a\<close>
    then have \<open>y ** (x ** inv(x)) = z ** (x ** inv(x))\<close>
      by (simp add: assoc [symmetric])
    then have \<open>?t\<close> by (simp add: rone rinv)
  }
  note x = this
  show \<open>?t\<close> by (rule x [OF \<open>?a\<close>])
qed

section \<open>Interpretation between locales: sublocales\<close>

sublocale lgrp < right?: rgrp
print_facts
proof unfold_locales
  {
    fix x
    have \<open>inv(x) ** x ** one = inv(x) ** x\<close> by (simp add: linv lone)
    then show \<open>x ** one = x\<close> by (simp add: assoc lcancel)
  }
  note rone = this
  {
    fix x
    have \<open>inv(x) ** x ** inv(x) = inv(x) ** one\<close>
      by (simp add: linv lone rone)
    then show \<open>x ** inv(x) = one\<close> by (simp add: assoc lcancel)
  }
qed

(* effect on printed locale *)

print_locale! lgrp

(* use of derived theorem *)

lemma (in lgrp)
  \<open>y ** x = z ** x \<longleftrightarrow> y = z\<close>
  apply (rule rcancel)
  done

(* circular interpretation *)

sublocale rgrp < left: lgrp
proof unfold_locales
  {
    fix x
    have \<open>one ** (x ** inv(x)) = x ** inv(x)\<close> by (simp add: rinv rone)
    then show \<open>one ** x = x\<close> by (simp add: assoc [symmetric] rcancel)
  }
  note lone = this
  {
    fix x
    have \<open>inv(x) ** (x ** inv(x)) = one ** inv(x)\<close>
      by (simp add: rinv lone rone)
    then show \<open>inv(x) ** x = one\<close> by (simp add: assoc [symmetric] rcancel)
  }
qed

(* effect on printed locale *)

print_locale! rgrp
print_locale! lgrp

(* Duality *)

locale order =
  fixes less :: \<open>'a => 'a => o\<close> (infix \<open><<\<close> 50)
  assumes refl: \<open>x << x\<close>
    and trans: \<open>[| x << y; y << z |] ==> x << z\<close>

sublocale order < dual: order \<open>%x y. y << x\<close>
  apply unfold_locales apply (rule refl) apply (blast intro: trans)
  done

print_locale! order  (* Only two instances of order. *)

locale order' =
  fixes less :: \<open>'a => 'a => o\<close> (infix \<open><<\<close> 50)
  assumes refl: \<open>x << x\<close>
    and trans: \<open>[| x << y; y << z |] ==> x << z\<close>

locale order_with_def = order'
begin

definition greater :: \<open>'a => 'a => o\<close> (infix \<open>>>\<close> 50) where
  \<open>x >> y \<longleftrightarrow> y << x\<close>

end

sublocale order_with_def < dual: order' \<open>(>>)\<close>
  apply unfold_locales
  unfolding greater_def
  apply (rule refl) apply (blast intro: trans)
  done

print_locale! order_with_def
(* Note that decls come after theorems that make use of them. *)

(* locale with many parameters ---
   interpretations generate alternating group A5 *)

locale A5 =
  fixes A and B and C and D and E
  assumes eq: \<open>A \<longleftrightarrow> B \<longleftrightarrow> C \<longleftrightarrow> D \<longleftrightarrow> E\<close>

sublocale A5 < 1: A5 _ _ \<open>D\<close> \<open>E\<close> \<open>C\<close>
print_facts
  using eq apply (blast intro: A5.intro) done

sublocale A5 < 2: A5 \<open>C\<close> _ \<open>E\<close> _ \<open>A\<close>
print_facts
  using eq apply (blast intro: A5.intro) done

sublocale A5 < 3: A5 \<open>B\<close> \<open>C\<close> \<open>A\<close> _ _
print_facts
  using eq apply (blast intro: A5.intro) done

(* Any even permutation of parameters is subsumed by the above. *)

print_locale! A5

(* Free arguments of instance *)

locale trivial =
  fixes P and Q :: \<open>o\<close>
  assumes Q: \<open>P \<longleftrightarrow> P \<longleftrightarrow> Q\<close>
begin

lemma Q_triv: \<open>Q\<close> using Q by fast

end

sublocale trivial < x: trivial \<open>x\<close> _
  apply unfold_locales using Q by fast

print_locale! trivial

context trivial
begin
thm x.Q [where ?x = \<open>True\<close>]
end

sublocale trivial < y: trivial \<open>Q\<close> \<open>Q\<close>
  by unfold_locales
  (* Succeeds since previous interpretation is more general. *)

print_locale! trivial  (* No instance for y created (subsumed). *)

subsection \<open>Sublocale, then interpretation in theory\<close>

interpretation int?: lgrp \<open>(+)\<close> \<open>0\<close> \<open>minus\<close>
proof unfold_locales
qed (rule int_assoc int_zero int_minus)+

thm int.assoc int.semi_axioms

interpretation int2?: semi \<open>(+)\<close>
  by unfold_locales  (* subsumed, thm int2.assoc not generated *)

ML \<open>(Global_Theory.get_thms \<^theory> "int2.assoc";
    raise Fail "thm int2.assoc was generated")
  handle ERROR _ => ([]:thm list);\<close>

thm int.lone int.right.rone
  (* the latter comes through the sublocale relation *)

subsection \<open>Interpretation in theory, then sublocale\<close>

interpretation fol: logic \<open>(+)\<close> \<open>minus\<close>
  by unfold_locales (rule int_assoc int_minus2)+

locale logic2 =
  fixes land (infixl \<open>&&\<close> 55)
    and lnot (\<open>-- _\<close> [60] 60)
  assumes assoc: \<open>(x && y) && z = x && (y && z)\<close>
    and notnot: \<open>-- (-- x) = x\<close>
begin

definition lor (infixl \<open>||\<close> 50) where
  \<open>x || y = --(-- x && -- y)\<close>

end

sublocale logic < two: logic2
  by unfold_locales (rule assoc notnot)+

thm fol.two.assoc

subsection \<open>Declarations and sublocale\<close>

locale logic_a = logic
locale logic_b = logic

sublocale logic_a < logic_b
  by unfold_locales

subsection \<open>Interpretation\<close>

subsection \<open>Rewrite morphism\<close>

locale logic_o =
  fixes land (infixl \<open>&&\<close> 55)
    and lnot (\<open>-- _\<close> [60] 60)
  assumes assoc_o: \<open>(x && y) && z \<longleftrightarrow> x && (y && z)\<close>
    and notnot_o: \<open>-- (-- x) \<longleftrightarrow> x\<close>
begin

definition lor_o (infixl \<open>||\<close> 50) where
  \<open>x || y \<longleftrightarrow> --(-- x && -- y)\<close>

end

interpretation x: logic_o \<open>(\<and>)\<close> \<open>Not\<close>
  rewrites bool_logic_o: \<open>x.lor_o(x, y) \<longleftrightarrow> x \<or> y\<close>
proof -
  show bool_logic_o: \<open>PROP logic_o((\<and>), Not)\<close> by unfold_locales fast+
  show \<open>logic_o.lor_o((\<and>), Not, x, y) \<longleftrightarrow> x \<or> y\<close>
    by (unfold logic_o.lor_o_def [OF bool_logic_o]) fast
qed

thm x.lor_o_def bool_logic_o

lemma lor_triv: \<open>z \<longleftrightarrow> z\<close> ..

lemma (in logic_o) lor_triv: \<open>x || y \<longleftrightarrow> x || y\<close> by fast

thm lor_triv [where z = \<open>True\<close>] (* Check strict prefix. *)
  x.lor_triv

subsection \<open>Rewrite morphisms in expressions\<close>

interpretation y: logic_o \<open>(\<or>)\<close> \<open>Not\<close> rewrites bool_logic_o2: \<open>logic_o.lor_o((\<or>), Not, x, y) \<longleftrightarrow> x \<and> y\<close>
proof -
  show bool_logic_o: \<open>PROP logic_o((\<or>), Not)\<close> by unfold_locales fast+
  show \<open>logic_o.lor_o((\<or>), Not, x, y) \<longleftrightarrow> x \<and> y\<close> unfolding logic_o.lor_o_def [OF bool_logic_o] by fast
qed

subsection \<open>Inheritance of rewrite morphisms\<close>

locale reflexive =
  fixes le :: \<open>'a => 'a => o\<close> (infix \<open>\<sqsubseteq>\<close> 50)
  assumes refl: \<open>x \<sqsubseteq> x\<close>
begin

definition less (infix \<open>\<sqsubset>\<close> 50) where \<open>x \<sqsubset> y \<longleftrightarrow> x \<sqsubseteq> y \<and> x \<noteq> y\<close>

end

axiomatization
  gle :: \<open>'a => 'a => o\<close> and gless :: \<open>'a => 'a => o\<close> and
  gle' :: \<open>'a => 'a => o\<close> and gless' :: \<open>'a => 'a => o\<close>
where
  grefl: \<open>gle(x, x)\<close> and gless_def: \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close> and
  grefl': \<open>gle'(x, x)\<close> and gless'_def: \<open>gless'(x, y) \<longleftrightarrow> gle'(x, y) \<and> x \<noteq> y\<close>

text \<open>Setup\<close>

locale mixin = reflexive
begin
lemmas less_thm = less_def
end

interpretation le: mixin \<open>gle\<close> rewrites \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
proof -
  show \<open>mixin(gle)\<close> by unfold_locales (rule grefl)
  note reflexive = this[unfolded mixin_def]
  show \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

text \<open>Rewrite morphism propagated along the locale hierarchy\<close>

locale mixin2 = mixin
begin
lemmas less_thm2 = less_def
end

interpretation le: mixin2 \<open>gle\<close>
  by unfold_locales

thm le.less_thm2  (* rewrite morphism applied *)
lemma \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le.less_thm2)

text \<open>Rewrite morphism does not leak to a side branch.\<close>

locale mixin3 = reflexive
begin
lemmas less_thm3 = less_def
end

interpretation le: mixin3 \<open>gle\<close>
  by unfold_locales

thm le.less_thm3  (* rewrite morphism not applied *)
lemma \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close> by (rule le.less_thm3)

text \<open>Rewrite morphism only available in original context\<close>

locale mixin4_base = reflexive

locale mixin4_mixin = mixin4_base

interpretation le: mixin4_mixin \<open>gle\<close>
  rewrites \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
proof -
  show \<open>mixin4_mixin(gle)\<close> by unfold_locales (rule grefl)
  note reflexive = this[unfolded mixin4_mixin_def mixin4_base_def mixin_def]
  show \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

locale mixin4_copy = mixin4_base
begin
lemmas less_thm4 = less_def
end

locale mixin4_combined = le1?: mixin4_mixin \<open>le'\<close> + le2?: mixin4_copy \<open>le\<close> for le' le
begin
lemmas less_thm4' = less_def
end

interpretation le4: mixin4_combined \<open>gle'\<close> \<open>gle\<close>
  by unfold_locales (rule grefl')

thm le4.less_thm4' (* rewrite morphism not applied *)
lemma \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le4.less_thm4')

text \<open>Inherited rewrite morphism applied to new theorem\<close>

locale mixin5_base = reflexive

locale mixin5_inherited = mixin5_base

interpretation le5: mixin5_base \<open>gle\<close>
  rewrites \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
proof -
  show \<open>mixin5_base(gle)\<close> by unfold_locales
  note reflexive = this[unfolded mixin5_base_def mixin_def]
  show \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

interpretation le5: mixin5_inherited \<open>gle\<close>
  by unfold_locales

lemmas (in mixin5_inherited) less_thm5 = less_def

thm le5.less_thm5  (* rewrite morphism applied *)
lemma \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le5.less_thm5)

text \<open>Rewrite morphism pushed down to existing inherited locale\<close>

locale mixin6_base = reflexive

locale mixin6_inherited = mixin5_base

interpretation le6: mixin6_base \<open>gle\<close>
  by unfold_locales
interpretation le6: mixin6_inherited \<open>gle\<close>
  by unfold_locales
interpretation le6: mixin6_base \<open>gle\<close>
  rewrites \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
proof -
  show \<open>mixin6_base(gle)\<close> by unfold_locales
  note reflexive = this[unfolded mixin6_base_def mixin_def]
  show \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

lemmas (in mixin6_inherited) less_thm6 = less_def

thm le6.less_thm6  (* mixin applied *)
lemma \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le6.less_thm6)

text \<open>Existing rewrite morphism inherited through sublocale relation\<close>

locale mixin7_base = reflexive

locale mixin7_inherited = reflexive

interpretation le7: mixin7_base \<open>gle\<close>
  rewrites \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
proof -
  show \<open>mixin7_base(gle)\<close> by unfold_locales
  note reflexive = this[unfolded mixin7_base_def mixin_def]
  show \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gless(x, y)\<close>
    by (simp add: reflexive.less_def[OF reflexive] gless_def)
qed

interpretation le7: mixin7_inherited \<open>gle\<close>
  by unfold_locales

lemmas (in mixin7_inherited) less_thm7 = less_def

thm le7.less_thm7  (* before, rewrite morphism not applied *)
lemma \<open>reflexive.less(gle, x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le7.less_thm7)

sublocale mixin7_inherited < mixin7_base
  by unfold_locales

lemmas (in mixin7_inherited) less_thm7b = less_def

thm le7.less_thm7b  (* after, mixin applied *)
lemma \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close>
  by (rule le7.less_thm7b)

text \<open>This locale will be interpreted in later theories.\<close>

locale mixin_thy_merge = le: reflexive \<open>le\<close> + le': reflexive \<open>le'\<close> for le le'

subsection \<open>Rewrite morphisms in sublocale\<close>

text \<open>Simulate a specification of left groups where unit and inverse are defined
  rather than specified.  This is possible, but not in FOL, due to the lack of a
  selection operator.\<close>

axiomatization glob_one and glob_inv
  where glob_lone: \<open>prod(glob_one(prod), x) = x\<close>
    and glob_linv: \<open>prod(glob_inv(prod, x), x) = glob_one(prod)\<close>

locale dgrp = semi
begin

definition one where \<open>one = glob_one(prod)\<close>

lemma lone: \<open>one ** x = x\<close>
  unfolding one_def by (rule glob_lone)

definition inv where \<open>inv(x) = glob_inv(prod, x)\<close>

lemma linv: \<open>inv(x) ** x = one\<close>
  unfolding one_def inv_def by (rule glob_linv)

end

sublocale lgrp < def?: dgrp
  rewrites one_equation: \<open>dgrp.one(prod) = one\<close> and inv_equation: \<open>dgrp.inv(prod, x) = inv(x)\<close>
proof -
  show \<open>dgrp(prod)\<close> by unfold_locales
  from this interpret d: dgrp .
  \<comment> \<open>Unit\<close>
  have \<open>dgrp.one(prod) = glob_one(prod)\<close> by (rule d.one_def)
  also have \<open>... = glob_one(prod) ** one\<close> by (simp add: rone)
  also have \<open>... = one\<close> by (simp add: glob_lone)
  finally show \<open>dgrp.one(prod) = one\<close> .
  \<comment> \<open>Inverse\<close>
  then have \<open>dgrp.inv(prod, x) ** x = inv(x) ** x\<close> by (simp add: glob_linv d.linv linv)
  then show \<open>dgrp.inv(prod, x) = inv(x)\<close> by (simp add: rcancel)
qed

print_locale! lgrp

context lgrp
begin

text \<open>Equations stored in target\<close>

lemma \<open>dgrp.one(prod) = one\<close> by (rule one_equation)
lemma \<open>dgrp.inv(prod, x) = inv(x)\<close> by (rule inv_equation)

text \<open>Rewrite morphisms applied\<close>

lemma \<open>one = glob_one(prod)\<close> by (rule one_def)
lemma \<open>inv(x) = glob_inv(prod, x)\<close> by (rule inv_def)

end

text \<open>Interpreted versions\<close>

lemma \<open>0 = glob_one ((+))\<close> by (rule int.def.one_def)
lemma \<open>- x = glob_inv((+), x)\<close> by (rule int.def.inv_def)

text \<open>Roundup applies rewrite morphisms at declaration level in DFS tree\<close>

locale roundup = fixes x assumes true: \<open>x \<longleftrightarrow> True\<close>

sublocale roundup \<subseteq> sub: roundup \<open>x\<close> rewrites \<open>x \<longleftrightarrow> True \<and> True\<close>
  apply unfold_locales apply (simp add: true) done
lemma (in roundup) \<open>True \<and> True \<longleftrightarrow> True\<close> by (rule sub.true)

section \<open>Interpretation in named contexts\<close>

locale container
begin
interpretation "private": roundup \<open>True\<close> by unfold_locales rule
lemmas true_copy = private.true
end

context container
begin
ML \<open>(Context.>> (fn generic => let val context = Context.proof_of generic
  val _ = Proof_Context.get_thms context "private.true" in generic end);
  raise Fail "thm private.true was persisted")
  handle ERROR _ => ([]:thm list);\<close>
thm true_copy
end

section \<open>Interpretation in proofs\<close>

notepad
begin
  interpret "local": lgrp \<open>(+)\<close> \<open>0\<close> \<open>minus\<close>
    by unfold_locales  (* subsumed *)
  {
    fix zero :: \<open>int\<close>
    assume \<open>!!x. zero + x = x\<close> \<open>!!x. (-x) + x = zero\<close>
    then interpret local_fixed: lgrp \<open>(+)\<close> \<open>zero\<close> \<open>minus\<close>
      by unfold_locales
    thm local_fixed.lone
  }
  assume \<open>!!x zero. zero + x = x\<close> \<open>!!x zero. (-x) + x = zero\<close>
  then interpret local_free: lgrp \<open>(+)\<close> \<open>zero\<close> \<open>minus\<close> for zero
    by unfold_locales
  thm local_free.lone [where ?zero = \<open>0\<close>]
end

notepad
begin
  {
    fix pand and pnot and por
    assume passoc: \<open>\<And>x y z. pand(pand(x, y), z) \<longleftrightarrow> pand(x, pand(y, z))\<close>
      and pnotnot: \<open>\<And>x. pnot(pnot(x)) \<longleftrightarrow> x\<close>
      and por_def: \<open>\<And>x y. por(x, y) \<longleftrightarrow> pnot(pand(pnot(x), pnot(y)))\<close>
    interpret loc: logic_o \<open>pand\<close> \<open>pnot\<close>
      rewrites por_eq: \<open>\<And>x y. logic_o.lor_o(pand, pnot, x, y) \<longleftrightarrow> por(x, y)\<close>  (* FIXME *)
    proof -
      show logic_o: \<open>PROP logic_o(pand, pnot)\<close> using passoc pnotnot by unfold_locales
      fix x y
      show \<open>logic_o.lor_o(pand, pnot, x, y) \<longleftrightarrow> por(x, y)\<close>
        by (unfold logic_o.lor_o_def [OF logic_o]) (rule por_def [symmetric])
    qed
    print_interps logic_o
    have \<open>\<And>x y. por(x, y) \<longleftrightarrow> pnot(pand(pnot(x), pnot(y)))\<close> by (rule loc.lor_o_def)
  }
end

end


(*  Title:      ListInf_Prefix.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

header {* Prefices on finite and infinite lists *}

theory ListInf_Prefix
imports "~~/src/HOL/Library/Sublist" ListInf
begin

subsection {* Additional list prefix results *}

lemma prefixeq_eq_prefix_take_ex: "prefixeq xs ys = (\<exists>n. ys \<down> n = xs)"
apply (unfold prefixeq_def, safe)
apply (rule_tac x="length xs" in exI, simp)
apply (rule_tac x="ys \<up> n" in exI, simp)
done

lemma prefix_take_eq_prefix_take_ex: "(ys \<down> (length xs) = xs) = (\<exists>n. ys \<down> n = xs)"
by (fastforce simp: min_def)

lemma prefixeq_eq_prefix_take: "prefixeq xs ys = (ys \<down> (length xs) = xs)"
by (simp only: prefixeq_eq_prefix_take_ex prefix_take_eq_prefix_take_ex)

lemma strict_prefix_take_eq_strict_prefix_take_ex: "
  (ys \<down> (length xs) = xs \<and> xs \<noteq> ys) =
  ((\<exists>n. ys \<down> n = xs) \<and> xs \<noteq> ys)"
by (simp add: prefix_take_eq_prefix_take_ex)

lemma prefix_eq_strict_prefix_take_ex: "prefix xs ys = ((\<exists>n. ys \<down> n = xs) \<and> xs \<noteq> ys)"
by (simp add: prefix_def prefixeq_eq_prefix_take_ex)
lemma prefix_eq_strict_prefix_take: "prefix xs ys = (ys \<down> (length xs) = xs \<and> xs \<noteq> ys)"
by (simp only: prefix_eq_strict_prefix_take_ex strict_prefix_take_eq_strict_prefix_take_ex)

lemma take_imp_prefixeq: "prefixeq (xs \<down> n) xs"
by (rule take_is_prefixeq)

lemma eq_imp_prefixeq: "xs = (ys::'a list) \<Longrightarrow> prefixeq xs ys"
by simp

lemma le_take_imp_prefixeq: "a \<le> b \<Longrightarrow> prefixeq (xs \<down> a) (xs \<down> b)"
by (fastforce simp: prefixeq_eq_prefix_take_ex min_def)

lemma take_prefixeq_imp_le: "
  \<lbrakk> a \<le> length xs; prefixeq (xs \<down> a) (xs \<down> b) \<rbrakk> \<Longrightarrow> a \<le> b"
by (drule prefixeq_length_le, simp)

lemma take_prefixeq_le_conv: "
  a \<le> length xs \<Longrightarrow> prefixeq (xs \<down> a) (xs \<down> b) = (a \<le> b)"
apply (rule iffI)
 apply (rule take_prefixeq_imp_le, assumption+)
apply (rule le_take_imp_prefixeq, assumption+)
done
lemma append_imp_prefixeq[simp, intro]: "prefixeq a (a @ b)"
by (unfold prefixeq_def, blast)

lemma prefixeq_imp_take_eq: "
  \<lbrakk> n \<le> length xs; prefixeq xs ys \<rbrakk> \<Longrightarrow> xs \<down> n = ys \<down> n"
by (clarsimp simp: prefixeq_def)

lemma prefixeq_length_le_eq_conv: "(prefixeq xs ys \<and> length ys \<le> length xs) = (xs = ys)"
apply (rule iffI)
 apply (erule conjE)
 apply (frule prefixeq_length_le)
 apply (simp add: prefixeq_eq_prefix_take)
apply simp
done

lemma take_length_prefixeq_conv: "
  length xs \<le> length ys \<Longrightarrow> prefixeq (ys \<down> length xs) xs = prefixeq xs ys"
by (fastforce simp: prefixeq_eq_prefix_take)

lemma append_eq_imp_take: "
  \<lbrakk> k \<le> length xs; length r1 = k; r1 @ r2 = xs \<rbrakk> \<Longrightarrow> r1 = xs \<down> k"
by fastforce

lemma take_the_conv: "
  xs \<down> k = (if length xs \<le> k then xs else (THE r. length r = k \<and> (\<exists>r2. r @ r2 = xs)))"
apply (clarsimp simp: linorder_not_le)
apply (rule the1I2)
 apply (simp add: Ex1_def)
 apply (rule_tac x="xs \<down> k" in exI)
 apply (intro conjI)
   apply (simp add: min_eqR)
  apply (rule_tac x="xs \<up> k" in exI, simp)
 apply fastforce
apply fastforce
done

lemma prefixeq_refl: "prefixeq xs (xs::'a list)"
by (rule prefix_order.order_refl)

lemma prefixeq_trans: "\<lbrakk> prefixeq xs ys; prefixeq (ys::'a list) zs \<rbrakk> \<Longrightarrow> prefixeq xs zs"
by (rule prefix_order.order_trans)

lemma prefixeq_antisym: "\<lbrakk> prefixeq xs ys; prefixeq (ys::'a list) xs \<rbrakk> \<Longrightarrow> xs = ys"
by (rule prefix_order.antisym)

subsection {* Counting equal pairs *}
text {* Counting number of equal elements in two lists *}

definition
  mirror_pair :: "('a \<times> 'b) \<Rightarrow> ('b \<times> 'a)"
where
  "mirror_pair p \<equiv> (snd p, fst p)"

lemma zip_mirror[rule_format]: "
  \<lbrakk> i < min (length xs) (length ys);
    p1 = (zip xs ys) ! i; p2 = (zip ys xs) ! i \<rbrakk> \<Longrightarrow>
  mirror_pair p1 = p2"
by (simp add: mirror_pair_def)

definition
  equal_pair :: "('a \<times> 'a) \<Rightarrow> bool"
where
  "equal_pair p \<equiv> (fst p = snd p)"

lemma mirror_pair_equal: "equal_pair (mirror_pair p) = (equal_pair p)"
by (fastforce simp: mirror_pair_def equal_pair_def)

primrec
  equal_pair_count :: "('a \<times> 'a) list \<Rightarrow> nat"
where
  "equal_pair_count [] = 0"
| "equal_pair_count (p # ps) = (
    if (fst p = snd p)
      then Suc (equal_pair_count ps)
      else 0)"

lemma equal_pair_count_le: "equal_pair_count xs \<le> length xs"
by (induct xs, simp_all)

lemma equal_pair_count_0: "
  fst (hd ps) \<noteq> snd (hd ps) \<Longrightarrow> equal_pair_count ps = 0"
by (case_tac ps, simp_all)

lemma equal_pair_count_Suc: "
  equal_pair_count ((a, a) # ps) = Suc (equal_pair_count ps)"
by simp

lemma equal_pair_count_eq_pairwise[rule_format]: "
  \<lbrakk> length ps1 = length ps2;
    \<forall>i<length ps2. equal_pair (ps1 ! i) = equal_pair(ps2 ! i) \<rbrakk>
  \<Longrightarrow> equal_pair_count ps1 = equal_pair_count ps2"
apply (induct rule: list_induct2)
 apply simp
apply (fastforce simp add: equal_pair_def)
done

lemma equal_pair_count_mirror_pairwise[rule_format]: "
  \<lbrakk> length ps1 = length ps2;
    \<forall>i<length ps2. ps1 ! i = mirror_pair (ps2 ! i) \<rbrakk>
  \<Longrightarrow> equal_pair_count ps1 = equal_pair_count ps2"
apply (rule equal_pair_count_eq_pairwise, assumption)
thm mirror_pair_equal
apply (simp add: mirror_pair_equal)
done

(* The lemma states that all pairs with index < equal_pair_count ps
  are equal. It does not deal with maximality of equal_pair_count *)
lemma equal_pair_count_correct:"
  \<And>i. i < equal_pair_count ps \<Longrightarrow> equal_pair (ps ! i)"
apply (induct ps)
 apply simp
apply simp
apply (split split_if_asm)
apply (case_tac i)
apply (simp add: equal_pair_def)+
done
thm equal_pair_count_correct

(* For @{text "i = equal_pair_count ps"} holds:
  either @{text "ps ! i"} not an equal pair,
  or all pairs are equal (@{text "equal_pair_count = length ps"}) *)
lemma equal_pair_count_maximality_aux[rule_format]: "\<And>i.
  i = equal_pair_count ps \<Longrightarrow> length ps = i \<or> \<not> equal_pair (ps ! i)"
apply (induct ps)
 apply simp
apply (simp add: equal_pair_def)
done
thm equal_pair_count_maximality_aux
corollary equal_pair_count_maximality1a[rule_format]: "
  equal_pair_count ps = length ps \<or> \<not> equal_pair (ps!equal_pair_count ps)"
thm equal_pair_count_maximality_aux[of "equal_pair_count ps" ps, simplified]
apply (insert equal_pair_count_maximality_aux[of "equal_pair_count ps" ps])
apply clarsimp
done

corollary equal_pair_count_maximality1b[rule_format]: "
  equal_pair_count ps \<noteq> length ps \<Longrightarrow>
  \<not> equal_pair (ps!equal_pair_count ps)"
by (insert equal_pair_count_maximality1a[of ps], simp)

lemma equal_pair_count_maximality2a[rule_format]: "
  equal_pair_count ps = length ps \<or> (* either all pairs are equal *)
  (\<forall>i\<ge>equal_pair_count ps.(\<exists>j\<le>i. \<not>equal_pair (ps ! j)))"
apply clarsimp
apply (rule_tac x="equal_pair_count ps" in exI)
thm equal_pair_count_maximality1b equal_pair_count_le
apply (simp add: equal_pair_count_maximality1b equal_pair_count_le)
done
corollary equal_pair_count_maximality2b[rule_format]: "
  equal_pair_count ps \<noteq> length ps \<Longrightarrow>
  \<forall>i\<ge>equal_pair_count ps.(\<exists>j\<le>i. \<not>equal_pair (ps!j))"
by (insert equal_pair_count_maximality2a[of ps], simp)

lemmas equal_pair_count_maximality =
  equal_pair_count_maximality1a equal_pair_count_maximality1b
  equal_pair_count_maximality2a equal_pair_count_maximality2b
thm
  equal_pair_count_correct[no_vars]
  equal_pair_count_maximality[no_vars]

subsection {* Prefix length *}

text {* Length of the prefix infimum *}
definition
  inf_prefix_length :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "inf_prefix_length xs ys \<equiv> equal_pair_count (zip xs ys)"

value "int (inf_prefix_length [1::int,2,3,4,7,8,15] [1::int,2,3,4,7,15])"
value "int (inf_prefix_length [1::int,2,3,4] [1::int,2,3,4,7,15])"
value "int (inf_prefix_length [] [1::int,2,3,4,7,15])"
value "int (inf_prefix_length [1::int,2,3,4,5] [1::int,2,3,4,5])"

lemma inf_prefix_length_commute[rule_format]:
  "inf_prefix_length xs ys = inf_prefix_length ys xs"
apply (unfold inf_prefix_length_def)
thm equal_pair_count_mirror_pairwise
apply (insert equal_pair_count_mirror_pairwise[of "zip xs ys" "zip ys xs"])
apply (simp add: equal_pair_count_mirror_pairwise[of "zip xs ys" "zip ys xs"] mirror_pair_def)
done

lemma inf_prefix_length_leL[intro]:
  "inf_prefix_length xs ys \<le> length xs"
apply (unfold inf_prefix_length_def)
apply (insert equal_pair_count_le[of "zip xs ys"])
apply simp
done
corollary inf_prefix_length_leR[intro]:
  "inf_prefix_length xs ys \<le> length ys"
thm inf_prefix_length_commute[of xs ys]
by (simp add: inf_prefix_length_commute[of xs] inf_prefix_length_leL)
lemmas inf_prefix_length_le =
  inf_prefix_length_leL
  inf_prefix_length_leR

lemma inf_prefix_length_le_min[rule_format]:
  "inf_prefix_length xs ys \<le> min (length xs) (length ys)"
by (simp add: inf_prefix_length_le)

thm equal_pair_count_0
lemma hd_inf_prefix_length_0: "
  hd xs \<noteq> hd ys \<Longrightarrow> inf_prefix_length xs ys = 0"
apply (unfold inf_prefix_length_def)
apply (case_tac "xs = []", simp)
apply (case_tac "ys = []", simp)
apply (simp add: equal_pair_count_0 hd_zip)
done

lemma inf_prefix_length_NilL[simp]: "inf_prefix_length [] ys = 0"
by (simp add: inf_prefix_length_def)
lemma inf_prefix_length_NilR[simp]: "inf_prefix_length xs [] = 0"
by (simp add: inf_prefix_length_def)

thm equal_pair_count_Suc
lemma inf_prefix_length_Suc[simp]: "
  inf_prefix_length (a # xs) (a # ys) = Suc (inf_prefix_length xs ys)"
by (simp add: inf_prefix_length_def)

thm equal_pair_count_correct
lemma inf_prefix_length_correct: "
  i < inf_prefix_length xs ys \<Longrightarrow> xs ! i = ys ! i"
thm order_less_le_trans[OF _ inf_prefix_length_leL]
apply (frule order_less_le_trans[OF _ inf_prefix_length_leL])
apply (frule order_less_le_trans[OF _ inf_prefix_length_leR])
apply (unfold inf_prefix_length_def)
apply (drule equal_pair_count_correct)
apply (simp add: equal_pair_def)
done

corollary nth_neq_imp_inf_prefix_length_le: "
  xs ! i \<noteq> ys ! i \<Longrightarrow> inf_prefix_length xs ys \<le> i"
apply (rule ccontr)
apply (simp add: inf_prefix_length_correct)
done

thm equal_pair_count_maximality1b
lemma inf_prefix_length_maximality1[rule_format]: "
  inf_prefix_length xs ys \<noteq> min (length xs) (length ys) \<Longrightarrow>
  xs ! (inf_prefix_length xs ys) \<noteq> ys ! (inf_prefix_length xs ys)"
thm equal_pair_count_maximality1b[of "zip xs ys"]
thm equal_pair_count_maximality1b[of "zip xs ys", folded inf_prefix_length_def]
apply (insert equal_pair_count_maximality1b[of "zip xs ys", folded inf_prefix_length_def], simp)
apply (drule neq_le_trans)
 apply (simp add: inf_prefix_length_le)
apply (simp add:  inf_prefix_length_def equal_pair_def)
done

thm equal_pair_count_maximality2b
corollary inf_prefix_length_maximality2[rule_format]: "
  \<lbrakk> inf_prefix_length xs ys \<noteq> min (length xs) (length ys);
    inf_prefix_length xs ys \<le> i \<rbrakk> \<Longrightarrow>
  \<exists>j\<le>i. xs ! j \<noteq> ys ! j"
apply (rule_tac x="inf_prefix_length xs ys" in exI)
apply (simp add: inf_prefix_length_maximality1 inf_prefix_length_le_min)
done

lemmas inf_prefix_length_maximality =
  inf_prefix_length_maximality1 inf_prefix_length_maximality2

lemma inf_prefix_length_append[simp]: "
  inf_prefix_length (zs @ xs) (zs @ ys) =
  length zs + inf_prefix_length xs ys"
apply (induct zs)
 apply simp
apply (simp add: inf_prefix_length_def)
done

lemma inf_prefix_length_take_correct: "
  n \<le> inf_prefix_length xs ys \<Longrightarrow> xs \<down> n = ys \<down> n"
apply (frule order_trans[OF _ inf_prefix_length_leL])
apply (frule order_trans[OF _ inf_prefix_length_leR])
apply (simp add: list_eq_iff inf_prefix_length_correct)
done

lemma inf_prefix_length_0_imp_hd_neq: "
  \<lbrakk> xs \<noteq> []; ys \<noteq> []; inf_prefix_length xs ys = 0 \<rbrakk> \<Longrightarrow> hd xs \<noteq> hd ys"
apply (rule ccontr)
thm inf_prefix_length_maximality2[of xs ys 0]
apply (insert inf_prefix_length_maximality2[of xs ys 0])
apply (simp add: hd_eq_first)
done

subsection {* Prefix infimum *}

definition
  inf_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixl "\<sqinter>" 70)
where
  "xs \<sqinter> ys \<equiv> xs \<down> (inf_prefix_length xs ys)"

lemma length_inf_prefix: "length (xs \<sqinter> ys) = inf_prefix_length xs ys"
by (simp add: inf_prefix_def min_eqR inf_prefix_length_leL)

lemma inf_prefix_commute: "xs \<sqinter> ys = ys \<sqinter> xs"
by (simp add: inf_prefix_def inf_prefix_length_commute[of ys] inf_prefix_length_take_correct)

lemma inf_prefix_takeL: "xs \<sqinter> ys = xs \<down> (inf_prefix_length xs ys)"
by (simp add: inf_prefix_def)
lemma inf_prefix_takeR: "xs \<sqinter> ys = ys \<down> (inf_prefix_length xs ys)"
by (subst inf_prefix_commute, subst inf_prefix_length_commute, rule inf_prefix_takeL)

thm inf_prefix_length_correct
lemma inf_prefix_correct: "i < length (xs \<sqinter> ys) \<Longrightarrow> xs ! i = ys ! i"
by (simp add: length_inf_prefix inf_prefix_length_correct)
corollary inf_prefix_correctL: "
  i < length (xs \<sqinter> ys) \<Longrightarrow> (xs \<sqinter> ys) ! i = xs ! i"
by (simp add: inf_prefix_takeL)
corollary inf_prefix_correctR: "
  i < length (xs \<sqinter> ys) \<Longrightarrow> (xs \<sqinter> ys) ! i = ys ! i"
by (simp add: inf_prefix_takeR)

thm inf_prefix_length_take_correct
lemma inf_prefix_take_correct: "
  n \<le> length (xs \<sqinter> ys) \<Longrightarrow> xs \<down> n = ys \<down> n"
by (simp add: length_inf_prefix inf_prefix_length_take_correct)

lemma is_inf_prefix[rule_format]: "
  \<lbrakk> length zs = length (xs \<sqinter> ys);
    \<And>i. i < length (xs \<sqinter> ys) \<Longrightarrow> zs ! i = xs ! i \<and> zs ! i = ys ! i \<rbrakk> \<Longrightarrow>
  zs = xs \<sqinter> ys"
by (simp add: list_eq_iff inf_prefix_def)

thm hd_inf_prefix_length_0
lemma hd_inf_prefix_Nil: "hd xs \<noteq> hd ys \<Longrightarrow> xs \<sqinter> ys = []"
by (simp add: inf_prefix_def hd_inf_prefix_length_0)

thm inf_prefix_length_0_imp_hd_neq
lemma inf_prefix_Nil_imp_hd_neq: "
  \<lbrakk> xs \<noteq> []; ys \<noteq> []; xs \<sqinter> ys = [] \<rbrakk> \<Longrightarrow> hd xs \<noteq> hd ys"
by (simp add: inf_prefix_def inf_prefix_length_0_imp_hd_neq)

lemma length_inf_prefix_append[simp]: "
  length ((zs @ xs) \<sqinter> (zs @ ys)) =
  length zs + length (xs \<sqinter> ys)"
by (simp add: length_inf_prefix)

lemma inf_prefix_append[simp]: "(zs @ xs) \<sqinter> (zs @ ys) = zs @ (xs \<sqinter> ys)"
apply (rule is_inf_prefix[symmetric], simp)
apply (clarsimp simp: nth_append)
thm inf_prefix_correctL inf_prefix_correctR
apply (intro conjI inf_prefix_correctL inf_prefix_correctR, simp+)
done

lemma hd_neq_inf_prefix_append: "
  hd xs \<noteq> hd ys \<Longrightarrow> (zs @ xs) \<sqinter> (zs @ ys) = zs"
by (simp add: hd_inf_prefix_Nil)

thm inf_prefix_length_NilL
lemma inf_prefix_NilL[simp]: "[] \<sqinter> ys = []"
by (simp del: length_0_conv add: length_0_conv[symmetric] length_inf_prefix)
corollary inf_prefix_NilR[simp]: "xs \<sqinter> [] = []"
by (simp add: inf_prefix_commute)
lemmas inf_prefix_Nil = inf_prefix_NilL inf_prefix_NilR
thm inf_prefix_Nil

lemma inf_prefix_Cons[simp]: "(a # xs) \<sqinter> (a # ys) = a # xs \<sqinter> ys"
by (insert inf_prefix_append[of "[a]" xs ys], simp)
corollary inf_prefix_hd[simp]: "hd ((a # xs) \<sqinter> (a # ys)) = a"
by simp

lemma inf_prefixeq_le1: "prefixeq (xs \<sqinter> ys) xs"
by (simp add: inf_prefix_takeL take_imp_prefixeq)
lemma inf_prefixeq_le2: "prefixeq (xs \<sqinter> ys) ys"
by (simp add: inf_prefix_takeR take_imp_prefixeq)

thm min_le_iff_conj
lemma le_inf_prefix_iff: "prefixeq x (y \<sqinter> z) = (prefixeq x y \<and> prefixeq x z)"
apply (rule iffI)
 apply (blast intro: prefix_order.order_trans inf_prefixeq_le1 inf_prefixeq_le2)
apply (clarsimp simp: prefixeq_def)
done
lemma le_imp_le_inf_prefixeq: "\<lbrakk> prefixeq x y; prefixeq x z \<rbrakk> \<Longrightarrow> prefixeq x (y \<sqinter> z)"
thm le_inf_prefix_iff[THEN iffD2]
by (rule le_inf_prefix_iff[THEN iffD2], simp)

interpretation prefix:
  semilattice_inf
    "op \<sqinter> :: 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
    "prefixeq"
    "prefix"
apply intro_locales
apply (rule class.semilattice_inf_axioms.intro)
apply (rule inf_prefixeq_le1)
apply (rule inf_prefixeq_le2)
apply (rule le_imp_le_inf_prefixeq, assumption+)
done

subsection {* Prefices for infinite lists *}

thm prefixeq_def
term "\<lambda>x y. prefixeq x (y::'a list)"
definition
  iprefix :: "'a list \<Rightarrow> 'a ilist \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
where
  "xs \<sqsubseteq> f \<equiv> \<exists>g. f = xs \<frown> g"

thm prefixeq_eq_prefix_take
lemma iprefix_eq_iprefix_take: "(xs \<sqsubseteq> f) = (f \<Down> length xs = xs)"
apply (unfold iprefix_def)
apply (rule iffI)
 apply clarsimp
apply (rule_tac x="f \<Up> (length xs)" in exI)
thm i_append_i_take_i_drop_id
apply (subst i_append_i_take_i_drop_id[where n="length xs", symmetric], simp)
done

thm prefix_take_eq_prefix_take_ex
lemma iprefix_take_eq_iprefix_take_ex: "
  (f \<Down> length xs = xs) = (\<exists>n. f \<Down> n = xs)"
apply (rule iffI)
 apply (rule_tac x="length xs" in exI, assumption)
apply clarsimp
done

thm prefixeq_eq_prefix_take_ex
lemma iprefix_eq_iprefix_take_ex: "(xs \<sqsubseteq> f) = (\<exists>n. f \<Down> n = xs)"
by (simp add: iprefix_eq_iprefix_take iprefix_take_eq_iprefix_take_ex)

thm take_imp_prefixeq
lemma i_take_imp_iprefix[intro]: "f \<Down> n \<sqsubseteq> f"
by (simp add: iprefix_eq_iprefix_take)

thm take_prefixeq_le_conv
lemma i_take_prefixeq_le_conv: "prefixeq (f \<Down> a) (f \<Down> b) = (a \<le> b)"
by (fastforce simp: prefixeq_eq_prefix_take list_eq_iff)

thm append_imp_prefixeq
lemma i_append_imp_iprefix[simp,intro]: "xs \<sqsubseteq> xs \<frown> f"
by (simp add: iprefix_def)

thm prefixeq_imp_take_eq

thm prefixeq_refl
thm prefixeq_trans
thm prefixeq_antisym
lemma prefixeq_iprefix_trans: "\<lbrakk> prefixeq xs ys; ys \<sqsubseteq> f \<rbrakk> \<Longrightarrow> xs \<sqsubseteq> f"
by (fastforce simp: iprefix_eq_iprefix_take_ex prefixeq_eq_prefix_take_ex)

thm take_length_prefixeq_conv
lemma i_take_length_prefix_conv: "prefixeq (f \<Down> length xs) xs = (xs \<sqsubseteq> f)"
thm prefixeq_length_le_eq_conv
by (simp add: iprefix_eq_iprefix_take prefixeq_length_le_eq_conv[symmetric])

thm Sublist.prefixeqI
lemma iprefixI[intro?]: "f = xs \<frown> g \<Longrightarrow> xs \<sqsubseteq> f"
by (unfold iprefix_def, simp)
thm Sublist.prefixeqE
lemma iprefixE[elim?]: "\<lbrakk> xs \<sqsubseteq> f; \<And>g. f = xs \<frown> g \<Longrightarrow> C \<rbrakk> \<Longrightarrow> C"
by (unfold iprefix_def, blast)

thm Sublist.Nil_prefixeq
lemma Nil_iprefix[iff]: "[] \<sqsubseteq> f"
by (unfold iprefix_def, simp)

thm Sublist.same_prefixeq_prefixeq
lemma same_prefix_iprefix[simp]: "(xs @ ys \<sqsubseteq> xs \<frown> f) = (ys \<sqsubseteq> f)"
by (simp add: iprefix_eq_iprefix_take)

thm Sublist.prefixeq_prefixeq
lemma prefix_iprefix[simp]: "prefixeq xs ys \<Longrightarrow> xs \<sqsubseteq> ys \<frown> f"
by (clarsimp simp: prefixeq_def iprefix_def i_append_assoc[symmetric] simp del: i_append_assoc)

thm Sublist.append_prefixeqD
lemma append_iprefixD: "xs @ ys \<sqsubseteq> f \<Longrightarrow> xs \<sqsubseteq> f"
by (clarsimp simp: iprefix_def i_append_assoc[symmetric] simp del: i_append_assoc)

lemma iprefix_length_le_imp_prefixeq: "
  \<lbrakk> xs \<sqsubseteq> ys \<frown> f; length xs \<le> length ys \<rbrakk> \<Longrightarrow> prefixeq xs ys"
by (clarsimp simp: iprefix_eq_iprefix_take_ex take_is_prefixeq)

thm Sublist.prefixeq_append
lemma iprefix_i_append: "
  (xs \<sqsubseteq> ys \<frown> f) = (prefixeq xs ys \<or> (\<exists>zs. xs = ys @ zs \<and> zs \<sqsubseteq> f))"
apply (rule iffI)
 apply (case_tac "length xs \<le> length ys")
  apply (blast intro: iprefix_length_le_imp_prefixeq)
 apply (rule disjI2)
 apply (rule_tac x="f \<Down> (length xs - length ys)" in exI)
 apply (simp add: iprefix_eq_iprefix_take)
apply fastforce
done

lemma i_append_one_iprefix: "
  xs \<sqsubseteq> f \<Longrightarrow> xs @ [f (length xs)] \<sqsubseteq> f"
by (simp add: iprefix_eq_iprefix_take i_take_Suc_conv_app_nth)

lemma iprefix_same_length_le: "
  \<lbrakk> xs \<sqsubseteq> f; ys \<sqsubseteq> f; length xs \<le> length ys \<rbrakk> \<Longrightarrow> prefixeq xs ys"
by (clarsimp simp: iprefix_eq_iprefix_take_ex i_take_prefixeq_le_conv)

thm Sublist.prefixeq_same_cases
lemma iprefix_same_cases: "
  \<lbrakk> xs \<sqsubseteq> f; ys \<sqsubseteq> f \<rbrakk> \<Longrightarrow> prefixeq xs ys \<or> prefixeq ys xs"
apply (case_tac "length xs \<le> length ys")
apply (simp add: iprefix_same_length_le)+
done

thm Sublist.set_mono_prefixeq
lemma set_mono_iprefix: "xs \<sqsubseteq> f \<Longrightarrow> set xs \<subseteq> range f"
by (unfold iprefix_def, fastforce)

end


theory DBM
  imports Floyd_Warshall HOL.Real
begin

type_synonym ('c, 't) cval = "'c \<Rightarrow> 't"

chapter \<open>Difference Bound Matrices\<close>

section \<open>Definitions\<close>

subsection \<open>Definition and Semantics of DBMs\<close>
text \<open>
  Difference Bound Matrices (DBMs) constrain differences of clocks
  (or more precisely, the difference of values assigned to individual clocks by a valuation).
  The possible constraints are given by the following datatype:
\<close>
datatype 't DBMEntry = Le 't | Lt 't | INF ("\<infinity>")

text \<open>\noindent This yields a simple definition of DBMs:\<close>

type_synonym 't DBM = "nat \<Rightarrow> nat \<Rightarrow> 't DBMEntry"

text \<open>\noindent
  To relate clocks with rows and columns of
  a DBM, we use a clock numbering \<open>v\<close> of type @{typ "'c \<Rightarrow> nat"} to map clocks to indices.
  DBMs will regularly be  accompanied by a natural number $n$,
  which designates the number of clocks constrained by the matrix.
  To be able to represent the full set of clock constraints with DBMs, we add an imaginary
  clock \<open>\<zero>\<close>, which shall be assigned to 0 in every valuation.
  In the following predicate we explicitly keep track of \<open>\<zero>\<close>.
\<close>

class time = linordered_ab_group_add +
  assumes dense: "x < y \<Longrightarrow> \<exists>z. x < z \<and> z < y"
  assumes non_trivial: "\<exists> x. x \<noteq> 0"

begin

lemma non_trivial_neg: "\<exists> x. x < 0"
proof -
  from non_trivial obtain x where "x \<noteq> 0" by auto
  then show ?thesis
  proof (cases "x < 0", auto, goal_cases)
    case 1
    then have "x > 0" by auto
    then have "(-x) < 0" by auto
    then show ?case by blast
  qed
qed

end

instantiation real :: time
begin
  instance proof
    fix x y :: real
    assume "x < y"
    then show "\<exists>z>x. z < y" using dense_order_class.dense by blast
  next
    have "(1 :: real) \<noteq> 0" by auto
    then show "\<exists>x. (x::real) \<noteq> 0" ..
  qed
end

inductive dbm_entry_val :: "('c, 't) cval \<Rightarrow> 'c option \<Rightarrow> 'c option \<Rightarrow> ('t::time) DBMEntry \<Rightarrow> bool"
where
  "u r \<le> d \<Longrightarrow> dbm_entry_val u (Some r) None (Le d)" |
  "-u c \<le> d \<Longrightarrow> dbm_entry_val u None (Some c) (Le d)" |
  "u r < d \<Longrightarrow> dbm_entry_val u (Some r) None (Lt d)" |
  "-u c < d \<Longrightarrow> dbm_entry_val u None (Some c) (Lt d)" |
  "u r - u c \<le> d \<Longrightarrow> dbm_entry_val u (Some r) (Some c) (Le d)" |
  "u r - u c < d \<Longrightarrow> dbm_entry_val u (Some r) (Some c) (Lt d)" |
  "dbm_entry_val _ _ _ \<infinity>"

declare dbm_entry_val.intros[intro]
inductive_cases[elim!]: "dbm_entry_val u None (Some c) (Le d)"
inductive_cases[elim!]: "dbm_entry_val u (Some c) None (Le d)"
inductive_cases[elim!]: "dbm_entry_val u None (Some c) (Lt d)"
inductive_cases[elim!]: "dbm_entry_val u (Some c) None (Lt d)"
inductive_cases[elim!]: "dbm_entry_val u (Some r) (Some c) (Le d)"
inductive_cases[elim!]: "dbm_entry_val u (Some r) (Some c) (Lt d)"

fun dbm_entry_bound :: "('t::time) DBMEntry \<Rightarrow> 't"
where
  "dbm_entry_bound (Le t) = t" |
  "dbm_entry_bound (Lt t) = t" |
  "dbm_entry_bound \<infinity> = 0"

inductive dbm_lt :: "('t::linorder) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> bool"
("_ \<prec> _" [51, 51] 50)
where
  "dbm_lt (Lt _) \<infinity>" |
  "dbm_lt (Le _) \<infinity>" |
  "a < b  \<Longrightarrow> dbm_lt (Le a) (Le b)" |
  "a < b  \<Longrightarrow> dbm_lt (Le a) (Lt b)" |
  "a \<le> b  \<Longrightarrow> dbm_lt (Lt a) (Le b)" |
  "a < b  \<Longrightarrow> dbm_lt (Lt a) (Lt b)"

declare dbm_lt.intros[intro]

definition dbm_le :: "('t::linorder) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> bool"
("_ \<preceq> _" [51, 51] 50)
where
  "dbm_le a b \<equiv> (a \<prec> b) \<or> a = b"

text \<open>
  Now a valuation is contained in the zone represented by a DBM if it fulfills all individual
  constraints:
\<close>
definition DBM_val_bounded :: "('c \<Rightarrow> nat) \<Rightarrow> ('c, 't) cval \<Rightarrow> ('t::time) DBM \<Rightarrow> nat \<Rightarrow> bool"
where
  "DBM_val_bounded v u m n \<equiv> Le 0 \<preceq> m 0 0 \<and>
    (\<forall> c. v c \<le> n \<longrightarrow> (dbm_entry_val u None (Some c) (m 0 (v c))
                      \<and> dbm_entry_val u (Some c) None (m (v c) 0)))
    \<and> (\<forall> c1 c2. v c1 \<le> n \<and> v c2 \<le> n \<longrightarrow> dbm_entry_val u (Some c1) (Some c2) (m (v c1) (v c2)))"

abbreviation DBM_val_bounded_abbrev ::
  "('c, 't) cval \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('t::time) DBM \<Rightarrow> bool"
("_ \<turnstile>\<^bsub>_,_\<^esub> _")
where
  "u \<turnstile>\<^bsub>v,n\<^esub> M \<equiv> DBM_val_bounded v u M n"

subsection \<open>Ordering DBM Entries\<close>
abbreviation
  "dmin a b \<equiv> if a \<prec> b then a else b"

lemma dbm_le_dbm_min:
  "a \<preceq> b \<Longrightarrow> a = dmin a b" unfolding dbm_le_def
by auto

lemma dbm_lt_asym:
  assumes "e \<prec> f"
  shows "~ f \<prec> e"
using assms
proof (safe, cases e f rule: dbm_lt.cases, goal_cases)
  case 1 from this(2) show ?case using 1(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 2 from this(2) show ?case using 2(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 3 from this(2) show ?case using 3(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 4 from this(2) show ?case using 4(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 5 from this(2) show ?case using 5(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 6 from this(2) show ?case using 6(3-) by (cases f e rule: dbm_lt.cases) auto
qed

lemma dbm_le_dbm_min2:
  "a \<preceq> b \<Longrightarrow> a = dmin b a"
using dbm_lt_asym by (auto simp: dbm_le_def)

lemma dmb_le_dbm_entry_bound_inf:
  "a \<preceq> b \<Longrightarrow> a = \<infinity> \<Longrightarrow> b = \<infinity>"
apply (auto simp: dbm_le_def)
  apply (cases rule: dbm_lt.cases)
by auto

lemma dbm_not_lt_eq: "\<not> a \<prec> b \<Longrightarrow> \<not> b \<prec> a \<Longrightarrow> a = b"
apply (cases a)
  apply (cases b, fastforce+)+
done

lemma dbm_not_lt_impl: "\<not> a \<prec> b \<Longrightarrow> b \<prec> a \<or> a = b" using dbm_not_lt_eq by auto

lemma "dmin a b = dmin b a"
proof (cases "a \<prec> b")
  case True thus ?thesis by (simp add: dbm_lt_asym)
next
  case False thus ?thesis by (simp add: dbm_not_lt_eq)
qed

lemma dbm_lt_trans: "a \<prec> b \<Longrightarrow> b \<prec> c \<Longrightarrow> a \<prec> c"
proof (cases a b rule: dbm_lt.cases, goal_cases)
  case 1 thus ?case by simp
next
  case 2 from this(2-) show ?case by (cases rule: dbm_lt.cases) simp+
next
  case 3 from this(2-) show ?case by (cases rule: dbm_lt.cases) simp+
next
  case 4 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 5 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 6 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 7 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
qed

lemma aux_3: "\<not> a \<prec> b \<Longrightarrow> \<not> b \<prec> c \<Longrightarrow> a \<prec> c \<Longrightarrow> c = a"
proof goal_cases
  case 1 thus ?case
  proof (cases "c \<prec> b")
    case True
    with \<open>a \<prec> c\<close> have "a \<prec> b" by (rule dbm_lt_trans)
    thus ?thesis using 1 by auto
  next
    case False thus ?thesis using dbm_not_lt_eq 1 by auto
  qed
qed

inductive_cases[elim!]: "\<infinity> \<prec> x"

lemma dbm_lt_asymmetric[simp]: "x \<prec> y \<Longrightarrow> y \<prec> x \<Longrightarrow> False"
by (cases x y rule: dbm_lt.cases) (auto elim: dbm_lt.cases)

lemma le_dbm_le: "Le a \<preceq> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma le_dbm_lt: "Le a \<preceq> Lt b \<Longrightarrow> a < b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma lt_dbm_le: "Lt a \<preceq> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma lt_dbm_lt: "Lt a \<preceq> Lt b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma not_dbm_le_le_impl: "\<not> Le a \<prec> Le b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(3) not_less)

lemma not_dbm_lt_le_impl: "\<not> Lt a \<prec> Le b \<Longrightarrow> a > b" by (metis dbm_lt.intros(5) not_less)

lemma not_dbm_lt_lt_impl: "\<not> Lt a \<prec> Lt b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(6) not_less)

lemma not_dbm_le_lt_impl: "\<not> Le a \<prec> Lt b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(4) not_less)

subsection \<open>Addition on DBM Entries\<close>

fun dbm_add :: "('t::linordered_cancel_ab_semigroup_add) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> 't DBMEntry" (infixl "\<otimes>" 70)
where
  "dbm_add \<infinity>     _      = \<infinity>" |
  "dbm_add _      \<infinity>     = \<infinity>" |
  "dbm_add (Le a) (Le b) = (Le (a+b))" |
  "dbm_add (Le a) (Lt b) = (Lt (a+b))" |
  "dbm_add (Lt a) (Le b) = (Lt (a+b))" |
  "dbm_add (Lt a) (Lt b) = (Lt (a+b))"

thm dbm_add.simps

lemma aux_4: "x \<prec> y \<Longrightarrow> \<not> dbm_add x z \<prec> dbm_add y z \<Longrightarrow> dbm_add x z = dbm_add y z"
by (cases x y rule: dbm_lt.cases; cases z; auto)

lemma aux_5: "\<not> x \<prec> y \<Longrightarrow> dbm_add x z \<prec> dbm_add y z \<Longrightarrow> dbm_add y z = dbm_add x z"
proof -
  assume lt: "dbm_add x z \<prec> dbm_add y z" "\<not> x \<prec> y"
  hence "x = y \<or> y \<prec> x" by (auto simp: dbm_not_lt_eq)
  thus ?thesis
  proof
    assume "x = y" thus ?thesis by simp
  next
    assume "y \<prec> x"
    thus ?thesis
    proof (cases y x rule: dbm_lt.cases, goal_cases)
      case 1 thus ?case using lt by auto
    next
      case 2 thus ?case using lt by auto
    next
      case 3 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 4 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 5 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 6 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    qed
  qed
qed

lemma aux_42: "x \<prec> y \<Longrightarrow> \<not> dbm_add z x \<prec> dbm_add z y \<Longrightarrow> dbm_add z x = dbm_add z y"
by (cases x y rule: dbm_lt.cases) ((cases z), auto)+

lemma aux_52: "\<not> x \<prec> y \<Longrightarrow> dbm_add z x \<prec> dbm_add z y \<Longrightarrow> dbm_add z y = dbm_add z x"
proof -
  assume lt: "dbm_add z x \<prec> dbm_add z y" "\<not> x \<prec> y"
  hence "x = y \<or> y \<prec> x" by (auto simp: dbm_not_lt_eq)
  thus ?thesis
  proof
    assume "x = y" thus ?thesis by simp
  next
    assume "y \<prec> x"
    thus ?thesis
    proof (cases y x rule: dbm_lt.cases, goal_cases)
      case 1 thus ?case using lt by (cases z) fastforce+
    next
      case 2 thus ?case using lt by (cases z) fastforce+
    next
      case 3 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 4 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 5 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 6 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    qed
  qed
qed

lemma dbm_add_not_inf:
  "a \<noteq> \<infinity> \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> dbm_add a b \<noteq> \<infinity>"
by (cases a, auto, cases b, auto, cases b, auto)

lemma dbm_le_not_inf:
  "a \<preceq> b \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> a \<noteq> \<infinity>"
by (cases "a = b") (auto simp: dbm_le_def)

subsection \<open>Negation of DBM Entries\<close>

fun neg_dbm_entry where
  "neg_dbm_entry (Le a) = Lt (-a)" |
  "neg_dbm_entry (Lt a) = Le (-a)" |
  "neg_dbm_entry \<infinity> = \<infinity>"
  \<comment> \<open>This case does not make sense but we make this definition for technical convenience.\<close>

lemma neg_entry:
  "{u. \<not> dbm_entry_val u a b e} = {u. dbm_entry_val u b a (neg_dbm_entry e)}"
  if "e \<noteq> (\<infinity> :: _ DBMEntry)" "a \<noteq> None \<or> b \<noteq> None"
  using that by (cases e; cases a; cases b; auto 4 3 simp: le_minus_iff less_minus_iff)

instantiation DBMEntry :: (uminus) uminus
begin
  definition uminus: "uminus = neg_dbm_entry"
  instance ..
end

text \<open>Note that it is not clear that this is the only sensible definition for negation DBM entries.
The following would also have been quite viable:
\<comment> \<open>fun neg_dbm_entry where
  "neg_dbm_entry (Le a) = Le (-a)" |
  "neg_dbm_entry (Lt a) = Lt (-a)" |
  "neg_dbm_entry \<infinity> = \<infinity>"\<close>

For most practical proofs using arithmetic on DBM entries we have found that this
does not make much of a difference. Lemma @{thm neg_entry} would not hold any longer, however.
\<close>

section \<open>DBM Entries Form a Linearly Ordered Abelian Monoid\<close>

instantiation DBMEntry :: (linorder) linorder
begin
  definition less_eq: "(\<le>) \<equiv> dbm_le"
  definition less: "(<) = dbm_lt"
  instance
  proof ((standard; unfold less less_eq), goal_cases)
    case 1 thus ?case unfolding dbm_le_def using dbm_lt_asymmetric by auto
  next
    case 2 thus ?case by (simp add: dbm_le_def)
  next
    case 3 thus ?case unfolding dbm_le_def using dbm_lt_trans by auto
  next
    case 4 thus ?case unfolding dbm_le_def using dbm_lt_asymmetric by auto
  next
    case 5 thus ?case unfolding dbm_le_def using dbm_not_lt_eq by auto
  qed
end

(* XXX Clean this dependency stack *)
class linordered_cancel_ab_monoid_add =
  linordered_cancel_ab_semigroup_add + zero +
    assumes neutl[simp]: "0 + x = x"
    assumes neutr[simp]: "x + 0 = x"
begin

  subclass linordered_ab_monoid_add
    by standard (rule neutl)

end

instantiation DBMEntry :: (zero) zero
begin
  definition neutral: "0 = Le 0"
  instance ..
end

instantiation DBMEntry :: (linordered_cancel_ab_monoid_add) linordered_ab_monoid_add
begin

  definition add: "(+) = dbm_add"

  instance proof ((standard; unfold add neutral less less_eq), goal_cases)
    case (1 a b c) thus ?case by (cases a; cases b; cases c; auto simp: add.assoc)
  next
    case (2 a b) thus ?case by (cases a; cases b; auto simp: add.commute)
  next
    case (3 a) thus ?case by (cases a) auto
  next
    case (4 a b c)
    thus ?case unfolding dbm_le_def
    apply safe
     apply (rule dbm_lt.cases)
          apply assumption
      by (cases c; fastforce)+
  qed

end

interpretation linordered_monoid:
  linordered_ab_monoid_add dbm_add "Le (0::'t::linordered_cancel_ab_monoid_add)" dbm_le dbm_lt
  apply (standard, fold neutral add less_eq less)
  using add.commute by (auto intro: add_left_mono simp: add.assoc)

instance time \<subseteq> linordered_cancel_ab_monoid_add by (standard; simp)

lemma dbm_add_strict_right_mono_neutral: "a < Le (d :: 't :: time) \<Longrightarrow> a + Le (-d) < Le 0"
unfolding less add by (cases a) (auto elim!: dbm_lt.cases)

lemma dbm_lt_not_inf_less[intro]: "A \<noteq> \<infinity> \<Longrightarrow> A \<prec> \<infinity>" by (cases A) auto

lemma add_inf[simp]:
  "a + \<infinity> = \<infinity>" "\<infinity> + a = \<infinity>"
unfolding add by (cases a) auto

lemma inf_lt[simp,dest!]:
  "\<infinity> < x \<Longrightarrow> False"
  by (cases x) (auto simp: less)

lemma inf_lt_impl_False[simp]:
  "\<infinity> < x = False"
  by auto

lemma Le_Le_dbm_lt_D[dest]: "Le a \<prec> Lt b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto
lemma Le_Lt_dbm_lt_D[dest]: "Le a \<prec> Le b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto
lemma Lt_Le_dbm_lt_D[dest]: "Lt a \<prec> Le b \<Longrightarrow> a \<le> b" by (cases rule: dbm_lt.cases) auto
lemma Lt_Lt_dbm_lt_D[dest]: "Lt a \<prec> Lt b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto

lemma Le_le_LeI[intro]: "a \<le> b \<Longrightarrow> Le a \<le> Le b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LeI[intro]: "a \<le> b \<Longrightarrow> Lt a \<le> Le b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LtI[intro]: "a \<le> b \<Longrightarrow> Lt a \<le> Lt b" unfolding less_eq dbm_le_def by auto
lemma Le_le_LtI[intro]: "a < b \<Longrightarrow> Le a \<le> Lt b" unfolding less_eq dbm_le_def by auto
lemma Lt_lt_LeI: "x \<le> y \<Longrightarrow> Lt x < Le y" unfolding less by auto

lemma Le_le_LeD[dest]: "Le a \<le> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def less_eq by auto
lemma Le_le_LtD[dest]: "Le a \<le> Lt b \<Longrightarrow> a < b" unfolding dbm_le_def less_eq by auto
lemma Lt_le_LeD[dest]: "Lt a \<le> Le b \<Longrightarrow> a \<le> b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LtD[dest]: "Lt a \<le> Lt b \<Longrightarrow> a \<le> b" unfolding less_eq dbm_le_def by auto

lemma inf_not_le_Le[simp]: "\<infinity> \<le> Le x = False" unfolding less_eq dbm_le_def by auto
lemma inf_not_le_Lt[simp]: "\<infinity> \<le> Lt x = False" unfolding less_eq dbm_le_def by auto
lemma inf_not_lt[simp]: "\<infinity> \<prec> x = False" by auto

lemma any_le_inf: "x \<le> (\<infinity> :: _ DBMEntry)" by (metis less_eq dmb_le_dbm_entry_bound_inf le_cases)

lemma dbm_lt_code_simps[code]:
  "dbm_lt (Lt a) \<infinity> = True"
  "dbm_lt (Le a) \<infinity> = True"
  "dbm_lt (Le a) (Le b) = (a < b)"
  "dbm_lt (Le a) (Lt b) = (a < b)"
  "dbm_lt (Lt a) (Le b) = (a \<le> b)"
  "dbm_lt (Lt a) (Lt b) = (a < b)"
  "dbm_lt \<infinity> x = False"
  by auto

section \<open>Basic Properties of DBMs\<close>

subsection \<open>DBMs and Length of Paths\<close>

lemma dbm_entry_val_add_1: "dbm_entry_val u (Some c) (Some d) a \<Longrightarrow>  dbm_entry_val u (Some d) None b
       \<Longrightarrow> dbm_entry_val u (Some c) None (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   apply (simp add: dbm_entry_val.intros(3) diff_less_eq less_le_trans)
  by (metis add_le_less_mono dbm_entry_val.intros(3) diff_add_cancel less_imp_le)
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_2: "dbm_entry_val u None (Some c) a \<Longrightarrow> dbm_entry_val u (Some c) (Some d) b
       \<Longrightarrow> dbm_entry_val u None (Some d) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_3:
  "dbm_entry_val u (Some c) (Some d) a \<Longrightarrow>  dbm_entry_val u (Some d) (Some e) b
   \<Longrightarrow> dbm_entry_val u (Some c) (Some e) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_4:
  "dbm_entry_val u (Some c) None a \<Longrightarrow> dbm_entry_val u None (Some d) b
   \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

no_notation dbm_add (infixl "\<otimes>" 70)

lemma DBM_val_bounded_len_1'_aux:
  assumes "DBM_val_bounded v u m n" "v c \<le> n" "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (Some c) None (len m (v c) 0 vs)" using assms
proof (induction vs arbitrary: c)
  case Nil then show ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with Cons have "dbm_entry_val u (Some c') None (len m (v c') 0 vs)" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems c'
  by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) None (m (v c) (v c') + len m (v c') 0 vs)"
  using dbm_entry_val_add_1 unfolding add by fastforce
  with c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_3'_aux:
  "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> v d \<le> n \<Longrightarrow> \<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)
   \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (len m (v c) (v d) vs)"
proof (induction vs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with Cons have "dbm_entry_val u (Some c') (Some d) (len m (v c') (v d) vs)" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems c'
  by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) (Some d) (m (v c) (v c') + len m (v c') (v d) vs)"
  using dbm_entry_val_add_3 unfolding add by fastforce
  with c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_2'_aux:
  "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)
  \<Longrightarrow> dbm_entry_val u None (Some c) (len m 0 (v c) vs)"
proof (cases vs, goal_cases)
  case 1 then show ?thesis unfolding DBM_val_bounded_def by auto
next
  case (2 k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with 2 have "dbm_entry_val u (Some c') (Some c) (len m (v c') (v c) vs)"
  using DBM_val_bounded_len_3'_aux by auto
  moreover have "dbm_entry_val u None (Some c') (m 0 (v c'))"
  using 2 c' by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u None (Some c) (m 0 (v c') + len m (v c') (v c) vs)"
  using dbm_entry_val_add_2 unfolding add by fastforce
  with 2(4) c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma cnt_0_D:
  "cnt x xs = 0 \<Longrightarrow> x \<notin> set xs"
apply (induction xs)
 apply simp
apply (rename_tac a xs)
apply (case_tac "x = a")
by simp+

lemma cnt_at_most_1_D:
  "cnt x (xs @ x # ys) \<le> 1 \<Longrightarrow> x \<notin> set xs \<and> x \<notin> set ys"
apply (induction xs)
  apply auto[]
  using cnt_0_D apply force
 apply (rename_tac a xs)
 apply (case_tac "a = x")
  apply simp
 apply simp
done

lemma nat_list_0 [intro]:
  "x \<in> set xs \<Longrightarrow> 0 \<notin> set (xs :: nat list) \<Longrightarrow> x > 0"
by (induction xs) auto

lemma DBM_val_bounded_len'2:
  fixes v
  assumes "DBM_val_bounded v u m n" "0 \<notin> set vs" "v c \<le> n"
          "\<forall> k \<in> set vs. k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u None (Some c) (len m 0 (v c) vs)"
using DBM_val_bounded_len_2'_aux[OF assms(1,3)] assms(2,4) by fastforce

lemma DBM_val_bounded_len'3:
  fixes v
  assumes "DBM_val_bounded v u m n" "cnt 0 vs \<le> 1" "v c1 \<le> n" "v c2 \<le> n"
          "\<forall> k \<in> set vs. k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (Some c1) (Some c2) (len m (v c1) (v c2) vs)"
proof -
  show ?thesis
  proof (cases "\<forall> k \<in> set vs. k > 0")
    case True
    with assms have "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)" by auto
    with DBM_val_bounded_len_3'_aux[OF assms(1,3,4)] show ?thesis by auto
  next
    case False
    then have "\<exists> k \<in> set vs. k = 0" by auto
    then obtain us ws where vs: "vs = us @ 0 # ws" by (meson split_list_last)
    with cnt_at_most_1_D[of 0 "us"] assms(2) have
      "0 \<notin> set us" "0 \<notin> set ws"
    by auto
    with vs have vs: "vs = us @ 0 # ws" "\<forall> k \<in> set us. k > 0" "\<forall> k \<in> set ws. k > 0" by auto
    with assms(5) have v:
      "\<forall>k\<in>set us. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)" "\<forall>k\<in>set ws. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)"
    by auto
    with
      dbm_entry_val_add_4[OF
        DBM_val_bounded_len_1'_aux[OF assms(1,3) v(1)]
        DBM_val_bounded_len_2'_aux[OF assms(1,4) v(2)]
      ]
    have "dbm_entry_val u (Some c1) (Some c2) (dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws))"
      by auto
    moreover from vs have "len m (v c1) (v c2) vs = dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws)"
      by (simp add: len_comp add)
    ultimately show ?thesis by auto
  qed
qed

paragraph \<open>Now unused\<close>

lemma DBM_val_bounded_len':
  fixes v
  defines "vo \<equiv> \<lambda> k. if k = 0 then None else Some (SOME c. v c = k)"
  assumes "DBM_val_bounded v u m n" "cnt 0 (i # j # vs) \<le> 1"
          "\<forall> k \<in> set (i # j # vs). k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (vo i) (vo j) (len m i j vs)"
proof -
  show ?thesis
  proof (cases "\<forall> k \<in> set vs. k > 0")
    case True
    with assms have *: "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)" by auto
    show ?thesis
    proof (cases "i = 0")
      case True
      then have i: "vo i = None" by (simp add: vo_def)
      show ?thesis
      proof (cases "j = 0")
        case True with assms \<open>i = 0\<close> show ?thesis by auto
      next
        case False
        with assms obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with \<open>i = 0\<close> i DBM_val_bounded_len_2'_aux[OF assms(2) _ *] show ?thesis by auto
      qed
    next
      case False
      with assms(4) obtain c1 where c1: "i \<le> n" "v c1 = i" "vo i = Some c1"
      unfolding vo_def by (fastforce intro: someI)
      show ?thesis
      proof (cases "j = 0")
        case True
        with DBM_val_bounded_len_1'_aux[OF assms(2) _ *] c1 show ?thesis by (auto simp: vo_def)
      next
        case False
        with assms obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with c1 DBM_val_bounded_len_3'_aux[OF assms(2) _ _ *] show ?thesis by auto
      qed
    qed
  next
    case False
    then have "\<exists> k \<in> set vs. k = 0" by auto
    then obtain us ws where vs: "vs = us @ 0 # ws" by (meson split_list_last)
    with cnt_at_most_1_D[of 0 "i # j # us" ws] assms(3) have
      "0 \<notin> set us" "0 \<notin> set ws" "i \<noteq> 0" "j \<noteq> 0"
    by auto
    with vs have vs: "vs = us @ 0 # ws" "\<forall> k \<in> set us. k > 0" "\<forall> k \<in> set ws. k > 0" by auto
    with assms(4) have v:
      "\<forall>k\<in>set us. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)" "\<forall>k\<in>set ws. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)"
    by auto
    from \<open>i \<noteq> 0\<close> \<open>j \<noteq> 0\<close> assms obtain c1 c2 where
      c1: "i \<le> n" "v c1 = i" "vo i = Some c1" and c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
    unfolding vo_def by (fastforce intro: someI)
    with dbm_entry_val_add_4 [OF DBM_val_bounded_len_1'_aux[OF assms(2) _ v(1)] DBM_val_bounded_len_2'_aux[OF assms(2) _ v(2)]]
    have "dbm_entry_val u (Some c1) (Some c2) (dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws))" by auto
    moreover from vs have "len m (v c1) (v c2) vs = dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws)"
      by (simp add: len_comp add)
    ultimately show ?thesis using c1 c2 by auto
  qed
qed

lemma DBM_val_bounded_len_1: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u (Some c) None (len m (v c) 0 (map v cs))"
proof (induction cs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons c' cs)
  hence "dbm_entry_val u (Some c') None (len m (v c') 0 (map v cs))" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems
    by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) None (m (v c) (v c') + len m (v c') 0 (map v cs))"
    using dbm_entry_val_add_1 unfolding add by fastforce
  thus ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_3: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> v d \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (len m (v c) (v d) (map v cs))"
proof (induction cs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons c' cs)
  hence "dbm_entry_val u (Some c') (Some d) (len m (v c') (v d) (map v cs))" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems
    by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) (Some d) (m (v c) (v c') + len m (v c') (v d) (map v cs))"
    using dbm_entry_val_add_3 unfolding add by fastforce
  thus ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_2: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u None (Some c) (len m 0 (v c) (map v cs))"
proof (cases cs, goal_cases)
  case 1 thus ?thesis unfolding DBM_val_bounded_def by auto
next
  case (2 c' cs)
  hence "dbm_entry_val u (Some c') (Some c) (len m (v c') (v c) (map v cs))"
    using DBM_val_bounded_len_3 by auto
  moreover have "dbm_entry_val u None (Some c') (m 0 (v c'))"
    using 2 by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u None (Some c) (m 0 (v c') + len m (v c') (v c) (map v cs))"
    using dbm_entry_val_add_2 unfolding add by fastforce
  thus ?case using 2(4) unfolding DBM_val_bounded_def by simp
qed

lemmas DBM_arith_defs = add neutral uminus

end (* Theory *)


theory practise imports Main

begin

fun sum_upTo ::  "nat \<Rightarrow> nat" where
"sum_upTo 0 = 0" |
"sum_upTo (Suc n) = (Suc n) + (sum_upTo n)"

value "sum_upTo 5"

theorem gaussumme: "sum_upTo n = (n * (n + 1)) div 2"
  apply(induction n)
   apply(auto)
  done

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] xs = xs" |
"itrev (x # xs) ys = itrev xs (x # ys)"

lemma abc: "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
   apply (auto)
  done

lemma "itrev xs [] = rev xs" sledgehammer
  by (simp add: abc)

end


section {* Partial First Order Logic *}

theory PFOL
  imports Main
begin

subsection {* Truth values *}

text {* We obtain three valued logic by simply using the option type *}

type_synonym tvl = "bool option"

notation
  Some ("\<lfloor>_\<rfloor>")

text {* Definedness of a given tvl value *}

definition tvl_defined :: "tvl \<Rightarrow> bool" ("\<D>\<^sub>3") where
"\<D>\<^sub>3(p) \<equiv> p \<noteq> None"

syntax
  "_true_tvl"  :: "tvl" ("true\<^sub>3")
  "_false_tvl" :: "tvl" ("false\<^sub>3")
  "_bot_tvl"   :: "tvl" ("\<bottom>\<^sub>3")

translations
  "_true_tvl"  => "CONST Some CONST True"
  "_false_tvl" => "CONST Some CONST False"
  "_bot_tvl"   => "CONST None"

lemma tvl_defined [intro, simp]: "\<D>\<^sub>3(\<lfloor>x\<rfloor>)"
  by (simp add: tvl_defined_def)

lemma tvl_cases:
  "\<lbrakk> p = true\<^sub>3 \<Longrightarrow> P; p = false\<^sub>3 \<Longrightarrow> P; p = \<bottom>\<^sub>3 \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto)

text {* Tautologies *}

definition tvl_taut :: "tvl \<Rightarrow> bool" ("[_]\<^sub>3") where
"tvl_taut p = (p = true\<^sub>3)"

lemma tvl_taut_Some [simp]: "[\<lfloor>x\<rfloor>]\<^sub>3 = x"
  by (simp add: tvl_taut_def)

lemma tvlI [intro]: "p \<Longrightarrow> [\<lfloor>p\<rfloor>]\<^sub>3"
  by (simp add: tvl_taut_def)

lemma tvlD [dest!]: "[\<lfloor>p\<rfloor>]\<^sub>3 \<Longrightarrow> p"
  by (simp add: tvl_taut_def)

lemma tvl_bot [simp]: "[\<bottom>\<^sub>3]\<^sub>3 = False"
  by (simp add: tvl_taut_def)

subsection {* Logical operators *}

text {* The operators in this section are taken from a paper by Gavilanes-Franco and Lucio-Carrasco
        called "A first order logic for partial functions". Rather than defining them in terms
        of conjunction and disjunction, we define them all separately and then prove the laws
        about the relationships. *}

definition knot :: "tvl \<Rightarrow> tvl" ("\<not>\<^sub>k _" [40] 40) where
"knot p = (case p of
             None \<Rightarrow> None |
             Some v \<Rightarrow> Some (\<not> v))"

definition kand :: "tvl \<Rightarrow> tvl \<Rightarrow> tvl" (infixr "\<and>\<^sub>k" 35) where
"kand p q =
  (if (p = true\<^sub>3 \<and> q = true\<^sub>3)
      then true\<^sub>3
   else if (p = false\<^sub>3 \<or> q = false\<^sub>3)
      then false\<^sub>3
   else \<bottom>\<^sub>3)"

definition kor :: "tvl \<Rightarrow> tvl \<Rightarrow> tvl" (infixr "\<or>\<^sub>k" 35) where
"(p \<or>\<^sub>k q) =
  (if (p = true\<^sub>3 \<or> q = true\<^sub>3)
      then true\<^sub>3
   else if (p = false\<^sub>3 \<and> q = false\<^sub>3)
      then false\<^sub>3
   else \<bottom>\<^sub>3)"

definition kimpl :: "tvl \<Rightarrow> tvl \<Rightarrow> tvl" (infixr "\<Rightarrow>\<^sub>k" 25) where
"(p \<Rightarrow>\<^sub>k q) =
    (if (p = false\<^sub>3 \<or> q = true\<^sub>3)
        then true\<^sub>3
     else if (p = true\<^sub>3 \<and> q = false\<^sub>3)
        then false\<^sub>3
     else \<bottom>\<^sub>3)"

definition kEx :: "('a \<Rightarrow> tvl) \<Rightarrow> tvl" (binder "\<exists>\<^sub>k" 10) where
"kEx P =
  (if (\<exists> x. P(x) = true\<^sub>3)
      then true\<^sub>3
   else if (\<forall> x. P(x) = false\<^sub>3)
      then false\<^sub>3
   else \<bottom>\<^sub>3)"

definition kAll :: "('a \<Rightarrow> tvl) \<Rightarrow> tvl" (binder "\<forall>\<^sub>k" 10) where
"kAll P =
  (if (\<forall> x. P(x) = true\<^sub>3)
      then true\<^sub>3
   else if (\<exists> x. P(x) = false\<^sub>3)
      then false\<^sub>3
   else \<bottom>\<^sub>3)"

definition kBall :: "'a set \<Rightarrow> ('a \<Rightarrow> tvl) \<Rightarrow> tvl" where
"kBall A P = (\<forall>\<^sub>k x. \<lfloor>x \<in> A\<rfloor> \<Rightarrow>\<^sub>k P x)" -- {* bounded universal quantification *}

definition kBex :: "'a set \<Rightarrow> ('a \<Rightarrow> tvl) \<Rightarrow> tvl" where
"kBex A P = (\<exists>\<^sub>k x. \<lfloor>x \<in> A\<rfloor> \<Rightarrow>\<^sub>k P x)" -- {* bounded existential quantification *}

syntax
  "_kBall" :: "pttrn => 'a set => bool => bool"      ("(3\<forall>\<^sub>k_\<in>_./ _)" [0, 0, 10] 10)
  "_kBex"  :: "pttrn => 'a set => bool => bool"      ("(3\<exists>\<^sub>k_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<forall>\<^sub>k x \<in> A. P" == "CONST kBall A (\<lambda> x. P)"
  "\<exists>\<^sub>k x \<in> A. P" == "CONST kBex A (\<lambda> x. P)"

subsection {* Definedness rules *}

text {* The first task in setting up proof automation is automate definedness checking. We
        first prove some laws about the definedness of the logical connectives. We need
        to do this first, as these laws will be necessary for the proof calculus. There
        are probably weakened forms of each of these rules, but I haven't the time to
        figure them out right now. *}

lemma tvl_defined_alt_def: "\<D>\<^sub>3(p) = [p]\<^sub>3 \<or> [\<not>\<^sub>k p]\<^sub>3"
  by (auto simp add: tvl_defined_def knot_def tvl_taut_def)

lemma knot_defined [simp]: "\<D>\<^sub>3 (\<not>\<^sub>k p) = \<D>\<^sub>3 p"
  by (cases p rule: tvl_cases, simp_all add: knot_def tvl_defined_def)

lemma knot_defI [intro]: "\<D>\<^sub>3 p \<Longrightarrow> \<D>\<^sub>3 (\<not>\<^sub>k p)"
  by simp

lemma kand_defI1 [intro]: "\<lbrakk> \<D>\<^sub>3(p); \<D>\<^sub>3(q) \<rbrakk> \<Longrightarrow> \<D>\<^sub>3(p \<and>\<^sub>k q)"
  by (auto simp add: kand_def tvl_defined_def)

lemma kor_defI1 [intro]: "\<lbrakk> \<D>\<^sub>3(p); \<D>\<^sub>3(q) \<rbrakk> \<Longrightarrow> \<D>\<^sub>3(p \<or>\<^sub>k q)"
  by (auto simp add: kor_def tvl_defined_def)

lemma kimpl_defI1 [intro]: "\<lbrakk> \<D>\<^sub>3(p); \<D>\<^sub>3(q) \<rbrakk> \<Longrightarrow> \<D>\<^sub>3(p \<Rightarrow>\<^sub>k q)"
  by (auto simp add: kimpl_def tvl_defined_def)

lemma kAll_defI1 [intro]: "\<lbrakk> \<And> x. \<D>\<^sub>3(P x) \<rbrakk> \<Longrightarrow> \<D>\<^sub>3 (\<forall>\<^sub>kx. P x)"
  by (auto simp add: tvl_defined_def kAll_def, metis (full_types))

lemma kEx_defI1 [intro]: "\<lbrakk> \<And> x. \<D>\<^sub>3(P x) \<rbrakk> \<Longrightarrow> \<D>\<^sub>3 (\<exists>\<^sub>kx. P x)"
  by (auto simp add: tvl_defined_def kEx_def, metis (full_types))

subsection {* Proof rules *}

text {* Many of these rules take a similar form to their HOL equivalents, but additionally
        have definedness provisos. These provisos much be discharged by the laws above.
        Again, there's a lot of work still to do to make proof automation effective. *}

lemma keqI [intro]: "\<lbrakk> [P \<Rightarrow>\<^sub>k Q]\<^sub>3; [Q \<Rightarrow>\<^sub>k P]\<^sub>3 \<rbrakk> \<Longrightarrow> P = Q"
  by (cases P rule: tvl_cases; cases Q rule:tvl_cases, simp_all add: tvl_taut_def kimpl_def)

lemma kNotI [intro]: "\<lbrakk> [P]\<^sub>3 \<Longrightarrow> False; \<D>\<^sub>3(P) \<rbrakk> \<Longrightarrow> [\<not>\<^sub>k P]\<^sub>3"
  by (cases P rule: tvl_cases, auto simp add: knot_def tvl_taut_def tvl_defined_def)

lemma kNotE [elim?]: "\<lbrakk> [\<not>\<^sub>k P]\<^sub>3; [\<not>\<^sub>k P]\<^sub>3 \<Longrightarrow> [P]\<^sub>3 \<rbrakk> \<Longrightarrow> R"
  by (simp add: knot_def tvl_taut_def)

lemma kAndI [intro]: "\<lbrakk> [P]\<^sub>3; [Q]\<^sub>3 \<rbrakk> \<Longrightarrow> [P \<and>\<^sub>k Q]\<^sub>3"
  by (simp add: kand_def tvl_taut_def)

lemma kAndE [elim]: "\<lbrakk> [P \<and>\<^sub>k Q]\<^sub>3; [P]\<^sub>3 \<Longrightarrow> [Q]\<^sub>3 \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (cases P rule: tvl_cases; cases Q rule: tvl_cases, simp_all add: kand_def tvl_taut_def)

lemma kOrI1 [intro]: "[P]\<^sub>3 \<Longrightarrow> [P \<or>\<^sub>k Q]\<^sub>3"
  by (simp add: kor_def tvl_taut_def)

lemma kOrI2 [intro]: "[Q]\<^sub>3 \<Longrightarrow> [P \<or>\<^sub>k Q]\<^sub>3"
  by (simp add: kor_def tvl_taut_def)

lemma kOrE [elim]: "\<lbrakk> [P \<or>\<^sub>k Q]\<^sub>3; [P]\<^sub>3 \<Longrightarrow> R; [Q]\<^sub>3 \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (cases P rule: tvl_cases; cases Q rule: tvl_cases, simp_all add: kor_def tvl_taut_def)

lemma kAllI [intro]: "\<lbrakk> \<And> x. [P x]\<^sub>3 \<rbrakk> \<Longrightarrow> [\<forall>\<^sub>k x. P x]\<^sub>3"
  by (auto simp add: kAll_def tvl_taut_def)

lemma kAllE [elim]: "\<lbrakk> [\<forall>\<^sub>k x. P x]\<^sub>3; [P x]\<^sub>3 \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (auto simp add: kAll_def tvl_taut_def, metis option.distinct(1) option.inject)

lemma kimpI [intro]: "\<lbrakk> [P]\<^sub>3 \<Longrightarrow> [Q]\<^sub>3 ; \<D>\<^sub>3(P) \<rbrakk> \<Longrightarrow> [P \<Rightarrow>\<^sub>k Q]\<^sub>3"
  by (cases P rule: tvl_cases; cases Q rule: tvl_cases , auto simp add: kimpl_def tvl_defined_def)

lemma kBallI [intro]: "\<lbrakk> \<And> x. x \<in> A \<Longrightarrow> [P x]\<^sub>3 \<rbrakk> \<Longrightarrow> [\<forall>\<^sub>k x \<in> A. P x]\<^sub>3"
  by (force simp add: kBall_def)

lemma kExI [intro]: "[P x]\<^sub>3 \<Longrightarrow> [\<exists>\<^sub>k x. P x]\<^sub>3"
  using option.inject by (auto simp add: kEx_def tvl_taut_def, fastforce)

lemma kBexI [intro]: "\<lbrakk> x \<in> A; [P x]\<^sub>3 \<rbrakk> \<Longrightarrow> [\<exists>\<^sub>k x \<in> A. P x]\<^sub>3"
  by (auto simp add: kBex_def)

subsection {* Algebraic laws *}

text {* Again, this set of laws is largely incomplete. *}

lemma knot_false [simp]: "(\<not>\<^sub>k false\<^sub>3) = true\<^sub>3"
  by blast

lemma knot_true [simp]: "(\<not>\<^sub>k true\<^sub>3) = false\<^sub>3"
  by (simp add: knot_def)

lemma knot_bot [simp]: "(\<not>\<^sub>k \<bottom>\<^sub>3) = \<bottom>\<^sub>3"
  by (simp add: knot_def)

lemma kand_assoc: "((p \<and>\<^sub>k q) \<and>\<^sub>k r) = (p \<and>\<^sub>k q \<and>\<^sub>k r)"
   by (cases p, simp_all add: kand_def)

lemma kand_comm: "(p \<and>\<^sub>k q) = (q \<and>\<^sub>k p)"
  by (cases p, simp_all add: kand_def)

lemma kand_idem: "(p \<and>\<^sub>k p) = p"
  by (cases p rule: tvl_cases, simp_all add: kand_def)

lemma kand_left_unit [simp]: "(true\<^sub>3  \<and>\<^sub>k p) = p"
  by (cases p rule: tvl_cases, simp_all add: kand_def)

lemma kand_right_unit [simp]: "(p \<and>\<^sub>k true\<^sub>3) = p"
  by (cases p rule: tvl_cases, simp_all add: kand_def)

lemma kand_left_anhil [simp]: "(false\<^sub>3  \<and>\<^sub>k p) = false\<^sub>3"
  by (cases p rule: tvl_cases, simp_all add: kand_def)

lemma kand_right_anhil [simp]: "(p \<and>\<^sub>k false\<^sub>3) = false\<^sub>3"
  by (cases p rule: tvl_cases, simp_all add: kand_def)

lemma kimpl_false [simp]: "(false\<^sub>3 \<Rightarrow>\<^sub>k p) = true\<^sub>3"
  by (simp add: kimpl_def)

lemma kimpl_kor: "(p \<Rightarrow>\<^sub>k q) = (\<not>\<^sub>k p \<or>\<^sub>k q)"
  by (cases p rule: tvl_cases, simp_all add: kimpl_def kor_def)

lemma kor_demorgan:
  "(p \<or>\<^sub>k q) = (\<not>\<^sub>k ((\<not>\<^sub>k p) \<and>\<^sub>k (\<not>\<^sub>k q)))"
  apply (cases p rule: tvl_cases; cases q rule: tvl_cases)
  apply (simp_all add: kor_def kand_def knot_def)
done

lemma kand_demorgan:
  "(p \<and>\<^sub>k q) = (\<not>\<^sub>k ((\<not>\<^sub>k p) \<or>\<^sub>k (\<not>\<^sub>k q)))"
  apply (cases p rule: tvl_cases; cases q rule: tvl_cases)
  apply (simp_all add: kor_def kand_def knot_def)
done

lemma kand_Some [simp]: "(\<lfloor>x\<rfloor> \<and>\<^sub>k \<lfloor>y\<rfloor>) = \<lfloor>x \<and> y\<rfloor>"
  by (simp add: kand_def)

lemma kor_Some [simp]: "(\<lfloor>x\<rfloor> \<or>\<^sub>k \<lfloor>y\<rfloor>) = \<lfloor>x \<or> y\<rfloor>"
  by (simp add: kor_def)

lemma kAll_kEx: "(\<forall>\<^sub>k x. P x) = (\<not>\<^sub>k (\<exists>\<^sub>k x. \<not>\<^sub>k P x))"
  by (simp add: kAll_def kEx_def knot_def, metis knot_bot knot_def knot_false knot_true tvl_cases)

lemma kAll_true [simp]: "(\<forall>\<^sub>k x. true\<^sub>3) = true\<^sub>3"
  by (simp add: kAll_def)

lemma kAll_kand: "(\<forall>\<^sub>k x. P x \<and>\<^sub>k Q x) = ((\<forall>\<^sub>k x. P x) \<and>\<^sub>k (\<forall>\<^sub>k x. Q x))"
  by (auto simp add: kAll_def kand_def)

lemma kAll_false [simp]: "(\<exists>\<^sub>k x. true\<^sub>3) = true\<^sub>3"
  by (simp add: kEx_def)
end


theory P16 imports Main begin

lemma "\<forall> x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow> \<exists> x. rich (father (father x)) \<and> rich x"
proof -
  assume "\<forall> x. \<not> rich x \<longrightarrow> rich (father x)"
  then obtain r where "rich r" by blast
  then show ?thesis using \<open>\<forall>x. \<not> rich x \<longrightarrow> rich (father x)\<close> by blast
qed

end