(* Author: Tobias Nipkow *)

theory Abs_Int1_const
imports Abs_Int1
begin

subsection "Constant Propagation"

datatype const = Const val | Any

fun \<gamma>_const where
"\<gamma>_const (Const i) = {i}" |
"\<gamma>_const (Any) = UNIV"

fun plus_const where
"plus_const (Const i) (Const j) = Const(i+j)" |
"plus_const _ _ = Any"

lemma plus_const_cases: "plus_const a1 a2 =
  (case (a1,a2) of (Const i, Const j) \<Rightarrow> Const(i+j) | _ \<Rightarrow> Any)"
by(auto split: prod.split const.split)

instantiation const :: semilattice_sup_top
begin

fun less_eq_const where "x \<le> y = (y = Any | x=y)"

definition "x < (y::const) = (x \<le> y & \<not> y \<le> x)"

fun sup_const where "x \<squnion> y = (if x=y then x else Any)"

definition "\<top> = Any"

instance
proof (standard, goal_cases)
  case 1 thus ?case by (rule less_const_def)
next
  case (2 x) show ?case by (cases x) simp_all
next
  case (3 x y z) thus ?case by(cases z, cases y, cases x, simp_all)
next
  case (4 x y) thus ?case by(cases x, cases y, simp_all, cases y, simp_all)
next
  case (6 x y) thus ?case by(cases x, cases y, simp_all)
next
  case (5 x y) thus ?case by(cases y, cases x, simp_all)
next
  case (7 x y z) thus ?case by(cases z, cases y, cases x, simp_all)
next
  case 8 thus ?case by(simp add: top_const_def)
qed

end

global_interpretation Val_semilattice
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
proof (standard, goal_cases)
  case (1 a b) thus ?case
    by(cases a, cases b, simp, simp, cases b, simp, simp)
next
  case 2 show ?case by(simp add: top_const_def)
next
  case 3 show ?case by simp
next
  case 4 thus ?case by(auto simp: plus_const_cases split: const.split)
qed

global_interpretation Abs_Int
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
defines AI_const = AI and step_const = step' and aval'_const = aval'
..

subsubsection "Tests"

definition "steps c i = (step_const \<top> ^^ i) (bot c)"

value "show_acom (steps test1_const 0)"
value "show_acom (steps test1_const 1)"
value "show_acom (steps test1_const 2)"
value "show_acom (steps test1_const 3)"
value "show_acom (the(AI_const test1_const))"

value "show_acom (the(AI_const test2_const))"
value "show_acom (the(AI_const test3_const))"

value "show_acom (steps test4_const 0)"
value "show_acom (steps test4_const 1)"
value "show_acom (steps test4_const 2)"
value "show_acom (steps test4_const 3)"
value "show_acom (steps test4_const 4)"
value "show_acom (the(AI_const test4_const))"

value "show_acom (steps test5_const 0)"
value "show_acom (steps test5_const 1)"
value "show_acom (steps test5_const 2)"
value "show_acom (steps test5_const 3)"
value "show_acom (steps test5_const 4)"
value "show_acom (steps test5_const 5)"
value "show_acom (steps test5_const 6)"
value "show_acom (the(AI_const test5_const))"

value "show_acom (steps test6_const 0)"
value "show_acom (steps test6_const 1)"
value "show_acom (steps test6_const 2)"
value "show_acom (steps test6_const 3)"
value "show_acom (steps test6_const 4)"
value "show_acom (steps test6_const 5)"
value "show_acom (steps test6_const 6)"
value "show_acom (steps test6_const 7)"
value "show_acom (steps test6_const 8)"
value "show_acom (steps test6_const 9)"
value "show_acom (steps test6_const 10)"
value "show_acom (steps test6_const 11)"
value "show_acom (steps test6_const 12)"
value "show_acom (steps test6_const 13)"
value "show_acom (the(AI_const test6_const))"

text{* Monotonicity: *}

global_interpretation Abs_Int_mono
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
proof (standard, goal_cases)
  case 1 thus ?case by(auto simp: plus_const_cases split: const.split)
qed

text{* Termination: *}

definition m_const :: "const \<Rightarrow> nat" where
"m_const x = (if x = Any then 0 else 1)"

global_interpretation Abs_Int_measure
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
and m = m_const and h = "1"
proof (standard, goal_cases)
  case 1 thus ?case by(auto simp: m_const_def split: const.splits)
next
  case 2 thus ?case by(auto simp: m_const_def less_const_def split: const.splits)
qed

thm AI_Some_measure

end


section \<open> Design Weakest Preconditions \<close>

theory utp_des_wp
  imports utp_des_prog utp_des_hoare
begin

definition wp_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> '\<beta> cond \<Rightarrow> '\<alpha> cond" (infix "wp\<^sub>D" 60) where
[upred_defs]: "Q wp\<^sub>D r = (\<lfloor>pre\<^sub>D(Q) ;; true :: ('\<alpha>, '\<beta>) urel\<rfloor>\<^sub>< \<and> (post\<^sub>D(Q) wlp r))"

text \<open> If two normal designs have the same weakest precondition for any given postcondition, then
  the two designs are equivalent. \<close>

theorem wpd_eq_intro: "\<lbrakk> \<And> r. (p\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>1) wp\<^sub>D r = (p\<^sub>2 \<turnstile>\<^sub>n Q\<^sub>2) wp\<^sub>D r \<rbrakk> \<Longrightarrow> (p\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>1) = (p\<^sub>2 \<turnstile>\<^sub>n Q\<^sub>2)"
apply (rel_simp robust; metis curry_conv)
done

theorem wpd_H3_eq_intro: "\<lbrakk> P is H1_H3; Q is H1_H3; \<And> r. P wp\<^sub>D r = Q wp\<^sub>D r \<rbrakk> \<Longrightarrow> P = Q"
  by (metis H1_H3_commute H1_H3_is_normal_design H3_idem Healthy_def' wpd_eq_intro)

lemma wp_d_abort [wp]: "true wp\<^sub>D p = false"
  by (rel_auto)

lemma wp_assigns_d [wp]: "\<langle>\<sigma>\<rangle>\<^sub>D wp\<^sub>D r = \<sigma> \<dagger> r"
  by (rel_auto)

theorem rdesign_wp [wp]:
  "(\<lceil>p\<rceil>\<^sub>< \<turnstile>\<^sub>r Q) wp\<^sub>D r = (p \<and> Q wlp r)"
  by (rel_auto)

theorem ndesign_wp [wp]:
  "(p \<turnstile>\<^sub>n Q) wp\<^sub>D r = (p \<and> Q wlp r)"
  by (simp add: ndesign_def rdesign_wp)

theorem wpd_seq_r:
  fixes Q1 Q2 :: "'\<alpha> hrel"
  shows "((\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1) ;; (\<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2)) wp\<^sub>D r = (\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1) wp\<^sub>D ((\<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2) wp\<^sub>D r)"
  apply (simp add: wp)
  apply (subst rdesign_composition_wp)
  apply (simp only: wp)
  apply (rel_auto)
done

theorem wpnd_seq_r [wp]:
  fixes Q1 Q2 :: "'\<alpha> hrel"
  shows "((p1 \<turnstile>\<^sub>n Q1) ;; (p2 \<turnstile>\<^sub>n Q2)) wp\<^sub>D r = (p1 \<turnstile>\<^sub>n Q1) wp\<^sub>D ((p2 \<turnstile>\<^sub>n Q2) wp\<^sub>D r)"
  by (simp add: ndesign_def wpd_seq_r)

theorem wpd_seq_r_H1_H3 [wp]:
  fixes P Q :: "'\<alpha> hrel_des"
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P ;; Q) wp\<^sub>D r = P wp\<^sub>D (Q wp\<^sub>D r)"
  by (metis H1_H3_commute H1_H3_is_normal_design H1_idem Healthy_def' assms(1) assms(2) wpnd_seq_r)

theorem wp_hoare_d_link:
  assumes "Q is \<^bold>N"
  shows "{p}Q{r}\<^sub>D \<longleftrightarrow> (Q wp\<^sub>D r \<sqsubseteq> p)"
  by (ndes_simp cls: assms, rel_auto)

end


theory RKAT_Models
  imports RKAT "$AFP/KAT_and_DRA/SingleSorted/KAT_Models"
begin

definition rel_spec :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"  where
  "rel_spec P Q \<equiv> Sup {X. P O X \<subseteq> X O Q}"

abbreviation rel_not :: "'a rel \<Rightarrow> 'a rel" where
  "rel_not x \<equiv> Id \<inter> ( - x)"

lemma rel_spec1: "near_dioid_tests_zerol.test rel_not P \<Longrightarrow>
   near_dioid_tests_zerol.test rel_not Q \<Longrightarrow>
   P O X \<subseteq> X O Q \<Longrightarrow> X \<le> rel_spec P Q"
   by (auto simp: rel_spec_def)

lemma rel_spec2: "near_dioid_tests_zerol.test rel_not P \<Longrightarrow>
   near_dioid_tests_zerol.test rel_not Q \<Longrightarrow>
   X \<le> rel_spec P Q \<Longrightarrow> P O X \<subseteq> X O Q"
proof (simp add: rel_spec_def rel_dioid_tests.kat_eq2[symmetric])
  assume "X \<subseteq> \<Union>{X. (P O X) O (rel_not Q) = {}}"
  hence "(P O X) O (rel_not Q) \<subseteq> (P O \<Union>{X. (P O X) O (rel_not Q) = {}}) O (rel_not Q)"
    by (simp add: relcomp_mono)
  also have "... \<subseteq> \<Union>{(P O X)O (Id \<inter> - Q) | X. (P O X) O (rel_not Q) = {}} "
    by auto
  also have "... \<subseteq> {}"
    by auto
  finally show "(P O X) O (rel_not Q) = {}"
    by auto
qed

interpretation rel_rkat: rkat "op \<union>" "op O" "Id :: 'a rel" "{}" "op \<subseteq>" "op \<subset>" rtrancl rel_not rel_spec
  apply (default, default)
  apply (simp_all add: rel_spec1 rel_spec2)
done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul3acc_rrot
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc x y z) = (mul3acc z x y))"
  oops

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Lemmas on list operations\<close>

theory Even_More_List
  imports Main
begin

lemma upt_add_eq_append':
  assumes "i \<le> j" and "j \<le> k"
  shows "[i..<k] = [i..<j] @ [j..<k]"
  using assms le_Suc_ex upt_add_eq_append by blast

lemma map_idem_upt_eq:
  \<open>map f [m..<n] = [m..<n]\<close> if \<open>\<And>q. m \<le> q \<Longrightarrow> q < n \<Longrightarrow> f q = q\<close>
proof (cases \<open>n \<ge> m\<close>)
  case False
  then show ?thesis
    by simp
next
  case True
  moreover define r where \<open>r = n - m\<close>
  ultimately have \<open>n = m + r\<close>
    by simp
  with that have \<open>\<And>q. m \<le> q \<Longrightarrow> q < m + r \<Longrightarrow> f q = q\<close>
    by simp
  then have \<open>map f [m..<m + r] = [m..<m + r]\<close>
    by (induction r) simp_all
  with \<open>n = m + r\<close> show ?thesis
    by simp
qed

lemma upt_zero_numeral_unfold:
  \<open>[0..<numeral n] = [0..<pred_numeral n] @ [pred_numeral n]\<close>
  by (simp add: numeral_eq_Suc)

lemma length_takeWhile_less:
  "\<exists>x\<in>set xs. \<not> P x \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (induct xs) (auto split: if_splits)

lemma Min_eq_length_takeWhile:
  \<open>Min {m. P m} = length (takeWhile (Not \<circ> P) ([0..<n]))\<close>
  if *: \<open>\<And>m. P m \<Longrightarrow> m < n\<close> and \<open>\<exists>m. P m\<close>
proof -
  from \<open>\<exists>m. P m\<close> obtain r where \<open>P r\<close> ..
  have \<open>Min {m. P m} = q + length (takeWhile (Not \<circ> P) ([q..<n]))\<close>
    if \<open>q \<le> n\<close> \<open>\<And>m. P m \<Longrightarrow> q \<le> m \<and> m < n\<close> for q
  using that proof (induction rule: inc_induct)
    case base
    from base [of r] \<open>P r\<close> show ?case
      by simp
  next
    case (step q)
    from \<open>q < n\<close> have *: \<open>[q..<n] = q # [Suc q..<n]\<close>
      by (simp add: upt_rec)
    show ?case
    proof (cases \<open>P q\<close>)
      case False
      then have \<open>Suc q \<le> m \<and> m < n\<close> if \<open>P m\<close> for m
        using that step.prems [of m] by (auto simp add: Suc_le_eq less_le)
      with \<open>\<not> P q\<close> show ?thesis
        by (simp add: * step.IH)
    next
      case True
      have \<open>{a. P a} \<subseteq> {0..n}\<close>
        using step.prems by (auto simp add: less_imp_le_nat)
      moreover have \<open>finite {0..n}\<close>
        by simp
      ultimately have \<open>finite {a. P a}\<close>
        by (rule finite_subset)
      with \<open>P q\<close> step.prems show ?thesis
        by (auto intro: Min_eqI simp add: *)
    qed
  qed
  from this [of 0] and that show ?thesis
    by simp
qed

lemma Max_eq_length_takeWhile:
  \<open>Max {m. P m} = n - Suc (length (takeWhile (Not \<circ> P) (rev [0..<n])))\<close>
  if *: \<open>\<And>m. P m \<Longrightarrow> m < n\<close> and \<open>\<exists>m. P m\<close>
using * proof (induction n)
  case 0
  with \<open>\<exists>m. P m\<close> show ?case
    by auto
next
  case (Suc n)
  show ?case
  proof (cases \<open>P n\<close>)
    case False
    then have \<open>m < n\<close> if \<open>P m\<close> for m
      using that Suc.prems [of m] by (auto simp add: less_le)
    with Suc.IH show ?thesis
      by auto
  next
    case True
    have \<open>{a. P a} \<subseteq> {0..n}\<close>
      using Suc.prems by (auto simp add: less_Suc_eq_le)
    moreover have \<open>finite {0..n}\<close>
      by simp
    ultimately have \<open>finite {a. P a}\<close>
      by (rule finite_subset)
    with \<open>P n\<close> Suc.prems show ?thesis
      by (auto intro: Max_eqI simp add: less_Suc_eq_le)
  qed
qed

end


theory IMP
  imports Main
    "~~/src/HOL/IMP/BExp"
begin

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 62] 62)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 63] 63)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 64] 64)
      | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [0, 64] 64)
      | Or com com              ("(_/ OR _)" [61,62] 61)

value "SKIP OR WHILE b DO c ;; c2"

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
RepeatTrue:
"\<lbrakk> bval b s\<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> s" |
RepeatFalse:
"\<lbrakk> \<not>bval b s; (c, s) \<Rightarrow> s'; (REPEAT c UNTIL b, s') \<Rightarrow> t\<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
OrL:
"(a,s) \<Rightarrow> t \<Longrightarrow> (a OR b, s) \<Rightarrow> t" |
OrR:
"(b,s) \<Rightarrow> t \<Longrightarrow> (a OR b, s) \<Rightarrow> t"
text_raw{*}%endsnip*}

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (REPEAT ''x'' ::= Plus (V ''x'') (N 5) UNTIL Not (Less (V ''x'') (V ''y'')),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2 OR ''x'' ::= N 3, <''x'' := 42>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]
  thm big_step.intros

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b, s) \<Rightarrow> t"
thm RepeatE

inductive_cases OrE[elim]: "(a OR b, s) \<Rightarrow> t"
thm OrE

text{* Only [elim]: [elim!] would not terminate. *}

text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof (intro allI, rule)
  fix s t assume "(?w, s) \<Rightarrow> t" then show "(?iw, s) \<Rightarrow> t"
  proof cases
    case WhileFalse
    then show ?thesis by blast
  next
    case (WhileTrue s\<^sub>2)
    then show ?thesis by blast
  qed
next
  fix s t assume iw: "(?iw, s) \<Rightarrow> t" then show "(?w,s) \<Rightarrow> t"
  proof(cases "bval b s")
    case True
    then have "(c;; WHILE b DO c, s) \<Rightarrow> t" using iw by auto
    then obtain s' where "(c,s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by blast
    then show "(?w, s) \<Rightarrow> t" using True by auto
  next
    case False
    then have "s=t" using iw by auto
    moreover have "(?w,s) \<Rightarrow> s" using False by auto
    ultimately show ?thesis by simp
  qed
qed

lemma Or_commute: "a OR b \<sim> b OR a"
  by blast

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
  by blast

lemma repeat_unfild:
  "(REPEAT c UNTIL b) \<sim> (IF b THEN SKIP ELSE c ;; (REPEAT c UNTIL b))"
  by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
proof -
  assume wc:"(WHILE b DO c,s) \<Rightarrow> t" and "c \<sim> c'"
  then show "(WHILE b DO c',s) \<Rightarrow> t" (is "?w1 \<Rightarrow> t")
  proof (induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
    case (WhileFalse b s c)
    assume "\<not> bval b s"
    then show "(WHILE b DO c', s) \<Rightarrow> s" by (rule big_step.WhileFalse)
  next
    case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
    then have "(c', s\<^sub>1) \<Rightarrow> s\<^sub>2" using `c \<sim> c'` by auto
    then show "(WHILE b DO c', s\<^sub>1) \<Rightarrow> s\<^sub>3" using WhileTrue by auto
  qed
qed

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic when no OR"

abbreviation "deterministic c \<equiv> \<forall> s t u. (c,s) \<Rightarrow> t \<and> (c,s) \<Rightarrow> u \<longrightarrow> t = u"

fun noOr::"com \<Rightarrow> bool" where
  "noOr (_ OR _) = False" |
  "noOr (_ ::= _) = True" |
  "noOr (a ;; b) = (noOr a \<and> noOr b)" |
  "noOr (IF _ THEN a ELSE b) = (noOr a \<and> noOr b)" |
  "noOr (WHILE _ DO c) = noOr c"|
  "noOr (REPEAT c UNTIL _) = noOr c" |
  "noOr SKIP = True"

text {* This proof is automatic. *}

(*lemma while_det:
  assumes "deterministic c"
  shows" deterministic (WHILE b DO c)"
    apply(induction "WHILE b DO c" rule: big_step_induct)
*)
theorem big_step_determ: "noOr c \<Longrightarrow> deterministic c"
proof(induction c rule: noOr.induct, auto)
  fix a s s1 s2 assume "deterministic a" "(a,s) \<Rightarrow> s1" "(a,s) \<Rightarrow> s2"
    then have "s1 = s2" by auto
    fix b t u assume "deterministic b" "(b, s1) \<Rightarrow> t" "(b, s2) \<Rightarrow> u"
    then show "t = u" using `s1 = s2` by auto
  next
    fix c s t u b
    assume "deterministic c" "(WHILE b DO c, s) \<Rightarrow> t" "(WHILE b DO c, s) \<Rightarrow> u"
    show "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> (WHILE b DO c, s) \<Rightarrow> u \<Longrightarrow> t = u"
      apply(induction "WHILE b DO c" s t rule: big_step_induct

  by(induction c s t arbitrary: u rule: big_step_induct, blast+)

text {*
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
*}
text_raw{*\snip{BigStepDetLong}{0}{2}{% *}
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  -- "the only interesting case, @{text WhileTrue}:"
  fix b c s s\<^sub>1 t t'
  -- "The assumptions of the rule:"
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  -- {* Ind.Hyp; note the @{text"\<And>"} because of arbitrary: *}
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  -- "Premise of implication:"
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with `bval b s` obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ -- "prove the rest automatically"
text_raw{*}%endsnip*}

fun assigned :: "com \<Rightarrow> vname set" where
  "assigned (v ::= _) = {v}" |
  "assigned SKIP = {}" |
  "assigned (a;;b) = assigned a \<union> assigned b" |
  "assigned (IF b THEN c1 ELSE c2) = assigned c1 \<union> assigned c2" |
  "assigned (WHILE b DO c) = assigned c" |
  "assigned (REPEAT c UNTIL b) = assigned c"

lemma "\<lbrakk>(c, s) \<Rightarrow> t ; x \<notin> assigned c\<rbrakk> \<Longrightarrow> s x = t x"
  by(induction c s t rule: big_step_induct, auto)

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
  "(V x, s) \<leadsto> N (s x)" |
  "(Plus (N a) (N b), _) \<leadsto> N (a + b)" |
  "(a, s) \<leadsto> a1 \<Longrightarrow> (Plus a b,s) \<leadsto> Plus a1 b" |
  "(b, s) \<leadsto> b1 \<Longrightarrow> (Plus (N a) b, s) \<leadsto> Plus (N a) b1"

lemmas astep_induct = astep.induct[split_format(complete)]

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
  by(induction a s a' rule: astep_induct, auto)

fun doWhile :: "bexp \<Rightarrow> com \<Rightarrow> com" where
  "doWhile b c = c ;; WHILE b DO c"

fun dewhile :: "com \<Rightarrow> com" where
  "dewhile SKIP = SKIP" |
  "dewhile (a::=b) = (a::=b)"|
  "dewhile (a;;b) = (dewhile a) ;; (dewhile b)"|
  "dewhile (IF b THEN c ELSE d) = (IF b THEN dewhile c ELSE dewhile d)"|
  "dewhile (WHILE b DO c) = IF b THEN doWhile b c ELSE SKIP" |
  "dewhile (REPEAT c UNTIL b) = IF b THEN SKIP ELSE doWhile (Not b) c"

lemma Repeat_suger: "(REPEAT c UNTIL b) \<sim> (WHILE (Not b) DO c)"
proof (intro allI, rule)
  fix s t assume "(REPEAT c UNTIL b, s) \<Rightarrow> t " then show " (WHILE bexp.Not b DO c, s) \<Rightarrow> t"
    proof(induction "REPEAT c UNTIL b" s t rule: big_step_induct)
      fix s assume "bval b s"
      then have "bval (Not b) s = False" by auto
      then show "(WHILE bexp.Not b DO c, s) \<Rightarrow> s" by auto
    next
      fix s s' t assume "\<not> bval b s"
      then have 1: "bval (Not b) s" by auto
      assume " (c, s) \<Rightarrow> s'" and "(WHILE bexp.Not b DO c, s') \<Rightarrow> t"
      then show "(WHILE bexp.Not b DO c, s) \<Rightarrow> t" using 1 by auto
    qed
next
  fix s t show "(WHILE bexp.Not b DO c, s) \<Rightarrow> t \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t"
    by(induction "WHILE bexp.Not b DO c" s t rule: big_step_induct, auto)
qed

lemma "dewhile c \<sim> c"
  apply(induction c rule: dewhile.induct)
  by(auto simp add: Repeat_suger while_unfold)

end


section\<open>Lspace as it is in HOL Light\<close>

text\<open>Mainly a repackaging of existing material from Lp\<close>

theory Lspace
  imports Lp.Lp
begin

abbreviation lspace :: "'a measure \<Rightarrow> ennreal \<Rightarrow> ('a \<Rightarrow> real) set"
  where "lspace M p \<equiv> space\<^sub>N (\<LL> p M)"

lemma lspace_1:
  assumes "S \<in> sets lebesgue"
  shows "f \<in> lspace (lebesgue_on S) 1 \<longleftrightarrow> f absolutely_integrable_on S"
  using assms by (simp add: L1_space integrable_restrict_space set_integrable_def)

lemma lspace_ennreal_iff:
  assumes "p > 0"
  shows "lspace (lebesgue_on S) (ennreal p) = {f \<in> borel_measurable (lebesgue_on S). integrable (lebesgue_on S) (\<lambda>x. (norm(f x) powr p))}"
  using assms  by (fastforce simp: Lp_measurable Lp_D intro: Lp_I)

lemma lspace_iff:
  assumes "\<infinity> > p" "p > 0"
  shows "lspace (lebesgue_on S) p = {f \<in> borel_measurable (lebesgue_on S). integrable (lebesgue_on S) (\<lambda>x. (norm(f x) powr (enn2real p)))}"
proof -
  obtain q::real where "p = enn2real q"
    using Lp_cases assms by auto
  then show ?thesis
    using assms lspace_ennreal_iff by auto
qed

lemma lspace_iff':
  assumes p: "\<infinity> > p" "p > 0" and S: "S \<in> sets lebesgue"
  shows "lspace (lebesgue_on S) p = {f \<in> borel_measurable (lebesgue_on S). (\<lambda>x. (norm(f x) powr (enn2real p))) integrable_on S}"
    (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
    using assms integrable_on_lebesgue_on by (auto simp: lspace_iff)
next
  show "?rhs \<subseteq> ?lhs"
  proof (clarsimp simp: lspace_iff [OF p])
    show "integrable (lebesgue_on S) (\<lambda>xa. \<bar>f xa\<bar> powr enn2real p)"
      if "f \<in> borel_measurable (lebesgue_on S)" and "(\<lambda>x. \<bar>f x\<bar> powr enn2real p) integrable_on S" for f
    proof -
      have "(\<lambda>x. \<bar>f x\<bar> powr enn2real p) absolutely_integrable_on S"
        by (simp add: absolutely_integrable_on_iff_nonneg that(2))
      then show ?thesis
        using L1_space S lspace_1 by blast
    qed
  qed
qed

lemma lspace_mono:
  assumes "f \<in> lspace (lebesgue_on S) q" and S: "S \<in> lmeasurable" and "p > 0" "p \<le> q" "q < \<infinity>"
  shows "f \<in> lspace (lebesgue_on S) p"
proof -
  have "p < \<infinity>"
    using assms by (simp add: top.not_eq_extremum)
  with assms show ?thesis
  proof (clarsimp simp add: lspace_iff')
    show "(\<lambda>x. \<bar>f x\<bar> powr enn2real p) integrable_on S"
      if "f \<in> borel_measurable (lebesgue_on S)"
        and "(\<lambda>x. \<bar>f x\<bar> powr enn2real q) integrable_on S"
    proof (rule measurable_bounded_by_integrable_imp_integrable)
      show "(\<lambda>x. \<bar>f x\<bar> powr enn2real p) \<in> borel_measurable (lebesgue_on S)"
        using measurable_abs_powr that(1) by blast
      let ?g = "\<lambda>x. max 1 (norm(f x) powr enn2real q)"
      have "?g absolutely_integrable_on S"
      proof (rule absolutely_integrable_max_1)
        show "(\<lambda>x. norm (f x) powr enn2real q) absolutely_integrable_on S"
          by (simp add: nonnegative_absolutely_integrable_1 that(2))
      qed (simp add: S)
      then show "?g integrable_on S"
        using absolutely_integrable_abs_iff by blast
      show "norm (\<bar>f x\<bar> powr enn2real p) \<le> ?g x" if "x \<in> S" for x
      proof -
        have "\<bar>f x\<bar> powr enn2real p \<le> \<bar>f x\<bar> powr enn2real q" if "1 \<le> \<bar>f x\<bar>"
          using assms enn2real_mono powr_mono that by auto
        then show ?thesis
          using powr_le1 by (fastforce simp add: le_max_iff_disj)
      qed
      show "S \<in> sets lebesgue"
        by (simp add: S fmeasurableD)
    qed
  qed
qed

lemma lspace_inclusion:
  assumes "S \<in> lmeasurable" and "p > 0" "p \<le> q" "q < \<infinity>"
  shows "lspace (lebesgue_on S) q \<subseteq> lspace (lebesgue_on S) p"
  using assms lspace_mono by auto

lemma lspace_const:
  fixes p::real
  assumes "p > 0""S \<in> lmeasurable"
  shows "(\<lambda>x. c) \<in> lspace (lebesgue_on S) p"
  by (simp add: Lp_space assms finite_measure.integrable_const finite_measure_lebesgue_on)

lemma lspace_max:
  fixes p::real
  assumes "f \<in> lspace (lebesgue_on S) p" "g \<in> lspace (lebesgue_on S) p" "p > 0"
  shows "(\<lambda>x. max (f x) (g x)) \<in> lspace (lebesgue_on S) p"
proof -
  have "integrable (lebesgue_on S) (\<lambda>x. \<bar>max (f x) (g x)\<bar> powr p)"
    if f: "f \<in> borel_measurable (lebesgue_on S)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>f x\<bar> powr p)"
      and g: "g \<in> borel_measurable (lebesgue_on S)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>g x\<bar> powr p)"
  proof -
    have "integrable (lebesgue_on S) (\<lambda>x. \<bar>\<bar>f x\<bar> powr p\<bar>)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>\<bar>g x\<bar> powr p\<bar>)"
      using integrable_abs that by blast+
    then have "integrable (lebesgue_on S) (\<lambda>x. max (\<bar>\<bar>f x\<bar> powr p\<bar>) (\<bar>\<bar>g x\<bar> powr p\<bar>))"
      using integrable_max by blast
    then show ?thesis
    proof (rule Bochner_Integration.integrable_bound)
      show "(\<lambda>x. \<bar>max (f x) (g x)\<bar> powr p) \<in> borel_measurable (lebesgue_on S)"
        using borel_measurable_max measurable_abs_powr that by blast
    qed auto
  qed
  then show ?thesis
    using assms by (auto simp: Lp_space borel_measurable_max)
qed

lemma lspace_min:
  fixes p::real
  assumes "f \<in> lspace (lebesgue_on S) p" "g \<in> lspace (lebesgue_on S) p" "p > 0"
  shows "(\<lambda>x. min (f x) (g x)) \<in> lspace (lebesgue_on S) p"
proof -
  have "integrable (lebesgue_on S) (\<lambda>x. \<bar>min (f x) (g x)\<bar> powr p)"
    if f: "f \<in> borel_measurable (lebesgue_on S)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>f x\<bar> powr p)"
      and g: "g \<in> borel_measurable (lebesgue_on S)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>g x\<bar> powr p)"
  proof -
    have "integrable (lebesgue_on S) (\<lambda>x. \<bar>\<bar>f x\<bar> powr p\<bar>)" "integrable (lebesgue_on S) (\<lambda>x. \<bar>\<bar>g x\<bar> powr p\<bar>)"
      using integrable_abs that by blast+
    then have "integrable (lebesgue_on S) (\<lambda>x. max (\<bar>\<bar>f x\<bar> powr p\<bar>) (\<bar>\<bar>g x\<bar> powr p\<bar>))"
      using integrable_max by blast
    then show ?thesis
    proof (rule Bochner_Integration.integrable_bound)
      show "(\<lambda>x. \<bar>min (f x) (g x)\<bar> powr p) \<in> borel_measurable (lebesgue_on S)"
        using borel_measurable_min measurable_abs_powr that by blast
    qed auto
  qed
  then show ?thesis
    using assms by (auto simp: Lp_space borel_measurable_min)
qed

lemma Lp_space_numeral:
  assumes "numeral n > (0::int)"
  shows "space\<^sub>N (\<LL> (numeral n) M) = {f \<in> borel_measurable M. integrable M (\<lambda>x. \<bar>f x\<bar> ^ numeral n)}"
  using Lp_space [of "numeral n" M] assms by simp

end


(* Title: ETTS/Manual/ETTS_Examples.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

section\<open>ETTS by example\<close>
theory ETTS_Examples
  imports
    ETTS_Syntax
    Complex_Main
begin

subsection\<open>Background\<close>

text\<open>
In this section, some of the capabilities of the extension of the framework
Types-To-Sets are demonstrated by example. The examples that are presented
in this section are expected to be sufficient to begin an independent
exploration of the extension, but do not cover the entire spectrum of its
functionality.
\<close>

subsection\<open>First steps\<close>

subsubsection\<open>Problem statement\<close>

text\<open>
Consider the task of the relativization of the type-based theorem
@{thm [source] topological_space_class.closed_Un} from the standard library
of Isabelle/HOL:
\begin{center}
@{thm [names_short = true] topological_space_class.closed_Un[no_vars]},
\end{center}
where \<open>S::'a::topological_space set\<close> and \<open>T::'a::topological_space set\<close>.
\<close>

subsubsection\<open>Unoverloading\<close>

text\<open>
The constant @{const closed} that occurs in the theorem is an overloaded
constant defined as \mbox{@{thm [names_short = true] closed_def[no_vars]}}
for any @{term [show_sorts] "S::'a::topological_space set"}.
The constant may be unoverloaded with
the help of the command @{command ud} that is provided as part of
the framework CTR:
\<close>
ud \<open>topological_space.closed\<close>
ud closed' \<open>closed\<close>
text\<open>
This invocation declares the constant @{const closed.with} that is defined as
\begin{center}
@{thm closed.with_def[no_vars]}
\end{center}
and provides the theorems @{thm [source] closed.with} given by
\begin{center}
@{thm closed.with[no_vars]}
\end{center}
and @{thm [source] closed'.with} given by
\begin{center}
@{thm closed'.with[no_vars]}
\end{center}
These theorems
are automatically added to the dynamic fact @{thm [source] ud_with}.
\<close>

subsubsection\<open>Conditional transfer rules\<close>

text\<open>
Before the relativization can be performed, the transfer rules need to be
available for each constant that occurs in the type-based theorem
immediately after step 4 of the KERA.
All binary relations that are used in the transfer rules must be
at least right total and bi-unique (assuming the default order on predicates in
Isabelle/HOL). For the theorem
@{thm [source] topological_space_class.closed_Un}, there are two such constants:
@{const class.topological_space} and @{const closed.with}.
The transfer rules can be obtained with the help of the command @{command ctr}
from the framework CTR. The process may involve
the synthesis of further relativized constants, as described in the
reference manual for the framework CTR.
\<close>
ctr
  relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
    and [transfer_rule]: "right_total A" "bi_unique A"
  trp (?'a A)
  in topological_space_ow: class.topological_space_def
    and closed_ow: closed.with_def

subsubsection\<open>Relativization\<close>

text\<open>
As mentioned previously, the relativization of theorems can only
be performed from within a suitable tts context. In setting up the tts context,
the users always need to provide the RI specification elements that are
compatible with the theorems that are meant to be relativized in the
tts context. The set of the schematic type variables that occur in the theorem
@{thm [source] topological_space_class.closed_Un} is \<open>{\<close>\<open>?'a\<close>\<open>}\<close>.
Thus, there needs to be exactly one RI specification element of the form
(\<open>?'a\<close>, @{term [show_types] "U::'a set"}):
\<close>
tts_context
  tts: (?'a to \<open>U::'a set\<close>)
begin

text\<open>
The relativization can be performed by invoking the command
@{command tts_lemmas} in the following manner:
\<close>
tts_lemmas? in closed_Un' = topological_space_class.closed_Un
text\<open>
In this case, the command was invoked in the active mode, providing
an active area that can be used to insert the following theorem directly
into the theory file:
\<close>

tts_lemma closed_Un':
  assumes "U \<noteq> {}"
    and "\<forall>x\<in>S. x \<in> U"
    and "\<forall>x\<in>T. x \<in> U"
    and "topological_space_ow U opena"
    and "closed_ow U opena S"
    and "closed_ow U opena T"
  shows "closed_ow U opena (S \<union> T)"
    is topological_space_class.closed_Un.

text\<open>
The invocation of the command @{command tts_lemmas} in the
active mode can be removed with no effect on the theorems that
were generated using the command.
\<close>

end

text\<open>
While our goal was achieved, that is, the theorem
@{thm [source] closed_Un'} is, indeed, a relativization
of the theorem @{thm [source] topological_space_class.closed_Un},
something does not appear right. Is the assumption \<open>U \<noteq> {}\<close> necessary?
Is it possible to simplify \<open>\<forall>x\<in>S. x \<in> U\<close>? Is it necessary to
use such a contrived name for the denotation of the open set predicate?
Of course, all of these
issues can be resolved by restating the theorem in the form that we would like
to see and using @{thm [source] closed_Un'} in the proof of this theorem,
e.g.
\<close>
lemma closed_Un'':
  assumes "S \<subseteq> U"
    and "T \<subseteq> U"
    and "topological_space_ow U \<tau>"
    and "closed_ow U \<tau> S"
    and "closed_ow U \<tau> T"
  shows "closed_ow U \<tau> (S \<union> T)"
  using assms
  unfolding topological_space_ow_def
  by (cases \<open>U = {}\<close>) (auto simp: assms(3) closed_Un' subset_iff)
text\<open>
However, having to restate the theorem presents a grave inconvenience.
This can be avoided by using a different format of the @{syntax tts_addendum}:
\<close>
tts_context
  tts: (?'a to \<open>U::'a set\<close>)
begin

tts_lemma closed_Un''':
  assumes "S \<subseteq> U"
    and "T \<subseteq> U"
    and "topological_space_ow U \<tau>"
    and "closed_ow U \<tau> S"
    and "closed_ow U \<tau> T"
  shows "closed_ow U \<tau> (S \<union> T)"
    given topological_space_class.closed_Un
proof(cases \<open>U = {}\<close>)
  case False assume prems[OF False]:
    "\<lbrakk>
      U \<noteq> {};
      \<forall>x\<in>S. x \<in> U;
      \<forall>x\<in>T. x \<in> U;
      topological_space_ow U \<tau>;
      closed_ow U \<tau> S;
      closed_ow U \<tau> T
     \<rbrakk> \<Longrightarrow> closed_ow U \<tau> (S \<union> T)"
    for U :: "'a set" and S T \<tau>
  from prems show ?thesis using assms by blast
qed simp

end
text\<open>
Nevertheless, could there still be some space for improvement?
It turns out that instead of having to state
the theorem in the desired form manually, often enough, it suffices
to provide additional parameters for post-processing
of the raw set-based theorem, as demonstrated in the code below:
\<close>
tts_context
  tts: (?'a to \<open>U::'a set\<close>)
  rewriting ctr_simps
  eliminating \<open>?U\<noteq>{}\<close> through (auto simp: topological_space_ow_def)
  applying[of _ _ _ \<tau>]
begin

tts_lemma closed_Un'''':
  assumes "S \<subseteq> U"
    and "T \<subseteq> U"
    and "topological_space_ow U \<tau>"
    and "closed_ow U \<tau> S"
    and "closed_ow U \<tau> T"
  shows "closed_ow U \<tau> (S \<union> T)"
    is topological_space_class.closed_Un.

end

text\<open>
Finding the most suitable set of parameters for post-processing of the
result of the relativization is an iterative process and requires practice
before fluency can be achieved.
\<close>

text\<open>\newpage\<close>

end


theory sledgeDuality imports sledgeCategory

begin

 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 180]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire remote_leo3]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

text\<open>Theory about the dual of a category. Can we prove something about the final/initial?\<close>

class categoryOp =
  fixes domainOp:: "'a \<Rightarrow> 'a" ("domOp _" [108] 109) and
        codomainOp:: "'a\<Rightarrow> 'a" ("codOp _" [110] 111) and
        compositionOp:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>\<^sub>o\<^sub>p" 110)

  assumes
        opS1: "E(domOp x) \<^bold>\<rightarrow> E x" and
        opS2: "E(codOp y) \<^bold>\<rightarrow> E y" and
        opS3: "E(x\<cdot>\<^sub>o\<^sub>py) \<^bold>\<leftrightarrow> domOp x \<simeq> codOp y" and
        opS4: "x\<cdot>\<^sub>o\<^sub>p(y\<cdot>\<^sub>o\<^sub>pz) \<cong> (x\<cdot>\<^sub>o\<^sub>py)\<cdot>\<^sub>o\<^sub>pz" and
        opS5: "x\<cdot>\<^sub>o\<^sub>p(domOp x) \<cong> x" and
        opS6: "(codOp y)\<cdot>\<^sub>o\<^sub>py \<cong> y"
begin

abbreviation typeOp where "typeOp x \<equiv> x \<cong> domOp x"

abbreviation isomorphismOp::"'a::type \<Rightarrow> bool" where
  "isomorphismOp (f::'a) \<equiv> \<exists>g::'a. (f \<cdot>\<^sub>o\<^sub>p g) \<cong> (domOp g) \<and> g\<cdot>\<^sub>o\<^sub>pf \<cong> (domOp f)"

abbreviation isomorphicOp::"'a \<Rightarrow> 'a \<Rightarrow> bool"  where
  "isomorphicOp z y \<equiv> \<exists>f::'a. domOp f \<cong> z \<and> codOp f \<cong> y \<and> isomorphismOp f"

abbreviation initialOp::"'a \<Rightarrow> bool" where
  "initialOp z \<equiv> \<^bold>\<forall>t::'a. (typeOp t) \<longrightarrow> (\<exists>!f::'a. domOp f \<simeq> z \<and> codOp f \<simeq> t)"

abbreviation finalOp::"'a \<Rightarrow> bool" where
  "finalOp z \<equiv> \<^bold>\<forall>t. (typeOp t) \<longrightarrow> (\<exists>!f. domOp f \<simeq> t \<and> codOp f \<simeq> z)"

end

sublocale category \<subseteq> categoryOp codomain domain "\<lambda>x y. y \<cdot> x"
proof
  show "\<And>x::'a. E x \<^bold>\<leftarrow> E (cod x)"
    using S2 by blast

  show "\<And>y::'a. E y \<^bold>\<leftarrow> E (dom y)"
    using S1 by blast

  show "\<And>(x::'a) y::'a. E(y\<cdot>x) \<^bold>\<leftrightarrow> cod x \<simeq> dom y"
    by (metis S3)

  show "\<And>(x::'a) (y::'a) z::'a. (z \<cdot> y) \<cdot> x \<cong> z \<cdot> (y \<cdot> x)"
    using S4 by fastforce

  show "\<And>x::'a. (cod x) \<cdot> x \<cong> x"
    using S6 by blast

  show "\<And>y::'a. y \<cdot> (dom y) \<cong> y"
    using S5 by blast
qed

sublocale categoryOp \<subseteq> category codomainOp domainOp "\<lambda>x y. y \<cdot>\<^sub>o\<^sub>p x"
proof
  show "\<And>x::'a. E x \<^bold>\<leftarrow> E (codOp x)"
    using opS2 by blast

  show "\<And>y::'a. E y \<^bold>\<leftarrow> E (domOp y)"
    using opS1 by blast

  show "\<And>(x::'a) y::'a. E(y\<cdot>\<^sub>o\<^sub>px) \<^bold>\<leftrightarrow> codOp x \<simeq> domOp y"
    by (metis opS3)

  show "\<And>(x::'a) (y::'a) z::'a. (z \<cdot>\<^sub>o\<^sub>p y) \<cdot>\<^sub>o\<^sub>p x \<cong> z \<cdot>\<^sub>o\<^sub>p (y \<cdot>\<^sub>o\<^sub>p x)"
    using opS4 by fastforce

  show "\<And>x::'a. (codOp x) \<cdot>\<^sub>o\<^sub>p x \<cong> x"
    using opS6 by blast

  show "\<And>y::'a. y \<cdot>\<^sub>o\<^sub>p (domOp y) \<cong> y"
    using opS5 by blast
qed

context categoryOp begin

print_facts

end

lemma "categoryOp_class.initialOp z \<longrightarrow> categoryOp_class.final z"
  by (metis categoryOp_class.S3 categoryOp_class.S5)

lemma Hello: assumes "category_class.finalOp z" shows "category_class.initial z"
  by (smt assms category_class.opS3 category_class.opS5 category_class.opS6)

lemma isoeq: "category_class.isomorphic z f \<longrightarrow> category_class.isomorphicOp z f"
  by (metis category_class.opS1 category_class.opS3 category_class.opS6)

\<comment> \<open>Duality proof that final obj in op are isomorphic.\<close>
lemma assumes 1:"category_class.finalOp z" and  2:"category_class.finalOp f" shows "category_class.isomorphicOp z f"
proof -
  from 1 have 3:"category_class.initial z" by (rule Hello)
  from 2 have 4:"category_class.initial f" by (rule Hello)

  have 5:"category_class.initial z \<and> category_class.initial f" using 3 4 by simp

  have "category_class.isomorphic z f" using 5 by (simp add: category_class.InitialsAreIsomorphic)
  thus "category_class.isomorphicOp z f" by (simp add: isoeq)
qed

end