(*  Title:      HOL/SMT_Examples/SMT_Tests.thy
    Author:     Sascha Boehme, TU Muenchen
*)

section {* Tests for the SMT binding *}

theory SMT_Tests
imports Complex_Main
begin

smt_status

text {* Most examples are taken from various Isabelle theories and from HOL4. *}

section {* Propositional logic *}

lemma
  "True"
  "\<not> False"
  "\<not> \<not> True"
  "True \<and> True"
  "True \<or> False"
  "False \<longrightarrow> True"
  "\<not> (False \<longleftrightarrow> True)"
  by smt+

lemma
  "P \<or> \<not> P"
  "\<not> (P \<and> \<not> P)"
  "(True \<and> P) \<or> \<not> P \<or> (False \<and> P) \<or> P"
  "P \<longrightarrow> P"
  "P \<and> \<not> P \<longrightarrow> False"
  "P \<and> Q \<longrightarrow> Q \<and> P"
  "P \<or> Q \<longrightarrow> Q \<or> P"
  "P \<and> Q \<longrightarrow> P \<or> Q"
  "\<not> (P \<or> Q) \<longrightarrow> \<not> P"
  "\<not> (P \<or> Q) \<longrightarrow> \<not> Q"
  "\<not> P \<longrightarrow> \<not> (P \<and> Q)"
  "\<not> Q \<longrightarrow> \<not> (P \<and> Q)"
  "(P \<and> Q) \<longleftrightarrow> (\<not> (\<not> P \<or> \<not> Q))"
  "(P \<and> Q) \<and> R \<longrightarrow> P \<and> (Q \<and> R)"
  "(P \<or> Q) \<or> R \<longrightarrow> P \<or> (Q \<or> R)"
  "(P \<and> Q) \<or> R  \<longrightarrow> (P \<or> R) \<and> (Q \<or> R)"
  "(P \<or> R) \<and> (Q \<or> R) \<longrightarrow> (P \<and> Q) \<or> R"
  "(P \<or> Q) \<and> R \<longrightarrow> (P \<and> R) \<or> (Q \<and> R)"
  "(P \<and> R) \<or> (Q \<and> R) \<longrightarrow> (P \<or> Q) \<and> R"
  "((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P"
  "(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R) \<longleftrightarrow> (P \<or> Q \<longrightarrow> R)"
  "(P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))"
  "((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow>  ((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<longrightarrow> R) \<longrightarrow> R"
  "\<not> (P \<longrightarrow> R) \<longrightarrow>  \<not> (Q \<longrightarrow> R) \<longrightarrow> \<not> (P \<and> Q \<longrightarrow> R)"
  "(P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)"
  "P \<longrightarrow> (Q \<longrightarrow> P)"
  "(P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q)\<longrightarrow> (P \<longrightarrow> R)"
  "(P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q \<or> R)"
  "((((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> Q) \<longrightarrow> Q"
  "(P \<longrightarrow> Q) \<longrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  "(P \<longrightarrow> Q \<or> R) \<longrightarrow> (P \<longrightarrow> Q) \<or> (P \<longrightarrow> R)"
  "(P \<longrightarrow> Q) \<and> (Q  \<longrightarrow> P) \<longrightarrow> (P \<longleftrightarrow> Q)"
  "(P \<longleftrightarrow> Q) \<longleftrightarrow> (Q \<longleftrightarrow> P)"
  "\<not> (P \<longleftrightarrow> \<not> P)"
  "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  "P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P"
  by smt+

lemma
  "(if P then Q1 else Q2) \<longleftrightarrow> ((P \<longrightarrow> Q1) \<and> (\<not> P \<longrightarrow> Q2))"
  "if P then (Q \<longrightarrow> P) else (P \<longrightarrow> Q)"
  "(if P1 \<or> P2 then Q1 else Q2) \<longleftrightarrow> (if P1 then Q1 else if P2 then Q1 else Q2)"
  "(if P1 \<and> P2 then Q1 else Q2) \<longleftrightarrow> (if P1 then if P2 then Q1 else Q2 else Q2)"
  "(P1 \<longrightarrow> (if P2 then Q1 else Q2)) \<longleftrightarrow>
   (if P1 \<longrightarrow> P2 then P1 \<longrightarrow> Q1 else P1 \<longrightarrow> Q2)"
  by smt+

lemma
  "case P of True \<Rightarrow> P | False \<Rightarrow> \<not> P"
  "case P of False \<Rightarrow> \<not> P | True \<Rightarrow> P"
  "case \<not> P of True \<Rightarrow> \<not> P | False \<Rightarrow> P"
  "case P of True \<Rightarrow> (Q \<longrightarrow> P) | False \<Rightarrow> (P \<longrightarrow> Q)"
  by smt+

section {* First-order logic with equality *}

lemma
  "x = x"
  "x = y \<longrightarrow> y = x"
  "x = y \<and> y = z \<longrightarrow> x = z"
  "x = y \<longrightarrow> f x = f y"
  "x = y \<longrightarrow> g x y = g y x"
  "f (f x) = x \<and> f (f (f (f (f x)))) = x \<longrightarrow> f x = x"
  "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
  by smt+

lemma
  "\<forall>x. x = x"
  "(\<forall>x. P x) \<longleftrightarrow> (\<forall>y. P y)"
  "\<forall>x. P x \<longrightarrow> (\<forall>y. P x \<or> P y)"
  "(\<forall>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>x. P x) \<and> (\<forall>x. Q x)"
  "(\<forall>x. P x) \<or> R \<longleftrightarrow> (\<forall>x. P x \<or> R)"
  "(\<forall>x y z. S x z) \<longleftrightarrow> (\<forall>x z. S x z)"
  "(\<forall>x y. S x y \<longrightarrow> S y x) \<longrightarrow> (\<forall>x. S x y) \<longrightarrow> S y x"
  "(\<forall>x. P x \<longrightarrow> P (f x)) \<and> P d \<longrightarrow> P (f(f(f(d))))"
  "(\<forall>x y. s x y = s y x) \<longrightarrow> a = a \<and> s a b = s b a"
  "(\<forall>s. q s \<longrightarrow> r s) \<and> \<not> r s \<and> (\<forall>s. \<not> r s \<and> \<not> q s \<longrightarrow> p t \<or> q t) \<longrightarrow> p t \<or> r t"
  by smt+

lemma
  "(\<forall>x. P x) \<and> R \<longleftrightarrow> (\<forall>x. P x \<and> R)"
  by smt

lemma
  "\<exists>x. x = x"
  "(\<exists>x. P x) \<longleftrightarrow> (\<exists>y. P y)"
  "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>x. P x) \<or> (\<exists>x. Q x)"
  "(\<exists>x. P x) \<and> R \<longleftrightarrow> (\<exists>x. P x \<and> R)"
  "(\<exists>x y z. S x z) \<longleftrightarrow> (\<exists>x z. S x z)"
  "\<not> ((\<exists>x. \<not> P x) \<and> ((\<exists>x. P x) \<or> (\<exists>x. P x \<and> Q x)) \<and> \<not> (\<exists>x. P x))"
  by smt+

lemma
  "\<exists>x y. x = y"
  "\<exists>x. P x \<longrightarrow> (\<exists>y. P x \<and> P y)"
  "(\<exists>x. P x) \<or> R \<longleftrightarrow> (\<exists>x. P x \<or> R)"
  "\<exists>x. P x \<longrightarrow> P a \<and> P b"
  "\<exists>x. (\<exists>y. P y) \<longrightarrow> P x"
  "(\<exists>x. Q \<longrightarrow> P x) \<longleftrightarrow> (Q \<longrightarrow> (\<exists>x. P x))"
  by smt+

lemma
  "(\<not> (\<exists>x. P x)) \<longleftrightarrow> (\<forall>x. \<not> P x)"
  "(\<exists>x. P x \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P x) \<longrightarrow> Q"
  "(\<forall>x y. R x y = x) \<longrightarrow> (\<exists>y. R x y) = R x c"
  "(if P x then \<not> (\<exists>y. P y) else (\<forall>y. \<not> P y)) \<longrightarrow> P x \<longrightarrow> P y"
  "(\<forall>x y. R x y = x) \<and> (\<forall>x. \<exists>y. R x y) = (\<forall>x. R x c) \<longrightarrow> (\<exists>y. R x y) = R x c"
  by smt+

lemma
  "\<forall>x. \<exists>y. f x y = f x (g x)"
  "(\<not> \<not> (\<exists>x. P x)) \<longleftrightarrow> (\<not> (\<forall>x. \<not> P x))"
  "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u) w (h u w)"
  "\<exists>x. if x = y then (\<forall>y. y = x \<or> y \<noteq> x) else (\<forall>y. y = (x, x) \<or> y \<noteq> (x, x))"
  "\<exists>x. if x = y then (\<exists>y. y = x \<or> y \<noteq> x) else (\<exists>y. y = (x, x) \<or> y \<noteq> (x, x))"
  "(\<exists>x. \<forall>y. P x \<longleftrightarrow> P y) \<longrightarrow> ((\<exists>x. P x) \<longleftrightarrow> (\<forall>y. P y))"
  "\<exists>z. P z \<longrightarrow> (\<forall>x. P x)"
  "(\<exists>y. \<forall>x. R x y) \<longrightarrow> (\<forall>x. \<exists>y. R x y)"
  by smt+

lemma
  "(\<exists>!x. P x) \<longrightarrow> (\<exists>x. P x)"
  "(\<exists>!x. P x) \<longleftrightarrow> (\<exists>x. P x \<and> (\<forall>y. y \<noteq> x \<longrightarrow> \<not> P y))"
  "P a \<longrightarrow> (\<forall>x. P x \<longrightarrow> x = a) \<longrightarrow> (\<exists>!x. P x)"
  "(\<exists>x. P x) \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> x = y) \<longrightarrow> (\<exists>!x. P x)"
  "(\<exists>!x. P x) \<and> (\<forall>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> R) \<longrightarrow> R"
  by smt+

lemma
  "(\<forall>x\<in>M. P x) \<and> c \<in> M \<longrightarrow> P c"
  "(\<exists>x\<in>M. P x) \<or> \<not> (P c \<and> c \<in> M)"
  by smt+

lemma
  "let P = True in P"
  "let P = P1 \<or> P2 in P \<or> \<not> P"
  "let P1 = True; P2 = False in P1 \<and> P2 \<longrightarrow> P2 \<or> P1"
  "(let x = y in x) = y"
  "(let x = y in Q x) \<longleftrightarrow> (let z = y in Q z)"
  "(let x = y1; z = y2 in R x z) \<longleftrightarrow> (let z = y2; x = y1 in R x z)"
  "(let x = y1; z = y2 in R x z) \<longleftrightarrow> (let z = y1; x = y2 in R z x)"
  "let P = (\<forall>x. Q x) in if P then P else \<not> P"
  by smt+

lemma
  "a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and> (\<forall>x y. f x = f y \<longrightarrow> y = x) \<longrightarrow> f a \<noteq> f b"
  by smt

lemma
  "(\<forall>x y z. f x y = f x z \<longrightarrow> y = z) \<and> b \<noteq> c \<longrightarrow> f a b \<noteq> f a c"
  "(\<forall>x y z. f x y = f z y \<longrightarrow> x = z) \<and> a \<noteq> d \<longrightarrow> f a b \<noteq> f d b"
  by smt+

section {* Guidance for quantifier heuristics: patterns *}

lemma
  assumes "\<forall>x.
    SMT.trigger (SMT.Symb_Cons (SMT.Symb_Cons (SMT.pat (f x)) SMT.Symb_Nil) SMT.Symb_Nil)
    (f x = x)"
  shows "f 1 = 1"
  using assms using [[smt_trace]] by smt

lemma
  assumes "\<forall>x y.
    SMT.trigger (SMT.Symb_Cons (SMT.Symb_Cons (SMT.pat (f x))
      (SMT.Symb_Cons (SMT.pat (g y)) SMT.Symb_Nil)) SMT.Symb_Nil) (f x = g y)"
  shows "f a = g b"
  using assms by smt

section {* Meta-logical connectives *}

lemma
  "True \<Longrightarrow> True"
  "False \<Longrightarrow> True"
  "False \<Longrightarrow> False"
  "P' x \<Longrightarrow> P' x"
  "P \<Longrightarrow> P \<or> Q"
  "Q \<Longrightarrow> P \<or> Q"
  "\<not> P \<Longrightarrow> P \<longrightarrow> Q"
  "Q \<Longrightarrow> P \<longrightarrow> Q"
  "\<lbrakk>P; \<not> Q\<rbrakk> \<Longrightarrow> \<not> (P \<longrightarrow> Q)"
  "P' x \<equiv> P' x"
  "P' x \<equiv> Q' x \<Longrightarrow> P' x = Q' x"
  "P' x = Q' x \<Longrightarrow> P' x \<equiv> Q' x"
  "x \<equiv> y \<Longrightarrow> y \<equiv> z \<Longrightarrow> x \<equiv> (z::'a::type)"
  "x \<equiv> y \<Longrightarrow> (f x :: 'b::type) \<equiv> f y"
  "(\<And>x. g x) \<Longrightarrow> g a \<or> a"
  "(\<And>x y. h x y \<and> h y x) \<Longrightarrow> \<forall>x. h x x"
  "(p \<or> q) \<and> \<not> p \<Longrightarrow> q"
  "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)"
  by smt+

section {* Integers *}

lemma
  "(0::int) = 0"
  "(0::int) = (- 0)"
  "(1::int) = 1"
  "\<not> (-1 = (1::int))"
  "(0::int) < 1"
  "(0::int) \<le> 1"
  "-123 + 345 < (567::int)"
  "(123456789::int) < 2345678901"
  "(-123456789::int) < 2345678901"
  by smt+

lemma
  "(x::int) + 0 = x"
  "0 + x = x"
  "x + y = y + x"
  "x + (y + z) = (x + y) + z"
  "(x + y = 0) = (x = -y)"
  by smt+

lemma
  "(-1::int) = - 1"
  "(-3::int) = - 3"
  "-(x::int) < 0 \<longleftrightarrow> x > 0"
  "x > 0 \<longrightarrow> -x < 0"
  "x < 0 \<longrightarrow> -x > 0"
  by smt+

lemma
  "(x::int) - 0 = x"
  "0 - x = -x"
  "x < y \<longrightarrow> x - y < 0"
  "x - y = -(y - x)"
  "x - y = -y + x"
  "x - y - z = x - (y + z)"
  by smt+

lemma
  "(x::int) * 0 = 0"
  "0 * x = 0"
  "x * 1 = x"
  "1 * x = x"
  "x * -1 = -x"
  "-1 * x = -x"
  "3 * x = x * 3"
  by smt+

lemma
  "(0::int) div 0 = 0"
  "(x::int) div 0 = 0"
  "(0::int) div 1 = 0"
  "(1::int) div 1 = 1"
  "(3::int) div 1 = 3"
  "(x::int) div 1 = x"
  "(0::int) div -1 = 0"
  "(1::int) div -1 = -1"
  "(3::int) div -1 = -3"
  "(x::int) div -1 = -x"
  "(0::int) div 3 = 0"
  "(0::int) div -3 = 0"
  "(1::int) div 3 = 0"
  "(3::int) div 3 = 1"
  "(5::int) div 3 = 1"
  "(1::int) div -3 = -1"
  "(3::int) div -3 = -1"
  "(5::int) div -3 = -2"
  "(-1::int) div 3 = -1"
  "(-3::int) div 3 = -1"
  "(-5::int) div 3 = -2"
  "(-1::int) div -3 = 0"
  "(-3::int) div -3 = 1"
  "(-5::int) div -3 = 1"
  using [[z3_extensions]]
  by smt+

lemma
  "(0::int) mod 0 = 0"
  "(x::int) mod 0 = x"
  "(0::int) mod 1 = 0"
  "(1::int) mod 1 = 0"
  "(3::int) mod 1 = 0"
  "(x::int) mod 1 = 0"
  "(0::int) mod -1 = 0"
  "(1::int) mod -1 = 0"
  "(3::int) mod -1 = 0"
  "(x::int) mod -1 = 0"
  "(0::int) mod 3 = 0"
  "(0::int) mod -3 = 0"
  "(1::int) mod 3 = 1"
  "(3::int) mod 3 = 0"
  "(5::int) mod 3 = 2"
  "(1::int) mod -3 = -2"
  "(3::int) mod -3 = 0"
  "(5::int) mod -3 = -1"
  "(-1::int) mod 3 = 2"
  "(-3::int) mod 3 = 0"
  "(-5::int) mod 3 = 1"
  "(-1::int) mod -3 = -1"
  "(-3::int) mod -3 = 0"
  "(-5::int) mod -3 = -2"
  "x mod 3 < 3"
  "(x mod 3 = x) \<longrightarrow> (x < 3)"
  using [[z3_extensions]]
  by smt+

lemma
  "(x::int) = x div 1 * 1 + x mod 1"
  "x = x div 3 * 3 + x mod 3"
  using [[z3_extensions]]
  by smt+

lemma
  "abs (x::int) \<ge> 0"
  "(abs x = 0) = (x = 0)"
  "(x \<ge> 0) = (abs x = x)"
  "(x \<le> 0) = (abs x = -x)"
  "abs (abs x) = abs x"
  by smt+

lemma
  "min (x::int) y \<le> x"
  "min x y \<le> y"
  "z < x \<and> z < y \<longrightarrow> z < min x y"
  "min x y = min y x"
  "x \<ge> 0 \<longrightarrow> min x 0 = 0"
  "min x y \<le> abs (x + y)"
  by smt+

lemma
  "max (x::int) y \<ge> x"
  "max x y \<ge> y"
  "z > x \<and> z > y \<longrightarrow> z > max x y"
  "max x y = max y x"
  "x \<ge> 0 \<longrightarrow> max x 0 = x"
  "max x y \<ge> - abs x - abs y"
  by smt+

lemma
  "0 < (x::int) \<and> x \<le> 1 \<longrightarrow> x = 1"
  "x \<le> x"
  "x \<le> y \<longrightarrow> 3 * x \<le> 3 * y"
  "x < y \<longrightarrow> 3 * x < 3 * y"
  "x < y \<longrightarrow> x \<le> y"
  "(x < y) = (x + 1 \<le> y)"
  "\<not> (x < x)"
  "x \<le> y \<longrightarrow> y \<le> z \<longrightarrow> x \<le> z"
  "x < y \<longrightarrow> y \<le> z \<longrightarrow> x \<le> z"
  "x \<le> y \<longrightarrow> y < z \<longrightarrow> x \<le> z"
  "x < y \<longrightarrow> y < z \<longrightarrow> x < z"
  "x < y \<and> y < z \<longrightarrow> \<not> (z < x)"
  by smt+

section {* Reals *}

lemma
  "(0::real) = 0"
  "(0::real) = -0"
  "(0::real) = (- 0)"
  "(1::real) = 1"
  "\<not> (-1 = (1::real))"
  "(0::real) < 1"
  "(0::real) \<le> 1"
  "-123 + 345 < (567::real)"
  "(123456789::real) < 2345678901"
  "(-123456789::real) < 2345678901"
  by smt+

lemma
  "(x::real) + 0 = x"
  "0 + x = x"
  "x + y = y + x"
  "x + (y + z) = (x + y) + z"
  "(x + y = 0) = (x = -y)"
  by smt+

lemma
  "(-1::real) = - 1"
  "(-3::real) = - 3"
  "-(x::real) < 0 \<longleftrightarrow> x > 0"
  "x > 0 \<longrightarrow> -x < 0"
  "x < 0 \<longrightarrow> -x > 0"
  by smt+

lemma
  "(x::real) - 0 = x"
  "0 - x = -x"
  "x < y \<longrightarrow> x - y < 0"
  "x - y = -(y - x)"
  "x - y = -y + x"
  "x - y - z = x - (y + z)"
  by smt+

lemma
  "(x::real) * 0 = 0"
  "0 * x = 0"
  "x * 1 = x"
  "1 * x = x"
  "x * -1 = -x"
  "-1 * x = -x"
  "3 * x = x * 3"
  by smt+

lemma
  "(1/2 :: real) < 1"
  "(1::real) / 3 = 1 / 3"
  "(1::real) / -3 = - 1 / 3"
  "(-1::real) / 3 = - 1 / 3"
  "(-1::real) / -3 = 1 / 3"
  "(x::real) / 1 = x"
  "x > 0 \<longrightarrow> x / 3 < x"
  "x < 0 \<longrightarrow> x / 3 > x"
  using [[z3_extensions]]
  by smt+

lemma
  "(3::real) * (x / 3) = x"
  "(x * 3) / 3 = x"
  "x > 0 \<longrightarrow> 2 * x / 3 < x"
  "x < 0 \<longrightarrow> 2 * x / 3 > x"
  using [[z3_extensions]]
  by smt+

lemma
  "abs (x::real) \<ge> 0"
  "(abs x = 0) = (x = 0)"
  "(x \<ge> 0) = (abs x = x)"
  "(x \<le> 0) = (abs x = -x)"
  "abs (abs x) = abs x"
  by smt+

lemma
  "min (x::real) y \<le> x"
  "min x y \<le> y"
  "z < x \<and> z < y \<longrightarrow> z < min x y"
  "min x y = min y x"
  "x \<ge> 0 \<longrightarrow> min x 0 = 0"
  "min x y \<le> abs (x + y)"
  by smt+

lemma
  "max (x::real) y \<ge> x"
  "max x y \<ge> y"
  "z > x \<and> z > y \<longrightarrow> z > max x y"
  "max x y = max y x"
  "x \<ge> 0 \<longrightarrow> max x 0 = x"
  "max x y \<ge> - abs x - abs y"
  by smt+

lemma
  "x \<le> (x::real)"
  "x \<le> y \<longrightarrow> 3 * x \<le> 3 * y"
  "x < y \<longrightarrow> 3 * x < 3 * y"
  "x < y \<longrightarrow> x \<le> y"
  "\<not> (x < x)"
  "x \<le> y \<longrightarrow> y \<le> z \<longrightarrow> x \<le> z"
  "x < y \<longrightarrow> y \<le> z \<longrightarrow> x \<le> z"
  "x \<le> y \<longrightarrow> y < z \<longrightarrow> x \<le> z"
  "x < y \<longrightarrow> y < z \<longrightarrow> x < z"
  "x < y \<and> y < z \<longrightarrow> \<not> (z < x)"
  by smt+

section {* Datatypes, Records, and Typedefs *}

subsection {* Without support by the SMT solver *}

subsubsection {* Algebraic datatypes *}

lemma
  "x = fst (x, y)"
  "y = snd (x, y)"
  "((x, y) = (y, x)) = (x = y)"
  "((x, y) = (u, v)) = (x = u \<and> y = v)"
  "(fst (x, y, z) = fst (u, v, w)) = (x = u)"
  "(snd (x, y, z) = snd (u, v, w)) = (y = v \<and> z = w)"
  "(fst (snd (x, y, z)) = fst (snd (u, v, w))) = (y = v)"
  "(snd (snd (x, y, z)) = snd (snd (u, v, w))) = (z = w)"
  "(fst (x, y) = snd (x, y)) = (x = y)"
  "p1 = (x, y) \<and> p2 = (y, x) \<longrightarrow> fst p1 = snd p2"
  "(fst (x, y) = snd (x, y)) = (x = y)"
  "(fst p = snd p) = (p = (snd p, fst p))"
  using fst_conv snd_conv pair_collapse
  by smt+

lemma
  "[x] \<noteq> Nil"
  "[x, y] \<noteq> Nil"
  "x \<noteq> y \<longrightarrow> [x] \<noteq> [y]"
  "hd (x # xs) = x"
  "tl (x # xs) = xs"
  "hd [x, y, z] = x"
  "tl [x, y, z] = [y, z]"
  "hd (tl [x, y, z]) = y"
  "tl (tl [x, y, z]) = [z]"
  using list.sel(1,3) list.simps
  by smt+

lemma
  "fst (hd [(a, b)]) = a"
  "snd (hd [(a, b)]) = b"
  using fst_conv snd_conv pair_collapse list.sel(1,3) list.simps
  by smt+

subsubsection {* Records *}

record point =
  cx :: int
  cy :: int

record bw_point = point +
  black :: bool

lemma
  "\<lparr>cx = x, cy = y\<rparr> = \<lparr>cx = x', cy = y'\<rparr> \<Longrightarrow> x = x' \<and> y = y'"
  using point.simps
  by smt

lemma
  "cx \<lparr> cx = 3, cy = 4 \<rparr> = 3"
  "cy \<lparr> cx = 3, cy = 4 \<rparr> = 4"
  "cx \<lparr> cx = 3, cy = 4 \<rparr> \<noteq> cy \<lparr> cx = 3, cy = 4 \<rparr>"
  "\<lparr> cx = 3, cy = 4 \<rparr> \<lparr> cx := 5 \<rparr> = \<lparr> cx = 5, cy = 4 \<rparr>"
  "\<lparr> cx = 3, cy = 4 \<rparr> \<lparr> cy := 6 \<rparr> = \<lparr> cx = 3, cy = 6 \<rparr>"
  "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr> = p"
  using point.simps
  by smt+

lemma
  "cy (p \<lparr> cx := a \<rparr>) = cy p"
  "cx (p \<lparr> cy := a \<rparr>) = cx p"
  "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
  sorry

lemma
  "\<lparr>cx = x, cy = y, black = b\<rparr> = \<lparr>cx = x', cy = y', black = b'\<rparr> \<Longrightarrow> x = x' \<and> y = y' \<and> b = b'"
  using point.simps bw_point.simps
  by smt

lemma
  "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> = 3"
  "cy \<lparr> cx = 3, cy = 4, black = b \<rparr> = 4"
  "black \<lparr> cx = 3, cy = 4, black = b \<rparr> = b"
  "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> \<noteq> cy \<lparr> cx = 3, cy = 4, black = b \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> cx := 5 \<rparr> = \<lparr> cx = 5, cy = 4, black = b \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> cy := 6 \<rparr> = \<lparr> cx = 3, cy = 6, black = b \<rparr>"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
  using point.simps bw_point.simps
  by smt+

lemma
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> black := w \<rparr> = \<lparr> cx = 3, cy = 4, black = w \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = True \<rparr> \<lparr> black := False \<rparr> =
     \<lparr> cx = 3, cy = 4, black = False \<rparr>"
  "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> =
     p \<lparr> black := True \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
    apply (smt add_One add_inc bw_point.update_convs(1) default_unit_def inc.simps(2) one_plus_BitM
      semiring_norm(6,26))
   apply (smt bw_point.update_convs(1))
  apply (smt bw_point.cases_scheme bw_point.update_convs(1) point.update_convs(1,2))
  done

subsubsection {* Type definitions *}

typedef int' = "UNIV::int set" by (rule UNIV_witness)

definition n0 where "n0 = Abs_int' 0"
definition n1 where "n1 = Abs_int' 1"
definition n2 where "n2 = Abs_int' 2"
definition plus' where "plus' n m = Abs_int' (Rep_int' n + Rep_int' m)"

lemma
  "n0 \<noteq> n1"
  "plus' n1 n1 = n2"
  "plus' n0 n2 = n2"
  by (smt n0_def n1_def n2_def plus'_def Abs_int'_inverse Rep_int'_inverse UNIV_I)+

subsection {* With support by the SMT solver (but without proofs) *}

subsubsection {* Algebraic datatypes *}

lemma
  "x = fst (x, y)"
  "y = snd (x, y)"
  "((x, y) = (y, x)) = (x = y)"
  "((x, y) = (u, v)) = (x = u \<and> y = v)"
  "(fst (x, y, z) = fst (u, v, w)) = (x = u)"
  "(snd (x, y, z) = snd (u, v, w)) = (y = v \<and> z = w)"
  "(fst (snd (x, y, z)) = fst (snd (u, v, w))) = (y = v)"
  "(snd (snd (x, y, z)) = snd (snd (u, v, w))) = (z = w)"
  "(fst (x, y) = snd (x, y)) = (x = y)"
  "p1 = (x, y) \<and> p2 = (y, x) \<longrightarrow> fst p1 = snd p2"
  "(fst (x, y) = snd (x, y)) = (x = y)"
  "(fst p = snd p) = (p = (snd p, fst p))"
  using fst_conv snd_conv pair_collapse
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "[x] \<noteq> Nil"
  "[x, y] \<noteq> Nil"
  "x \<noteq> y \<longrightarrow> [x] \<noteq> [y]"
  "hd (x # xs) = x"
  "tl (x # xs) = xs"
  "hd [x, y, z] = x"
  "tl [x, y, z] = [y, z]"
  "hd (tl [x, y, z]) = y"
  "tl (tl [x, y, z]) = [z]"
  using list.sel(1,3)
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "fst (hd [(a, b)]) = a"
  "snd (hd [(a, b)]) = b"
  using fst_conv snd_conv pair_collapse list.sel(1,3)
  using [[smt_oracle, z3_extensions]]
  by smt+

subsubsection {* Records *}

lemma
  "\<lparr>cx = x, cy = y\<rparr> = \<lparr>cx = x', cy = y'\<rparr> \<Longrightarrow> x = x' \<and> y = y'"
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "cx \<lparr> cx = 3, cy = 4 \<rparr> = 3"
  "cy \<lparr> cx = 3, cy = 4 \<rparr> = 4"
  "cx \<lparr> cx = 3, cy = 4 \<rparr> \<noteq> cy \<lparr> cx = 3, cy = 4 \<rparr>"
  "\<lparr> cx = 3, cy = 4 \<rparr> \<lparr> cx := 5 \<rparr> = \<lparr> cx = 5, cy = 4 \<rparr>"
  "\<lparr> cx = 3, cy = 4 \<rparr> \<lparr> cy := 6 \<rparr> = \<lparr> cx = 3, cy = 6 \<rparr>"
  "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr> = p"
  using point.simps
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "cy (p \<lparr> cx := a \<rparr>) = cy p"
  "cx (p \<lparr> cy := a \<rparr>) = cx p"
  "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
  using point.simps
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "\<lparr>cx = x, cy = y, black = b\<rparr> = \<lparr>cx = x', cy = y', black = b'\<rparr> \<Longrightarrow> x = x' \<and> y = y' \<and> b = b'"
  using [[smt_oracle, z3_extensions]]
  by smt

lemma
  "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> = 3"
  "cy \<lparr> cx = 3, cy = 4, black = b \<rparr> = 4"
  "black \<lparr> cx = 3, cy = 4, black = b \<rparr> = b"
  "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> \<noteq> cy \<lparr> cx = 3, cy = 4, black = b \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> cx := 5 \<rparr> = \<lparr> cx = 5, cy = 4, black = b \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> cy := 6 \<rparr> = \<lparr> cx = 3, cy = 6, black = b \<rparr>"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> = p"
  "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
     p \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
  using point.simps bw_point.simps
  using [[smt_oracle, z3_extensions]]
  by smt+

lemma
  "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> black := w \<rparr> = \<lparr> cx = 3, cy = 4, black = w \<rparr>"
  "\<lparr> cx = 3, cy = 4, black = True \<rparr> \<lparr> black := False \<rparr> =
     \<lparr> cx = 3, cy = 4, black = False \<rparr>"
  sorry

lemma
  "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> =
     p \<lparr> black := True \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
  using point.simps bw_point.simps
  using [[smt_oracle, z3_extensions]]
  by smt

subsubsection {* Type definitions *}

lemma
  "n0 \<noteq> n1"
  "plus' n1 n1 = n2"
  "plus' n0 n2 = n2"
  using [[smt_oracle, z3_extensions]]
  by (smt n0_def n1_def n2_def plus'_def)+

section {* Function updates *}

lemma
  "(f (i := v)) i = v"
  "i1 \<noteq> i2 \<longrightarrow> (f (i1 := v)) i2 = f i2"
  "i1 \<noteq> i2 \<longrightarrow> (f (i1 := v1, i2 := v2)) i1 = v1"
  "i1 \<noteq> i2 \<longrightarrow> (f (i1 := v1, i2 := v2)) i2 = v2"
  "i1 = i2 \<longrightarrow> (f (i1 := v1, i2 := v2)) i1 = v2"
  "i1 = i2 \<longrightarrow> (f (i1 := v1, i2 := v2)) i1 = v2"
  "i1 \<noteq> i2 \<and>i1 \<noteq> i3 \<and>  i2 \<noteq> i3 \<longrightarrow> (f (i1 := v1, i2 := v2)) i3 = f i3"
  using fun_upd_same fun_upd_apply
  by smt+

section {* Sets *}

lemma Empty: "x \<notin> {}" by simp

lemmas smt_sets = Empty UNIV_I Un_iff Int_iff

lemma
  "x \<notin> {}"
  "x \<in> UNIV"
  "x \<in> A \<union> B \<longleftrightarrow> x \<in> A \<or> x \<in> B"
  "x \<in> P \<union> {} \<longleftrightarrow> x \<in> P"
  "x \<in> P \<union> UNIV"
  "x \<in> P \<union> Q \<longleftrightarrow> x \<in> Q \<union> P"
  "x \<in> P \<union> P \<longleftrightarrow> x \<in> P"
  "x \<in> P \<union> (Q \<union> R) \<longleftrightarrow> x \<in> (P \<union> Q) \<union> R"
  "x \<in> A \<inter> B \<longleftrightarrow> x \<in> A \<and> x \<in> B"
  "x \<notin> P \<inter> {}"
  "x \<in> P \<inter> UNIV \<longleftrightarrow> x \<in> P"
  "x \<in> P \<inter> Q \<longleftrightarrow> x \<in> Q \<inter> P"
  "x \<in> P \<inter> P \<longleftrightarrow> x \<in> P"
  "x \<in> P \<inter> (Q \<inter> R) \<longleftrightarrow> x \<in> (P \<inter> Q) \<inter> R"
  "{x. x \<in> P} = {y. y \<in> P}"
  by (smt smt_sets)+

end


theory BExp imports AExp begin

subsection "Boolean Expressions"

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

text_raw{*\snip{BExpbvaldef}{1}{2}{% *}
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw{*}%endsnip*}

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

text{* To improve automation: *}

lemma bval_And_if[simp]:
  "bval (And b1 b2) s = (if bval b1 s then bval b2 s else False)"
by(simp)

declare bval.simps(3)[simp del]

subsection "Constant Folding"

text{* Optimizing constructors: *}

text_raw{*\snip{BExplessdef}{0}{2}{% *}
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

text_raw{*\snip{BExpanddef}{2}{2}{% *}
fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"
text_raw{*}%endsnip*}

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

text_raw{*\snip{BExpnotdef}{2}{2}{% *}
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"
text_raw{*}%endsnip*}

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text{* Now the overall optimizer: *}

text_raw{*\snip{BExpbsimpdef}{0}{2}{% *}
fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end


theory RmMultiset imports "~~/src/HOL/Library/Multiset" begin

definition rm_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "rm_mset x M \<equiv> M - replicate_mset (count M x) x"

lemma diff_id[rule_format]: "A - B = A \<longrightarrow> (\<forall>a \<in># A. a \<notin># B)"
  apply(rule_tac M=B in multiset_induct)
  apply(simp)
  by (metis diff_empty disjunct_not_in multiset_inter_def)

lemma rm_mset_idD[rule_format]: "\<forall>x. rm_mset x M = M \<longrightarrow> x \<notin># M"
  apply(unfold rm_mset_def)
  apply(rule multiset_induct)
  apply(simp)
  apply(clarify)
  apply(drule diff_id)
  apply(assumption)
  apply(erule notE)
  apply(case_tac "x = xa")
  apply(auto)
  done

lemma rm_mset_idI: "x \<notin># M \<Longrightarrow> rm_mset x M = M"
  apply(unfold rm_mset_def)
  apply(subst (asm) count_eq_zero_iff[symmetric])
  apply(erule ssubst)
  apply(subst replicate_mset_0)
  apply(subst diff_empty)
  apply(rule refl)
  done

theorem rm_mset_id_iff: "x \<notin># M \<longleftrightarrow> rm_mset x M = M"
  apply(rule iffI)
  apply(erule rm_mset_idI)
  apply(erule rm_mset_idD)
  done

theorem rm_mset_plus_replicate_mset_count_cancel: "(rm_mset x M) + replicate_mset (count M x) x = M"
  apply(unfold rm_mset_def)
  by (meson count_le_replicate_mset_subset_eq less_imp_le not_le subset_mset.diff_add)

theorem nmem_rm_mset: "x \<notin># rm_mset x M"
  by (simp add: rm_mset_def in_diff_count)

theorem count_rm_set: "count (rm_mset x M) x = (if x \<in># M then 0 else count M x)"
  apply(case_tac "x \<in># M")
  apply(subst if_P)
  apply(assumption)
  apply(subst rm_mset_def)
  apply(subst count_diff)
  apply(subst count_replicate_mset)
  apply(subst if_P)
  apply(rule refl)
  apply(rule diff_self_eq_0)
  apply(subst if_not_P)
  apply(assumption)
  apply(subst (asm) rm_mset_id_iff)
  apply(erule ssubst)
  apply(rule refl)
  done
end


theory Simulink
imports Main
begin

(*fun Gain :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "Gain x y = mult x y"*)
primrec add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

primrec mult :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "mult 0 n = 0" |
  "mult (Suc m) n = add (mult m n) m"

primrec pow :: "nat => nat => nat" where
  "pow 0 x       = Suc 0" |
  "pow (Suc n) x = mult x (pow n x)"

definition
  threegains :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "threegains t x y z = t*x*y*z"
declare threegains_def[simp]

primrec feedback :: "nat \<Rightarrow> nat" where
  "feedback 0 = Suc(0)"|
  "feedback (Suc t) = (feedback t)*3"

theorem sum_of_naturals:
  "2 * (\<Sum>i::nat=0..n. i) = n * (n + 1)"
  (is "?P n" is "?S n = _")
proof (induct n)
  show "?P 0" by simp
next
  fix n have "?S (n + 1) = ?S n + 2 * (n + 1)"
    by simp
  assume "?P n"
  also have "\<dots> + 2 * (n + 1) = (n + 1) * (n + 2)"
    by simp
  finally show "?P (Suc n)"
    by simp
qed

lemma th1: "threegains 3 4 5 6 = 360"
  apply(simp)
  done

(*
lemma th3: "feedback t = pow 3 t"
  apply(induct t)
  apply(simp)
  apply(auto)
  apply(sym)
done *)
(*\<lbrakk> if foo then a \<noteq> a else b \<noteq> b \<rbrakk>*)

(*
lemma th2: "\<not>(t>5) \<or> ((feedback t) > 200)" (is "?H(t)" is "?P(t)\<or>?Q(t)" is "(?P(t))\<or>(?F(t) > 200)")
proof(induct t)
    case 0 show "?P 0 \<or> ?Q 0" by simp
  next
    have b: "?F (Suc(t)) \<ge> ?F(t)" by simp
    assume a:" ?F(t) > 200"
    from b and a have c: "?F(Suc(t)) > 200" by simp
    from c have e: "?Q(Suc(t))" by simp
    assume d: "?P(t) = False"
    from d have f:"?P(Suc(t)) = False" by simp
    from f and e have g: "?P(Suc(t))\<or>?Q(Suc(t))" by simp
    from a and d and g have h: "?P(t)\<or>?Q(t) \<Longrightarrow> ?P(Suc(t))\<or>?Q(Suc(t))" by simp
    from a and d have "?H(Suc(t))" by simp
  qed
*)
lemma th2: "\<not>(t>5) \<or> ((feedback t) > 200)"
proof (induct t)
  case 0
  show ?case by simp
next
  case (Suc t)
  thus ?case
  proof
    assume "\<not>t > 5"
    moreover have "feedback 6 = 729" by code_simp
      -- \<open>"simp add: eval_nat_numeral" would also work\<close>
    ultimately show ?thesis
      by (cases "t = 5") auto
  next
    assume "feedback t > 200"
    thus ?thesis by simp
  qed
qed

lemma th3: "\<not>(t>5) \<or> ((feedback t) > 200)"
proof (induct t)
  case (Suc t)
  moreover have "feedback 6 = 729" by code_simp
  ultimately show ?case by (cases "t = 5") auto
qed simp_all


section \<open>Abstract Dijkstra Algorithm\<close>
theory Dijkstra_Abstract
imports Directed_Graph
begin

subsection \<open>Abstract Algorithm\<close>

type_synonym 'v estimate = "'v \<Rightarrow> enat"
text \<open>We fix a start node and a weighted graph\<close>
locale Dijkstra = WGraph w for w :: "('v) wgraph" +
  fixes s :: 'v
begin

text \<open>Relax all outgoing edges of node \<open>u\<close>\<close>
definition relax_outgoing :: "'v \<Rightarrow> 'v estimate \<Rightarrow> 'v estimate"
  where "relax_outgoing u D \<equiv> \<lambda>v. min (D v) (D u + w (u,v))"

text \<open>Initialization\<close>
definition "initD \<equiv> (\<lambda>_. \<infinity>)(s:=0)"
definition "initS \<equiv> {}"

text \<open>Relaxing will never increase estimates\<close>
lemma relax_mono: "relax_outgoing u D v \<le> D v"
  by (auto simp: relax_outgoing_def)

definition "all_dnodes \<equiv> Set.insert s { v . \<exists>u. w (u,v)\<noteq>\<infinity> }"
definition "unfinished_dnodes S \<equiv> all_dnodes - S "

lemma unfinished_nodes_subset: "unfinished_dnodes S \<subseteq> all_dnodes"
  by (auto simp: unfinished_dnodes_def)

end

subsubsection \<open>Invariant\<close>
text \<open>The invariant is defined as locale\<close>

locale Dijkstra_Invar = Dijkstra w s for w and s :: 'v +
  fixes D :: "'v estimate" and S :: "'v set"
  assumes upper_bound: \<open>\<delta> s u \<le> D u\<close> \<comment> \<open>\<open>D\<close> is a valid estimate\<close>
  assumes s_in_S: \<open>s\<in>S \<or> (D=(\<lambda>_. \<infinity>)(s:=0) \<and> S={})\<close> \<comment> \<open>The start node is
    finished, or we are in initial state\<close>
  assumes S_precise: "u\<in>S \<Longrightarrow> D u = \<delta> s u" \<comment> \<open>Finished nodes have precise
    estimate\<close>
  assumes S_relaxed: \<open>v\<in>S \<Longrightarrow> D u \<le> \<delta> s v + w (v,u)\<close> \<comment> \<open>Outgoing edges of
    finished nodes have been relaxed, using precise distance\<close>
begin

abbreviation (in Dijkstra) "D_invar \<equiv> Dijkstra_Invar w s"

text \<open>The invariant holds for the initial state\<close>

text \<open>Relaxing some edges maintains the upper bound property\<close>
lemma maintain_upper_bound: "\<delta> s u \<le> (relax_outgoing v D) u"
  apply (clarsimp simp: relax_outgoing_def upper_bound split: prod.splits)
  using triangle upper_bound add_right_mono dual_order.trans by blast

text \<open>Relaxing edges will not affect nodes with already precise estimates\<close>
lemma relax_precise_id: "D v = \<delta> s v \<Longrightarrow> relax_outgoing u D v = \<delta> s v"
  using maintain_upper_bound upper_bound relax_mono
  by (metis antisym)

text \<open>In particular, relaxing edges will not affect finished nodes\<close>
lemma relax_finished_id: "v\<in>S \<Longrightarrow> relax_outgoing u D v = D v"
  by (simp add: S_precise relax_precise_id)

text \<open>The least (finite) estimate among all nodes \<open>u\<close> not in \<open>S\<close> is already precise.
  This will allow us to add the node \<open>u\<close> to \<open>S\<close>. \<close>
lemma maintain_S_precise_and_connected:
  assumes UNS: "u\<notin>S"
  assumes MIN: "\<forall>v. v\<notin>S \<longrightarrow> D u \<le> D v"
  shows "D u = \<delta> s u"
  text \<open>We start with a case distinction whether we are in the first
    step of the loop, where we process the start node, or in subsequent steps,
    where the start node has already been finished.\<close>
proof (cases "u=s")
  assume [simp]: "u=s" \<comment> \<open>First step of loop\<close>
  then show ?thesis using \<open>u\<notin>S\<close> s_in_S by simp
next
  assume \<open>u\<noteq>s\<close> \<comment> \<open>Later step of loop\<close>
  text \<open>The start node has already been finished\<close>
  with s_in_S MIN have \<open>s\<in>S\<close> apply clarsimp using infinity_ne_i0 by metis

  show ?thesis
  text \<open>Next, we handle the case that \<open>u\<close> is unreachable.\<close>
  proof (cases \<open>\<delta> s u < \<infinity>\<close>)
    assume "\<not>(\<delta> s u < \<infinity>)" \<comment> \<open>Node is unreachable (infinite distance)\<close>
    text \<open>By the upper-bound property, we get \<open>D u = \<delta> s u = \<infinity>\<close>\<close>
    then show ?thesis using upper_bound[of u] by auto
  next
    assume "\<delta> s u < \<infinity>" \<comment> \<open>Main case: Node has finite distance\<close>

    text \<open>Consider a shortest path from \<open>s\<close> to \<open>u\<close>\<close>
    obtain p where "path s p u" and DSU: "\<delta> s u = sum_list p"
      by (rule obtain_shortest_path)
    text \<open>It goes from inside \<open>S\<close> to outside \<open>S\<close>, so there must be an edge at the border.
      Let \<open>(x,y)\<close> be such an edge, with \<open>x\<in>S\<close> and \<open>y\<notin>S\<close>.\<close>
    from find_leave_edgeE[OF \<open>path s p u\<close> \<open>s\<in>S\<close> \<open>u\<notin>S\<close>] obtain p1 x y p2 where
      [simp]: "p = p1 @ w (x, y) # p2"
      and DECOMP: "x \<in> S" "y \<notin> S" "path s p1 x" "path y p2 u" .
    text \<open>As prefixes of shortest paths are again shortest paths, the shortest
          path to \<open>y\<close> ends with edge \<open>(x,y)\<close> \<close>
    have DSX: "\<delta> s x = sum_list p1" and DSY: "\<delta> s y = \<delta> s x + w (x, y)"
      using shortest_path_prefix[of s p1 x "w (x,y)#p2" u]
        and shortest_path_prefix[of s "p1@[w (x,y)]" y p2 u]
        and \<open>\<delta> s u < \<infinity>\<close> DECOMP
        by (force simp: DSU)+
    text \<open>Upon adding \<open>x\<close> to \<open>S\<close>, this edge has been relaxed with the precise
       estimate for \<open>x\<close>. At this point the estimate for \<open>y\<close> has become
       precise, too\<close>
    with \<open>x\<in>S\<close> have "D y = \<delta> s y"
      by (metis S_relaxed antisym_conv upper_bound)
    moreover text \<open>The shortest path to \<open>y\<close> is a prefix of that to \<open>u\<close>, thus
      it shorter or equal\<close>
    have "\<dots> \<le> \<delta> s u" using DSU by (simp add: DSX DSY)
    moreover text \<open>The estimate for \<open>u\<close> is an upper bound\<close>
    have "\<dots> \<le> D u" using upper_bound by (auto)
    moreover text \<open>\<open>u\<close> was a node with smallest estimate\<close>
    have "\<dots> \<le> D y" using \<open>u\<notin>S\<close> \<open>y\<notin>S\<close> MIN by auto
    ultimately text \<open>This closed a cycle in the inequation chain. Thus, by
      antisymmetry, all items are equal. In particular, \<open>D u = \<delta> s u\<close>, qed.\<close>
    show "D u = \<delta> s u" by simp
  qed
qed

text \<open>A step of Dijkstra's algorithm maintains the invariant.
  More precisely, in a step of Dijkstra's algorithm,
  we pick a node \<open>u\<notin>S\<close> with least finite estimate, relax the outgoing
  edges of \<open>u\<close>, and add \<open>u\<close> to \<open>S\<close>.\<close>
theorem maintain_D_invar:
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u < \<infinity>"
  assumes MIN: "\<forall>v. v\<notin>S \<longrightarrow> D u \<le> D v"
  shows "D_invar (relax_outgoing u D) (Set.insert u S)"
  apply (cases \<open>s\<in>S\<close>)
  subgoal
    apply (unfold_locales)
    subgoal by (simp add: maintain_upper_bound)
    subgoal by simp
    subgoal
      using maintain_S_precise_and_connected[OF UNS MIN] S_precise
      by (auto simp: relax_precise_id)
    subgoal
      using maintain_S_precise_and_connected[OF UNS MIN]
      by (auto simp: relax_outgoing_def S_relaxed min.coboundedI1)
    done
  subgoal
    apply unfold_locales
    using s_in_S UNI distance_direct
    by (auto simp: relax_outgoing_def split: if_splits)
  done

text \<open>When the algorithm is finished, i.e., when there are
  no unfinished nodes with finite estimates left,
  then all estimates are accurate.\<close>
lemma invar_finish_imp_correct:
  assumes F: "\<forall>u. u\<notin>S \<longrightarrow> D u = \<infinity>"
  shows "D u = \<delta> s u"
proof (cases "u\<in>S")
  assume "u\<in>S" text \<open>The estimates of finished nodes are accurate\<close>
  then show ?thesis using S_precise by simp
next
  assume \<open>u\<notin>S\<close> text \<open>\<open>D u\<close> is minimal, and minimal estimates are precise\<close>
  then show ?thesis
    using F maintain_S_precise_and_connected[of u] by auto

qed

text \<open>A step decreases the set of unfinished nodes.\<close>
lemma unfinished_nodes_decr:
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u < \<infinity>"
  shows "unfinished_dnodes (Set.insert u S) \<subset> unfinished_dnodes S"
proof -
  text \<open>There is a path to \<open>u\<close>\<close>
  from UNI have "\<delta> s u < \<infinity>" using upper_bound[of u] leD by fastforce

  text \<open>Thus, \<open>u\<close> is among \<open>all_dnodes\<close>\<close>
  have "u\<in>all_dnodes"
  proof -
    obtain p where "path s p u" "sum_list p < \<infinity>"
      apply (rule obtain_shortest_path[of s u])
      using \<open>\<delta> s u < \<infinity>\<close> by auto
    with \<open>u\<notin>S\<close> show ?thesis
      apply (cases p rule: rev_cases)
      by (auto simp: Dijkstra.all_dnodes_def)
  qed
  text \<open>Which implies the proposition\<close>
  with \<open>u\<notin>S\<close> show ?thesis by (auto simp: unfinished_dnodes_def)
qed

end

subsection \<open>Refinement by Priority Map and Map\<close>
text \<open>
  In a second step, we implement \<open>D\<close> and \<open>S\<close> by a priority map \<open>Q\<close> and a map \<open>V\<close>.
  Both map nodes to finite weights, where \<open>Q\<close> maps unfinished nodes, and \<open>V\<close>
  maps finished nodes.

  Note that this implementation is slightly non-standard:
  In the standard implementation, \<open>Q\<close> contains also unfinished nodes with
  infinite weight.

  We chose this implementation because it avoids enumerating all nodes of
  the graph upon initialization of \<open>Q\<close>.
  However, on relaxing an edge to a node not in \<open>Q\<close>, we require an extra
  lookup to check whether the node is finished.
\<close>

subsubsection \<open>Implementing \<open>enat\<close> by Option\<close>

text \<open>Our maps are functions to \<open>nat option\<close>,which are interpreted as \<open>enat\<close>,
  \<open>None\<close> being \<open>\<infinity>\<close>\<close>

fun enat_of_option :: "nat option \<Rightarrow> enat" where
  "enat_of_option None = \<infinity>"
| "enat_of_option (Some n) = enat n"

lemma enat_of_option_inj[simp]: "enat_of_option x = enat_of_option y \<longleftrightarrow> x=y"
  by (cases x; cases y; simp)

lemma enat_of_option_simps[simp]:
  "enat_of_option x = enat n \<longleftrightarrow> x = Some n"
  "enat_of_option x = \<infinity> \<longleftrightarrow> x = None"
  "enat n = enat_of_option x \<longleftrightarrow> x = Some n"
  "\<infinity> = enat_of_option x \<longleftrightarrow> x = None"
  by (cases x; auto; fail)+

lemma enat_of_option_le_conv:
  "enat_of_option m \<le> enat_of_option n \<longleftrightarrow> (case (m,n) of
      (_,None) \<Rightarrow> True
    | (Some a, Some b) \<Rightarrow> a\<le>b
    | (_, _) \<Rightarrow> False
  )"
  by (auto split: option.split)

subsubsection \<open>Implementing \<open>D,S\<close> by Priority Map and Map\<close>
context Dijkstra begin

text \<open>We define a coupling relation, that connects the concrete with the
  abstract data. \<close>
definition "coupling Q V D S \<equiv>
  D = enat_of_option o (V ++ Q)
\<and> S = dom V
\<and> dom V \<inter> dom Q = {}"

text \<open>Note that our coupling relation is functional.\<close>
(* TODO: Why not use functions instead? *)
lemma coupling_fun: "coupling Q V D S \<Longrightarrow> coupling Q V D' S' \<Longrightarrow> D'=D \<and> S'=S"
  by (auto simp: coupling_def)

text \<open>The concrete version of the invariant.\<close>
definition "D_invar' Q V \<equiv>
  \<exists>D S. coupling Q V D S \<and> D_invar D S"

text \<open>Refinement of \<open>relax-outgoing\<close>\<close>

definition "relax_outgoing' u du V Q v \<equiv>
  case w (u,v) of
    \<infinity> \<Rightarrow> Q v
  | enat d \<Rightarrow> (case Q v of
      None \<Rightarrow> if v\<in>dom V then None else Some (du+d)
    | Some d' \<Rightarrow> Some (min d' (du+d)))
"

text \<open>A step preserves the coupling relation.\<close>
lemma (in Dijkstra_Invar) coupling_step:
  assumes C: "coupling Q V D S"
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u = enat du"

  shows "coupling
    ((relax_outgoing' u du V Q)(u:=None)) (V(u\<mapsto>du))
    (relax_outgoing u D) (Set.insert u S)"
  using C unfolding coupling_def
proof (intro ext conjI; elim conjE)
  assume \<alpha>: "D = enat_of_option \<circ> V ++ Q" "S = dom V"
     and DD: "dom V \<inter> dom Q = {}"

  show "Set.insert u S = dom (V(u \<mapsto> du))"
    by (auto simp: \<alpha>)

  have [simp]: "Q u = Some du" "V u = None"
    using DD UNI UNS by (auto simp: \<alpha>)

  from DD
  show "dom (V(u \<mapsto> du)) \<inter> dom ((relax_outgoing' u du V Q)(u := None)) = {}"
    by (auto 0 3
          simp: relax_outgoing'_def dom_def
          split: if_splits enat.splits option.splits)

  fix v

  show "relax_outgoing u D v
    = (enat_of_option \<circ> V(u \<mapsto> du) ++ (relax_outgoing' u du V Q)(u := None)) v"
  proof (cases "v\<in>S")
    case True
    then show ?thesis using DD
      apply (simp add: relax_finished_id)
      by (auto
        simp: relax_outgoing'_def map_add_apply \<alpha> min_def
        split: option.splits enat.splits)
  next
    case False
    then show ?thesis
      by (auto
        simp: relax_outgoing_def relax_outgoing'_def map_add_apply \<alpha> min_def
        split: option.splits enat.splits)
  qed
qed

text \<open>Refinement of initial state\<close>
definition "initQ \<equiv> Map.empty(s\<mapsto>0)"
definition "initV \<equiv> Map.empty"

lemma coupling_init:
  "coupling initQ initV initD initS"
  unfolding coupling_def initD_def initQ_def initS_def initV_def
  by (auto
    simp: coupling_def relax_outgoing_def map_add_apply enat_0
    split: option.split enat.split
    del: ext intro!: ext)

lemma coupling_cond:
  assumes "coupling Q V D S"
  shows "(Q = Map.empty) \<longleftrightarrow> (\<forall>u. u\<notin>S \<longrightarrow> D u = \<infinity>)"
  using assms
  by (fastforce simp add: coupling_def)

text \<open>Termination argument: Refinement of unfinished nodes.\<close>
definition "unfinished_dnodes' V \<equiv> unfinished_dnodes (dom V)"

lemma coupling_unfinished:
  "coupling Q V D S \<Longrightarrow> unfinished_dnodes' V = unfinished_dnodes S"
  by (auto simp: coupling_def unfinished_dnodes'_def unfinished_dnodes_def)

subsubsection \<open>Implementing graph by successor list\<close>

definition "relax_outgoing'' l du V Q = fold (\<lambda>(d,v) Q.
  case Q v of None \<Rightarrow> if v\<in>dom V then Q else Q(v\<mapsto>du+d)
            | Some d' \<Rightarrow> Q(v\<mapsto>min (du+d) d')) l Q"

lemma relax_outgoing''_refine:
  assumes "set l = {(d,v). w (u,v) = enat d}"
  shows "relax_outgoing'' l du V Q = relax_outgoing' u du V Q"
proof
  fix v

  have aux1:
     "relax_outgoing'' l du V Q v
     = (if v\<in>snd`set l then relax_outgoing' u du V Q v else Q v)"
  if "set l \<subseteq> {(d,v). w (u,v) = enat d}"
    using that
    apply (induction l arbitrary: Q v)
    by (auto
      simp: relax_outgoing''_def relax_outgoing'_def image_iff
      split!: if_splits option.splits)

  have aux2:
    "relax_outgoing' u du V Q v = Q v" if "w (u,v) = \<infinity>"
    using that by (auto simp: relax_outgoing'_def)

  show "relax_outgoing'' l du V Q v = relax_outgoing' u du V Q v"
    using aux1
    apply (cases "w (u,v)")
    by (all \<open>force simp: aux2 assms\<close>)
qed

end

end


section \<open>The Pointwise Less-Than Relation Between Two Sets\<close>

theory Nash_Extras
  imports "HOL-Library.Ramsey" "HOL-Library.Countable_Set"

begin

definition less_sets :: "['a::order set, 'a::order set] \<Rightarrow> bool" (infixr "\<lless>" 50)
    where "A \<lless> B \<equiv> \<forall>x\<in>A. \<forall>y\<in>B. x < y"

lemma less_sets_empty[iff]: "S \<lless> {}" "{} \<lless> T"
  by (auto simp: less_sets_def)

lemma less_setsD: "\<lbrakk>A \<lless> B; a \<in> A; b \<in> B\<rbrakk> \<Longrightarrow> a < b"
  by (auto simp: less_sets_def)

lemma less_sets_irrefl [simp]: "A \<lless> A \<longleftrightarrow> A = {}"
  by (auto simp: less_sets_def)

lemma less_sets_trans: "\<lbrakk>A \<lless> B; B \<lless> C; B \<noteq> {}\<rbrakk> \<Longrightarrow> A \<lless> C"
  unfolding less_sets_def using less_trans by blast

lemma less_sets_weaken1: "\<lbrakk>A' \<lless> B; A \<subseteq> A'\<rbrakk> \<Longrightarrow> A \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_weaken2: "\<lbrakk>A \<lless> B'; B \<subseteq> B'\<rbrakk> \<Longrightarrow> A \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_imp_disjnt: "A \<lless> B \<Longrightarrow> disjnt A B"
  by (auto simp: less_sets_def disjnt_def)

lemma less_sets_UN1: "less_sets (\<Union>\<A>) B \<longleftrightarrow> (\<forall>A\<in>\<A>. A \<lless> B)"
  by (auto simp: less_sets_def)

lemma less_sets_UN2: "less_sets A (\<Union> \<B>) \<longleftrightarrow> (\<forall>B\<in>\<B>. A \<lless> B)"
  by (auto simp: less_sets_def)

lemma less_sets_Un1: "less_sets (A \<union> A') B \<longleftrightarrow> A \<lless> B \<and> A' \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_Un2: "less_sets A (B \<union> B') \<longleftrightarrow> A \<lless> B \<and> A \<lless> B'"
  by (auto simp: less_sets_def)

lemma strict_sorted_imp_less_sets:
  "strict_sorted (as @ bs) \<Longrightarrow> (list.set as) \<lless> (list.set bs)"
  by (simp add: less_sets_def sorted_wrt_append)

lemma Sup_nat_less_sets_singleton:
  fixes n::nat
  assumes "Sup T < n" "finite T"
  shows "less_sets T {n}"
  using assms Max_less_iff
  by (auto simp: Sup_nat_def less_sets_def split: if_split_asm)

end


(*  Title:      Depth-First Search
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Maintainer: Yasuhiko Minamide <minamide at cs.tsukuba.ac.jp>
*)

section "Depth-First Search"

theory DFS
imports Main "Eval_Base.Eval_Base"
begin

subsection "Definition of Graphs"

typedecl node
type_synonym graph = "(node * node) list"

primrec nexts :: "[graph, node] \<Rightarrow> node list"
where
  "nexts [] n = []"
| "nexts (e#es) n = (if fst e = n then snd e # nexts es n else nexts es n)"

definition nextss :: "[graph, node list] \<Rightarrow> node set"
  where "nextss g xs = set g `` set xs"

lemma nextss_Cons: "nextss g (x#xs) = set (nexts g x) \<union> nextss g xs"
  unfolding nextss_def by (auto simp add:Image_def nexts_set)

definition reachable :: "[graph, node list] \<Rightarrow> node set"
  where "reachable g xs = (set g)\<^sup>* `` set xs"

subsection "Depth-First Search with Stack"

definition nodes_of :: "graph \<Rightarrow> node set"
  where "nodes_of g = set (map fst g @ map snd g)"

lemma [simp]: "finite (nodes_of g - set ys)"
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

function
  dfs :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  dfs_base: "dfs g [] ys = ys"
| dfs_inductive: "dfs g (x#xs) ys = (if List.member ys x then dfs g xs ys
                        else dfs g (nexts g x@xs) (x#ys))"
by pat_completeness auto

termination
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
by (case_tac  "x \<in> nodes_of g") (auto simp add: List.member_def)

text \<open>
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
\<close>

subsection "Depth-First Search with Nested-Recursion"

function
  dfs2 :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  "dfs2 g [] ys = ys"
|  dfs2_inductive:
          "dfs2 g (x#xs) ys = (if List.member ys x then dfs2 g xs ys
                               else dfs2 g xs (dfs2 g (nexts g x) (x#ys)))"
by pat_completeness auto

lemma dfs2_invariant: "dfs2_dom (g, xs, ys) \<Longrightarrow> set ys \<subseteq> set (dfs2 g xs ys)"
apply2 (induct g xs ys rule: dfs2.pinduct) by(force simp add: dfs2.psimps)+

termination dfs2
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
apply (case_tac  "x \<in> nodes_of g")
apply (auto simp add: List.member_def)[2]
by (insert dfs2_invariant) force

(*lemma dfs2_induct[induct type]:
  assumes B: "\<And>g ys. P g [] ys" and
  H: "\<And>g x xs ys.
        \<lbrakk>\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys));
         \<not> x mem ys \<longrightarrow> P g (nexts g x) (x # ys); x mem ys \<longrightarrow> P g xs ys\<rbrakk>
         \<Longrightarrow> P g (x # xs) ys"
  shows "P u v w"

proof (induct u v w rule: dfs2.induct)
  case 1 show ?case by (rule B)
next
  case (2 g x xs ys)
  show ?case
  proof (rule H)
    show "\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys))"
    proof
      assume *: "\<not> x mem ys"
      have "set (x#ys) \<subseteq> set (dfs2 (g, nexts g x, x # ys))"
        by (rule dfs2_inv)
      with 2 * show "P g xs (dfs2 (g, nexts g x, x # ys))"
        by auto
    qed
  qed (rule 2)+
qed
*)

lemma dfs_app: "dfs g (xs@ys) zs = dfs g ys (dfs g xs zs)"
  apply2 (induct g xs zs rule: dfs.induct) by auto

lemma "dfs2 g xs ys = dfs g xs ys"
  apply2 (induct g xs ys rule: dfs2.induct) by(auto simp add: dfs_app)

subsection "Basic Properties"

lemma visit_subset_dfs: "set ys \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule: dfs.induct) by auto

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
proof2(induct g xs ys rule:dfs.induct)
  case(2 g x xs ys)
  show ?case
  proof(cases "x \<in> set ys")
    case True
    have "set ys \<subseteq> set (dfs g xs ys)"
      by (rule visit_subset_dfs)
    with 2 and True show ?thesis
      by (auto simp add: List.member_def)
  next
    case False
    have "set (x#ys) \<subseteq> set (dfs g (nexts g x @ xs) (x#ys))"
      by(rule visit_subset_dfs)
    with 2 and False show ?thesis
      by (auto simp add: List.member_def)
  qed
qed(simp)

lemma nextss_closed_dfs'[rule_format]:
 "nextss g ys \<subseteq> set xs \<union> set ys \<longrightarrow> nextss g (dfs g xs ys) \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule:dfs.induct) by(auto simp add:nextss_Cons List.member_def)

lemma nextss_closed_dfs: "nextss g (dfs g xs []) \<subseteq> set (dfs g xs [])"
  by (rule nextss_closed_dfs', simp add: nextss_def)

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    {
      fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X"
        apply2 (induct) by(insert assms y, auto simp add: Image_def)
    }
    then show ?thesis unfolding Image_def by auto
  qed
qed auto

lemma reachable_closed_dfs: "reachable g xs \<subseteq> set(dfs g xs [])"
proof -
  have "reachable g xs \<subseteq> reachable g (dfs g xs [])"
    unfolding reachable_def by (rule Image_mono) (auto simp add: next_subset_dfs)
  also have "\<dots> = set(dfs g xs [])"
    unfolding reachable_def
  proof (rule Image_closed_trancl)
    from nextss_closed_dfs
    show "set g `` set (dfs g xs []) \<subseteq> set (dfs g xs [])"
      by (simp add: nextss_def)
  qed
  finally show ?thesis .
qed

lemma reachable_nexts: "reachable g (nexts g x) \<subseteq> reachable g [x]"
  unfolding reachable_def
  by (auto intro: converse_rtrancl_into_rtrancl simp: nexts_set)

lemma reachable_append: "reachable g (xs @ ys) = reachable g xs \<union> reachable g ys"
  unfolding reachable_def by auto

lemma dfs_subset_reachable_visit_nodes: "set (dfs g xs ys) \<subseteq> reachable g xs \<union> set ys"
proof2(induct g xs ys rule: dfs.induct)
  case 1
  then show ?case by simp
next
  case (2 g x xs ys)
  show ?case
  proof (cases "x \<in> set ys")
    case True
    with 2 show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  next
    case False
    have "reachable g (nexts g x) \<subseteq> reachable g [x]"
      by (rule reachable_nexts)
    hence a: "reachable g (nexts g x @ xs) \<subseteq> reachable g (x#xs)"
      by(simp add: reachable_append, auto simp add: reachable_def)
    with False 2
    show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  qed
qed

subsection "Correctness"

theorem dfs_eq_reachable: "set (dfs g xs []) = reachable g xs"
proof
  have "set (dfs g xs []) \<subseteq> reachable g xs \<union> set []"
    by (rule dfs_subset_reachable_visit_nodes[of g xs "[]"])
 thus "set (dfs g xs []) \<subseteq> reachable g xs"
   by simp
qed(rule reachable_closed_dfs)

theorem "y \<in> set (dfs g [x] []) = ((x,y) \<in> (set g)\<^sup>*)"
  by(simp only:dfs_eq_reachable reachable_def, auto)

subsection "Executable Code"

consts Node :: "int \<Rightarrow> node"

code_datatype Node

instantiation node :: equal
begin

definition equal_node :: "node \<Rightarrow> node \<Rightarrow> bool"
where
  [code del]: "equal_node = HOL.eq"

instance proof
qed (simp add: equal_node_def)

end

declare [[code abort: "HOL.equal :: node \<Rightarrow> node \<Rightarrow> bool"]]

export_code dfs dfs2 in SML file \<open>dfs.ML\<close>

end


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: Machine_Number.thy                                                   *)
(******************************************************************************)
(* LAST REVIEWED: 11 July 2017 *)

section {* Machine Numbers *}

theory Machine_Number
imports Preliminaries
begin

subsection {* Type Class *}

text \<open>
  Machine numbers are introduced via a type class \<open>machine_number\<close>. The class
  extends a linear order by including a constant \<open>max_number\<close> that yields the
  largest representable number.
\<close>

class machine_number = linorder +
  fixes max_number :: "'a"
begin

text \<open>All numbers less or equal to @{const max_number} are within range.\<close>

definition number_range :: "'a set" where
[simp]: "number_range = {x. x \<le> max_number}"
end

text \<open>We can easily prove that @{const number_range} is a non-empty set.\<close>

lemma ex_leq_max_number:
"\<exists>x. x \<le> max_number"
apply (rule_tac x = "max_number" in exI)
apply (rule order_refl)
done

lemma ex_in_number_range:
"\<exists>x. x \<in> number_range"
apply (clarsimp)
apply (rule ex_leq_max_number)
done

subsection {* Type Definition *}

text \<open>The above lemma enables us to introduce a type for representable numbers.\<close>

typedef (overloaded)
  'a::machine_number machine_number = "number_range::'a set"
apply (rule ex_in_number_range)
done

text \<open>The notation \<open>MN(_)\<close> will be used for the abstraction function.\<close>

notation Abs_machine_number ("MN'(_')")

text \<open>The notation \<open>\<lbrakk>_\<rbrakk>\<close> will be used for the representation function.\<close>

notation Rep_machine_number ("\<lbrakk>_\<rbrakk>")

setup_lifting type_definition_machine_number

subsection {* Proof Support *}

lemmas Rep_machine_number_inject_sym = sym [OF Rep_machine_number_inject]

declare Abs_machine_number_inverse
  [simplified number_range_def mem_Collect_eq, simp]

declare Rep_machine_number_inverse
  [simplified number_range_def mem_Collect_eq, simp]

declare Abs_machine_number_inject
  [simplified number_range_def mem_Collect_eq, simp]

declare Rep_machine_number_inject_sym
  [simplified number_range_def mem_Collect_eq, simp]

subsection {* Instantiations *}

subsubsection {* Linear Order *}

instantiation machine_number :: (machine_number) linorder
begin
definition less_eq_machine_number ::
  "'a machine_number \<Rightarrow> 'a machine_number \<Rightarrow> bool" where
[simp]: "less_eq_machine_number x y \<longleftrightarrow> \<lbrakk>x\<rbrakk> \<le> \<lbrakk>y\<rbrakk>"

definition less_machine_number ::
  "'a machine_number \<Rightarrow> 'a machine_number \<Rightarrow> bool" where
[simp]: "less_machine_number x y \<longleftrightarrow> \<lbrakk>x\<rbrakk> < \<lbrakk>y\<rbrakk>"
instance
apply (intro_classes)
apply (unfold less_eq_machine_number_def less_machine_number_def)
-- {* Subgoal 1 *}
apply (transfer')
apply (rule less_le_not_le)
-- {* Subgoal 2 *}
apply (transfer')
apply (rule order_refl)
-- {* Subgoal 3 *}
apply (transfer')
apply (erule order_trans)
apply (assumption)
-- {* Subgoal 4 *}
apply (transfer')
apply (erule antisym)
apply (assumption)
-- {* Subgoal 5 *}
apply (transfer')
apply (rule linear)
done
end

subsubsection {* Arithmetic Operators *}

instantiation machine_number :: ("{machine_number, zero}") zero
begin
definition zero_machine_number :: "'a machine_number" where
[simp]: "zero_machine_number = MN(0)"
instance ..
end

instantiation machine_number :: ("{machine_number, one}") one
begin
definition one_machine_number :: "'a machine_number" where
[simp]: "one_machine_number = MN(1)"
instance ..
end

instantiation machine_number :: ("{machine_number, plus}") plus
begin
definition plus_machine_number :: "'a machine_number binop" where
[simp]: "plus_machine_number x y = MN(\<lbrakk>x\<rbrakk> + \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, minus}") minus
begin
definition minus_machine_number :: "'a machine_number binop" where
[simp]: "minus_machine_number x y = MN(\<lbrakk>x\<rbrakk> - \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, times}") times
begin
definition times_machine_number :: "'a machine_number binop" where
[simp]: "times_machine_number x y = MN(\<lbrakk>x\<rbrakk> * \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, divide}") divide
begin
definition divide_machine_number :: "'a machine_number binop" where
[simp]: "divide_machine_number x y = MN(\<lbrakk>x\<rbrakk> div \<lbrakk>y\<rbrakk>)"
instance ..
end
end