theory Ch3
imports Complex_Main "~~/src/HOL/IMP/AExp" "~~/src/HOL/IMP/BExp" "~~/src/HOL/IMP/ASM"
begin

(* 3.1 *)
fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (Plus (N _) (N _)) = False" |
  "optimal (Plus a1 a2) = (optimal a1 \<and> optimal a2)" |
  "optimal _ = True"

theorem optimal_asimp_const [simp]: "optimal (asimp_const a)"
  apply(induction a)
  apply(auto split: aexp.split)
done

(* 3.2 *)
fun zero_N :: "aexp \<Rightarrow> aexp" where
  "zero_N (N _) = (N 0)" |
  "zero_N (Plus a1 a2) = Plus (zero_N a1) (zero_N a2)" |
  "zero_N a = a"

fun full_sum :: "aexp \<Rightarrow> val" where
  "full_sum (N n) = n" |
  "full_sum (V v) = 0" |
  "full_sum (Plus a1 a2) = full_sum a1 + full_sum a2"

fun expand_sum :: "aexp \<Rightarrow> aexp" where
  "expand_sum a = N (full_sum a)"

lemma plus_sum_zero_equiv [simp]: "aval (Plus (expand_sum a) (zero_N a)) s = aval a s"
  apply(induction a rule: zero_N.induct)
  apply(auto)
done

fun full_vars :: "aexp \<Rightarrow> vname list" where
  "full_vars (N n) = []" |
  "full_vars (V v) = [v]" |
  "full_vars (Plus a1 a2) = full_vars a1 @ full_vars a2"

fun expand_vlist :: "vname list \<Rightarrow> aexp" where
  "expand_vlist [v] = V v" |
  "expand_vlist (v # vs) = Plus (V v) (expand_vlist vs)" |
  "expand_vlist [] = N 0"

fun expand_vars :: "aexp \<Rightarrow> aexp" where
  "expand_vars a = expand_vlist (full_vars a)"

lemma vlist_cons [simp]: "aval (expand_vlist (v # vs)) s = aval (V v) s + aval (expand_vlist vs) s"
  apply(induction vs)
  apply(auto)
done

lemma vlist_app [simp]: "aval (expand_vlist (vs1 @ vs2)) s =
    aval (expand_vlist vs1) s + aval (expand_vlist vs2) s"
  apply(induction vs1)
  apply(auto)
done

lemma vars_zero_equiv [simp]: "aval (expand_vars a) s = aval (zero_N a) s"
  apply(induction a)
  apply(auto)
done

fun sum_vars :: "aexp \<Rightarrow> aexp" where
  "sum_vars a = Plus (expand_sum a) (expand_vars a)"

lemma sum_vars_correct [simp]: "aval (sum_vars a) s = aval a s"
  apply(induction a)
  apply(auto)
done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp a = asimp (sum_vars a)"

theorem full_asimp_correct: "aval (full_asimp a) s = aval a s"
  apply(induction a)
  apply(auto)
done

(* 3.3 *)
fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst x a (V v) = (if v = x then a else V v)" |
  "subst x a (Plus e1 e2) = Plus (subst x a e1) (subst x a e2)" |
  "subst x a e = e"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y''))"

lemma subst_

theorem subst_eq: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(induction e)
  apply(auto)
done

(* 3.4 *)
(* See Ch3_AExp.thy *)

(* 3.5 *)
datatype aexp2 = N2 val
               | V2 vname
               | Plus2 aexp2 aexp2
               | Times2 aexp2 aexp2
               | Div2 aexp2 aexp2
               | PostInc2 vname

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> ((val, state) prod) option" where
  "aval2 (N2 n) s = Some (n, s)" |
  "aval2 (V2 v) s = Some (s v, s)" |
  "aval2 (Plus2 a1 a2) s = (
    case aval2 a1 s of Some (x, t) \<Rightarrow> (
      case aval2 a2 t of Some (y, u) \<Rightarrow> (
        Some (x + y, u)
      )
    )
  )" |
  "aval2 (Times2 a1 a2) s = (
    case aval2 a1 s of Some (x, t) \<Rightarrow> (
      case aval2 a2 t of Some (y, u) \<Rightarrow> (
        Some (x * y, u)
      )
    )
  )" |
  "aval2 (Div2 a1 a2) s = (
    case aval2 a1 s of Some (x, t) \<Rightarrow> (
      case aval2 a2 t of Some (y, u) \<Rightarrow> (
        if y = 0 then None else Some (x div y, u)
      )
    )
  )" |
  "aval2 (PostInc2 v) s = Some (s v, s(v := s v + 1))"

(* 3.6 *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
  "lval (Nl n) s = n" |
  "lval (Vl v) s = s v" |
  "lval (Plusl e1 e2) s = lval e1 s + lval e2 s" |
  "lval (LET v e1 e2) s = lval e2 (s(v := lval e1 s))"

fun inline :: "lexp \<Rightarrow> aexp" where
  "inline (Nl n) = N n" |
  "inline (Vl v) = V v" |
  "inline (Plusl e1 e2) = Plus (inline e1) (inline e2)" |
  "inline (LET v e1 e2) = subst v (inline e1) (inline e2)"

theorem inline_correct: "lval e s = aval (inline e) s"
  apply(induction e arbitrary: s)
  apply(auto)
done

(* 3.7 *)
fun or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "or (Bc True) _ = Bc True" |
  "or _ (Bc True) = Bc True" |
  "or (Bc False) b = b" |
  "or b (Bc False) = b" |
  "or b1 b2 = not(and (not(b1)) (not(b2)))"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq (N n1) (N n2) = Bc (n1 = n2)" |
  "Eq a1 a2 = and (not(less a1 a2)) (not(less a2 a1))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Le (N n1) (N n2) = Bc (n1 \<le> n2)" |
  "Le a1 a2 = or (less a1 a2) (Eq a1 a2)"

theorem eq_correct [simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(induction a1 rule: Eq.induct)
  apply(auto)
done

theorem le_correct [simp]: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(induction a1 rule: Le.induct)
  apply(auto)
done

(* 3.8 *)
datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bc2 v) s = v" |
  "ifval (If bp bt be) s = (if (ifval bp s) then (ifval bt s) else (ifval be s))" |
  "ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = Bc2 v" |
  "b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
  "b2ifexp (And b1 b2) = If (b2ifexp b1) (If (b2ifexp b2) (Bc2 True) (Bc2 False)) (Bc2 False)" |
  "b2ifexp (Less a1 a2) = Less2 a1 a2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bc2 v) = Bc v" |
  "if2bexp (If bp bt be) = or (And (if2bexp bp) (if2bexp bt)) (And (Not (if2bexp bp)) (if2bexp be))" |
  "if2bexp (Less2 a1 a2) = Less a1 a2"

theorem b2ifexp_correct: "ifval (b2ifexp b) s = bval b s"
  apply(induction b)
  apply(auto)
done

theorem i2bfexp_correct: "bval (if2bexp i) s = ifval i s"
  apply(induction i)
  apply(auto)
done

(* 3.9 *)
datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
  "pbval (VAR x) s = s x" |
  "pbval (NOT b) s = (\<not> pbval b s)" |
  "pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
  "pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf (VAR _) = True" |
  "is_nnf (NOT (VAR _)) = True" |
  "is_nnf (NOT _) = False" |
  "is_nnf (AND b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
  "is_nnf (OR b1 b2) = (is_nnf b1 \<and> is_nnf b2)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf (NOT (NOT b)) = nnf b" |
  "nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
  "nnf (OR b1 b2) = OR (nnf b1) (nnf b2)" |
  "nnf b = b"

theorem nnf_correct [simp]: "pbval (nnf b) s = pbval b s"
  apply(induction b rule: nnf.induct)
  apply(auto)
done

theorem nnf_is_nnf [simp]: "is_nnf (nnf b)"
  apply(induction b rule: nnf.induct)
  apply(auto)
done

fun no_or :: "pbexp \<Rightarrow> bool" where
  "no_or (AND b1 b2) = (no_or b1 \<and> no_or b2)" |
  "no_or (OR _ _) = False" |
  "no_or _ = True"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
  "is_dnf (AND b1 b2) = (no_or b1 \<and> no_or b2)" |
  "is_dnf (OR b1 b2) = (is_dnf b1 \<and> is_dnf b2)" |
  "is_dnf _ = True"

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
  "dist_AND b (OR b1 b2) = OR (dist_AND b b1) (dist_AND b b2)" |
  "dist_AND (OR b1 b2) b = OR (dist_AND b1 b) (dist_AND b2 b)" |
  "dist_AND b1 b2 = AND b1 b2"

lemma dist_AND_correct [simp]: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
  apply(induction b1 b2 rule: dist_AND.induct)
  apply(auto)
done

lemma is_dnf_dist [simp]: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
  apply(induction b1 b2 rule: dist_AND.induct)
  apply(auto)
done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (AND b1 b2) = dist_AND (dnf_of_nnf b1) (dnf_of_nnf b2)" |
  "dnf_of_nnf (OR b1 b2) = OR (dnf_of_nnf b1) (dnf_of_nnf b2)" |
  "dnf_of_nnf b = b"

theorem dnf_of_nnf_correct [simp]: "pbval (dnf_of_nnf b) s = pbval b s"
  apply(induction b)
  apply(auto)
done

theorem dnf_of_nnf_converts: "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply(induction b rule: dnf_of_nnf.induct)
  apply(auto)
done

(* 3.10 *)
(* See Ch3_ASM.thy *)

(* 3.11 *)
type_synonym reg = nat

datatype instr = LDI val reg | LD vname reg | ADD reg reg

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec1 (LDI n r) _ rs = rs(r := n)" |
  "exec1 (LD v r) s rs = rs(r := s v)" |
  "exec1 (ADD r1 r2) _ rs = rs(r1 := rs r1 + rs r2)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec [] _ rs = rs" |
  "exec (i # is) s rs = exec is s (exec1 i s rs)"

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "comp (N n) r = [LDI n r]" |
  "comp (V v) r = [LD v r]" |
  "comp (Plus e1 e2) r = comp e1 r @ comp e2 (r + 1) @ [ADD r (r + 1)]"

lemma exec_dist_app [simp]: "exec (is1 @ is2) s rs = exec is2 s (exec is1 s rs)"
  apply(induction is1 arbitrary: rs)
  apply(auto)
done

lemma exec_gt_r [simp]: "r2 > r1 \<Longrightarrow> exec (comp a r2) s rs r1 = rs r1"
  apply(induction a arbitrary: r1 r2 rs)
  apply(auto)
done

theorem comp_correct [simp]: "exec (comp a r) s rs r = aval a s"
  apply(induction a arbitrary: r rs)
  apply(auto)
done

(* 3.12 *)
datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec01 (LDI0 n) _ rs = rs(0 := n)" |
  "exec01 (LD0 v) s rs = rs(0 := s v)" |
  "exec01 (MV0 r) _ rs = rs(r := rs 0)" |
  "exec01 (ADD0 r) _ rs = rs(0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
  "exec0 [] _ rs = rs" |
  "exec0 (i # is) s rs = exec0 is s (exec01 i s rs)"

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
  "comp0 (N n) r = [LDI0 n, MV0 r]" |
  "comp0 (V v) r = [LD0 v, MV0 r]" |
  "comp0 (Plus e1 e2) r =
    comp0 e1 (r + 1) @
    comp0 e2 (r + 2) @
    [LDI0 0, ADD0 (r + 1), ADD0 (r + 2), MV0 r]"

lemma exec0_dist_app [simp]: "exec0 (is1 @ is2) s rs = exec0 is2 s (exec0 is1 s rs)"
  apply(induction is1 arbitrary: rs)
  apply(auto)
done

lemma exec0_gt_r [simp]: "r2 > r1 \<Longrightarrow> r1 > 0 \<Longrightarrow> exec0 (comp0 a r2) s rs r1 = rs r1"
  apply(induction a arbitrary: r1 r2 rs)
  apply(auto)
done

theorem comp0_correct_r [simp]: "exec0 (comp0 a r) s rs r = aval a s"
  apply(induction a arbitrary: r rs)
  apply(auto)
done

theorem comp0_correct [simp]: "exec0 (comp0 a r) s rs 0 = aval a s"
  apply(induction a arbitrary: r rs)
  apply(auto)
done

end


theory PFHOL_pol imports Main
begin

(* A polymorphic Embedding of Positive Free Higher-Order Logic (PFHOL) in HOL *)

text \<open> Positive Free Higher-Order Logic \<close>

  typedecl i (* — Type for individuals *)

  consts fExistence :: "'a \<Rightarrow> bool" ("E") (* — Existence/definedness predicate *)

  consts fUndef :: "'a" ("\<^bold>e") (* Distinguished symbol for undefinedness or falsehood *)
  axiomatization where fUndefIAxiom: "\<not>E (\<^bold>e::i)"
  axiomatization where fFalsehoodBAxiom: "(\<^bold>e::bool) = False"

  (* axiomatization where fNonemptyDomains: "\<exists>x. E x" *)

  definition fIdentity :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>=" 56) (* — Free identity *)
    where "\<phi> \<^bold>= \<psi> \<equiv> \<phi> = \<psi>"

  definition fNot :: "bool \<Rightarrow> bool" ("\<^bold>\<not>_" [52]53) (* — Free negation *)
    where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
  definition fOr :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<or>" 51) (* — Free disjunction *)
    where "\<phi> \<^bold>\<or> \<psi> \<equiv> \<phi> \<or> \<psi>"

  definition fForall :: "('a \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<forall>") (* — Free universal quantification guarded by predicate E *)
    where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
  definition fForallBinder:: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<forall>" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"

  definition fThat :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" ("\<^bold>I") (* — Free definite description guarded by predicate E *)
    where "\<^bold>I\<Phi> \<equiv> if \<exists>x. E x \<and> \<Phi> x \<and> (\<forall>y. (E y \<and> \<Phi> y) \<longrightarrow> (y = x))
                 then THE x. E x \<and> \<Phi> x
                 else \<^bold>e"
  definition fThatBinder:: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "\<^bold>I" [8]9) (* — Binder notation *)
    where "\<^bold>Ix. \<phi> x \<equiv> \<^bold>I\<phi>"

  text \<open> Further logical constants can be defined as usual \<close>

  definition fAnd :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<and>" 52) (* — Free conjunction *)
    where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
  definition fImp :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<rightarrow>" 49) (* — Free implication *)
    where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<^bold>\<not>\<phi> \<^bold>\<or> \<psi>"
  definition fEquiv :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<leftrightarrow>" 50) (* — Free equivalence *)
    where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> \<phi> \<^bold>\<rightarrow> \<psi> \<^bold>\<and> \<psi> \<^bold>\<rightarrow> \<phi>"

  definition fExists :: "('a \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<exists>") (* — Free existential quantification *)
    where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  definition fExistsBinder :: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<exists>" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"

  (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
  named_theorems Defs declare fIdentity_def[Defs] fNot_def[Defs] fOr_def[Defs] fForall_def[Defs]
    fForallBinder_def[Defs] fThat_def[Defs] fThatBinder_def[Defs] fAnd_def[Defs] fImp_def[Defs]
    fEquiv_def[Defs] fExists_def[Defs] fExistsBinder_def[Defs]

text \<open> Some Tests \<close>

  lemma "(\<^bold>\<forall>x. P x) \<^bold>\<rightarrow>  P x" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "((\<^bold>\<forall>x. (P x)) \<^bold>\<and> (E x)) \<^bold>\<rightarrow> (P x)"
    by (metis fAnd_def fForallBinder_def fForall_def fImp_def fNot_def fOr_def) (* properly valid *)

  lemma "P x \<^bold>\<rightarrow> (\<^bold>\<exists>x. P x)" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "(x \<^bold>= y) \<^bold>\<rightarrow> (\<^bold>\<exists>x. (x \<^bold>= y))" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "(x \<^bold>\<or> y) \<^bold>\<rightarrow> (\<^bold>\<exists>x. (x \<^bold>\<or> y))" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "((P x) \<^bold>\<and> (E x)) \<^bold>\<rightarrow> (\<^bold>\<exists>x. P x)" unfolding Defs by blast (* properly valid *)

  lemma "(P x) \<^bold>\<and> (\<^bold>\<exists>x. P x)" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "(P x) \<^bold>\<rightarrow> (E x)" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)

  lemma "(P x) \<^bold>\<or> (\<^bold>\<not>(P x))" unfolding Defs by auto (* properly valid *)
  lemma "(P x) \<^bold>\<and> (\<^bold>\<not>(P x))" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<^bold>\<not>((P x) \<^bold>\<and> (\<^bold>\<not>(P x)))" unfolding Defs by auto (* properly valid *)

  consts fIndividual1 :: "i" ("i\<^sub>1")
  axiomatization where fUndefIndividual1Axiom: "\<^bold>\<not>(E i\<^sub>1)"

  consts fIndividual2 :: "i" ("i\<^sub>2")
  axiomatization where fUndefIndividual2Axiom: "\<^bold>\<not>(E i\<^sub>2)"

  lemma "x \<^bold>= x" unfolding Defs by auto (* properly valid *)
  lemma "i\<^sub>1 \<^bold>= i\<^sub>1" unfolding Defs by auto (* properly valid *)

  lemma test_True: "True" by simp
  lemma test_False: "False" nitpick [satisfy, user_axioms=true] oops

text \<open> Prior's Theorem \<close>

  lemma "(Q (\<forall>p. (Q p \<longrightarrow> (\<not>p)))) \<longrightarrow> ((\<exists>p. Q p \<and> p) \<and> (\<exists>p. Q p \<and> (\<not>p)))" by blast

  lemma "(Q (\<^bold>\<forall>p. (Q p \<^bold>\<rightarrow> (\<^bold>\<not>p)))) \<^bold>\<rightarrow> ((\<^bold>\<exists>p. Q p \<^bold>\<and> p) \<^bold>\<and> (\<^bold>\<exists>p. Q p \<^bold>\<and> (\<^bold>\<not>p)))"
    nitpick [user_axioms=true, show_all, format=2] oops

  axiomatization where fTrueAxiom: "E True"
  axiomatization where fFalseAxiom: "E False"

  lemma "(Q (\<^bold>\<forall>p. (Q p \<^bold>\<rightarrow> (\<^bold>\<not>p)))) \<^bold>\<rightarrow> ((\<^bold>\<exists>p. Q p \<^bold>\<and> p) \<^bold>\<and> (\<^bold>\<exists>p. Q p \<^bold>\<and> (\<^bold>\<not>p)))"
    unfolding Defs
    by (smt fFalseAxiom fTrueAxiom)


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
verification components.\<close>

theory HS_VC_Examples
  imports HS_VC_Spartan
    "Hybrid-Verification.Real_Arith_Tactics"

begin

subsubsection \<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma pendulum_dyn: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |EVOL \<phi> G T] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by force

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>= f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (auto intro!: diff_inv_rules vderiv_intros)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: vderiv_intros)

lemma pendulum_flow: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>=f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (force simp: local_flow.fbox_g_ode_subset[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection \<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma "diff_inv (\<lambda>s. UNIV) S G (\<lambda>t. f g) t\<^sub>0 (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)"
  by (auto intro!: vderiv_intros diff_inv_rules)

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(f g) & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  apply(rule fbox_loopI, simp_all, force, force simp: bb_real_arith)
  by (rule fbox_g_odei) (auto intro!: vderiv_intros diff_inv_rules)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0"
    by auto
  hence "g * (g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x) = 0"
    by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    apply -
    by distribute (mon_simp_vars g x)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    by bin_unfold
      (metis (no_types, opaque_lifting) add.commute add.left_commute mult.assoc mult.commute)
  thus "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
    by (simp add: add.commute distrib_right power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> + v) * (g * \<tau> + v)" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  by (rule fbox_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: vderiv_intros)

lemma bouncing_ball_flow: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(\<lambda>t. f g) & (\<lambda> s. s$1 \<ge> 0) on (\<lambda>s. UNIV) UNIV @ 0) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  apply(rule fbox_loopI, simp_all add: local_flow.fbox_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection \<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: vderiv_intros local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.fbox_g_ode_subset[OF local_flow_temp]

lemma thermostat:
  assumes "a > 0" and "0 < Tmin" and "Tmax < L"
  shows "(\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0) \<le>
  |LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f a 0 & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a))
    ELSE (x\<acute>= f a L & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a))) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1))]
  (\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax)"
  apply(rule fbox_loopI, simp_all add: fbox_temp_dyn[OF assms(1)] le_fun_def)
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(3), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,2), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k * s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: vderiv_intros simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) * \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o * \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemma tank_flow:
  assumes "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "I hmin hmax \<le>
  |LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f (c\<^sub>i-c\<^sub>o) & (G hmax (c\<^sub>i-c\<^sub>o)))
     ELSE (x\<acute>= f (-c\<^sub>o) & (G hmin (-c\<^sub>o)))) ) INV I hmin hmax]
  I hmin hmax"
  apply(rule fbox_loopI, simp_all add: le_fun_def)
  apply(clarsimp simp: le_fun_def local_flow.fbox_g_ode_subset[OF local_flow_tank])
  using assms tank_arith[OF _ assms] by auto

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")
        and tank_guard ("G")

subsubsection \<open> Dynamics: Darboux equality \<close>

lemma mult_abs_right_mono: "a < b \<Longrightarrow> a * \<bar>c\<bar> \<le> b * \<bar>c\<bar>" for c::real
  by (simp add: mult_right_mono)

lemma local_lipschitz_first_order_linear:
  fixes c::"real \<Rightarrow> real"
  assumes "continuous_on T c"
  shows "local_lipschitz T UNIV (\<lambda>t. (*) (c t))"
proof(unfold local_lipschitz_def lipschitz_on_def, clarsimp simp: dist_norm)
  fix x t::real assume "t \<in> T"
  then obtain \<delta> where d_hyp: "\<delta> > 0 \<and> (\<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<bar>c \<tau> - c t\<bar> < max 1 \<bar>c t\<bar>)"
    using assms unfolding continuous_on_iff
    apply(erule_tac x=t in ballE, erule_tac x="max 1 (\<bar>c t\<bar>)" in allE; clarsimp)
    by (metis dist_norm less_max_iff_disj real_norm_def zero_less_one)
  {fix \<tau> x\<^sub>1 x\<^sub>2
    assume "\<tau> \<in> cball t (\<delta>/2) \<inter> T" "x\<^sub>1 \<in> cball x (\<delta>/2)" "x\<^sub>2 \<in> cball x (\<delta>/2)"
    hence "\<bar>\<tau> - t\<bar> < \<delta>" "\<tau> \<in> T"
      by (auto simp: dist_norm, smt d_hyp)
    hence "\<bar>c \<tau> - c t\<bar> < max 1 \<bar>c t\<bar>"
      using d_hyp by auto
    hence "- (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) < c \<tau> \<and> c \<tau> < max 1 \<bar>c t\<bar> + \<bar>c t\<bar>"
      by (auto simp: abs_le_eq)
    hence obs: "\<bar>c \<tau>\<bar> < max 1 \<bar>c t\<bar> + \<bar>c t\<bar>"
      by (simp add: abs_le_eq)
    have "\<bar>c \<tau> * x\<^sub>1 - c \<tau> * x\<^sub>2\<bar> = \<bar>c \<tau>\<bar> * \<bar>x\<^sub>1 - x\<^sub>2\<bar>"
      by (metis abs_mult left_diff_distrib mult.commute)
    also have "... \<le> (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) * \<bar>x\<^sub>1 - x\<^sub>2\<bar>"
      using mult_abs_right_mono[OF obs] by blast
    finally have "\<bar>c \<tau> * x\<^sub>1 - c \<tau> * x\<^sub>2\<bar> \<le> (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) * \<bar>x\<^sub>1 - x\<^sub>2\<bar>" .}
  hence "\<exists>L. \<forall>t\<in>cball t (\<delta>/2) \<inter> T. 0 \<le> L \<and>
    (\<forall>x\<^sub>1\<in>cball x (\<delta>/2). \<forall>x\<^sub>2\<in>cball x (\<delta>/2). \<bar>c t * x\<^sub>1 - c t * x\<^sub>2\<bar> \<le> L * \<bar>x\<^sub>1 - x\<^sub>2\<bar>)"
    by (rule_tac x="max 1 \<bar>c t\<bar> + \<bar>c t\<bar>" in exI, clarsimp simp: dist_norm)
  thus "\<exists>u>0. \<exists>L. \<forall>t\<in>cball t u \<inter> T. 0 \<le> L \<and>
    (\<forall>xa\<in>cball x u. \<forall>y\<in>cball x u. \<bar>c t * xa - c t * y\<bar> \<le> L * \<bar>xa - y\<bar>)"
    apply(rule_tac x="\<delta>/2" in exI)
    using d_hyp by auto
qed

lemma picard_lindeloef_first_order_linear: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> is_interval T \<Longrightarrow>
  continuous_on T c \<Longrightarrow> picard_lindeloef (\<lambda>t x::real. c t * x) T UNIV t\<^sub>0"
  apply(unfold_locales; clarsimp?)
   apply(intro continuous_intros, assumption)
  by (rule local_lipschitz_first_order_linear)

(* x+z=0 -> [{x'=(A*x^2+B()*x), z' = A*z*x+B()*z}] 0=-x-z *)
lemma "(\<lambda>s::real^2. s$1 + s$2 = 0) \<le>
  |x\<acute>= (\<lambda>t s. (\<chi> i. if i=1 then A*(s$1)^2+B*(s$1) else A*(s$2)*(s$1)+B*(s$2))) & G on (\<lambda>s. UNIV) UNIV @ 0]
  (\<lambda>s. 0 = - s$1 - s$2)"
proof-
  have key: "diff_inv (\<lambda>s. UNIV) UNIV G
  (\<lambda>t s. \<chi> i. if i = 1 then A*(s$1)^2+B*(s$1) else A*(s$2)*(s$1)+B*(s$2)) 0 (\<lambda>s. s$1 + s$2 = 0)"
  proof(clarsimp simp: diff_inv_eq ivp_sols_def forall_2)
    fix X::"real\<Rightarrow>real^2" and t::real
    let "?c" = "(\<lambda>t.  X t$1 + X t$2)"
    assume init: "?c 0 = 0"
      and D1: "D (\<lambda>t. X t$1) = (\<lambda>t. A * (X t$1)\<^sup>2 + B * X t$1) on UNIV"
      and D2: "D (\<lambda>t. X t$2) = (\<lambda>t. A * X t$2 * X t$1 + B * X t$2) on UNIV"
    hence "D ?c = (\<lambda>t. ?c t * (A * (X t$1) + B)) on UNIV"
      by (auto intro!: vderiv_intros simp: field_simps)
    hence "D ?c = (\<lambda>t. (A * X t$1 + B) * (X t$1 + X t$2)) on {0--t}"
      using has_vderiv_on_subset[OF _ subset_UNIV[of "{0--t}"]] by (simp add: mult.commute)
    moreover have "continuous_on UNIV (\<lambda>t. A * (X t$1) + B)"
      apply(rule vderiv_on_continuous_on)
      using D1 by (auto intro!: vderiv_intros simp: field_simps)
    moreover have "D (\<lambda>t. 0) = (\<lambda>t. (A * X t$1 + B) * 0) on {0--t}"
      by (auto intro!: vderiv_intros)
    moreover note picard_lindeloef.ivp_unique_solution[OF
      picard_lindeloef_first_order_linear[OF UNIV_I open_UNIV is_interval_univ calculation(2)]
      UNIV_I is_interval_closed_segment_1 subset_UNIV _
      ivp_solsI[of ?c]
      ivp_solsI[of "\<lambda>t. 0"], of t "\<lambda>s. 0" 0 "\<lambda>s. t" 0]
    ultimately show "X t$1 + X t$2 = 0"
      using init by auto
  qed
  show ?thesis
    apply(subgoal_tac "(\<lambda>s. 0 = - s$1 - s$2) = (\<lambda>s. s$1 + s$2 = 0)", erule ssubst)
    using key by auto
qed

subsubsection \<open> Dynamics: Fractional Darboux equality \<close> (*N 30 *)

(* x+z=0 -> [{x'=(A*y+B()*x)/z^2, z' = (A*x+B())/z & y = x^2 & z^2 > 0}] x+z=0 *)
(* requires picard-lindeloef for closed intervals *)

subsubsection \<open> Dynamics: Darboux inequality \<close> (*N 31 *)

abbreviation darboux_ineq_f :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i=1 then (s$1)^2 else (s$2)*(s$1)+(s$1)^2)"

abbreviation darboux_ineq_flow2 :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i=1 then (s$1/(1 - t * s$1)) else
      (s$2 - s$1 * ln(1 - t * s$1))/(1 - t * s$1))"

abbreviation darboux_ineq_df :: "real \<times> (real ^ 2) \<Rightarrow> (real ^ 2) \<Rightarrow>\<^sub>L (real ^ 2)" ("df")
  where "df p \<equiv> (case p of (t,x) \<Rightarrow> Blinfun (\<lambda>s. (\<chi> i::2. if i=1 then 2 * (s$1) * (x$1) else
  x$2 * s$1 + s$2 * x$1 + 2 * s$1 * x$1)))"

thm c1_implies_local_lipschitz c1_local_lipschitz

lemma picard_lindeloef_darboux_ineq: "picard_lindeloef (\<lambda>t. f) UNIV {s. s$1 + s$2 > 0} 0"
  apply(unfold_locales, simp_all)
  prefer 2
   apply(rule_tac f'=df in c1_implies_local_lipschitz)
      apply (clarsimp simp: has_derivative_coordinate)
  subgoal for s i
    apply(cases "i = 1")
     apply clarsimp
     apply(subst Blinfun_inverse, clarsimp)
      apply(subst bounded_linear_coordinate, clarsimp)
    subgoal for j
    using exhaust_2[of j] by (auto intro!: bounded_linear_intros)
      apply(auto intro!: derivative_eq_intros)[1]
  apply(subst Blinfun_inverse, clarsimp)
   apply(subst bounded_linear_coordinate)
   apply (clarsimp simp: has_derivative_coordinate)
 subgoal for j
    using exhaust_2[of j] by (auto intro!: bounded_linear_intros)
  by (auto intro!: derivative_eq_intros)[1]
  apply (auto intro!: continuous_intros)
  sorry

lemma darboux_flow_ivp: "(\<lambda>t. \<phi> t s) \<in> Sols (\<lambda>s. {t. 0 \<le> t \<and> t * s$1 < 1}) UNIV (\<lambda>t. f) 0 s"
  by (rule ivp_solsI) (auto intro!: vderiv_intros
      simp: forall_2 power2_eq_square add_divide_distrib power_divide vec_eq_iff)

lemma darboux_ineq_arith:
  assumes "0 \<le> s\<^sub>1 + s\<^sub>2" and "0 \<le> (t::real)" and "t * s\<^sub>1 < 1"
  shows "0 \<le> s\<^sub>1 / (1 - t * s\<^sub>1) + (s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1)) / (1 - t * s\<^sub>1)"
proof-
  have "s\<^sub>1 * ln (1 - t * s\<^sub>1) \<le> 0"
  proof(cases "s\<^sub>1 \<le> 0")
    case True
    hence "1 - t * s\<^sub>1 \<ge> 1"
      using \<open>0 \<le> t\<close> by (simp add: mult_le_0_iff)
    thus ?thesis
      using True ln_ge_zero mult_nonneg_nonpos2 by blast
  next
    case False
    hence "1 - t * s\<^sub>1 \<le> 1"
      using \<open>0 \<le> t\<close> by auto
    thus ?thesis
      by (metis False add_0 assms(3) less_diff_eq ln_le_zero_iff mult_le_0_iff nle_le)
  qed
  hence "s\<^sub>1 + s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1) \<ge> s\<^sub>1 + s\<^sub>2"
    by linarith
  hence "(s\<^sub>1 + s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1))/(1 - t * s\<^sub>1) \<ge> (s\<^sub>1 + s\<^sub>2)/(1 - t * s\<^sub>1)"
    using \<open>t * s\<^sub>1 < 1\<close> by (simp add: \<open>0 \<le> s\<^sub>1 + s\<^sub>2\<close> divide_le_cancel)
  also have "(s\<^sub>1 + s\<^sub>2)/(1 - t * s\<^sub>1) \<ge> 0"
    using \<open>t * s\<^sub>1 < 1\<close> by (simp add: \<open>0 \<le> s\<^sub>1 + s\<^sub>2\<close>)
  ultimately show ?thesis
    by (metis (full_types) add_diff_eq add_divide_distrib order_trans)
qed

(* x+z>=0 -> [{x'=x^2, z' = z*x+y & y = x^2}] x+z>=0 *)
(* x' + z' \<ge> 0 \<longleftrightarrow> x^2 + z*x + x^2 \<ge> 0*)
lemma "(\<lambda>s::real^2. s$1 + s$2 \<ge> 0) \<le>
  |EVOL \<phi> (\<lambda>s. y = (s$1)^2) (\<lambda>s. {t. 0 \<le> t \<and> t * s$1 < 1})]
  (\<lambda>s. s$1 + s$2 \<ge> 0)"
  apply(subst fbox_g_evol, simp_all add: le_fun_def)
  using darboux_ineq_arith by smt

no_notation darboux_ineq_flow2 ("\<phi>")
        and darboux_ineq_f ("f")

subsection \<open> Dynamics: Fractional Darboux equality \<close>

(* x+z=0 -> [{x'=(A*y+B()*x)/z^2, z' = (A*x+B())/z & y = x^2 & z^2 > 0}] x+z=0 *)
(* x' + z' = (A*y+B*x)/z^2 + (A*x+B)/z = (A*y+B*x+A*x*z+B*z)/z^2 = (x*(A*x+B)+z*(A*x+B))/z^2 *)
lemma "0 \<le> t \<Longrightarrow> (\<lambda>s::real^3. s$1 + s$3 = 0) \<le>
  |x\<acute>= (\<lambda> s. (\<chi> i::3. if i=1 then (A*(s$2)+B*(s$1))/(s$3)\<^sup>2 else (if i = 3 then (A*(s$1)+B)/s$3 else 0))) & (\<lambda>s. (s$2) = (s$1)^2 \<and> (s$3)^2 > 0)]
  (\<lambda>s. s$1 + s$3 = 0)"
proof-
  have "diff_inv (\<lambda>s. Collect ((\<le>) 0)) UNIV (\<lambda>s. s$2 = (s$1)\<^sup>2 \<and> s$3 \<noteq> 0)
  (\<lambda>t s. \<chi> i::3. if i = 1 then (A*(s$2)+B*(s$1))/(s$3)\<^sup>2 else if i = 3 then (A*(s$1)+B)/s$3 else 0)
  0 (\<lambda>s::real^3. s$1 + s$3 = 0)"
  proof(clarsimp simp: diff_inv_eq ivp_sols_def forall_3)
    fix X::"real\<Rightarrow>real^3" and t::real
    let "?c" = "(\<lambda>t.  X t$1 + X t$3)"
    assume init: "?c 0 = 0" and "t \<ge> 0"
      and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> X \<tau>$2 = (X \<tau>$1)\<^sup>2 \<and> X \<tau>$3 \<noteq> 0"
      and D1: "D (\<lambda>t. X t$1) = (\<lambda>t. (A * (X t$2) + B * X t$1)/(X t$3)\<^sup>2) on Collect ((\<le>) 0)"
      and D2: "D (\<lambda>t. X t$2) = (\<lambda>t. 0) on Collect ((\<le>) 0)"
      and D3: "D (\<lambda>t. X t$3) = (\<lambda>t. (A * X t$1 + B)/(X t$3)) on Collect ((\<le>) 0)"
    have "D ?c = (\<lambda>t. (A * (X t$2) + B * X t$1)/(X t$3)\<^sup>2 + (A * X t$1 + B)/(X t$3)) on {0--t}"
      apply(rule_tac S="Collect ((\<le>) 0)" in has_vderiv_on_subset)
      using \<open>t \<ge> 0\<close> by (auto simp: closed_segment_eq_real_ivl intro!: vderiv_intros D1 D3)
    hence "D ?c = (\<lambda>t. (A * X t$1 + B)/(X t$3)\<^sup>2 * ?c t) on {0--t}"
      apply(rule has_vderiv_on_eq_rhs)
      using guard \<open>t \<ge> 0\<close>
      using segment_open_subset_closed
      by (auto simp: field_simps closed_segment_eq_real_ivl)
    moreover have "continuous_on {0--t} (\<lambda>t. (A * X t$1 + B)/(X t$3)\<^sup>2)"
      apply(rule vderiv_on_continuous_on)
      apply(rule vderiv_intros)
      using guard segment_open_subset_closed \<open>t \<ge> 0\<close> apply (force simp: closed_segment_eq_real_ivl)
        apply(intro vderiv_intros, rule vderiv_intros)
      apply(rule has_vderiv_on_subset[OF D1])
      using \<open>t \<ge> 0\<close> apply(simp add: closed_segment_eq_real_ivl subset_eq, force)
         apply(rule vderiv_intros, force)
      apply(rule vderiv_intros,simp)
      apply(rule has_vderiv_on_subset[OF D3])
      using \<open>t \<ge> 0\<close> by (simp_all add: closed_segment_eq_real_ivl subset_eq)
    moreover have "D (\<lambda>t. 0) = (\<lambda>t. (A * X t$1 + B)/(X t$3)\<^sup>2 * 0) on {0--t}"
      by (auto intro!: vderiv_intros)
    (*moreover note picard_lindeloef.unique_solution_general[OF
        picard_lindeloef_first_order_linear[OF _ _ _ calculation(2)] _ _ _ _ _ this _ _ calculation(1)]
   *)
    thm picard_lindeloef.unique_solution_closed_ivl
    thm picard_lindeloef.unique_solution[of "(\<lambda>t. (*) ((A * X t$1 + B) / (X t$3)\<^sup>2))" _ _ 0]
    thm picard_lindeloef_first_order_linear[OF _ _ _ calculation(2)]
    moreover note picard_lindeloef.unique_solution_closed_ivl[OF
        picard_lindeloef_first_order_linear[OF _ _ _ calculation(2)] this _ _ _ calculation(1)]
    ultimately show "X t$1 + X t$3 = 0"
      using init by auto
        (* continuous because of guard need to change assumptions of picard_lindeloef *)
        (* correct interval of existence or differentiabe \<Longrightarrow> lipschitz *)
  qed
  thus ?thesis
    by auto
qed

subsection \<open> STTT Tutorial: Example 9b \<close>

abbreviation f9 :: "real ^ 3 \<Rightarrow> real ^ 3"
  where "f9 \<equiv> (\<lambda>s. \<chi> i. if i = 1 then s $ 2 else if i = 2 then - 2 * (s $ 1 - s $ 3) - 3 * s $ 2 else 0)"

(* { x' = v, v' = -Kp*(x-xr) - Kd*v & v >= 0 } *)
term "(\<lambda>(t::real) (s::real^3). \<chi> i::3. if i = 1 then s $ 2 else if i = 2 then - 2 * (s $ 1 - s $ 3) - 3 * s $ 2 else 0)"
lemma "local_lipschitz UNIV UNIV (\<lambda>(t::real). f9)"
  apply(rule_tac \<DD>=f9 in c1_local_lipschitz; clarsimp?)
  apply (clarsimp simp: has_derivative_coordinate)
  subgoal for s i
    using exhaust_3[of i]
    by (auto intro!: derivative_eq_intros)
  apply(rule_tac f'="\<lambda>t. f9" in has_derivative_continuous_on, clarsimp)
  apply (clarsimp simp: has_derivative_coordinate)
  subgoal for s i
    using exhaust_3[of i]
    by (auto intro!: derivative_eq_intros)
  done

end


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2010 TU Muenchen
*)

theory Quickcheck_Lattice_Examples
imports Main
begin

declare [[quickcheck_finite_type_size=5]]

text \<open>We show how other default types help to find counterexamples to propositions if
  the standard default type \<^typ>\<open>int\<close> is insufficient.\<close>

notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less  (infix "\<sqsubset>" 50) and
  top ("\<top>") and
  bot ("\<bottom>") and
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65)

declare [[quickcheck_narrowing_active = false, quickcheck_timeout = 3600]]

subsection \<open>Distributive lattices\<close>

lemma sup_inf_distrib2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = no_counterexample]
by(simp add: inf_sup_aci sup_inf_distrib1)

lemma sup_inf_distrib2_1:
 "((y :: 'a :: lattice) \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma sup_inf_distrib2_2:
 "((y :: 'a :: distrib_lattice) \<sqinter> z') \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib1_1:
 "(x :: 'a :: distrib_lattice) \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x' \<sqinter> z)"
  quickcheck[expect = counterexample]
  oops

lemma inf_sup_distrib2_1:
 "((y :: 'a :: distrib_lattice) \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (y \<sqinter> x)"
  quickcheck[expect = counterexample]
  oops

subsection \<open>Bounded lattices\<close>

lemma inf_bot_left [simp]:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_bot_left_1:
  "\<bottom> \<sqinter> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_2:
  "y \<sqinter> (x :: 'a :: bounded_lattice_bot) = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_left_3:
  "x \<noteq> \<bottom> ==> y \<sqinter> (x :: 'a :: bounded_lattice_bot) \<noteq> \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_bot_right_1:
  "x \<noteq> \<bottom> ==> (x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> = y"
  quickcheck[expect = counterexample]
  oops

lemma inf_bot_right_2:
  "(x :: 'a :: bounded_lattice_bot) \<sqinter> \<bottom> ~= \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_right [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = \<bottom>"
  quickcheck[expect = counterexample]
  oops

lemma sup_bot_left [simp]:
  "\<bottom> \<squnion> (x :: 'a :: bounded_lattice_bot) = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma sup_bot_right_2 [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> \<bottom> = x"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_eq_bot_iff [simp]:
  "(x :: 'a :: bounded_lattice_bot) \<squnion> y = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

lemma sup_top_left [simp]:
  "\<top> \<squnion> (x :: 'a :: bounded_lattice_top) = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb1) simp

lemma sup_top_right [simp]:
  "(x :: 'a :: bounded_lattice_top) \<squnion> \<top> = \<top>"
  quickcheck[expect = no_counterexample]
  by (rule sup_absorb2) simp

lemma inf_top_left [simp]:
  "\<top> \<sqinter> x = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb2) simp

lemma inf_top_right [simp]:
  "x \<sqinter> \<top> = (x :: 'a :: bounded_lattice_top)"
  quickcheck[expect = no_counterexample]
  by (rule inf_absorb1) simp

lemma inf_eq_top_iff [simp]:
  "(x :: 'a :: bounded_lattice_top) \<sqinter> y = \<top> \<longleftrightarrow> x = \<top> \<and> y = \<top>"
  quickcheck[expect = no_counterexample]
  by (simp add: eq_iff)

no_notation
  less_eq  (infix "\<sqsubseteq>" 50) and
  less (infix "\<sqsubset>" 50) and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  top ("\<top>") and
  bot ("\<bottom>")

end


(* Attempting to discover laws form Hinze's stream calculus using Hipster *)
theory "Hinze_Streams"
  imports Main "$HIPSTER_HOME/IsaHipster"
    "~~/src/HOL/Library/BNF_Corec"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
setup Misc_Data.set_time

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

datatype ('a, 'b) Twople = Pair2 (fst2: 'a) (snd2: 'b)

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

(* Lifting *)
primcorec spure :: "'a \<Rightarrow> 'a Stream" where
  "shd (spure x) = x"
| "stl (spure x) = spure x"

(* Sequential application *)
primcorec sapp :: " ('a \<Rightarrow> 'b) Stream \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "shd (sapp fs xs) = (shd fs) (shd xs)"
| "stl (sapp fs xs) = sapp (stl fs) (stl xs)"

primcorec szip :: "'a Stream \<Rightarrow> 'b Stream \<Rightarrow> (('a, 'b) Twople) Stream" where
  "shd (szip s1 s2) = Pair2 (shd s1) (shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

(* Map *)
primcorec smap2 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap2 f xs = sapp (spure f) xs"

(* Interleaving *)
primcorec sinterleave :: "'a Stream \<Rightarrow> 'a Stream \<Rightarrow> 'a Stream" where
  "sinterleave s t = SCons (shd s) (sinterleave t (stl s))"

(* Tabulate and lookup *)
datatype MyNat = MyZero | MySuc MyNat

primcorec stabulate :: "(MyNat \<Rightarrow> 'a) \<Rightarrow> 'a Stream" where
  "stabulate f = SCons (f MyZero) (stabulate (f \<circ> (\<lambda>x. MySuc x)))"

fun slookup :: "'a Stream \<Rightarrow> (MyNat \<Rightarrow> 'a)" where
  "slookup s MyZero = shd s" |
  "slookup s (MySuc n) = slookup (stl s) n"

(* Pairs of streams *)
primcorec szip2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream \<Rightarrow> 'c Stream" where
  "szip2 g s t = sapp (sapp (spure g) s) t"

primcorec spair :: "'a Stream => 'b Stream => ('a, 'b) Twople Stream" where
  "spair xs ys = szip2 Pair2 xs ys"

(* Iterate *)
primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "siterate f a = SCons a (siterate f (f a))"

(* Recurse *)
primcorec monomap :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a Stream \<Rightarrow> 'a Stream" where
  "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"

friend_of_corec monomap where
   "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"
  by (auto intro: monomap.code)

corec srecurse :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "srecurse f a = SCons a (monomap f (srecurse f a))"

(* Unfolding *)
primcorec sunfold :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b Stream" where
  "sunfold g f a = SCons (g a) (sunfold g f (f a))"

(* Uncomment the following cohipster calls to explore this theory *)
(* cohipster sapp spure Fun.id Fun.comp *)
(* cohipster smap2 Fun.id Fun.comp *)
(* cohipster spair smap2 fst2 snd2 *)
(* cohipster sinterleave spure sapp *)
(* cohipster stabulate smap2 Fun.comp *)
(* cohipster slookup smap Fun.comp *)
(* cohipster siterate srecurse *)
(* cohipster sunfold Fun.comp smap *)
(* cohipster sunfold shd stl Fun.id *)

(* The output of the above cohipster calls follows below *)
(* lemma_a is Hinze's property 1, lemma_aa is Hinze's property 3 *)
(* cohipster sapp spure Fun.id Fun.comp *)
lemma lemma_a [thy_expl]: "sapp (spure id) y = y"
by(coinduction arbitrary: y rule: Stream.coinduct_strong)
  simp

lemma lemma_aa [thy_expl]: "sapp (spure z) (spure x2) = spure (z x2)"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  auto

lemma lemma_ab [thy_expl]: "SCons (y (shd z)) (stl z) = sapp (SCons y (spure id)) z"
by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
  (simp add: lemma_a)

lemma lemma_ac [thy_expl]: "SCons (z x2) (sapp (spure z) x3) = sapp (spure z) (SCons x2 x3)"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  simp

lemma lemma_ad [thy_expl]: "sapp (SCons z (spure x2)) (spure x3) = SCons (z x3) (spure (x2 x3))"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  (simp add: lemma_aa)

lemma lemma_ae [thy_expl]: "sapp (spure x2) (SCons z (spure x3)) = SCons (x2 z) (spure (x2 x3))"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  (simp add: lemma_aa)

lemma lemma_af [thy_expl]: "sapp (spure x2) (sapp (spure x3) x4) = sapp (spure (x2 \<circ> x3)) x4"
by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
  auto

lemma lemma_ag [thy_expl]: "sapp (SCons y (spure id)) (spure z) = SCons (y z) (spure z)"
by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
  (metis lemma_ab spure.simps(1) spure.simps(2))

lemma lemma_ah [thy_expl]: "sapp (SCons id (spure y)) (spure z) = SCons z (spure (y z))"
by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
  (simp add: Hinze_Streams.lemma_aa)

(* cohipster smap2 Fun.id Fun.comp *)
(* lemma_ai is Hinze's property 5, lemma_aj is Hinze's property 6 *)
lemma lemma_ai [thy_expl]: "smap2 id y = y"
  by(coinduction arbitrary: y rule: Stream.coinduct_strong)
  (simp add: smap2.code)

lemma lemma_aj [thy_expl]: "smap2 z (spure x2) = spure (z x2)"
  by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  (simp add: lemma_aa)

lemma lemma_ak [thy_expl]: "stl (smap2 z x2) = smap2 z (stl x2)"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
simp

lemma lemma_al [thy_expl]: "smap2 (x2 \<circ> x3) x4 = smap2 x2 (smap2 x3 x4)"
by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
(simp add: lemma_af)

lemma lemma_am [thy_expl]: "SCons (z x2) (smap2 z x3) = smap2 z (SCons x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
(simp add: smap2.code)

lemma lemma_an [thy_expl]: "SCons (shd z) (smap2 y (stl z)) = sapp (SCons id (spure y)) z"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
    (simp add: smap2.code)

(* cohipster spair smap2 fst2 snd2 *)
(* None of these are among Hinze's properties *)
lemma lemma_ao [thy_expl]: "sapp (smap2 x2 x3) x4 = szip2 x2 x3 x4"
  by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
  simp

lemma lemma_ap [thy_expl]: "spair (stl z) (stl x2) = stl (spair z x2)"
  by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  simp

lemma lemma_aq [thy_expl]: "stl (spair z (spure x2)) = spair (stl z) (spure x2)"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  simp

lemma lemma_ar [thy_expl]: "stl (spair (spure z) x2) = spair (spure z) (stl x2)"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  simp

lemma lemma_as [thy_expl]: "stl (spair x2 (SCons z x3)) = spair (stl x2) x3"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  simp

lemma lemma_at [thy_expl]: "stl (spair (SCons z x2) x3) = spair x2 (stl x3)"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  simp

lemma lemma_au [thy_expl]: "spair (smap2 x2 (stl x3)) (stl x4) = stl (spair (smap2 x2 x3) x4)"
by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
  simp

lemma lemma_av [thy_expl]: "spair (stl x2) (smap2 x3 (stl x4)) = stl (spair x2 (smap2 x3 x4))"
by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
  simp

lemma unknown [thy_expl]: "spair (spure z) (spure x2) = spure (Pair2 z x2)"
oops

lemma unknown [thy_expl]: "spair (SCons z x3) (SCons x2 x4) = SCons (Pair2 z x2) (spair x3 x4)"
  oops

(* cohipster sinterleave spure sapp *)
(* lemma_ax is Hinze's property 10 *)
lemma lemma_aw [thy_expl]: "sinterleave (SCons y x2) z = SCons y (sinterleave z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.coinduct_strong)
  simp

lemma lemma_ax [thy_expl]: "sinterleave (spure y) (spure y) = spure y"
  by(coinduction arbitrary: y rule: Stream.coinduct_strong)
  auto

lemma lemma_ay [thy_expl]: "SCons y (sinterleave z (spure y)) = sinterleave (spure y) z"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
simp

lemma lemma_az [thy_expl]: "sinterleave (spure z) (SCons y (spure z)) = SCons z (SCons y (spure z))"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
    (simp add: lemma_aw lemma_ax)

(* cohipster stabulate smap2 Fun.comp *)
(* lemma_ba is Hinze's property 12 (commuted) *)
lemma lemma_ba [thy_expl]: "stabulate (z \<circ> x2) = smap2 z (stabulate x2)"
  by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
    (metis (no_types, lifting) comp_apply comp_assoc lemma_ak sapp.simps(1) smap2.code spure.simps(1) stabulate.simps(1) stabulate.simps(2))

(* cohipster slookup smap Fun.comp *)
(* lemma_bb is Hinze's property 13 (commuted) *)
lemma lemma_bb [thy_expl]: "slookup (smap z x2) x3 = z (slookup x2 x3)"
  apply (induct x3 arbitrary: x2)
  apply simp
  apply simp
  done

lemma lemma_bc [thy_expl]: "smap (x2 \<circ> x3) x4 = smap x2 (smap x3 x4)"
  by(coinduction arbitrary: x2 x3 x4 rule: Stream.coinduct_strong)
    auto

lemma lemma_bd [thy_expl]: "SCons (z x2) (smap z x3) = smap z (SCons x2 x3)"
by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
  simp

(* cohipster siterate srecurse *)
(* lemma_bg is Hinze's property 14 *)
lemma lemma_be [thy_expl]: "monomap y (siterate y z) = siterate y (y z)"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
auto

lemma lemma_bf [thy_expl]: "monomap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
  by(coinduction rule: monomap.coinduct)
(simp add: lemma_be srecurse.cong_refl)

lemma lemma_bg [thy_expl]: "srecurse y z = siterate y z"
by(coinduction rule: srecurse.coinduct)
  (smt Stream.collapse Stream.inject lemma_be siterate.code srecurse.code srecurse.cong_base srecurse.cong_monomap)

(* cohipster sunfold Fun.comp smap *)
(* lemma_bi is Hinze's property 18 (commuted) *)
lemma lemma_bh [thy_expl]: "smap z (sunfold x2 x2 x3) = sunfold z x2 (x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Stream.coinduct_strong)
    auto

lemma lemma_bi [thy_expl]: "sunfold (x2 \<circ> x3) x4 x5 = smap x2 (sunfold x3 x4 x5)"
  by(coinduction arbitrary: x2 x3 x4 x5 rule: Stream.coinduct_strong)
    auto

(* cohipster sunfold shd stl Fun.id *)
(* None of these are among Hinze's laws *)
lemma lemma_bj [thy_expl]: "sunfold id y (y z) = sunfold y y z"
by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
  auto

lemma lemma_bk [thy_expl]: "sunfold id id (z x2) = sunfold z id x2"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  auto

lemma lemma_bl [thy_expl]: "SCons z (sunfold y y z) = sunfold id y z"
by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
  (simp add: lemma_bj)

lemma lemma_bm [thy_expl]: "SCons (z x2) (sunfold z id x2) = sunfold z id x2"
by(coinduction arbitrary: x2 z rule: Stream.coinduct_strong)
  simp

end


(*  Author:     Tobias Nipkow
    Copyright   1994 TU Muenchen
*)

section {* Quicksort with function package *}

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

context linorder
begin

fun quicksort :: "'a list \<Rightarrow> 'a list" where
  "quicksort []     = []"
| "quicksort (x#xs) = quicksort [y\<leftarrow>xs. \<not> x\<le>y] @ [x] @ quicksort [y\<leftarrow>xs. x\<le>y]"

lemma quicksort_permutes [simp]:
  "multiset_of (quicksort xs) = multiset_of xs"
  by (induct xs rule: quicksort.induct) (simp_all add: ac_simps)

lemma set_quicksort [simp]: "set (quicksort xs) = set xs"
  by (simp add: set_count_greater_0)

lemma sorted_quicksort: "sorted (quicksort xs)"
  by (induct xs rule: quicksort.induct) (auto simp add: sorted_Cons sorted_append not_le less_imp_le)

theorem sort_quicksort:
  "sort = quicksort"
  by (rule ext, rule properties_for_sort) (fact quicksort_permutes sorted_quicksort)+

end

end