theory KAT
  imports Kleene_Algebra Galois_Connection Boolean_Algebra_Extras
begin

record 'a test_algebra = "'a kleene_algebra" +
  test :: "'a ord"

abbreviation tests :: "('a, 'b) test_algebra_scheme \<Rightarrow> 'a set" where
    "tests A \<equiv> carrier (test A)"

locale kat' =
  fixes A :: "('a, 'b) test_algebra_scheme" (structure)
  assumes kat_ka: "kleene_algebra A"
  and test_subset: "tests A \<subseteq> carrier A"
  and test_le [simp]: "le (test A) = dioid.nat_order A"
  and test_ba: "boolean_algebra (test A)"

sublocale kat' \<subseteq> kleene_algebra using kat_ka .

locale kat = kat' +
  assumes test_one: "bounded_lattice.top (test A) = 1"
  and test_zero: "bounded_lattice.bot (test A) = 0"
  and test_join: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> order.join (test A) x y = x + y"
  and test_meet: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> order.meet (test A) x y = x \<cdot> y"

sublocale kat \<subseteq> test: boolean_algebra "test A"
  where "bounded_lattice.top (test A) = 1"
  and "bounded_lattice.bot (test A) = 0"
  and "x \<sqsubseteq>\<^bsub>test A\<^esub> y \<longleftrightarrow> x \<sqsubseteq> y"
  by (simp_all add: test_ba test_one test_zero test_join test_meet test_join)

context kat
begin

  lemma rem_tj: "\<lbrakk>P (x \<sqinter>\<^bsub>test A\<^esub> y); x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> P (x \<cdot> y)"
    by (metis test_meet)

  lemma test_le_var: "x \<sqsubseteq>\<^bsub>test A\<^esub> y \<longleftrightarrow> x \<sqsubseteq> y"
    by (metis (full_types) test_le)

  lemma test_subset_var: "p \<in> tests A \<Longrightarrow> p \<in> carrier A"
    by (metis insert_absorb insert_subset test_subset)

  lemma test_ord: "order (test A)"
    apply (insert test_ba)
    by (simp add: boolean_algebra_def distributive_lattice_def lattice_def join_semilattice_def)

  lemma test_bl: "bounded_lattice (test A)"
    by (insert test_ba, simp add: boolean_algebra_def complemented_lattice_def)

  lemma test_js: "join_semilattice (test A)"
    by (insert test_bl, simp add: bounded_lattice_def lattice_def)

  lemma test_ms: "meet_semilattice (test A)"
    by (insert test_bl, simp add: bounded_lattice_def lattice_def)

  lemma test_lattice: "lattice (test A)"
    by (insert test_bl, simp add: bounded_lattice_def)

  lemma test_distributive: "distributive_lattice (test A)"
    by (insert test_ba, simp add: boolean_algebra_def)

  lemma test_complemented: "complemented_lattice (test A)"
    by (insert test_ba, simp add: boolean_algebra_def)

  lemma test_plus_closed [simp]: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x + y \<in> tests A"
    by (metis test.join_closed test_join)

  lemma test_mult_closed [simp]: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x\<cdot>y \<in> tests A"
    by (metis meet_closed test_meet)

  declare test_join [simp]
  declare test_meet [simp]
  declare test_le_var[simp]
  declare test_one[simp]
  declare test_zero[simp]

  lemma test_dist1:
    "\<lbrakk>x \<in> tests A; y \<in> tests A; z \<in> tests A\<rbrakk> \<Longrightarrow> x \<cdot> (y + z) = (x \<cdot> y) + (x \<cdot> z)"
    by (insert distributive_lattice.dist1[OF test_distributive], simp)

  lemma test_dist2:
    "\<lbrakk>x \<in> tests A; y \<in> tests A; z \<in> tests A\<rbrakk> \<Longrightarrow> x + y \<cdot> z = (x + y) \<cdot> (x + z)"
    by (insert distributive_lattice.dist2[OF test_distributive], simp)

  lemma test_join_closed: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x + y \<in> tests A"
    by (insert join_semilattice.join_closed[OF test_js], simp)

  lemma test_meet_closed: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> tests A"
    by (insert meet_semilattice.meet_closed[OF test_ms], simp)

  lemma test_absorb1: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x + x \<cdot> y = x"
    by (insert lattice.absorb1[OF test_lattice], simp)

  lemma test_absorb2: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x \<cdot> (x + y) = x"
    by (insert lattice.absorb2[OF test_lattice], simp)

  lemma test_join_assoc:
    "\<lbrakk>x \<in> tests A; y \<in> tests A; z \<in> tests A\<rbrakk> \<Longrightarrow> (x + y) + z = x + (y + z)"
    by (insert join_semilattice.join_assoc[OF test_js], simp)

  lemma test_meet_assoc:
    "\<lbrakk>x \<in> tests A; y \<in> tests A; z \<in> tests A\<rbrakk> \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    by (insert meet_semilattice.meet_assoc[OF test_ms], simp)

  lemma test_join_idem: "x \<in> tests A \<Longrightarrow> x + x = x"
    by (insert join_semilattice.join_idem[OF test_js], simp)

  lemma test_meet_idem: "x \<in> tests A \<Longrightarrow> x \<cdot> x = x"
    by (insert meet_semilattice.meet_idem[OF test_ms], simp)

  lemma test_leq_def:
        "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> (x \<sqsubseteq> y) = (x + y = y)"
    by (insert join_semilattice.leq_def[OF test_js], simp)

  lemma test_leq_meet_def:
        "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> (x \<sqsubseteq> y) = (x \<cdot> y = x)"
    by (insert meet_semilattice.leq_meet_def[OF test_ms], simp)

  lemma test_refl: "x \<in> tests A \<Longrightarrow> x \<sqsubseteq> x"
    by (insert order.order_refl[OF test_ord], simp)

  lemma test_trans:
    "\<lbrakk>x \<in> tests A; y \<in> tests A; z \<in> tests A; x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
    by (insert order.order_trans[OF test_ord,simplified,of x y z], auto)

  lemma test_antisym: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> x = y"
    by (insert order.order_antisym[OF test_ord], simp)

  lemma test_compl:
    "x \<in> tests A \<Longrightarrow> \<exists>y. y \<in> tests A \<and> x + y = 1 \<and> x \<cdot> y = 0"
    apply (insert complemented_lattice.compl[OF test_complemented], simp)
    by (metis test_join test_meet)

  lemma test_compl_uniq:
    "x \<in> tests A \<Longrightarrow> \<exists>!y. y \<in> tests A \<and> x + y = 1 \<and> x \<cdot> y = 0"
    apply (insert boolean_algebra.compl_uniq[OF test_ba], simp)
    by (metis test_join test_meet)

  lemmas test_one_closed = bounded_lattice.top_closed[OF test_bl, simplified]
    and test_zero_closed = bounded_lattice.bot_closed[OF test_bl, simplified]

  declare test_join_closed [simp del]
  declare test_meet_closed [simp del]
  declare test_join [simp del]
  declare test_meet [simp del]
  declare test_le_var [simp del]
  declare test_one [simp del]
  declare test_zero [simp del]

  definition complement :: "'a \<Rightarrow> 'a" ("!") where
    "complement x = (THE y. y \<in> tests A \<and> x + y = 1 \<and> x \<cdot> y = 0)"

  lemma complement_closed: assumes xc: "x \<in> tests A" shows "!x \<in> tests A"
    by (simp add: complement_def, rule the1I2, rule test_compl_uniq[OF xc], auto)

  lemma complement1: "p \<in> tests A \<Longrightarrow> p + !p = 1"
    by (simp add: complement_def, rule the1I2, rule test_compl_uniq[OF assms], auto+)

  lemma complement2: "p \<in> tests A \<Longrightarrow> p \<cdot> !p = 0"
    by (simp add: complement_def, rule the1I2, rule test_compl_uniq[OF assms], auto+)

  lemma test_under_one: "p \<in> tests A \<Longrightarrow> p \<sqsubseteq> 1"
    by (metis mult_oner test_leq_meet_def test_one_closed test_subset_var)

  lemma test_star: "p \<in> tests A \<Longrightarrow> p\<^sup>\<star> = 1"
    by (smt set_rev_mp star_subid test_subset test_under_one)

  lemma test_not_one: "!1 = 0"
    by (metis (lifting) complement2 complement_closed mult_onel test_one_closed test_subset_var)

  lemma test_not_zero: "!0 = 1"
    by (metis add_zerol complement1 complement_closed test_subset_var test_zero_closed)

  lemma test_mult_comm: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p\<cdot>q = q\<cdot>p"
    by (metis (lifting) meet_semilattice.meet_comm test_meet test_ms)

  lemma test_double_compl: "p \<in> tests A \<Longrightarrow> p = !(!p)"
    apply (simp add: complement_def)
    apply (rule the1I2)
    apply (simp_all add: complement_def[symmetric])
    apply (rule test_compl_uniq)
    apply (rule complement_closed[OF assms])
    apply auto
    by (smt add_comm complement1 complement2 complement_closed test_compl_uniq test_mult_comm test_subset_var)

  lemma de_morgan1: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> !p \<cdot> !q = !(p + q)"
    apply (subgoal_tac "p + q + !p\<cdot>!q = 1" "(p + q) \<cdot> (!p\<cdot>!q) = 0")
    apply (smt complement1 complement2 complement_closed test_compl_uniq test_join_closed test_meet_closed)
    apply (smt complement2 complement_closed mult_zeror test_dist1 test_join_closed test_meet_assoc test_meet_closed test_mult_comm test_subset_var)
    by (smt add_comm complement1 complement_closed nat_order_def test_absorb2 test_dist2 test_join_assoc test_join_closed test_subset_var test_under_one)

  lemma test_meet_def: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p \<cdot> q = !(!p + !q)"
    by (metis complement_closed de_morgan1 test_double_compl)

  lemma de_morgan2: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> !p + !q = !(p \<cdot> q)"
    by (smt complement_closed test_double_compl test_join_closed test_meet_def)

  lemma test_compl_anti: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> !q \<sqsubseteq> !p"
    by (metis add_idem de_morgan2 nat_order_def test_leq_meet_def test_meet_def test_mult_comm test_subset_var)

  lemma test_join_def: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p + q = !(!p \<cdot> !q)"
    by (metis de_morgan1 test_double_compl test_join_closed)

  lemma ba_3: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p = (p \<cdot> q) + (p \<cdot> !q)"
    by (metis (lifting) complement1 complement_closed mult_oner test_dist1 test_subset_var)

  lemma ba_5: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> (p + q) \<cdot> !p = q \<cdot> !p"
    by (metis (lifting) complement2 complement_closed dioid.add_zerol distr ka_dioid mult_closed test_subset_var)

  lemma compl_1: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> !p = !(p + q) + !(p + !q)"
    by (metis (lifting) ba_3 complement_closed de_morgan1)

  lemma ba_1: "\<lbrakk>p \<in> tests A; q \<in> tests A; r \<in> tests A\<rbrakk> \<Longrightarrow> p + q + !q = r + !r"
    by (metis (lifting) complement1 complement_closed nat_order_def test_join_assoc test_under_one)

  lemma ba_2: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p + p = p + !(q + !q)"
    by (metis (lifting) add_zeror complement1 test_join_idem test_not_one test_subset_var)

  lemma ba_4: "\<lbrakk>p \<in> tests A; q \<in> tests A\<rbrakk> \<Longrightarrow> p = (p + !q) \<cdot> (p + q)"
    by (metis complement2 complement_closed dioid.add_zeror ka_dioid test_dist2 test_mult_comm test_subset_var)

  lemma shunting:
    assumes pc: "p \<in> tests A" and qc: "q \<in> tests A" and rc: "r \<in> tests A"
    shows "p \<cdot> q \<sqsubseteq> r \<longleftrightarrow> q \<sqsubseteq> !p + r"
    apply default
    apply (smt complement1 complement_closed distl mult_assoc mult_oner pc qc rc test_absorb2 test_double_compl test_join_closed test_leq_meet_def test_meet_closed test_mult_comm test_subset_var)
    by (smt ba_5 complement_closed pc qc rc test_double_compl test_join_closed test_leq_meet_def test_meet_assoc test_meet_def test_mult_comm)

  lemma shunting_galois:
    assumes pc: "p \<in> tests A"
    shows "galois_connection (test A) (test A) (\<lambda>x. p \<cdot> x) (\<lambda>x. !p + x)"
  proof (simp add: galois_connection_def test_le_var, intro conjI, safe del: iffI)
    from test_ord show "order (test A)" .

    show "(\<lambda>x. p \<cdot> x) \<in> tests A \<rightarrow> tests A"
      by (smt ftype_pred pc test_meet_closed)

    show "(\<lambda>x. !p + x) \<in> tests A \<rightarrow> tests A"
      by (smt ftype_pred pc test_join_closed complement_closed)

    fix q r assume qc: "q \<in> tests A" and rc: "r \<in> tests A"
    show "p \<cdot> q \<sqsubseteq> r \<longleftrightarrow> q \<sqsubseteq> !p + r"
      by (rule shunting[OF pc qc rc])
  qed

  text {* We can now import a few theorems based on the shunting
  Galois connection *}

  declare test_join [simp]
  declare test_meet [simp]
  declare test_le_var[simp]
  declare test_one[simp]
  declare test_zero[simp]
  declare o_def[simp]

  lemmas test_max = galois_max[OF shunting_galois, simplified]
    and test_min = galois_min[OF shunting_galois, simplified]
    and test_semi_inverse1 = semi_inverse1[OF _ shunting_galois, simplified]
    and test_semi_inverse2 = semi_inverse2[OF _ shunting_galois, simplified]
    and test_fg_iso = fg_iso[OF shunting_galois, simplified]
    and test_gf_iso = gf_iso[OF shunting_galois, simplified]
    and test_lower_iso = galois_connection.lower_iso[OF shunting_galois, simplified]
    and test_upper_iso = galois_connection.upper_iso[OF shunting_galois, simplified]
    and test_idem1 = galois_connection.adjoint_idem1[OF shunting_galois, simplified]
    and test_idem2 = galois_connection.adjoint_idem2[OF shunting_galois, simplified]

  declare test_join [simp del]
  declare test_meet [simp del]
  declare test_le_var[simp del]
  declare test_one[simp del]
  declare test_zero[simp del]
  declare o_def[simp del]

end

primrec (in kat) kat_bexpr_unfold :: "'a bexpr \<Rightarrow> 'a" where
  "kat_bexpr_unfold (BLeaf x) = x"
| "kat_bexpr_unfold (BOr x y) = kat_bexpr_unfold x + kat_bexpr_unfold y"
| "kat_bexpr_unfold (BAnd x y) = kat_bexpr_unfold x \<cdot> kat_bexpr_unfold y"
| "kat_bexpr_unfold BOne = 1"
| "kat_bexpr_unfold BZero = 0"
| "kat_bexpr_unfold (BNot x) = !(kat_bexpr_unfold x)"

lemma (in kat) kat_bexpr_fold_leaf: "x \<in> tests A \<Longrightarrow> x = kat_bexpr_unfold (BLeaf x)"
  by (rule kat_bexpr_unfold.simps(1)[symmetric])

lemma (in kat) kat_bexpr_test: "bexpr_leaves \<alpha> \<subseteq> tests A \<Longrightarrow> kat_bexpr_unfold \<alpha> \<in> tests A"
  apply (induct \<alpha>, simp_all)
  by (metis test_join_closed test_meet_closed test_one_closed test_zero_closed complement_closed)+

ML {*

fun test_fold_tac leaves = Subgoal.FOCUS (fn {context, prems, ...} =>
  let
    val witnesses = Locale.get_witnesses context
    val subst_thm = hd (witnesses RL @{thms kat.kat_bexpr_fold_leaf})
    val subst_thms = prems RL [subst_thm]
    val unfolds = witnesses RL @{thms kat.kat_bexpr_unfold.simps[symmetric]}
    val to_leaves_thm = hd (witnesses RL @{thms kat.kat_bexpr_test})
  in
    Method.insert_tac subst_thms 1
    THEN REPEAT (etac @{thm ssubst} 1)
    THEN asm_full_simp_tac (HOL_basic_ss addsimps unfolds) 1
    THEN (if leaves then rtac to_leaves_thm 1 else all_tac)
  end)

*}

method_setup test_closure = {*
Scan.succeed (fn ctxt =>
  METHOD (fn _ => test_fold_tac true ctxt 1 THEN asm_full_simp_tac @{simpset} 1))
*}

lemma (in kat) test_closure_example: "\<lbrakk>x \<in> tests A; y \<in> tests A\<rbrakk> \<Longrightarrow> 1\<cdot>y\<cdot>!(y + 0 + !x) \<in> tests A"
  by test_closure

datatype 'a kat_expr = KATLeaf 'a
                     | KATPlus "'a kat_expr" "'a kat_expr"
                     | KATTimes "'a kat_expr" "'a kat_expr"
                     | KATStar "'a kat_expr"
                     | KATBool "'a bexpr"

no_notation
  Groups.plus_class.plus (infixl "+" 65) and
  Groups.one_class.one ("1") and
  Groups.zero_class.zero ("0")

primrec (in kat) kat_expr_unfold :: "'a kat_expr \<Rightarrow> 'a" where
  "kat_expr_unfold (KATLeaf x) = x"
| "kat_expr_unfold (KATPlus x y) = kat_expr_unfold x + kat_expr_unfold y"
| "kat_expr_unfold (KATTimes x y) = kat_expr_unfold x \<cdot> kat_expr_unfold y"
| "kat_expr_unfold (KATStar x) = (kat_expr_unfold x)\<^sup>\<star>"
| "kat_expr_unfold (KATBool x) = kat_bexpr_unfold x"

lemma (in kat) kat_expr_fold_leaf: "x \<in> carrier A \<Longrightarrow> x = kat_expr_unfold (KATLeaf x)"
  by (rule kat_expr_unfold.simps(1)[symmetric])

primrec kat_expr_leaves :: "'a kat_expr \<Rightarrow> 'a set" where
  "kat_expr_leaves (KATLeaf x) = {x}"
| "kat_expr_leaves (KATPlus x y) = kat_expr_leaves x \<union> kat_expr_leaves y"
| "kat_expr_leaves (KATTimes x y) = kat_expr_leaves x \<union> kat_expr_leaves y"
| "kat_expr_leaves (KATStar x) = kat_expr_leaves x"
| "kat_expr_leaves (KATBool x) = {}"

primrec kat_expr_bexpr_leaves :: "'a kat_expr \<Rightarrow> 'a set" where
  "kat_expr_bexpr_leaves (KATLeaf x) = {}"
| "kat_expr_bexpr_leaves (KATPlus x y) = kat_expr_bexpr_leaves x \<union> kat_expr_bexpr_leaves y"
| "kat_expr_bexpr_leaves (KATTimes x y) = kat_expr_bexpr_leaves x \<union> kat_expr_bexpr_leaves y"
| "kat_expr_bexpr_leaves (KATStar x) = kat_expr_bexpr_leaves x"
| "kat_expr_bexpr_leaves (KATBool x) = bexpr_leaves x"

lemma (in kat) kat_expr_closed:
  "\<lbrakk>kat_expr_leaves \<alpha> \<subseteq> carrier A; kat_expr_bexpr_leaves \<alpha> \<subseteq> tests A\<rbrakk> \<Longrightarrow> kat_expr_unfold \<alpha> \<in> carrier A"
  apply (induct \<alpha>, simp_all)
  by (metis add_closed mult_closed star_closed kat_bexpr_test test_subset_var)+

lemma (in kat) bexpr_to_kat_expr: "kat_bexpr_unfold \<alpha> = kat_expr_unfold (KATBool \<alpha>)" by simp

ML {*

fun inst_thm thm ctrm = SOME (Drule.instantiate' [] [SOME ctrm] thm)
  handle _ => NONE

fun inst_thms thm ctrms = List.mapPartial (inst_thm thm) ctrms

fun delete_alpha_eq y (x::xs) =
    if y aconvc x
    then delete_alpha_eq y xs
    else x :: (delete_alpha_eq y xs)
  | delete_alpha_eq _ [] = []

fun rem_alpha_eq (x::xs) = x :: rem_alpha_eq (delete_alpha_eq x xs)
  | rem_alpha_eq [] = []

fun kat_fold_tac leaves = Subgoal.FOCUS (fn {context, prems, ...} =>
  let
    val witnesses = Locale.get_witnesses context
    val subst_thm = hd (witnesses RL @{thms kat.kat_expr_fold_leaf})
    val subst_thms = prems RL [subst_thm]
    val to_kat_expr_thm = hd (witnesses RL @{thms kat.bexpr_to_kat_expr})
    val folds = witnesses RL @{thms kat.kat_expr_unfold.simps[symmetric]}
    val to_leaves_thm = hd (witnesses RL @{thms kat.kat_expr_closed})
  in
    DETERM
      (TRY (simp_tac (HOL_basic_ss addsimps [to_kat_expr_thm]) 1)
      THEN Method.insert_tac subst_thms 1
      THEN REPEAT (etac @{thm ssubst} 1)
      THEN asm_full_simp_tac (HOL_basic_ss addsimps folds) 1)
    THEN (if leaves then rtac to_leaves_thm 1 else all_tac)
  end)

fun safe_dest_fun ct = SOME (Thm.dest_fun ct)
  handle CTERM _ => NONE

fun safe_dest_arg ct = SOME (Thm.dest_arg ct)
  handle CTERM _ => NONE

fun safe_dest_funarg ct = SOME (Thm.dest_fun ct, Thm.dest_arg ct)
  handle CTERM _ => NONE

fun safe_dest_funargs ct acc =
  case safe_dest_funarg ct of
    SOME (ct_f, ct_x) => safe_dest_funargs ct_f (ct_x :: acc)
  | NONE => (ct, acc)

datatype apptree = App of cterm * apptree list

fun mk_apptree ct =
  case safe_dest_funargs ct [] of
    (f, xs) => App (f, map mk_apptree xs)

fun get_kat_expr_unfolds ct =
  case safe_dest_funargs ct [] of
    (f, xs) =>
      if f aconvc @{cterm "kat.kat_expr_unfold"}
      then [ct]
      else List.concat (map get_kat_expr_unfolds xs)

val get_kat_exprs_ct = map Thm.dest_arg o get_kat_expr_unfolds

datatype kat_expr = KLeaf of cterm
                  | KPlus of kat_expr * kat_expr
                  | KTimes of kat_expr * kat_expr
                  | KStar of kat_expr
                  | KBool of cterm;

fun mk_kat_expr ct =
  case safe_dest_funargs ct [] of
    (f, [x]) =>
      if f aconvc @{cterm KATLeaf}
      then KLeaf x
      else
        if f aconvc @{cterm KATBool}
        then KBool x
        else KStar (mk_kat_expr x)
  | (f, [x, y]) =>
      if f aconvc @{cterm KATPlus}
      then KPlus (mk_kat_expr x, mk_kat_expr y)
      else KTimes (mk_kat_expr x, mk_kat_expr y)

val get_kat_exprs = map mk_kat_expr o get_kat_exprs_ct

fun kat_expr_explode kat_expr =
  case kat_expr of
    (KPlus (k1, k2)) => kat_expr :: (kat_expr_explode k1 @ kat_expr_explode k2)
  | (KTimes (k1, k2)) => kat_expr :: (kat_expr_explode k1 @ kat_expr_explode k2)
  | (KStar k) => kat_expr :: kat_expr_explode k
  | _ => [kat_expr]

fun kat_expr_ct (KLeaf ct) = Thm.apply @{cterm KATLeaf} ct
  | kat_expr_ct (KPlus (k1, k2)) =
      Thm.apply (Thm.apply @{cterm KATPlus} (kat_expr_ct k1)) (kat_expr_ct k2)
  | kat_expr_ct (KTimes (k1, k2)) =
      Thm.apply (Thm.apply @{cterm KATTimes} (kat_expr_ct k1)) (kat_expr_ct k2)
  | kat_expr_ct (KStar k) = Thm.apply @{cterm KATStar} (kat_expr_ct k)
  | kat_expr_ct (KBool ct) = Thm.apply @{cterm KATBool} ct

fun get_explosions context ct =
  get_kat_exprs ct
  |> map kat_expr_explode
  |> List.concat
  |> map kat_expr_ct
  |> rem_alpha_eq
  |> map (Thm.apply @{cterm "\<lambda>x. kat.kat_expr_unfold A x \<in> carrier A"})

fun my_subgoal_tac ct i =
  case inst_thm @{thm mp[rule_format]} ct of
    SOME thm => rtac thm i
  | NONE => no_tac

val explode_tac = Subgoal.FOCUS (fn {context, concl, ...} =>
  EVERY (get_explosions context concl |> map (fn cc => my_subgoal_tac cc 1)))

fun kat_closure_tac ctxt i =
  let
    val witnesses = Locale.get_witnesses ctxt
    val unfolds1 = witnesses RL @{thms kat.kat_expr_unfold.simps}
    val unfolds2 = witnesses RL @{thms kat.kat_bexpr_unfold.simps}
  in
    test_fold_tac false ctxt i
    THEN DETERM (kat_fold_tac true ctxt i)
    THEN asm_full_simp_tac @{simpset} i
    THEN asm_full_simp_tac (@{simpset} addsimps unfolds1 @ unfolds2) i
  end

*}

method_setup kat_closure = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD (kat_closure_tac ctxt 1))
*}

method_setup kat_explode = {*
Scan.succeed (fn ctxt =>
  let
    val witnesses = Locale.get_witnesses ctxt
    val unfolds1 = witnesses RL @{thms kat.kat_expr_unfold.simps}
    val unfolds2 = witnesses RL @{thms kat.kat_bexpr_unfold.simps}
  in
    test_fold_tac false ctxt 1
    THEN kat_fold_tac false ctxt 1
    THEN explode_tac ctxt 1
    THEN defer_tac 1
    THEN ALLGOALS (asm_full_simp_tac (@{simpset} addsimps unfolds1 @ unfolds2))
    THEN REPEAT1 (kat_closure_tac ctxt 1)
    |> SIMPLE_METHOD
  end)
*}

lemma (in kat) test1: "\<lbrakk>x \<in> carrier A\<rbrakk> \<Longrightarrow> 1 + x\<cdot>x\<^sup>\<star>\<cdot>x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
  by (kat_explode, metis mult_assoc star_trans_eq star_unfoldl)

lemma (in kat) test2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> (x + (x + y + x)) + x = (x + x) + (y + (x + x))"
  by (kat_explode, metis add_assoc)

context kat
begin

  definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("IF _ THEN _ ELSE _ ENDIF" [64,64,64] 63) where
    "IF b THEN p ELSE q ENDIF \<equiv> b\<cdot>p + (!b)\<cdot>q"

  definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("WHILE _ DO _ WEND" [64,64] 63) where
    "WHILE b DO p WEND = (b\<cdot>p)\<^sup>\<star>\<cdot>!b"

(*
  definition hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<lbrace> _ \<rbrace> _" [54,54,54] 53) where
    "b \<lbrace> p \<rbrace> c \<equiv> b \<in> tests A \<and> c \<in> tests A \<and> p \<in> carrier A \<and> b\<cdot>p\<cdot>(!c) = 0"

  lemma hoare_triple_var: "b \<lbrace> p \<rbrace> c \<longleftrightarrow> b \<in> tests A \<and> c \<in> tests A \<and> p \<in> carrier A \<and> b\<cdot>p = b\<cdot>p\<cdot>c"
    apply (auto simp add: hoare_triple_def)
    apply (smt add_zerol complement2 complement_closed de_morgan2 distl mult_closed mult_oner test_double_compl test_not_zero test_subset_var)
    by (metis (lifting) complement2 complement_closed mult_assoc mult_closed mult_zeror test_subset_var)

  lemma mult4_assoc: "\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A; d \<in> carrier A\<rbrakk> \<Longrightarrow> a\<cdot>(b\<cdot>c\<cdot>d) = (a\<cdot>b\<cdot>c)\<cdot>d"
    by (metis (lifting) mult_assoc mult_closed)

  lemma hoare_composition: "\<lbrakk>b \<lbrace> p \<rbrace> c; c \<lbrace> q \<rbrace> d\<rbrakk> \<Longrightarrow> b \<lbrace> p \<cdot> q \<rbrace> d"
    apply (simp add: hoare_triple_var, safe, metis mult_closed)
    by (metis (hide_lams, no_types) mult_assoc mult_closed test_subset_var)

  lemma hoare_weakening: "\<lbrakk>b' \<in> tests A; c' \<in> tests A; b' \<sqsubseteq> b; b \<lbrace> p \<rbrace> c; c \<sqsubseteq> c'\<rbrakk> \<Longrightarrow> b' \<lbrace> p \<rbrace> c'"
    apply (simp add: hoare_triple_var, safe)
    by (smt mult4_assoc mult_assoc test_leq_meet_def test_subset_var)

  lemma hoare_if:
    assumes bt: "b \<in> tests A" and ct: "c \<in> tests A"
    and then_branch: "b\<cdot>c \<lbrace> p \<rbrace> d"
    and else_branch: "!b\<cdot>c \<lbrace> q \<rbrace> d"
    shows "c \<lbrace> IF b THEN p ELSE q ENDIF \<rbrace> d"
    apply (insert then_branch else_branch)
    apply (simp add: hoare_triple_var if_then_else_def ct bt, safe)
    apply (metis add_closed bt complement_closed dioid.mult_closed ka_dioid test_subset_var)
    by (smt bt complement_closed ct distl distr mult_assoc mult_closed test_mult_comm test_subset_var)

  lemma hoare_while:
    assumes bt: "b \<in> tests A" and ct: "c \<in> tests A" and pc: "p \<in> carrier A"
    shows "b\<cdot>c \<lbrace>p\<rbrace> c \<Longrightarrow> c \<lbrace> WHILE b DO p WEND \<rbrace> !b \<cdot> c"
    apply (simp add: hoare_triple_var while_def, safe)
    apply (metis bt complement_closed test_meet_closed)
    apply (metis bt complement_closed mult_closed star_closed test_subset_var)
  proof -
    assume "b\<cdot>c \<in> tests A" and "c \<in> tests A" and "p \<in> carrier A" and asm: "b \<cdot> c \<cdot> p = b \<cdot> c \<cdot> p \<cdot> c"
    hence "c\<cdot>b\<cdot>p \<sqsubseteq> c\<cdot>b\<cdot>p\<cdot>c"
      by (metis (lifting) bt mult_closed nat_refl test_mult_comm test_subset_var)
    hence "c\<cdot>(b\<cdot>p)\<^sup>\<star> \<sqsubseteq> (c\<cdot>b\<cdot>p)\<^sup>\<star>\<cdot>c"
      by (metis (lifting) bt ct mult_assoc mult_closed pc star_sim2 test_subset_var)
    hence "c\<cdot>(b\<cdot>p)\<^sup>\<star> \<sqsubseteq> c\<cdot>(b\<cdot>p)\<^sup>\<star>\<cdot>c"
      by (smt asm bt ct mult_assoc mult_closed pc star_closed star_sim test_meet_idem test_mult_comm test_subset_var)
    thus "c\<cdot>((b\<cdot>p)\<^sup>\<star>\<cdot>!b) = c\<cdot>((b\<cdot>p)\<^sup>\<star>\<cdot>!b)\<cdot>(!b\<cdot>c)"
      by (smt bt complement_closed ct mult_double_iso mult_assoc mult_closed mult_oner nat_antisym nat_refl one_closed pc star_closed test_meet_idem test_mult_comm test_subset_var test_under_one)
  qed

  lemma hoare_skip: "b \<in> tests A \<Longrightarrow> b \<lbrace> SKIP \<rbrace> b"
    by (metis (lifting) complement2 hoare_triple_def mult_oner one_closed test_subset_var)

*)

lemma "{c,d1,d2} \<subseteq> tests A \<Longrightarrow> c\<cdot>d1 + !c\<cdot>d2 = (!c + d1)\<cdot>(c + d2)"
  apply auto
  by (smt ba_5 de_morgan2 local.complement_closed test_dist1 test_dist2 test_join_def test_meet_closed test_mult_comm)

end

notation
  Groups.plus_class.plus (infixl "+" 65) and
  Groups.one_class.one ("1") and
  Groups.zero_class.zero ("0")

end


(*  Title:      HOL/HOLCF/UpperPD.thy
    Author:     Brian Huffman
*)

section {* Upper powerdomain *}

theory UpperPD
imports Compact_Basis
begin

subsection {* Basis preorder *}

definition
  upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
  "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"

lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
unfolding upper_le_def by fast

lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
unfolding upper_le_def
apply (rule ballI)
apply (drule (1) bspec, erule bexE)
apply (drule (1) bspec, erule bexE)
apply (erule rev_bexI)
apply (erule (1) below_trans)
done

interpretation upper_le: preorder upper_le
by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)

lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
unfolding upper_le_def Rep_PDUnit by simp

lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
unfolding upper_le_def Rep_PDUnit by simp

lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
unfolding upper_le_def Rep_PDPlus by fast

lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
unfolding upper_le_def Rep_PDPlus by fast

lemma upper_le_PDUnit_PDUnit_iff [simp]:
  "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
unfolding upper_le_def Rep_PDUnit by fast

lemma upper_le_PDPlus_PDUnit_iff:
  "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast

lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
unfolding upper_le_def Rep_PDPlus by fast

lemma upper_le_induct [induct set: upper_le]:
  assumes le: "t \<le>\<sharp> u"
  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
  assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
  assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
  shows "P t u"
using le apply (induct u arbitrary: t rule: pd_basis_induct)
apply (erule rev_mp)
apply (induct_tac t rule: pd_basis_induct)
apply (simp add: 1)
apply (simp add: upper_le_PDPlus_PDUnit_iff)
apply (simp add: 2)
apply (subst PDPlus_commute)
apply (simp add: 2)
apply (simp add: upper_le_PDPlus_iff 3)
done

subsection {* Type definition *}

typedef 'a upper_pd =
  "{S::'a pd_basis set. upper_le.ideal S}"
by (rule upper_le.ex_ideal)

type_notation (xsymbols) upper_pd ("('(_')\<sharp>)")

instantiation upper_pd :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"

instance ..
end

instance upper_pd :: (bifinite) po
using type_definition_upper_pd below_upper_pd_def
by (rule upper_le.typedef_ideal_po)

instance upper_pd :: (bifinite) cpo
using type_definition_upper_pd below_upper_pd_def
by (rule upper_le.typedef_ideal_cpo)

definition
  upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
  "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"

interpretation upper_pd:
  ideal_completion upper_le upper_principal Rep_upper_pd
using type_definition_upper_pd below_upper_pd_def
using upper_principal_def pd_basis_countable
by (rule upper_le.typedef_ideal_completion)

text {* Upper powerdomain is pointed *}

lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
by (induct ys rule: upper_pd.principal_induct, simp, simp)

instance upper_pd :: (bifinite) pcpo
by intro_classes (fast intro: upper_pd_minimal)

lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
by (rule upper_pd_minimal [THEN bottomI, symmetric])

subsection {* Monadic unit and plus *}

definition
  upper_unit :: "'a \<rightarrow> 'a upper_pd" where
  "upper_unit = compact_basis.extension (\<lambda>a. upper_principal (PDUnit a))"

definition
  upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
  "upper_plus = upper_pd.extension (\<lambda>t. upper_pd.extension (\<lambda>u.
      upper_principal (PDPlus t u)))"

abbreviation
  upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
    (infixl "\<union>\<sharp>" 65) where
  "xs \<union>\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"

syntax
  "_upper_pd" :: "args \<Rightarrow> logic" ("{_}\<sharp>")

translations
  "{x,xs}\<sharp>" == "{x}\<sharp> \<union>\<sharp> {xs}\<sharp>"
  "{x}\<sharp>" == "CONST upper_unit\<cdot>x"

lemma upper_unit_Rep_compact_basis [simp]:
  "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
unfolding upper_unit_def
by (simp add: compact_basis.extension_principal PDUnit_upper_mono)

lemma upper_plus_principal [simp]:
  "upper_principal t \<union>\<sharp> upper_principal u = upper_principal (PDPlus t u)"
unfolding upper_plus_def
by (simp add: upper_pd.extension_principal
    upper_pd.extension_mono PDPlus_upper_mono)

interpretation upper_add: semilattice upper_add proof
  fix xs ys zs :: "'a upper_pd"
  show "(xs \<union>\<sharp> ys) \<union>\<sharp> zs = xs \<union>\<sharp> (ys \<union>\<sharp> zs)"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (induct ys rule: upper_pd.principal_induct, simp)
    apply (induct zs rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_assoc)
    done
  show "xs \<union>\<sharp> ys = ys \<union>\<sharp> xs"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (induct ys rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_commute)
    done
  show "xs \<union>\<sharp> xs = xs"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_absorb)
    done
qed

lemmas upper_plus_assoc = upper_add.assoc
lemmas upper_plus_commute = upper_add.commute
lemmas upper_plus_absorb = upper_add.idem
lemmas upper_plus_left_commute = upper_add.left_commute
lemmas upper_plus_left_absorb = upper_add.left_idem

text {* Useful for @{text "simp add: upper_plus_ac"} *}
lemmas upper_plus_ac =
  upper_plus_assoc upper_plus_commute upper_plus_left_commute

text {* Useful for @{text "simp only: upper_plus_aci"} *}
lemmas upper_plus_aci =
  upper_plus_ac upper_plus_absorb upper_plus_left_absorb

lemma upper_plus_below1: "xs \<union>\<sharp> ys \<sqsubseteq> xs"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (simp add: PDPlus_upper_le)
done

lemma upper_plus_below2: "xs \<union>\<sharp> ys \<sqsubseteq> ys"
by (subst upper_plus_commute, rule upper_plus_below1)

lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys \<union>\<sharp> zs"
apply (subst upper_plus_absorb [of xs, symmetric])
apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
done

lemma upper_below_plus_iff [simp]:
  "xs \<sqsubseteq> ys \<union>\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
apply safe
apply (erule below_trans [OF _ upper_plus_below1])
apply (erule below_trans [OF _ upper_plus_below2])
apply (erule (1) upper_plus_greatest)
done

lemma upper_plus_below_unit_iff [simp]:
  "xs \<union>\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (induct z rule: compact_basis.principal_induct, simp)
apply (simp add: upper_le_PDPlus_PDUnit_iff)
done

lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct y rule: compact_basis.principal_induct, simp)
apply simp
done

lemmas upper_pd_below_simps =
  upper_unit_below_iff
  upper_below_plus_iff
  upper_plus_below_unit_iff

lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
unfolding po_eq_conv by simp

lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
using upper_unit_Rep_compact_basis [of compact_bot]
by (simp add: inst_upper_pd_pcpo)

lemma upper_plus_strict1 [simp]: "\<bottom> \<union>\<sharp> ys = \<bottom>"
by (rule bottomI, rule upper_plus_below1)

lemma upper_plus_strict2 [simp]: "xs \<union>\<sharp> \<bottom> = \<bottom>"
by (rule bottomI, rule upper_plus_below2)

lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)

lemma upper_plus_bottom_iff [simp]:
  "xs \<union>\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
                 upper_le_PDPlus_PDUnit_iff)
done

lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
by (auto dest!: compact_basis.compact_imp_principal)

lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
apply (safe elim!: compact_upper_unit)
apply (simp only: compact_def upper_unit_below_iff [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
done

lemma compact_upper_plus [simp]:
  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs \<union>\<sharp> ys)"
by (auto dest!: upper_pd.compact_imp_principal)

subsection {* Induction rules *}

lemma upper_pd_induct1:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<sharp>"
  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> \<union>\<sharp> ys)"
  shows "P (xs::'a upper_pd)"
apply (induct xs rule: upper_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct1)
apply (simp only: upper_unit_Rep_compact_basis [symmetric])
apply (rule unit)
apply (simp only: upper_unit_Rep_compact_basis [symmetric]
                  upper_plus_principal [symmetric])
apply (erule insert [OF unit])
done

lemma upper_pd_induct
  [case_names adm upper_unit upper_plus, induct type: upper_pd]:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<sharp>"
  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs \<union>\<sharp> ys)"
  shows "P (xs::'a upper_pd)"
apply (induct xs rule: upper_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct)
apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
apply (simp only: upper_plus_principal [symmetric] plus)
done

subsection {* Monadic bind *}

definition
  upper_bind_basis ::
  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
  "upper_bind_basis = fold_pd
    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
    (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<sharp> y\<cdot>f)"

lemma ACI_upper_bind:
  "semilattice (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<sharp> y\<cdot>f)"
apply unfold_locales
apply (simp add: upper_plus_assoc)
apply (simp add: upper_plus_commute)
apply (simp add: eta_cfun)
done

lemma upper_bind_basis_simps [simp]:
  "upper_bind_basis (PDUnit a) =
    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
  "upper_bind_basis (PDPlus t u) =
    (\<Lambda> f. upper_bind_basis t\<cdot>f \<union>\<sharp> upper_bind_basis u\<cdot>f)"
unfolding upper_bind_basis_def
apply -
apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
done

lemma upper_bind_basis_mono:
  "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
unfolding cfun_below_iff
apply (erule upper_le_induct, safe)
apply (simp add: monofun_cfun)
apply (simp add: below_trans [OF upper_plus_below1])
apply simp
done

definition
  upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
  "upper_bind = upper_pd.extension upper_bind_basis"

syntax
  "_upper_bind" :: "[logic, logic, logic] \<Rightarrow> logic"
    ("(3\<Union>\<sharp>_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>\<sharp>x\<in>xs. e" == "CONST upper_bind\<cdot>xs\<cdot>(\<Lambda> x. e)"

lemma upper_bind_principal [simp]:
  "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
unfolding upper_bind_def
apply (rule upper_pd.extension_principal)
apply (erule upper_bind_basis_mono)
done

lemma upper_bind_unit [simp]:
  "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma upper_bind_plus [simp]:
  "upper_bind\<cdot>(xs \<union>\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f \<union>\<sharp> upper_bind\<cdot>ys\<cdot>f"
by (induct xs rule: upper_pd.principal_induct, simp,
    induct ys rule: upper_pd.principal_induct, simp, simp)

lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)

lemma upper_bind_bind:
  "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct xs, simp_all)

subsection {* Map *}

definition
  upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
  "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"

lemma upper_map_unit [simp]:
  "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
unfolding upper_map_def by simp

lemma upper_map_plus [simp]:
  "upper_map\<cdot>f\<cdot>(xs \<union>\<sharp> ys) = upper_map\<cdot>f\<cdot>xs \<union>\<sharp> upper_map\<cdot>f\<cdot>ys"
unfolding upper_map_def by simp

lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
unfolding upper_map_def by simp

lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_map_ID: "upper_map\<cdot>ID = ID"
by (simp add: cfun_eq_iff ID_def upper_map_ident)

lemma upper_map_map:
  "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_bind_map:
  "upper_bind\<cdot>(upper_map\<cdot>f\<cdot>xs)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: upper_map_def upper_bind_bind)

lemma upper_map_bind:
  "upper_map\<cdot>f\<cdot>(upper_bind\<cdot>xs\<cdot>g) = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_map\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: upper_map_def upper_bind_bind)

lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
apply default
apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
apply (induct_tac y rule: upper_pd_induct)
apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
done

lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
apply default
apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
apply (induct_tac x rule: upper_pd_induct)
apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
done

(* FIXME: long proof! *)
lemma finite_deflation_upper_map:
  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  have "deflation d" by fact
  thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  hence *: "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
    apply (rule rev_finite_subset)
    apply clarsimp
    apply (induct_tac xs rule: upper_pd.principal_induct)
    apply (simp add: adm_mem_finite *)
    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
    apply simp
    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDUnit)
    apply (rule range_eqI)
    apply (erule sym)
    apply (rule exI)
    apply (rule Abs_compact_basis_inverse [symmetric])
    apply (simp add: d.compact)
    apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDPlus)
    done
  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
    by (rule finite_range_imp_finite_fixes)
qed

subsection {* Upper powerdomain is bifinite *}

lemma approx_chain_upper_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. upper_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP upper_map_ID finite_deflation_upper_map)

instance upper_pd :: (bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_upper_map)
qed

subsection {* Join *}

definition
  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"

lemma upper_join_unit [simp]:
  "upper_join\<cdot>{xs}\<sharp> = xs"
unfolding upper_join_def by simp

lemma upper_join_plus [simp]:
  "upper_join\<cdot>(xss \<union>\<sharp> yss) = upper_join\<cdot>xss \<union>\<sharp> upper_join\<cdot>yss"
unfolding upper_join_def by simp

lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
unfolding upper_join_def by simp

lemma upper_join_map_unit:
  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_join_map_join:
  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
by (induct xsss rule: upper_pd_induct, simp_all)

lemma upper_join_map_map:
  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
by (induct xss rule: upper_pd_induct, simp_all)

end


(*  Title: Examples of hybrid systems verifications *)

subsection \<open> Examples \<close>

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

theory HS_Lens_Examples
  imports "Hybrid-Verification.Hybrid_Verification"

begin

lemma num2I: "P 1 \<Longrightarrow> P 2 \<Longrightarrow> P j" for j::2
  by (meson forall_2)

lemma num3I: "P 1 \<Longrightarrow> P 2 \<Longrightarrow> P 3 \<Longrightarrow> P j" for j::3
  by (meson forall_3)

lemma num4I: "P 1 \<Longrightarrow> P 2 \<Longrightarrow> P 3 \<Longrightarrow> P 4 \<Longrightarrow> P j" for j::4
  by (meson forall_4)

lemma hoare_cases: "\<^bold>{p \<and> I\<^bold>}S\<^bold>{p \<and> I\<^bold>} \<Longrightarrow> \<^bold>{\<not> p \<and> I\<^bold>}S\<^bold>{\<not> p \<and> I\<^bold>} \<Longrightarrow> \<^bold>{I\<^bold>}S\<^bold>{I\<^bold>}"
  by (auto simp add: fbox_def SEXP_def)

abbreviation (input) real_of_bool :: "bool \<Rightarrow> real" where "real_of_bool \<equiv> of_bool"

declare [[coercion real_of_bool]]

lemma differentiable_of_bool [closure]:
  "\<lbrakk> vwb_lens a; $a \<sharp> (e)\<^sub>e \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (of_bool e) on a"
  by (rule differentiable_discr_expr, simp, unrest)

definition vec_lens :: "'i \<Rightarrow> ('a \<Longrightarrow> 'a^'i)" where
[lens_defs]: "vec_lens k = \<lparr> lens_get = (\<lambda> s. vec_nth s k)
                           , lens_put = (\<lambda> s v. (\<chi> j. ((($) s)(k := v)) j)) \<rparr>"

lemma vec_vwb_lens [simp]: "vwb_lens (vec_lens k)"
  apply (unfold_locales)
  apply (simp_all add: vec_lens_def fun_eq_iff)
  using vec_lambda_unique apply fastforce
  done

lemma vec_lens_indep [simp]: "(i \<noteq> j) \<Longrightarrow> (vec_lens i \<bowtie> vec_lens j)"
  by (simp add: lens_indep_vwb_iff, auto simp add: lens_defs)

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>

dataspace pendulum =
  constants r :: real
  variables
    x :: real
    y :: real

context pendulum
begin

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

abbreviation "pend_flow \<tau> \<equiv> [
  x \<leadsto> x * \<guillemotleft>cos \<tau>\<guillemotright> + y * \<guillemotleft>sin \<tau>\<guillemotright>,
  y \<leadsto> - x * \<guillemotleft>sin \<tau>\<guillemotright> + y * \<guillemotleft>cos \<tau>\<guillemotright>]"

lemma pendulum_dyn:
  "\<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = ($x)\<^sup>2 + ($y)\<^sup>2\<^bold>} (EVOL pend_flow G U) \<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = ($x)\<^sup>2 + ($y)\<^sup>2\<^bold>}"
  by (simp add: fbox_g_evol) expr_auto

\<comment> \<open>Verified with lie_derivative \<close>

lemma pendulum_lie: "\<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>} {(x, y)` = (y, -x)} \<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>}"
  by dInduct

\<comment> \<open>Verified with differential invariants as cartesian product \<close>

lemma pendulum_inv: "\<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>} {(x, y)` = (y, -x)} \<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>}"
  apply(simp add: hoare_diff_inv_on')
  apply(rule diff_inv_on_eqI)
  by clarsimp+ (expr_auto, auto intro!: vderiv_intros simp: case_prod_beta)

end

locale pendulum2 =
  fixes x :: "real \<Longrightarrow> real^2"
    and y :: "real \<Longrightarrow> real^2"
  assumes x_def [simp]: "x \<equiv> vec_lens 1"
    and   y_def [simp]: "y \<equiv> vec_lens 2"
begin

\<comment> \<open>Verified with differential invariants in @{text "\<real>\<^sup>2"} \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "fpend \<equiv> [x \<leadsto> y, y \<leadsto> -x]"

lemma pendulum_inv: "\<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>} (x\<acute>= f & G) \<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>}"
  by (simp add: hoare_diff_inv, expr_auto)
    (auto intro!: diff_inv_rules vderiv_intros)

\<comment> \<open>Verified with the flow in @{text "\<real>\<^sup>2"} \<close>

abbreviation pend_flow2 :: "real \<Rightarrow> real ^ 2 \<Rightarrow> real ^ 2" ("\<phi>")
  where "pend_flow2 \<tau> \<equiv> [
  x \<leadsto> x * \<guillemotleft>cos \<tau>\<guillemotright> + y * \<guillemotleft>sin \<tau>\<guillemotright>,
  y \<leadsto> - x * \<guillemotleft>sin \<tau>\<guillemotright> + y * \<guillemotleft>cos \<tau>\<guillemotright>]"

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(clarsimp, expr_auto, simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
   apply(expr_auto, case_tac "i = 1 \<or> i = 2", auto simp: forall_2  intro!: vderiv_intros)
  using exhaust_2 by force expr_auto+

lemma "local_flow f UNIV UNIV \<phi>"
  apply (unfold_locales; expr_auto)
  apply ((rule_tac \<DD>=f in c1_local_lipschitz; expr_auto), fastforce intro: num2I intro!: derivative_intros,
   fastforce intro: num2I continuous_intros)
   apply(case_tac "i = 1 \<or> i = 2", auto simp: forall_2  intro!: vderiv_intros)
  using exhaust_2 by (auto simp: vec_eq_iff)

lemma pendulum_flow: "\<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>} (x\<acute>= f & G) \<^bold>{\<guillemotleft>r\<guillemotright>\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>}"
  apply(subst local_flow.fbox_g_ode_subset[OF local_flow_pend], simp)
  by (auto, expr_auto)

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

end

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 "y' 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. We prove that the ball remains above ground and below its initial resting
position. \<close>

locale bouncing_ball =
  fixes g :: real         \<comment> \<open> Gravitational acceleration constant \<close>
    and H :: real         \<comment> \<open> The initial or maximum height of the ball \<close>
    and c :: real         \<comment> \<open> The damping coefficient applied upon rebound \<close>
    and y :: "real \<Longrightarrow> real^2"
    and v :: "real \<Longrightarrow> real^2"
  assumes g_pos: "g > 0"  \<comment> \<open> The gravitational constant should be strictly positive (e.g. 9.81) \<close>
    and c_pos: "c > 0"    \<comment> \<open> The damping coefficient is greater than 0... \<close>
    and c_le_one: "c \<le> 1" \<comment> \<open> ... and no greater than 1, otherwise it increases its bounce. \<close>
    and H_pos: "H \<ge> 0"
    and y_def [simp]: "y \<equiv> vec_lens 1"
    and v_def [simp]: "v \<equiv> vec_lens 2"
begin

abbreviation fball :: "real ^ 2 \<Rightarrow> real ^ 2" ("f")
  where "fball \<equiv> [y \<leadsto> v, v \<leadsto> - \<guillemotleft>g\<guillemotright>]"

abbreviation ball_loop_inv :: "real ^ 2 \<Rightarrow> bool" ("I")
  where "I \<equiv> (v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y))\<^sub>e"

\<comment> \<open>Verified with differential invariants in @{text "\<real>\<^sup>2"} \<close>

abbreviation "BBall_dinv \<equiv>
  LOOP (
    (x\<acute>= f & (0 \<le> y)\<^sub>e DINV I);
    IF v = 0 THEN v ::= - \<guillemotleft>c\<guillemotright> * v ELSE skip)
  INV (0 \<le> y \<and> v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y))"

lemma ball_diff_inv: "\<^bold>{v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y)\<^bold>} (x\<acute>= f & (0 \<le> $y)\<^sub>e) \<^bold>{v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y)\<^bold>}"
  apply(subst hoare_diff_inv)
   apply(rule_tac \<mu>'="(2 * \<guillemotleft>g\<guillemotright> * v)\<^sub>e" and \<nu>'="(2 * \<guillemotleft>g\<guillemotright> * v)\<^sub>e" in diff_inv_leq_law)
      apply (simp_all add: is_interval_def)
  by expr_auto (auto intro!: vderiv_intros)

lemma "\<^bold>{v = 0 \<and> y = \<guillemotleft>H\<guillemotright>\<^bold>} BBall_dinv \<^bold>{0 \<le> y \<and> y \<le> \<guillemotleft>H\<guillemotright>\<^bold>}"
  apply(rule hoare_loopI, simp only: wlp fbox_if_then_else)
    apply(rule hoare_g_odei)
  using ball_diff_inv apply simp
     apply force
    apply expr_auto
   apply(simp add: H_pos)
  by expr_auto (smt g_pos mult_pos_neg zero_le_power2)

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

abbreviation ball_flow :: "real \<Rightarrow> real ^ 2 \<Rightarrow> real ^ 2" ("\<phi>")
  where "\<phi> \<tau> \<equiv> [
  y \<leadsto> - \<guillemotleft>g\<guillemotright> * \<guillemotleft>\<tau>\<guillemotright>\<^sup>2 / 2 + v * \<guillemotleft>\<tau>\<guillemotright> + y,
  v \<leadsto> - \<guillemotleft>g\<guillemotright> * \<guillemotleft>\<tau>\<guillemotright> + v]"

abbreviation "BBall_dyn \<equiv>
  LOOP (
    (EVOL \<phi> (0 \<le> y)\<^sub>e (\<lambda>s. UNIV));
    IF v = 0 THEN v ::= - \<guillemotleft>c\<guillemotright> * v ELSE skip)
  INV (0 \<le> y \<and> v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y))"

lemma BBall_dyn_arith:
  assumes "g * (2 * x) + x' * x' \<le> H * (g * 2)"
  shows "x \<le> H"
proof-
  have "g * (2 * x) \<le> H * (g * 2)"
    using assms by (metis add.commute le_add_same_cancel2
        mult_2_right order_trans zero_le_square)
  hence "2 * g * x \<le> 2 * g * H"
    by (simp add: mult.commute)
  thus "x \<le> H"
    using g_pos by auto
qed

lemma "\<^bold>{v = 0 \<and> y = \<guillemotleft>H\<guillemotright>\<^bold>} BBall_dyn \<^bold>{0 \<le> y \<and> y \<le> \<guillemotleft>H\<guillemotright>\<^bold>}"
  apply(rule hoare_loopI, simp only: wlp fbox_if_then_else fbox_g_evol)
    apply(expr_auto, auto simp: field_simps)
  using c_pos c_le_one H_pos apply expr_auto
    using BBall_dyn_arith by expr_auto

\<comment> \<open>Verified with the flow in @{text "\<real>\<^sup>2"} \<close>

abbreviation "BBall \<equiv>
  LOOP (
    (x\<acute>= f & (0 \<le> y)\<^sub>e);
    IF v = 0 THEN v ::= - \<guillemotleft>c\<guillemotright> * v ELSE skip)
  INV (0 \<le> y \<and> v\<^sup>2 \<le> 2 * \<guillemotleft>g\<guillemotright> * (\<guillemotleft>H\<guillemotright> - y))"

lemma local_flow_ball: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, expr_auto)
    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)
  apply (expr_auto, case_tac "i = 1 \<or> i = 2", auto simp: forall_2 intro!: vderiv_intros )
  using exhaust_2 by force expr_auto+

abbreviation dfball :: "real ^ 2 \<Rightarrow> real ^ 2" ("df")
  where "dfball \<equiv> [y \<leadsto> v, v \<leadsto> 0]"

lemma "local_flow f UNIV UNIV \<phi>"
  apply (unfold_locales; expr_auto)
  apply ((rule_tac \<DD>=df in c1_local_lipschitz; expr_auto), fastforce intro: num2I intro!: derivative_intros,
   fastforce intro: num2I continuous_intros)
   apply(case_tac "i = 1 \<or> i = 2", auto simp: forall_2  intro!: vderiv_intros)
  using exhaust_2 by (auto simp: vec_eq_iff)

lemma "\<^bold>{v = 0 \<and> y = \<guillemotleft>H\<guillemotright>\<^bold>} BBall \<^bold>{0 \<le> y \<and> y \<le> \<guillemotleft>H\<guillemotright>\<^bold>}"
  apply(rule hoare_loopI, simp only: wlp fbox_if_then_else)
    apply(subst local_flow.fbox_g_ode_subset[OF local_flow_ball], simp)
  using g_pos apply(expr_simp, clarsimp simp: field_simps)
  using c_pos c_le_one H_pos apply expr_auto
  using BBall_dyn_arith
  by (expr_auto, clarsimp simp: field_simps, simp add: mult.commute)

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

end

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 prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

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

lit_vars

locale thermostat =
    \<comment> \<open> constants \<close>
  fixes a :: real
    and L :: real
    and "T\<^sub>m" :: real
    and "T\<^sub>M" :: real
    \<comment> \<open> variables \<close>
    and \<theta> :: "real \<Longrightarrow> real^4"
    and T :: "real \<Longrightarrow> real^4"
    and t :: "real \<Longrightarrow> real^4"
    and T\<^sub>0 :: "real \<Longrightarrow> real^4"
  assumes T_def [simp]: "T \<equiv> vec_lens 1"
    and t_def [simp]: "t \<equiv> vec_lens 2"
    and theta_def [simp]: "\<theta> \<equiv> vec_lens 3"
    and T0_def [simp]: "T\<^sub>0 \<equiv> vec_lens 4"
    and Tm_nonneg: "0 < T\<^sub>m"
    and Tm_less_TM: "T\<^sub>m + 1 < T\<^sub>M"
    and TM_less_L: "T\<^sub>M < L"
    and a_ge0: "a > 0"
begin

abbreviation therm_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f c \<equiv> [T \<leadsto> - a * (T - c), t \<leadsto> 1, \<theta> \<leadsto> 0, T\<^sub>0 \<leadsto> 0]"

abbreviation therm_flow2 :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> c \<tau> \<equiv> [
  T \<leadsto> - exp(-a * \<tau>) * (c - T) + c,
  t \<leadsto> \<tau> + t,
  \<theta> \<leadsto> \<theta>,
  T\<^sub>0 \<leadsto> T\<^sub>0]"

lemma norm_diff_therm_dyn: "\<parallel>f c s\<^sub>1 - f c s\<^sub>2\<parallel> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(expr_simp, simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  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 + - c) + - (a * (s\<^sub>2$1 + - c))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a_ge0 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - c) - a * (s\<^sub>1$1 - c)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_therm_dyn:
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f c)"
  using a_ge0 apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarify, rule_tac x=1 in exI, rule conjI, simp, rule_tac x=a in exI)
  by (simp only: norm_diff_therm_dyn) (metis Finite_Cartesian_Product.norm_nth_le
      abs_1 abs_ge_zero mult.right_neutral mult_le_cancel_left_pos mult_zero_right
      real_norm_def vector_minus_component)

lemma local_flow_therm: "local_flow (f c) UNIV UNIV (\<phi> c)"
  using a_ge0 apply unfold_locales
  prefer 6 apply(rule local_lipschitz_therm_dyn)
  apply (simp_all add: forall_4 vec_eq_iff, expr_auto)
  by (auto intro!: vderiv_intros) expr_auto+

abbreviation dftherm :: "real \<Rightarrow> real ^ 4 \<Rightarrow> real ^ 4" ("df")
  where "dftherm c \<equiv> [T \<leadsto> - a * T, t \<leadsto> 0, \<theta> \<leadsto> 0, T\<^sub>0 \<leadsto> 0]"

lemma "local_flow (f c) UNIV UNIV (\<phi> c)"
  apply (unfold_locales)
  prefer 6
    apply (rule_tac \<DD>="df c" in c1_local_lipschitz; expr_auto add: has_derivative_coordinate)
  subgoal for s i
    using exhaust_4[of i] apply safe
    by (auto intro!: derivative_eq_intros)
          apply(fastforce intro: num4I continuous_intros)
         apply (simp_all add: forall_4 vec_eq_iff, expr_auto)
  by (auto intro!: vderiv_intros) expr_auto+

abbreviation "therm_ctrl \<equiv> ((t ::= 0);(T\<^sub>0 ::= T);
    (IF \<theta> = 0 \<and> T\<^sub>0 \<le> T\<^sub>m + 1 THEN (\<theta> ::= 1) ELSE
    (IF \<theta> = 1 \<and> T\<^sub>0 \<ge> T\<^sub>M - 1 THEN (\<theta> ::= 0) ELSE skip)))"

abbreviation "therm_dyn \<equiv>
    (IF \<theta> = 0 THEN (x\<acute>= f 0 & (t \<le> - (ln (T\<^sub>m/T\<^sub>0))/a)\<^sub>e) ELSE
    (x\<acute>= f L & (t \<le> - (ln ((L - T\<^sub>M)/(L - T\<^sub>0)))/a)\<^sub>e))"

lemmas fbox_therm_dyn = local_flow.fbox_g_ode_subset[OF local_flow_therm]

lemma
  "\<^bold>{T\<^sub>m \<le> T \<and> T \<le> T\<^sub>M \<and> \<theta> = 0\<^bold>}
    (LOOP (therm_ctrl; therm_dyn) INV (T\<^sub>m \<le> T \<and> T \<le> T\<^sub>M \<and> (\<theta> = 0 \<or> \<theta> = 1)))
   \<^bold>{T\<^sub>m \<le> T \<and> T \<le> T\<^sub>M\<^bold>}"
  apply(rule hoare_loopI, simp only: wlp fbox_if_then_else)
    apply(subst fbox_therm_dyn, expr_simp)+
  using temp_dyn_up_real_arith[OF a_ge0 _ _ TM_less_L, of "T\<^sub>m"]
    and temp_dyn_down_real_arith[OF a_ge0 Tm_nonneg, of _ "T\<^sub>M"]
  by expr_auto+

end

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 "H\<^sub>l \<le> h \<le> H\<^sub>u"}. 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 prove that the controller keeps the level of
water between @{text "H\<^sub>l"} and @{text "H\<^sub>u"}. \<close>

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)

named_theorems local_flow

dataspace water_tank =
  constants H\<^sub>l::real H\<^sub>u::real c\<^sub>o::real c\<^sub>i::real
  assumes co: "0 < c\<^sub>o" and ci: "c\<^sub>o < c\<^sub>i"
  variables flw::"bool" h::"real" h\<^sub>m::"real" t::"real"

context water_tank
begin

abbreviation tank_ode :: "real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> 'st \<Rightarrow> 'st set"
  where "tank_ode h\<^sub>x k s \<equiv> {h` = k, t` = 1 | t \<le> (h\<^sub>x - h\<^sub>m)/k}"

abbreviation (input) tank_vec_field :: "real \<Rightarrow> 'st \<Rightarrow> 'st" ("f")
  where "tank_vec_field k \<equiv> [h \<leadsto> k, t \<leadsto> 1]"

abbreviation (input) tank_flow :: "real \<Rightarrow> real \<Rightarrow> 'st \<Rightarrow> 'st" ("\<phi>")
  where "tank_flow k \<tau> \<equiv> [h \<leadsto> k * \<tau> + h, t \<leadsto> \<tau> + t]"

lemma lflow_tank [local_flow]: "local_flow_on (f k) (h+\<^sub>Lt) UNIV UNIV (\<phi> k)"
  by local_flow_on_auto

lemma lf: "local_flow_on [h \<leadsto> k, t \<leadsto> 1] (h+\<^sub>Lt) UNIV UNIV (\<lambda>\<tau>. [h \<leadsto> k * \<tau> + h, t \<leadsto> \<tau> + t])"
  by local_flow_on_auto

abbreviation "ctrl \<equiv> (t, h\<^sub>m) ::= (0, h);
     IF \<not>flw \<and> h\<^sub>m \<le> H\<^sub>l + 1 THEN flw ::= True ELSE
     IF flw \<and> h\<^sub>m \<ge> H\<^sub>u - 1 THEN flw ::= False ELSE skip"

abbreviation "dyn \<equiv> IF flw THEN {h` = c\<^sub>i - c\<^sub>o, t` = 1 | t \<le> (H\<^sub>u - h\<^sub>m)/(c\<^sub>i - c\<^sub>o)}
     ELSE {h` = - c\<^sub>o, t` = 1 | t \<le> (H\<^sub>l - h\<^sub>m)/(- c\<^sub>o)}"

abbreviation "dyn' \<equiv> {h` = (flw*c\<^sub>i) - c\<^sub>o, t` = 1 | t \<le> ((flw*H\<^sub>u + (\<not>flw)*H\<^sub>l) - h\<^sub>m)/((flw*c\<^sub>i) - c\<^sub>o)}"

lemma nm: "dyn nmods {flw, h\<^sub>m}" by (simp add: closure)

lemma "\<^bold>{flw = F\<^bold>}dyn\<^bold>{flw = F\<^bold>}" by (rule nmods_invariant[OF nm], unrest)

lemma
  "\<^bold>{H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
    LOOP ctrl ; dyn INV (H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u)
   \<^bold>{H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  using tank_arith[OF _ co ci]
  by (hoare_wp_auto local_flow: lflow_tank)

lemma "\<^bold>{flw \<and> 0 \<le> t \<and> h = (c\<^sub>i - c\<^sub>o)*t + h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
         dyn'
       \<^bold>{flw \<and> 0 \<le> t \<and> h = (c\<^sub>i - c\<^sub>o)*t + h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  using ci by dInduct_mega'

lemma "\<^bold>{0 \<le> t \<and> h = (c\<^sub>i - c\<^sub>o)*t + h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
         {h` = c\<^sub>i - c\<^sub>o, t` = 1 | t \<le> (H\<^sub>u - h\<^sub>m)/(c\<^sub>i - c\<^sub>o)}
       \<^bold>{0 \<le> t \<and> h = (c\<^sub>i - c\<^sub>o)*t + h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  using ci by dInduct_mega

lemma tank_correct:
  "\<^bold>{t = 0 \<and> h = h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
      LOOP ctrl ; dyn INV (0 \<le> t \<and> h = ((flw * c\<^sub>i) - c\<^sub>o)*t + h\<^sub>m \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u)
   \<^bold>{H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  using ci co by dProve

(* TODO: Tactic for automated Hoare-style verification. *)
(* named_theorems hoare_intros "introduction rules from Hoare logic"

declare hoare_invs [hoare_intros]
    and hoare_skip [hoare_intros]
    and hoare_test [hoare_intros]
    and H_assign_init [hoare_intros]
    and hoare_if_then_else [hoare_intros]

method body_hoare
  = (rule hoare_intros,(simp)?; body_hoare?)

method hyb_hoare for P::"'b \<Rightarrow> bool"
  = (rule hoare_loopI, rule hoare_kcomp[where R=P]; body_hoare?)

lemma tank_diff_inv:
  "\<^bold>{h = k * t + h\<^sub>0 \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
    {h` = k, t` = 1 | t \<le> (H\<^sub>u - h\<^sub>m)/k}
   \<^bold>{h = k * t + h\<^sub>0 \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  apply(subst subst_ode)
  apply(intro hoare_invs)
    apply(dInduct_mega)[1]
   apply(subst hoare_diff_inv_on)
   apply(rule lie_deriv_le_rule)
  sorry

lemma
  "\<^bold>{H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}
    LOOP ctrl ; dyn INV (h = k * t + h\<^sub>0 \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u)
   \<^bold>{H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u\<^bold>}"
  apply(hyb_hoare "(h = k * t + h\<^sub>0 \<and> H\<^sub>l \<le> h \<and> h \<le> H\<^sub>u)\<^sub>e")
        prefer 4 prefer 5
  using tank_diff_inv
  apply (rule hoare_loopI)
  apply(rule hoare_loopI)
  apply(hyb_hoare "(H\<^sub>l \<le> $h)\<^sub>e")
    apply (simp only: wp fbox_if_then_else)
  apply clarsimp
  apply (hoare_wp_auto)
  apply (rule hoare_if_then_else_inv)
  using ci apply dInduct_mega
  thm nmods_invariant
      apply (rule_tac nmods_invariant)
       apply (rule nmods_g_orbital_on_discrete')
       apply (simp)
      apply unrest
     apply (dInduct_mega)
  apply (dInduct_auto)
  oops

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real^4) upred" ("dI")
  where "dI h\<^sub>l h\<^sub>h k \<equiv> \<^U>(h = k \<cdot> t + h\<^sub>0 \<and> 0 \<le> t \<and> h\<^sub>l \<le> h\<^sub>0 \<and> h\<^sub>0 \<le> h\<^sub>h \<and> (\<pi> = 0 \<or> \<pi> = 1))"

lemma tank_diff_inv:
  "0 \<le> \<tau> \<Longrightarrow> diff_invariant (dI h\<^sub>l h\<^sub>h k) (f k) {0..\<tau>} UNIV 0 Guard"
  apply(pred_simp, intro diff_invariant_conj_rule)
      apply(force intro!: poly_derivatives diff_invariant_rules)
     apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 1" in diff_invariant_leq_rule, simp_all)
    apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 0" in diff_invariant_leq_rule, simp_all)
  by (auto intro!: poly_derivatives diff_invariant_rules)

lemma tank_inv_arith1:
  assumes "0 \<le> (\<tau>::real)" and "c\<^sub>o < c\<^sub>i" and b: "h\<^sub>l \<le> y\<^sub>0" and g: "\<tau> \<le> (h\<^sub>h - y\<^sub>0) / (c\<^sub>i - c\<^sub>o)"
  shows "h\<^sub>l \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0" and "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> h\<^sub>h"
proof-
  have "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> \<le> (h\<^sub>h - y\<^sub>0)"
    using g assms(2,3) by (metis diff_gt_0_iff_gt mult.commute pos_le_divide_eq)
  thus "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> h\<^sub>h"
    by auto
  show "h\<^sub>l \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0"
    using b assms(1,2) by (metis add.commute add_increasing2 diff_ge_0_iff_ge
        less_eq_real_def mult_nonneg_nonneg)
qed

lemma tank_inv_arith2:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and b: "y\<^sub>0 \<le> h\<^sub>h" and g: "\<tau> \<le> - ((h\<^sub>l - y\<^sub>0) / c\<^sub>o)"
  shows "h\<^sub>l \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>" and "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> h\<^sub>h"
proof-
  have "\<tau> \<cdot> c\<^sub>o \<le> y\<^sub>0 - h\<^sub>l"
    using g \<open>0 < c\<^sub>o\<close> pos_le_minus_divide_eq by fastforce
  thus "h\<^sub>l \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>"
    by (auto simp: mult.commute)
  show "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> h\<^sub>h"
    using b assms(1,2)
    by (smt mult_sign_intros(1))
qed

abbreviation tank_dyn_dinv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real^4) nd_fun" ("dyn")
  where "dyn c\<^sub>i c\<^sub>o h\<^sub>l h\<^sub>h \<tau> \<equiv> IF (\<pi> = 0) THEN
    x\<acute>= f (c\<^sub>i-c\<^sub>o) & G h\<^sub>h (c\<^sub>i-c\<^sub>o) on {0..\<tau>} UNIV @ 0 DINV (dI h\<^sub>l h\<^sub>h (c\<^sub>i-c\<^sub>o))
  ELSE x\<acute>= f (-c\<^sub>o) & G h\<^sub>l (-c\<^sub>o) on {0..\<tau>} UNIV @ 0 DINV (dI h\<^sub>l h\<^sub>h (-c\<^sub>o))"

abbreviation "tank_dinv c\<^sub>i c\<^sub>o h\<^sub>l h\<^sub>h \<tau> \<equiv> LOOP (ctrl h\<^sub>l h\<^sub>h ; dyn c\<^sub>i c\<^sub>o h\<^sub>l h\<^sub>h \<tau>) INV (I h\<^sub>l h\<^sub>h)"

lemma tank_inv:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<^bold>{I h\<^sub>l h\<^sub>h\<^bold>} tank_dinv c\<^sub>i c\<^sub>o h\<^sub>l h\<^sub>h \<tau> \<^bold>{I h\<^sub>l h\<^sub>h\<^bold>}"
  apply(hyb_hoare "\<^U>(I h\<^sub>l h\<^sub>h \<and> t = 0 \<and> h\<^sub>0 = h)")
            prefer 4 prefer 7 using tank_diff_inv assms apply force+
  using assms tank_inv_arith1 tank_inv_arith2 by (rel_auto' simp: eucl_nth_def) *)

end

locale example_9b =
  fixes Kp::real
    and Kd::real
    and x::"real \<Longrightarrow> real^3"
    and v::"real \<Longrightarrow> real^3"
    and xr::"real \<Longrightarrow> real^3"
  assumes x_def [simp]: "x \<equiv> vec_lens 1"
    and v_def [simp]: "v \<equiv> vec_lens 2"
    and xr_def [simp]: "xr \<equiv> vec_lens 3"
    and kp_def: "Kp = 2"
    and kd_def: "Kd = 3 "
begin

(* { x' = v, v' = -Kp*(x-xr) - Kd*v & v >= 0 } *)
abbreviation f9 :: "real ^ 3 \<Rightarrow> real ^ 3"
  where "f9 \<equiv> [x \<leadsto> v, v \<leadsto> -Kp * (x - xr) - Kd * v, xr \<leadsto> 0]"

lemma local_lipschitz_f9: "local_lipschitz UNIV UNIV (\<lambda>t::real. f9)"
  apply(rule_tac \<DD>=f9 in c1_local_lipschitz; clarsimp)
  apply (expr_auto add: has_derivative_coordinate)
  subgoal for s i
    using exhaust_3[of i]
    by (auto intro!: derivative_eq_intros)
  apply expr_auto
  apply(rule_tac f'="\<lambda>t. f9" in has_derivative_continuous_on)
  apply (expr_auto add: has_derivative_coordinate)
  subgoal for s i
    using exhaust_3[of i]
    by (auto intro!: derivative_eq_intros)
  done

abbreviation "flow9 \<tau> \<equiv> [
  x \<leadsto> exp ((-2)*\<tau>) * (xr - 2 * (exp \<tau>) * xr + (exp (2 * \<tau>)) * xr - v + (exp \<tau>) * v - x + 2 * (exp \<tau>) * x),
  v \<leadsto> exp ((-2)*\<tau>) * (-2 * xr + 2 * (exp \<tau>) * xr + 2 * v - (exp \<tau>) * v + 2* x - 2 * (exp \<tau>) * x),
  xr \<leadsto> xr]"

lemma "local_flow f9 UNIV UNIV flow9"
  apply(unfold_locales; (rule local_lipschitz_f9)?; clarsimp simp: vec_eq_iff; expr_auto)
  subgoal for t s i
    using exhaust_3[of i] apply (safe; clarsimp simp: kp_def kd_def)
      apply(auto intro!: vderiv_intros)[1]
         apply(force simp: field_simps)+
     prefer 2 apply(rule vderiv_intros)
      apply(auto intro!: vderiv_intros)[1]
    by (auto simp: field_simps exp_minus_inverse)
  done

end

end


(*  Title:      HOL/Proofs/Lambda/Lambda.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen
*)

section \<open>Basic definitions of Lambda-calculus\<close>

theory Lambda
imports MainRLT
begin

declare [[syntax_ambiguity_warning = false]]

subsection \<open>Lambda-terms in de Bruijn notation and substitution\<close>

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

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

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

declare subst_Var [simp del]

text \<open>Optimized versions of \<^term>\<open>subst\<close> and \<^term>\<open>lift\<close>.\<close>

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

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

subsection \<open>Beta-reduction\<close>

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

abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t == beta\<^sup>*\<^sup>* s t"

inductive_cases beta_cases [elim!]:
  "Var i \<rightarrow>\<^sub>\<beta> t"
  "Abs r \<rightarrow>\<^sub>\<beta> s"
  "s \<degree> t \<rightarrow>\<^sub>\<beta> u"

declare if_not_P [simp] not_less_eq [simp]
  \<comment> \<open>don't add \<open>r_into_rtrancl[intro!]\<close>\<close>

subsection \<open>Congruence rules\<close>

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "[| s \<rightarrow>\<^sub>\<beta>\<^sup>* s'; t \<rightarrow>\<^sub>\<beta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection \<open>Substitution-lemmas\<close>

lemma subst_eq [simp]: "(Var k)[u/k] = u"
  by (simp add: subst_Var)

lemma subst_gt [simp]: "i < j ==> (Var j)[u/i] = Var (j - 1)"
  by (simp add: subst_Var)

lemma subst_lt [simp]: "j < i ==> (Var j)[u/i] = Var j"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst [simp]:
    "j < i + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t (i + 1)) [lift s i / j]"
  by (induct t arbitrary: i j s)
    (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t i) [lift s i / j + 1]"
  by (induct t arbitrary: i j s) (simp_all add: subst_Var lift_lift)

lemma subst_lift [simp]:
    "(lift t k)[s/k] = t"
  by (induct t arbitrary: k s) simp_all

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t[lift v i / Suc j][u[v/j]/i] = t[u/i][v/j]"
  by (induct t arbitrary: i j u v)
    (simp_all add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
      split: nat.split)

subsection \<open>Equivalence proof for optimized substitution\<close>

lemma liftn_0 [simp]: "liftn 0 t k = t"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma liftn_lift [simp]: "liftn (Suc n) t k = lift (liftn n t k) k"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma substn_subst_n [simp]: "substn t s n = t[liftn n s 0 / n]"
  by (induct t arbitrary: n) (simp_all add: subst_Var)

theorem substn_subst_0: "substn t s 0 = t[s/0]"
  by simp

subsection \<open>Preservation theorems\<close>

text \<open>Not used in Church-Rosser proof, but in Strong
  Normalization. \medskip\<close>

theorem subst_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r[t/i] \<rightarrow>\<^sub>\<beta> s[t/i]"
  by (induct arbitrary: t i set: beta) (simp_all add: subst_subst [symmetric])

theorem subst_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> r[t/i] \<rightarrow>\<^sub>\<beta>\<^sup>* s[t/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule subst_preserves_beta)
  done

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
  by (induct arbitrary: i set: beta) auto

theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule lift_preserves_beta)
  done

theorem subst_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct t arbitrary: r s i)
    apply (simp add: subst_Var r_into_rtranclp)
   apply (simp add: rtrancl_beta_App)
  apply (simp add: rtrancl_beta_Abs)
  done

theorem subst_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp_trans)
  apply (erule subst_preserves_beta2)
  done

end