(*  Title:      CTT/CTT.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Constructive Type Theory *}

theory CTT
imports Pure
begin

ML_file "~~/src/Provers/typedsimp.ML"
setup Pure_Thy.old_appl_syntax_setup

typedecl i
typedecl t
typedecl o

consts
  (*Types*)
  F         :: "t"
  T         :: "t"          (*F is empty, T contains one element*)
  contr     :: "i\<Rightarrow>i"
  tt        :: "i"
  (*Natural numbers*)
  N         :: "t"
  succ      :: "i\<Rightarrow>i"
  rec       :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow> i"
  (*Unions*)
  inl       :: "i\<Rightarrow>i"
  inr       :: "i\<Rightarrow>i"
  when      :: "[i, i\<Rightarrow>i, i\<Rightarrow>i]\<Rightarrow>i"
  (*General Sum and Binary Product*)
  Sum       :: "[t, i\<Rightarrow>t]\<Rightarrow>t"
  fst       :: "i\<Rightarrow>i"
  snd       :: "i\<Rightarrow>i"
  split     :: "[i, [i,i]\<Rightarrow>i] \<Rightarrow>i"
  (*General Product and Function Space*)
  Prod      :: "[t, i\<Rightarrow>t]\<Rightarrow>t"
  (*Types*)
  Plus      :: "[t,t]\<Rightarrow>t"           (infixr "+" 40)
  (*Equality type*)
  Eq        :: "[t,i,i]\<Rightarrow>t"
  eq        :: "i"
  (*Judgements*)
  Type      :: "t \<Rightarrow> prop"          ("(_ type)" [10] 5)
  Eqtype    :: "[t,t]\<Rightarrow>prop"        ("(_ =/ _)" [10,10] 5)
  Elem      :: "[i, t]\<Rightarrow>prop"       ("(_ /: _)" [10,10] 5)
  Eqelem    :: "[i,i,t]\<Rightarrow>prop"      ("(_ =/ _ :/ _)" [10,10,10] 5)
  Reduce    :: "[i,i]\<Rightarrow>prop"        ("Reduce[_,_]")
  (*Types*)

  (*Functions*)
  lambda    :: "(i \<Rightarrow> i) \<Rightarrow> i"      (binder "lam " 10)
  app       :: "[i,i]\<Rightarrow>i"           (infixl "`" 60)
  (*Natural numbers*)
  Zero      :: "i"                  ("0")
  (*Pairing*)
  pair      :: "[i,i]\<Rightarrow>i"           ("(1<_,/_>)")

syntax
  "_PROD"   :: "[idt,t,t]\<Rightarrow>t"       ("(3PROD _:_./ _)" 10)
  "_SUM"    :: "[idt,t,t]\<Rightarrow>t"       ("(3SUM _:_./ _)" 10)
translations
  "PROD x:A. B" == "CONST Prod(A, \<lambda>x. B)"
  "SUM x:A. B"  == "CONST Sum(A, \<lambda>x. B)"

abbreviation
  Arrow     :: "[t,t]\<Rightarrow>t"  (infixr "-->" 30) where
  "A --> B == PROD _:A. B"
abbreviation
  Times     :: "[t,t]\<Rightarrow>t"  (infixr "*" 50) where
  "A * B == SUM _:A. B"

notation (xsymbols)
  lambda  (binder "\<lambda>\<lambda>" 10) and
  Elem  ("(_ /\<in> _)" [10,10] 5) and
  Eqelem  ("(2_ =/ _ \<in>/ _)" [10,10,10] 5) and
  Arrow  (infixr "\<longrightarrow>" 30) and
  Times  (infixr "\<times>" 50)

notation (HTML output)
  lambda  (binder "\<lambda>\<lambda>" 10) and
  Elem  ("(_ /\<in> _)" [10,10] 5) and
  Eqelem  ("(2_ =/ _ \<in>/ _)" [10,10,10] 5) and
  Times  (infixr "\<times>" 50)

syntax (xsymbols)
  "_PROD"   :: "[idt,t,t] \<Rightarrow> t"     ("(3\<Pi> _\<in>_./ _)"    10)
  "_SUM"    :: "[idt,t,t] \<Rightarrow> t"     ("(3\<Sigma> _\<in>_./ _)" 10)

syntax (HTML output)
  "_PROD"   :: "[idt,t,t] \<Rightarrow> t"     ("(3\<Pi> _\<in>_./ _)"    10)
  "_SUM"    :: "[idt,t,t] \<Rightarrow> t"     ("(3\<Sigma> _\<in>_./ _)" 10)

  (*Reduction: a weaker notion than equality;  a hack for simplification.
    Reduce[a,b] means either that  a=b:A  for some A or else that "a" and "b"
    are textually identical.*)

  (*does not verify a:A!  Sound because only trans_red uses a Reduce premise
    No new theorems can be proved about the standard judgements.*)
axiomatization where
  refl_red: "\<And>a. Reduce[a,a]" and
  red_if_equal: "\<And>a b A. a = b : A \<Longrightarrow> Reduce[a,b]" and
  trans_red: "\<And>a b c A. \<lbrakk>a = b : A; Reduce[b,c]\<rbrakk> \<Longrightarrow> a = c : A" and

  (*Reflexivity*)

  refl_type: "\<And>A. A type \<Longrightarrow> A = A" and
  refl_elem: "\<And>a A. a : A \<Longrightarrow> a = a : A" and

  (*Symmetry*)

  sym_type:  "\<And>A B. A = B \<Longrightarrow> B = A" and
  sym_elem:  "\<And>a b A. a = b : A \<Longrightarrow> b = a : A" and

  (*Transitivity*)

  trans_type:   "\<And>A B C. \<lbrakk>A = B; B = C\<rbrakk> \<Longrightarrow> A = C" and
  trans_elem:   "\<And>a b c A. \<lbrakk>a = b : A; b = c : A\<rbrakk> \<Longrightarrow> a = c : A" and

  equal_types:  "\<And>a A B. \<lbrakk>a : A; A = B\<rbrakk> \<Longrightarrow> a : B" and
  equal_typesL: "\<And>a b A B. \<lbrakk>a = b : A; A = B\<rbrakk> \<Longrightarrow> a = b : B" and

  (*Substitution*)

  subst_type:   "\<And>a A B. \<lbrakk>a : A; \<And>z. z:A \<Longrightarrow> B(z) type\<rbrakk> \<Longrightarrow> B(a) type" and
  subst_typeL:  "\<And>a c A B D. \<lbrakk>a = c : A; \<And>z. z:A \<Longrightarrow> B(z) = D(z)\<rbrakk> \<Longrightarrow> B(a) = D(c)" and

  subst_elem:   "\<And>a b A B. \<lbrakk>a : A; \<And>z. z:A \<Longrightarrow> b(z):B(z)\<rbrakk> \<Longrightarrow> b(a):B(a)" and
  subst_elemL:
    "\<And>a b c d A B. \<lbrakk>a = c : A; \<And>z. z:A \<Longrightarrow> b(z)=d(z) : B(z)\<rbrakk> \<Longrightarrow> b(a)=d(c) : B(a)" and

  (*The type N -- natural numbers*)

  NF: "N type" and
  NI0: "0 : N" and
  NI_succ: "\<And>a. a : N \<Longrightarrow> succ(a) : N" and
  NI_succL:  "\<And>a b. a = b : N \<Longrightarrow> succ(a) = succ(b) : N" and

  NE:
   "\<And>p a b C. \<lbrakk>p: N; a: C(0); \<And>u v. \<lbrakk>u: N; v: C(u)\<rbrakk> \<Longrightarrow> b(u,v): C(succ(u))\<rbrakk>
   \<Longrightarrow> rec(p, a, \<lambda>u v. b(u,v)) : C(p)" and

  NEL:
   "\<And>p q a b c d C. \<lbrakk>p = q : N; a = c : C(0);
      \<And>u v. \<lbrakk>u: N; v: C(u)\<rbrakk> \<Longrightarrow> b(u,v) = d(u,v): C(succ(u))\<rbrakk>
   \<Longrightarrow> rec(p, a, \<lambda>u v. b(u,v)) = rec(q,c,d) : C(p)" and

  NC0:
   "\<And>a b C. \<lbrakk>a: C(0); \<And>u v. \<lbrakk>u: N; v: C(u)\<rbrakk> \<Longrightarrow> b(u,v): C(succ(u))\<rbrakk>
   \<Longrightarrow> rec(0, a, \<lambda>u v. b(u,v)) = a : C(0)" and

  NC_succ:
   "\<And>p a b C. \<lbrakk>p: N;  a: C(0); \<And>u v. \<lbrakk>u: N; v: C(u)\<rbrakk> \<Longrightarrow> b(u,v): C(succ(u))\<rbrakk> \<Longrightarrow>
   rec(succ(p), a, \<lambda>u v. b(u,v)) = b(p, rec(p, a, \<lambda>u v. b(u,v))) : C(succ(p))" and

  (*The fourth Peano axiom.  See page 91 of Martin-Lof's book*)
  zero_ne_succ: "\<And>a. \<lbrakk>a: N; 0 = succ(a) : N\<rbrakk> \<Longrightarrow> 0: F" and

  (*The Product of a family of types*)

  ProdF: "\<And>A B. \<lbrakk>A type; \<And>x. x:A \<Longrightarrow> B(x) type\<rbrakk> \<Longrightarrow> PROD x:A. B(x) type" and

  ProdFL:
    "\<And>A B C D. \<lbrakk>A = C; \<And>x. x:A \<Longrightarrow> B(x) = D(x)\<rbrakk> \<Longrightarrow> PROD x:A. B(x) = PROD x:C. D(x)" and

  ProdI:
    "\<And>b A B. \<lbrakk>A type; \<And>x. x:A \<Longrightarrow> b(x):B(x)\<rbrakk> \<Longrightarrow> lam x. b(x) : PROD x:A. B(x)" and

  ProdIL: "\<And>b c A B. \<lbrakk>A type; \<And>x. x:A \<Longrightarrow> b(x) = c(x) : B(x)\<rbrakk> \<Longrightarrow>
    lam x. b(x) = lam x. c(x) : PROD x:A. B(x)" and

  ProdE:  "\<And>p a A B. \<lbrakk>p : PROD x:A. B(x); a : A\<rbrakk> \<Longrightarrow> p`a : B(a)" and
  ProdEL: "\<And>p q a b A B. \<lbrakk>p = q: PROD x:A. B(x); a = b : A\<rbrakk> \<Longrightarrow> p`a = q`b : B(a)" and

  ProdC: "\<And>a b A B. \<lbrakk>a : A; \<And>x. x:A \<Longrightarrow> b(x) : B(x)\<rbrakk> \<Longrightarrow> (lam x. b(x)) ` a = b(a) : B(a)" and

  ProdC2: "\<And>p A B. p : PROD x:A. B(x) \<Longrightarrow> (lam x. p`x) = p : PROD x:A. B(x)" and

  (*The Sum of a family of types*)

  SumF:  "\<And>A B. \<lbrakk>A type; \<And>x. x:A \<Longrightarrow> B(x) type\<rbrakk> \<Longrightarrow> SUM x:A. B(x) type" and
  SumFL: "\<And>A B C D. \<lbrakk>A = C; \<And>x. x:A \<Longrightarrow> B(x) = D(x)\<rbrakk> \<Longrightarrow> SUM x:A. B(x) = SUM x:C. D(x)" and

  SumI:  "\<And>a b A B. \<lbrakk>a : A; b : B(a)\<rbrakk> \<Longrightarrow> <a,b> : SUM x:A. B(x)" and
  SumIL: "\<And>a b c d A B. \<lbrakk> a = c : A; b = d : B(a)\<rbrakk> \<Longrightarrow> <a,b> = <c,d> : SUM x:A. B(x)" and

  SumE: "\<And>p c A B C. \<lbrakk>p: SUM x:A. B(x); \<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> c(x,y): C(<x,y>)\<rbrakk>
    \<Longrightarrow> split(p, \<lambda>x y. c(x,y)) : C(p)" and

  SumEL: "\<And>p q c d A B C. \<lbrakk>p = q : SUM x:A. B(x);
      \<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> c(x,y)=d(x,y): C(<x,y>)\<rbrakk>
    \<Longrightarrow> split(p, \<lambda>x y. c(x,y)) = split(q, \<lambda>x y. d(x,y)) : C(p)" and

  SumC: "\<And>a b c A B C. \<lbrakk>a: A;  b: B(a); \<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> c(x,y): C(<x,y>)\<rbrakk>
    \<Longrightarrow> split(<a,b>, \<lambda>x y. c(x,y)) = c(a,b) : C(<a,b>)" and

  fst_def:   "\<And>a. fst(a) == split(a, \<lambda>x y. x)" and
  snd_def:   "\<And>a. snd(a) == split(a, \<lambda>x y. y)" and

  (*The sum of two types*)

  PlusF: "\<And>A B. \<lbrakk>A type; B type\<rbrakk> \<Longrightarrow> A+B type" and
  PlusFL: "\<And>A B C D. \<lbrakk>A = C; B = D\<rbrakk> \<Longrightarrow> A+B = C+D" and

  PlusI_inl: "\<And>a A B. \<lbrakk>a : A; B type\<rbrakk> \<Longrightarrow> inl(a) : A+B" and
  PlusI_inlL: "\<And>a c A B. \<lbrakk>a = c : A; B type\<rbrakk> \<Longrightarrow> inl(a) = inl(c) : A+B" and

  PlusI_inr: "\<And>b A B. \<lbrakk>A type; b : B\<rbrakk> \<Longrightarrow> inr(b) : A+B" and
  PlusI_inrL: "\<And>b d A B. \<lbrakk>A type; b = d : B\<rbrakk> \<Longrightarrow> inr(b) = inr(d) : A+B" and

  PlusE:
    "\<And>p c d A B C. \<lbrakk>p: A+B;
      \<And>x. x:A \<Longrightarrow> c(x): C(inl(x));
      \<And>y. y:B \<Longrightarrow> d(y): C(inr(y)) \<rbrakk> \<Longrightarrow> when(p, \<lambda>x. c(x), \<lambda>y. d(y)) : C(p)" and

  PlusEL:
    "\<And>p q c d e f A B C. \<lbrakk>p = q : A+B;
      \<And>x. x: A \<Longrightarrow> c(x) = e(x) : C(inl(x));
      \<And>y. y: B \<Longrightarrow> d(y) = f(y) : C(inr(y))\<rbrakk>
    \<Longrightarrow> when(p, \<lambda>x. c(x), \<lambda>y. d(y)) = when(q, \<lambda>x. e(x), \<lambda>y. f(y)) : C(p)" and

  PlusC_inl:
    "\<And>a c d A C. \<lbrakk>a: A;
      \<And>x. x:A \<Longrightarrow> c(x): C(inl(x));
      \<And>y. y:B \<Longrightarrow> d(y): C(inr(y)) \<rbrakk>
    \<Longrightarrow> when(inl(a), \<lambda>x. c(x), \<lambda>y. d(y)) = c(a) : C(inl(a))" and

  PlusC_inr:
    "\<And>b c d A B C. \<lbrakk>b: B;
      \<And>x. x:A \<Longrightarrow> c(x): C(inl(x));
      \<And>y. y:B \<Longrightarrow> d(y): C(inr(y))\<rbrakk>
    \<Longrightarrow> when(inr(b), \<lambda>x. c(x), \<lambda>y. d(y)) = d(b) : C(inr(b))" and

  (*The type Eq*)

  EqF: "\<And>a b A. \<lbrakk>A type; a : A; b : A\<rbrakk> \<Longrightarrow> Eq(A,a,b) type" and
  EqFL: "\<And>a b c d A B. \<lbrakk>A = B; a = c : A; b = d : A\<rbrakk> \<Longrightarrow> Eq(A,a,b) = Eq(B,c,d)" and
  EqI: "\<And>a b A. a = b : A \<Longrightarrow> eq : Eq(A,a,b)" and
  EqE: "\<And>p a b A. p : Eq(A,a,b) \<Longrightarrow> a = b : A" and

  (*By equality of types, can prove C(p) from C(eq), an elimination rule*)
  EqC: "\<And>p a b A. p : Eq(A,a,b) \<Longrightarrow> p = eq : Eq(A,a,b)" and

  (*The type F*)

  FF: "F type" and
  FE: "\<And>p C. \<lbrakk>p: F; C type\<rbrakk> \<Longrightarrow> contr(p) : C" and
  FEL: "\<And>p q C. \<lbrakk>p = q : F; C type\<rbrakk> \<Longrightarrow> contr(p) = contr(q) : C" and

  (*The type T
     Martin-Lof's book (page 68) discusses elimination and computation.
     Elimination can be derived by computation and equality of types,
     but with an extra premise C(x) type x:T.
     Also computation can be derived from elimination. *)

  TF: "T type" and
  TI: "tt : T" and
  TE: "\<And>p c C. \<lbrakk>p : T; c : C(tt)\<rbrakk> \<Longrightarrow> c : C(p)" and
  TEL: "\<And>p q c d C. \<lbrakk>p = q : T; c = d : C(tt)\<rbrakk> \<Longrightarrow> c = d : C(p)" and
  TC: "\<And>p. p : T \<Longrightarrow> p = tt : T"

subsection "Tactics and derived rules for Constructive Type Theory"

(*Formation rules*)
lemmas form_rls = NF ProdF SumF PlusF EqF FF TF
  and formL_rls = ProdFL SumFL PlusFL EqFL

(*Introduction rules
  OMITTED: EqI, because its premise is an eqelem, not an elem*)
lemmas intr_rls = NI0 NI_succ ProdI SumI PlusI_inl PlusI_inr TI
  and intrL_rls = NI_succL ProdIL SumIL PlusI_inlL PlusI_inrL

(*Elimination rules
  OMITTED: EqE, because its conclusion is an eqelem,  not an elem
           TE, because it does not involve a constructor *)
lemmas elim_rls = NE ProdE SumE PlusE FE
  and elimL_rls = NEL ProdEL SumEL PlusEL FEL

(*OMITTED: eqC are TC because they make rewriting loop: p = un = un = ... *)
lemmas comp_rls = NC0 NC_succ ProdC SumC PlusC_inl PlusC_inr

(*rules with conclusion a:A, an elem judgement*)
lemmas element_rls = intr_rls elim_rls

(*Definitions are (meta)equality axioms*)
lemmas basic_defs = fst_def snd_def

(*Compare with standard version: B is applied to UNSIMPLIFIED expression! *)
lemma SumIL2: "\<lbrakk>c = a : A; d = b : B(a)\<rbrakk> \<Longrightarrow> <c,d> = <a,b> : Sum(A,B)"
apply (rule sym_elem)
apply (rule SumIL)
apply (rule_tac [!] sym_elem)
apply assumption+
done

lemmas intrL2_rls = NI_succL ProdIL SumIL2 PlusI_inlL PlusI_inrL

(*Exploit p:Prod(A,B) to create the assumption z:B(a).
  A more natural form of product elimination. *)
lemma subst_prodE:
  assumes "p: Prod(A,B)"
    and "a: A"
    and "\<And>z. z: B(a) \<Longrightarrow> c(z): C(z)"
  shows "c(p`a): C(p`a)"
apply (rule assms ProdE)+
done

subsection {* Tactics for type checking *}

ML {*

local

fun is_rigid_elem (Const(@{const_name Elem},_) $ a $ _) = not(is_Var (head_of a))
  | is_rigid_elem (Const(@{const_name Eqelem},_) $ a $ _ $ _) = not(is_Var (head_of a))
  | is_rigid_elem (Const(@{const_name Type},_) $ a) = not(is_Var (head_of a))
  | is_rigid_elem _ = false

in

(*Try solving a:A or a=b:A by assumption provided a is rigid!*)
fun test_assume_tac ctxt = SUBGOAL(fn (prem,i) =>
    if is_rigid_elem (Logic.strip_assums_concl prem)
    then  assume_tac ctxt i  else  no_tac)

fun ASSUME ctxt tf i = test_assume_tac ctxt i  ORELSE  tf i

end;

*}

(*For simplification: type formation and checking,
  but no equalities between terms*)
lemmas routine_rls = form_rls formL_rls refl_type element_rls

ML {*
local
  val equal_rls = @{thms form_rls} @ @{thms element_rls} @ @{thms intrL_rls} @
    @{thms elimL_rls} @ @{thms refl_elem}
in

fun routine_tac rls ctxt prems =
  ASSUME ctxt (filt_resolve_from_net_tac ctxt 4 (Tactic.build_net (prems @ rls)));

(*Solve all subgoals "A type" using formation rules. *)
val form_net = Tactic.build_net @{thms form_rls};
fun form_tac ctxt =
  REPEAT_FIRST (ASSUME ctxt (filt_resolve_from_net_tac ctxt 1 form_net));

(*Type checking: solve a:A (a rigid, A flexible) by intro and elim rules. *)
fun typechk_tac ctxt thms =
  let val tac =
    filt_resolve_from_net_tac ctxt 3
      (Tactic.build_net (thms @ @{thms form_rls} @ @{thms element_rls}))
  in  REPEAT_FIRST (ASSUME ctxt tac)  end

(*Solve a:A (a flexible, A rigid) by introduction rules.
  Cannot use stringtrees (filt_resolve_tac) since
  goals like ?a:SUM(A,B) have a trivial head-string *)
fun intr_tac ctxt thms =
  let val tac =
    filt_resolve_from_net_tac ctxt 1
      (Tactic.build_net (thms @ @{thms form_rls} @ @{thms intr_rls}))
  in  REPEAT_FIRST (ASSUME ctxt tac)  end

(*Equality proving: solve a=b:A (where a is rigid) by long rules. *)
fun equal_tac ctxt thms =
  REPEAT_FIRST
    (ASSUME ctxt (filt_resolve_from_net_tac ctxt 3 (Tactic.build_net (thms @ equal_rls))))

end
*}

method_setup form = {* Scan.succeed (fn ctxt => SIMPLE_METHOD (form_tac ctxt)) *}
method_setup typechk = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (typechk_tac ctxt ths)) *}
method_setup intr = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (intr_tac ctxt ths)) *}
method_setup equal = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (equal_tac ctxt ths)) *}

subsection {* Simplification *}

(*To simplify the type in a goal*)
lemma replace_type: "\<lbrakk>B = A; a : A\<rbrakk> \<Longrightarrow> a : B"
apply (rule equal_types)
apply (rule_tac [2] sym_type)
apply assumption+
done

(*Simplify the parameter of a unary type operator.*)
lemma subst_eqtyparg:
  assumes 1: "a=c : A"
    and 2: "\<And>z. z:A \<Longrightarrow> B(z) type"
  shows "B(a)=B(c)"
apply (rule subst_typeL)
apply (rule_tac [2] refl_type)
apply (rule 1)
apply (erule 2)
done

(*Simplification rules for Constructive Type Theory*)
lemmas reduction_rls = comp_rls [THEN trans_elem]

ML {*
(*Converts each goal "e : Eq(A,a,b)" into "a=b:A" for simplification.
  Uses other intro rules to avoid changing flexible goals.*)
val eqintr_net = Tactic.build_net @{thms EqI intr_rls}
fun eqintr_tac ctxt =
  REPEAT_FIRST (ASSUME ctxt (filt_resolve_from_net_tac ctxt 1 eqintr_net))

(** Tactics that instantiate CTT-rules.
    Vars in the given terms will be incremented!
    The (rtac EqE i) lets them apply to equality judgements. **)

fun NE_tac ctxt sp i =
  TRY (rtac @{thm EqE} i) THEN res_inst_tac ctxt [(("p", 0), sp)] @{thm NE} i

fun SumE_tac ctxt sp i =
  TRY (rtac @{thm EqE} i) THEN res_inst_tac ctxt [(("p", 0), sp)] @{thm SumE} i

fun PlusE_tac ctxt sp i =
  TRY (rtac @{thm EqE} i) THEN res_inst_tac ctxt [(("p", 0), sp)] @{thm PlusE} i

(** Predicate logic reasoning, WITH THINNING!!  Procedures adapted from NJ. **)

(*Finds f:Prod(A,B) and a:A in the assumptions, concludes there is z:B(a) *)
fun add_mp_tac ctxt i =
    rtac @{thm subst_prodE} i  THEN  assume_tac ctxt i  THEN  assume_tac ctxt i

(*Finds P-->Q and P in the assumptions, replaces implication by Q *)
fun mp_tac ctxt i = etac @{thm subst_prodE} i  THEN  assume_tac ctxt i

(*"safe" when regarded as predicate calculus rules*)
val safe_brls = sort (make_ord lessb)
    [ (true, @{thm FE}), (true,asm_rl),
      (false, @{thm ProdI}), (true, @{thm SumE}), (true, @{thm PlusE}) ]

val unsafe_brls =
    [ (false, @{thm PlusI_inl}), (false, @{thm PlusI_inr}), (false, @{thm SumI}),
      (true, @{thm subst_prodE}) ]

(*0 subgoals vs 1 or more*)
val (safe0_brls, safep_brls) =
    List.partition (curry (op =) 0 o subgoals_of_brl) safe_brls

fun safestep_tac ctxt thms i =
    form_tac ctxt ORELSE
    resolve_tac thms i  ORELSE
    biresolve_tac safe0_brls i  ORELSE  mp_tac ctxt i  ORELSE
    DETERM (biresolve_tac safep_brls i)

fun safe_tac ctxt thms i = DEPTH_SOLVE_1 (safestep_tac ctxt thms i)

fun step_tac ctxt thms = safestep_tac ctxt thms  ORELSE'  biresolve_tac unsafe_brls

(*Fails unless it solves the goal!*)
fun pc_tac ctxt thms = DEPTH_SOLVE_1 o (step_tac ctxt thms)
*}

method_setup eqintr = {* Scan.succeed (SIMPLE_METHOD o eqintr_tac) *}
method_setup NE = {*
  Scan.lift Args.name_inner_syntax >> (fn s => fn ctxt => SIMPLE_METHOD' (NE_tac ctxt s))
*}
method_setup pc = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (pc_tac ctxt ths)) *}
method_setup add_mp = {* Scan.succeed (SIMPLE_METHOD' o add_mp_tac) *}

ML_file "rew.ML"
method_setup rew = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (rew_tac ctxt ths)) *}
method_setup hyp_rew = {* Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (hyp_rew_tac ctxt ths)) *}

subsection {* The elimination rules for fst/snd *}

lemma SumE_fst: "p : Sum(A,B) \<Longrightarrow> fst(p) : A"
apply (unfold basic_defs)
apply (erule SumE)
apply assumption
done

(*The first premise must be p:Sum(A,B) !!*)
lemma SumE_snd:
  assumes major: "p: Sum(A,B)"
    and "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
  shows "snd(p) : B(fst(p))"
  apply (unfold basic_defs)
  apply (rule major [THEN SumE])
  apply (rule SumC [THEN subst_eqtyparg, THEN replace_type])
  apply (typechk assms)
  done

end


subsection \<open> ETP definitions \<close>

text \<open> We define Extended Trapdoor Permutations (ETPs) following \cite{DBLP:books/sp/17/Lindell17} and \cite{DBLP:books/cu/Goldreich2004}.
In particular we consider the property of Hard Core Predicates (HCPs). \<close>

theory ETP imports
  CryptHOL.CryptHOL
begin

type_synonym ('index,'input,'bool) dist2 = "('input \<times> 'index \<times> 'bool \<times> 'bool) \<Rightarrow> bool spmf"

type_synonym ('index,'range, 'bool,'output,'input) advP2 = "('index,'input,'bool) dist2 \<Rightarrow> 'index \<Rightarrow> 'input \<Rightarrow> 'output \<Rightarrow> 'range \<Rightarrow> bool spmf"

locale etp =
  fixes I :: "('index \<times> 'trap) spmf" \<comment> \<open>samples index and trapdoor\<close>
    and domain :: "'index \<Rightarrow> 'range set"
    and range :: "'index \<Rightarrow> 'range set"
    and F :: "'index \<Rightarrow> ('range \<Rightarrow> 'range)" \<comment> \<open>permutation\<close>
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range" \<comment> \<open>must be efficiently computable\<close>
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool" \<comment> \<open>hard core predicate\<close>
  assumes dom_eq_ran: "y \<in> set_spmf I \<longrightarrow> domain (fst y) = range (fst y)"
    and finite_range: "y \<in> set_spmf I \<longrightarrow> finite (range (fst y))"
    and non_empty_range: "y \<in> set_spmf I \<longrightarrow> range (fst y) \<noteq> {}"
    and bij_betw: "y \<in> set_spmf I \<longrightarrow> bij_betw (F (fst y)) (domain (fst y)) (range (fst y))"
    and lossless_I: "lossless_spmf I"
    and F_f_inv: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> F\<^sub>i\<^sub>n\<^sub>v (fst y) (snd y) (F (fst y) x) = x"
begin

definition S :: "'index \<Rightarrow> 'range spmf"
  where "S \<alpha> = spmf_of_set (range \<alpha>)"

lemma lossless_S: "y \<in> set_spmf I \<longrightarrow>  lossless_spmf (S (fst y))"
  by(simp add: lossless_spmf_def S_def finite_range non_empty_range)

lemma set_spmf_S [simp]: "y \<in> set_spmf I \<longrightarrow> set_spmf (S (fst y)) = range (fst y)"
  by (simp add: S_def finite_range)

lemma f_inj_on: "y \<in> set_spmf I \<longrightarrow> inj_on (F (fst y)) (range (fst y))"
  by(metis bij_betw_def bij_betw dom_eq_ran bij_betw_def bij_betw dom_eq_ran)

lemma range_f: "y \<in> set_spmf I \<longrightarrow>  x \<in> range (fst y) \<longrightarrow> F (fst y) x \<in> range (fst y)"
  by (metis bij_betw bij_betw dom_eq_ran bij_betwE)

lemma f_inv_f [simp]: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> F\<^sub>i\<^sub>n\<^sub>v (fst y) (snd y) (F (fst y) x) = x"
  by (metis F_f_inv)

lemma f_inv_f' [simp]: "y \<in> set_spmf I \<longrightarrow> x \<in> range (fst y) \<longrightarrow> Hilbert_Choice.inv_into (range (fst y)) (F (fst y)) (F (fst y) x) = x"
  by (metis bij_betw bij_betw_inv_into_left bij_betw dom_eq_ran)

lemma B_F_inv_rewrite: "(B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = m1)) = m1"
  by auto

lemma uni_set_samp:
  assumes "y \<in> set_spmf I"
  shows "map_spmf (\<lambda> x. F (fst y) x) (S (fst y)) = (S (fst y))"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set (range (fst y))"
    unfolding S_def by(simp)
  also have "map_spmf (\<lambda> x. F (fst y) x) (spmf_of_set (range (fst y))) = spmf_of_set ((\<lambda> x. F (fst y) x) ` (range (fst y)))"
    using f_inj_on assms
    by (metis map_spmf_of_set_inj_on)
  also have "(\<lambda> x. F (fst y) x) ` (range (fst y)) = range (fst y)"
    apply(rule endo_inj_surj)
    using bij_betw
      by (auto simp add: bij_betw_def dom_eq_ran f_inj_on bij_betw finite_range assms)
  finally show ?thesis by(simp add: rhs)
qed

text\<open>We define the security property of the hard core predicate (HCP) using a game.\<close>

definition HCP_game :: "('index,'range, 'bool,'output,'input) advP2 \<Rightarrow> 'input \<Rightarrow> 'output \<Rightarrow> ('index,'input,'bool) dist2 \<Rightarrow> bool spmf"
  where "HCP_game A \<sigma> b\<^sub>\<sigma> D = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x \<leftarrow> S \<alpha>;
    b' \<leftarrow> A D \<alpha> \<sigma> b\<^sub>\<sigma> x;
    let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    return_spmf (b = b')}"

definition HCP_adv :: "('index,'range, 'bool,'output,'input) advP2  \<Rightarrow>  'input \<Rightarrow> 'output \<Rightarrow> ('index,'input,'bool) dist2 \<Rightarrow> real"
  where "HCP_adv A \<sigma> b\<^sub>\<sigma> D = \<bar>((spmf (HCP_game A \<sigma> b\<^sub>\<sigma> D) True) - 1/2)\<bar>"

end

end


(* Title:      N-Relation-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>N-Relation-Algebras\<close>

theory N_Relation_Algebras

imports Stone_Relation_Algebras.Relation_Algebras N_Omega_Algebras

begin

context bounded_distrib_allegory
begin

subclass lattice_ordered_pre_left_semiring ..

end

text \<open>Theorem 37\<close>

sublocale relation_algebra < n_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top
  apply unfold_locales
  using N_comp_top comp_inf.semiring.distrib_left inf.sup_monoid.add_commute inf_vector_comp apply simp
  apply (metis N_comp compl_sup double_compl mult_assoc mult_right_dist_sup top_mult_top N_comp_N)
  apply (metis brouwer.p_antitone inf.sup_monoid.add_commute inf.sup_right_isotone mult_left_isotone p_antitone_sup)
  apply simp
  using N_vector_top apply force
  apply simp
  apply (simp add: brouwer.p_antitone_iff top_right_mult_increasing)
  apply simp
  apply (metis N_comp_top conv_complement_sub double_compl le_supI2 le_iff_sup mult_assoc mult_left_isotone schroeder_3)
  by simp

sublocale relation_algebra < n_algebra_apx where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq
  apply unfold_locales
  using n_less_eq_char by force

no_notation
  inverse_divide (infixl "'/" 70)

notation
  divide (infixl "'/" 70)

class left_residuated_relation_algebra = relation_algebra + inverse +
  assumes lres_def: "x / y = -(-x * y\<^sup>T)"
begin

text \<open>Theorem 32.1\<close>

subclass residuated_pre_left_semiring
  apply unfold_locales
  by (metis compl_le_swap1 lres_def schroeder_4)

end

context left_residuated_relation_algebra
begin

text \<open>Theorem 32.3\<close>

lemma lres_mult_lres_lres:
  "x / (z * y) = (x / y) / z"
  by (metis conv_dist_comp double_compl lres_def mult_assoc)

text \<open>Theorem 32.5\<close>

lemma lres_dist_inf:
  "(x \<sqinter> y) / z = (x / z) \<sqinter> (y / z)"
  by (metis compl_inf compl_sup lres_def mult_right_dist_sup)

text \<open>Theorem 32.6\<close>

lemma lres_add_export_vector:
  assumes "vector x"
    shows "(x \<squnion> y) / z = x \<squnion> (y / z)"
proof -
  have "(x \<squnion> y) / z = -((-x \<sqinter> -y) * z\<^sup>T)"
    by (simp add: lres_def)
  also have "... = -(-x \<sqinter> (-y * z\<^sup>T))"
    using assms vector_complement_closed vector_inf_comp by auto
  also have "... = x \<squnion> (y / z)"
    by (simp add: lres_def)
  finally show ?thesis
    .
qed

text \<open>Theorem 32.7\<close>

lemma lres_top_vector:
  "vector (x / top)"
  using equivalence_top_closed lres_def vector_complement_closed vector_mult_closed vector_top_closed by auto

text \<open>Theorem 32.10\<close>

lemma lres_top_export_inf_mult:
  "((x / top) \<sqinter> y) * z = (x / top) \<sqinter> (y * z)"
  by (simp add: vector_inf_comp lres_top_vector)

lemma N_lres:
  "N(x) = x / top \<sqinter> 1"
  using lres_def by auto

end

class complete_relation_algebra = relation_algebra + complete_lattice
begin

definition mu :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" where "mu f \<equiv> Inf { y . f y \<le> y }"
definition nu :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" where "nu f \<equiv> Sup { y . y \<le> f y }"

lemma mu_lower_bound:
  "f x \<le> x \<Longrightarrow> mu f \<le> x"
  by (auto simp add: mu_def intro: Inf_lower)

lemma mu_greatest_lower_bound:
  "(\<forall>y . f y \<le> y \<longrightarrow> x \<le> y) \<Longrightarrow> x \<le> mu f"
  using lfp_def lfp_greatest mu_def by auto

lemma mu_unfold_1:
  "isotone f \<Longrightarrow> f (mu f) \<le> mu f"
  by (metis mu_greatest_lower_bound order_trans mu_lower_bound isotone_def)

lemma mu_unfold_2:
  "isotone f \<Longrightarrow> mu f \<le> f (mu f)"
  by (simp add: mu_lower_bound mu_unfold_1 ord.isotone_def)

lemma mu_unfold:
  "isotone f \<Longrightarrow> mu f = f (mu f)"
  by (simp add: order.antisym mu_unfold_1 mu_unfold_2)

lemma mu_const:
  "mu (\<lambda>x . y) = y"
  by (simp add: isotone_def mu_unfold)

lemma mu_lpfp:
  "isotone f \<Longrightarrow> is_least_prefixpoint f (mu f)"
  by (simp add: is_least_prefixpoint_def mu_lower_bound mu_unfold_1)

lemma mu_lfp:
  "isotone f \<Longrightarrow> is_least_fixpoint f (mu f)"
  by (metis is_least_fixpoint_def mu_lower_bound mu_unfold order_refl)

lemma mu_pmu:
  "isotone f \<Longrightarrow> p\<mu> f = mu f"
  using least_prefixpoint_same mu_lpfp by force

lemma mu_mu:
  "isotone f \<Longrightarrow> \<mu> f = mu f"
  using least_fixpoint_same mu_lfp by fastforce

end

class omega_relation_algebra = relation_algebra + star + omega +
  assumes ra_star_left_unfold : "1 \<squnion> y * y\<^sup>\<star> \<le> y\<^sup>\<star>"
  assumes ra_star_left_induct : "z \<squnion> y * x \<le> x \<longrightarrow> y\<^sup>\<star> * z \<le> x"
  assumes ra_star_right_induct: "z \<squnion> x * y \<le> x \<longrightarrow> z * y\<^sup>\<star> \<le> x"
  assumes ra_omega_unfold: "y\<^sup>\<omega> = y * y\<^sup>\<omega>"
  assumes ra_omega_induct: "x \<le> z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z"
begin

subclass bounded_omega_algebra
  apply unfold_locales
  using ra_star_left_unfold apply blast
  using ra_star_left_induct apply blast
  using ra_star_right_induct apply blast
  using ra_omega_unfold apply blast
  using ra_omega_induct by blast

end

text \<open>Theorem 38\<close>

sublocale omega_relation_algebra < n_omega_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq and Omega = "\<lambda>x . N(x\<^sup>\<omega>) * top \<squnion> x\<^sup>\<star>"
  apply unfold_locales
  apply simp
  using n_split_omega_mult omega_vector star_mult_omega apply force
  by simp

end


section \<open>General Domain Theory\<close>
theory RefineG_Domain
imports "../Refine_Misc"
begin

  subsection \<open>General Order Theory Tools\<close>
  lemma chain_f_apply: "Complete_Partial_Order.chain (fun_ord le) F
    \<Longrightarrow> Complete_Partial_Order.chain le {y . \<exists>f\<in>F. y = f x}"
    unfolding Complete_Partial_Order.chain_def
    by (auto simp: fun_ord_def)

  lemma ccpo_lift:
    assumes "class.ccpo lub le lt"
    shows "class.ccpo (fun_lub lub) (fun_ord le) (mk_less (fun_ord le))"
  proof -
    interpret ccpo: ccpo lub le lt by fact
    show ?thesis
      apply unfold_locales
      apply (simp_all only: mk_less_def fun_ord_def fun_lub_def)
      apply simp
      using ccpo.order_trans apply blast
      using ccpo.order.antisym apply blast
      using ccpo.ccpo_Sup_upper apply (blast intro: chain_f_apply)
      using ccpo.ccpo_Sup_least apply (blast intro: chain_f_apply)
      done
  qed

  (* TODO: Move *)
  lemma fun_lub_simps[simp]:
    "fun_lub lub {} = (\<lambda>x. lub {})"
    "fun_lub lub {f} = (\<lambda>x. lub {f x})"
    unfolding fun_lub_def by auto

  subsection \<open>Flat Ordering\<close>
  lemma flat_ord_chain_cases:
    assumes A: "Complete_Partial_Order.chain (flat_ord b) C"
    obtains "C={}"
    | "C={b}"
    | x where "x\<noteq>b" and "C={x}"
    | x where "x\<noteq>b" and "C={b,x}"
  proof -
    have "\<exists>m1 m2. C \<subseteq> {m1,m2} \<and> (m1 = b \<or> m2 = b)"
      apply (rule ccontr)
    proof clarsimp
      assume "\<forall>m1 m2. C \<subseteq> {m1, m2} \<longrightarrow> m1\<noteq>b \<and> m2\<noteq>b"
      then obtain m1 m2 where "m1\<in>C" "m2\<in>C"
        "m1\<noteq>m2" "m1\<noteq>b" "m2\<noteq>b"
        by blast
      with A show False
        unfolding Complete_Partial_Order.chain_def flat_ord_def
        by auto
    qed
    then obtain m where "C \<subseteq> {m,b}" by blast
    thus ?thesis
      apply (cases "m=b")
      using that
      apply blast+
      done
  qed

  lemma flat_lub_simps[simp]:
    "flat_lub b {} = b"
    "flat_lub b {x} = x"
    "flat_lub b (insert b X) = flat_lub b X"
    unfolding flat_lub_def
    by auto

  lemma flat_ord_simps[simp]:
    "flat_ord b b x"
    by (simp add: flat_ord_def)

  interpretation flat_ord: ccpo "flat_lub b" "flat_ord b" "mk_less (flat_ord b)"
    apply unfold_locales
    apply (simp_all only: mk_less_def flat_ord_def) apply auto [4]
    apply (erule flat_ord_chain_cases, auto) []
    apply (erule flat_ord_chain_cases, auto) []
    done

  interpretation flat_le_mono_setup: mono_setup_loc "flat_ord b"
    by standard auto

  subsubsection \<open>Flat function Ordering\<close>
  abbreviation "flatf_ord b == fun_ord (flat_ord b)"
  abbreviation "flatf_lub b == fun_lub (flat_lub b)"

  interpretation flatf_ord: ccpo "flatf_lub b" "flatf_ord b" "mk_less (flatf_ord b)"
    apply (rule ccpo_lift)
    apply unfold_locales
    done

  subsubsection \<open>Fixed Points in Flat Ordering\<close>
  text \<open>
    Fixed points in a flat ordering are used to express recursion.
    The bottom element is interpreted as non-termination.
\<close>

  abbreviation "flat_mono b == monotone (flat_ord b) (flat_ord b)"
  abbreviation "flatf_mono b == monotone (flatf_ord b) (flatf_ord b)"
  abbreviation "flatf_fp b \<equiv> flatf_ord.fixp b"

  lemma flatf_fp_mono[refine_mono]:
    \<comment> \<open>The fixed point combinator is monotonic\<close>
    assumes "flatf_mono b f"
      and "flatf_mono b g"
      and "\<And>Z x. flat_ord b (f Z x) (g Z x)"
    shows "flat_ord b (flatf_fp b f x) (flatf_fp b g x)"
  proof -
    have "flatf_ord b (flatf_fp b f) (flatf_fp b g)"
      apply (rule flatf_ord.fixp_mono[OF assms(1,2)])
      using assms(3) by (simp add: fun_ord_def)
    thus ?thesis unfolding fun_ord_def by blast
  qed

  lemma flatf_admissible_pointwise:
    "(\<And>x. P x b) \<Longrightarrow>
      ccpo.admissible (flatf_lub b) (flatf_ord b) (\<lambda>g. \<forall>x. P x (g x))"
    apply (intro ccpo.admissibleI allI impI)
    apply (drule_tac x=x in chain_f_apply)
    apply (erule flat_ord_chain_cases)
    apply (auto simp add: fun_lub_def) [2]
    apply (force simp add: fun_lub_def) []
    apply (auto simp add: fun_lub_def) []
    done

  text \<open>
    If a property is defined pointwise, and holds for the bottom element,
    we can use fixed-point induction for it.

    In the induction step, we can assume that the function is less or equal
    to the fixed-point.

    This rule covers refinement and transfer properties,
    such as: Refinement of fixed-point combinators and transfer of
    fixed-point combinators to different domains.
\<close>
  lemma flatf_fp_induct_pointwise:
    \<comment> \<open>Fixed-point induction for pointwise properties\<close>
    fixes a :: 'a
    assumes cond_bot: "\<And>a x. pre a x \<Longrightarrow> post a x b"
    assumes MONO: "flatf_mono b B"
    assumes PRE0: "pre a x"
    assumes STEP: "\<And>f a x.
      \<lbrakk>\<And>a' x'. pre a' x' \<Longrightarrow> post a' x' (f x'); pre a x;
        flatf_ord b f (flatf_fp b B) \<rbrakk>
      \<Longrightarrow> post a x (B f x)"
    shows "post a x (flatf_fp b B x)"
  proof -
    define ub where "ub = flatf_fp b B"

    have "(\<forall>x a. pre a x \<longrightarrow> post a x (flatf_fp b B x))
      \<and> flatf_ord b (flatf_fp b B) ub"
      apply (rule flatf_ord.fixp_induct[OF _ MONO])
      apply (rule admissible_conj)
      apply (rule flatf_admissible_pointwise)
      apply (blast intro: cond_bot)
      apply (rule ccpo.admissibleI)
      apply (blast intro: flatf_ord.ccpo_Sup_least)

      apply (auto intro: cond_bot simp: fun_ord_def flat_ord_def) []

      apply (rule conjI)
      unfolding ub_def

      apply (blast intro: STEP)

      apply (subst flatf_ord.fixp_unfold[OF MONO])
      apply (blast intro: monotoneD[OF MONO])
      done
    with PRE0 show ?thesis by blast
  qed

  text \<open>
    The next rule covers transfer between fixed points.
    It allows to lift a pointwise transfer condition
    \<open>P x y \<longrightarrow> tr (f x) (f y)\<close> to fixed points.
    Note that one of the fixed points may be an arbitrary fixed point.
\<close>
  lemma flatf_fixp_transfer:
    \<comment> \<open>Transfer rule for fixed points\<close>
    assumes TR_BOT[simp]: "\<And>x'. tr b x'"
    assumes MONO: "flatf_mono b B"
    assumes FP': "fp' = B' fp'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; fp' = f'\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_fp b B x) (fp' x')"
    apply (rule flatf_fp_induct_pointwise[where pre="\<lambda>x y. P y x", OF _ MONO])
    apply simp
    apply (rule R0)
    apply (subst FP')
    apply (blast intro: RS)
    done

  subsubsection \<open>Relation of Flat Ordering to Complete Lattices\<close>
  text \<open>
    In this section, we establish the relation between flat orderings
    and complete lattices. This relation is exploited to show properties
    of fixed points wrt. a refinement ordering.
\<close>

  abbreviation "flat_le \<equiv> flat_ord bot"
  abbreviation "flat_ge \<equiv> flat_ord top"
  abbreviation "flatf_le \<equiv> flatf_ord bot"
  abbreviation "flatf_ge \<equiv> flatf_ord top"

  text \<open>The flat ordering implies the lattice ordering\<close>
  lemma flat_ord_compat:
    fixes x y :: "'a :: complete_lattice"
    shows
    "flat_le x y \<Longrightarrow> x \<le> y"
    "flat_ge x y \<Longrightarrow> x \<ge> y"
    unfolding flat_ord_def by auto

  lemma flatf_ord_compat:
    fixes x y :: "'a \<Rightarrow> ('b :: complete_lattice)"
    shows
    "flatf_le x y \<Longrightarrow> x \<le> y"
    "flatf_ge x y \<Longrightarrow> x \<ge> y"
    by (auto simp: flat_ord_compat le_fun_def fun_ord_def)

  abbreviation "flat_mono_le \<equiv> flat_mono bot"
  abbreviation "flat_mono_ge \<equiv> flat_mono top"

  abbreviation "flatf_mono_le \<equiv> flatf_mono bot"
  abbreviation "flatf_mono_ge \<equiv> flatf_mono top"

  abbreviation "flatf_gfp \<equiv> flatf_ord.fixp top"
  abbreviation "flatf_lfp \<equiv> flatf_ord.fixp bot"

  text \<open>If a functor is monotonic wrt. both the flat and the
    lattice ordering, the fixed points wrt. these orderings coincide.
\<close>
  lemma lfp_eq_flatf_lfp:
    assumes FM: "flatf_mono_le B" and M: "mono B"
    shows "lfp B = flatf_lfp B"
  proof -
    from lfp_unfold[OF M, symmetric] have "B (lfp B) = lfp B" .
    hence "flatf_le (B (lfp B)) (lfp B)" by simp
    with flatf_ord.fixp_lowerbound[OF FM] have "flatf_le (flatf_lfp B) (lfp B)" .
    with flatf_ord_compat have "flatf_lfp B \<le> lfp B" by blast
    also
    from flatf_ord.fixp_unfold[OF FM, symmetric] have "B (flatf_lfp B) = flatf_lfp B" .
    hence "B (flatf_lfp B) \<le> flatf_lfp B" by simp
    with lfp_lowerbound[where A="flatf_lfp B"] have "lfp B \<le> flatf_lfp B" .
    finally show "lfp B = flatf_lfp B" ..
  qed

  lemma gfp_eq_flatf_gfp:
    assumes FM: "flatf_mono_ge B" and M: "mono B"
    shows "gfp B = flatf_gfp B"
  proof -
    from gfp_unfold[OF M, symmetric] have "B (gfp B) = gfp B" .
    hence "flatf_ge (B (gfp B)) (gfp B)" by simp
    with flatf_ord.fixp_lowerbound[OF FM] have "flatf_ge (flatf_gfp B) (gfp B)" .
    with flatf_ord_compat have "gfp B \<le> flatf_gfp B" by blast
    also
    from flatf_ord.fixp_unfold[OF FM, symmetric] have "B (flatf_gfp B) = flatf_gfp B" .
    hence "flatf_gfp B \<le> B (flatf_gfp B)" by simp
    with gfp_upperbound[where X="flatf_gfp B"] have "flatf_gfp B \<le> gfp B" .
    finally show "gfp B = flatf_gfp B" .
  qed

  (* TODO: This belongs to "General Recursion"*)
  text \<open>
    The following lemma provides a well-founded induction scheme for arbitrary
    fixed point combinators.
\<close>
  lemma wf_fixp_induct:
    \<comment> \<open>Well-Founded induction for arbitrary fixed points\<close>
    fixes a :: 'a
    assumes fixp_unfold: "fp B = B (fp B)"
    assumes WF: "wf V"
    assumes P0: "pre a x"
    assumes STEP: "\<And>f a x. \<lbrakk>
      \<And>a' x'. \<lbrakk> pre a' x'; (x',x)\<in>V \<rbrakk> \<Longrightarrow> post a' x' (f x'); fp B = f; pre a x
    \<rbrakk> \<Longrightarrow> post a x (B f x)"
    shows "post a x (fp B x)"
  proof -
    have "\<forall>a. pre a x \<longrightarrow> post a x (fp B x)"
      using WF
      apply (induct x rule: wf_induct_rule)
      apply (intro allI impI)
      apply (subst fixp_unfold)
      apply (rule STEP)
      apply (simp)
      apply (simp)
      apply (simp)
      done
    with P0 show ?thesis by blast
  qed

  lemma flatf_lfp_transfer:
    \<comment> \<open>Transfer rule for least fixed points\<close>
    fixes B::"(_ \<Rightarrow> 'a::order_bot) \<Rightarrow> _"
    assumes TR_BOT[simp]: "\<And>x. tr bot x"
    assumes MONO: "flatf_mono_le B"
    assumes MONO': "flatf_mono_le B'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; flatf_lfp B' = f'\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_lfp B x) (flatf_lfp B' x')"
    apply (rule flatf_fixp_transfer[where tr=tr and fp'="flatf_lfp B'" and P=P])
    apply (fact|rule flatf_ord.fixp_unfold[OF MONO'])+
    done

  lemma flatf_gfp_transfer:
    \<comment> \<open>Transfer rule for greatest fixed points\<close>
    fixes B::"(_ \<Rightarrow> 'a::order_top) \<Rightarrow> _"
    assumes TR_TOP[simp]: "\<And>x. tr x top"
    assumes MONO: "flatf_mono_ge B"
    assumes MONO': "flatf_mono_ge B'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; flatf_gfp B = f\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_gfp B x) (flatf_gfp B' x')"
    apply (rule flatf_fixp_transfer[where
        tr="\<lambda>x y. tr y x" and fp'="flatf_gfp B" and P="\<lambda>x y. P y x"])
    apply (fact|assumption|rule flatf_ord.fixp_unfold[OF MONO] RS)+
    done

  lemma meta_le_everything_if_top: "(m=top) \<Longrightarrow> (\<And>x. x \<le> (m::'a::order_top))"
    by auto

  lemmas flatf_lfp_refine = flatf_lfp_transfer[
    where tr = "\<lambda>a b. a \<le> cf b" for cf, OF bot_least]
  lemmas flatf_gfp_refine = flatf_gfp_transfer[
    where tr = "\<lambda>a b. a \<le> cf b" for cf, OF meta_le_everything_if_top]

  lemma flat_ge_sup_mono[refine_mono]: "\<And>a a'::'a::complete_lattice.
    flat_ge a a' \<Longrightarrow> flat_ge b b' \<Longrightarrow> flat_ge (sup a b) (sup a' b')"
    by (auto simp: flat_ord_def)

  declare sup_mono[refine_mono]

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul3acc_assoc1
  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 (mul3acc x1 x2 x3acc) x4 x5) =
      (mul3acc x1 x2 (mul3acc x3acc x4 x5)))"
  oops

end


(*  Title:       Verification and refinement of hybrid systems in the relational KAT
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open>Verification of hybrid programs\<close>

text \<open> We use our state transformers model to obtain verification and refinement components for
hybrid programs. We retake the three methods for reasoning with evolution commands and their
continuous dynamics: providing flows, solutions or invariants. \<close>

theory HS_VC_KAT_ndfun
  imports
    "../HS_ODEs"
    "HS_VC_KAT"
    "../HS_VC_KA_ndfun"

begin

instantiation nd_fun :: (type) kat
begin

definition "n f = (\<lambda>x. if ((f\<^sub>\<bullet>) x = {}) then {x} else {})\<^sup>\<bullet>"

lemma nd_fun_n_op_one[nd_fun_ka]: "n (n (1::'a nd_fun)) = 1"
  and nd_fun_n_op_mult[nd_fun_ka]: "n (n (n x \<cdot> n y)) = n x \<cdot> n y"
  and nd_fun_n_op_mult_comp[nd_fun_ka]: "n x \<cdot> n (n x) = 0"
  and nd_fun_n_op_de_morgan[nd_fun_ka]: "n (n (n x) \<cdot> n (n y)) = n x + n y" for x::"'a nd_fun"
  unfolding n_op_nd_fun_def one_nd_fun_def times_nd_fun_def plus_nd_fun_def zero_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def)

instance
  by (intro_classes, auto simp: nd_fun_ka)

end

instantiation nd_fun :: (type) rkat
begin

definition "Ref_nd_fun P Q \<equiv> (\<lambda>s. \<Union>{(f\<^sub>\<bullet>) s|f. Hoare P f Q})\<^sup>\<bullet>"

instance
  apply(intro_classes)
  by (unfold Hoare_def n_op_nd_fun_def Ref_nd_fun_def times_nd_fun_def)
    (auto simp: kcomp_def le_fun_def less_eq_nd_fun_def)

end

subsubsection \<open> Regular programs\<close>

text \<open> Lemmas for manipulation of predicates in the relational model \<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
        and Archimedean_Field.floor_ceiling_class.floor ("\<lfloor>_\<rfloor>")
        and tau ("\<tau>")
        and Relation.relcomp (infixl ";" 75)
        and proto_near_quantale_class.bres (infixr "\<rightarrow>" 60)

definition p2ndf :: "'a pred \<Rightarrow> 'a nd_fun" ("(1\<lceil>_\<rceil>)")
  where "\<lceil>Q\<rceil> \<equiv> (\<lambda> x::'a. {s::'a. s = x \<and> Q s})\<^sup>\<bullet>"

lemma p2ndf_simps[simp]:
  "\<lceil>P\<rceil> \<le> \<lceil>Q\<rceil> = (\<forall>s. P s \<longrightarrow> Q s)"
  "(\<lceil>P\<rceil> = \<lceil>Q\<rceil>) = (\<forall>s. P s = Q s)"
  "(\<lceil>P\<rceil> \<cdot> \<lceil>Q\<rceil>) = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  "(\<lceil>P\<rceil> + \<lceil>Q\<rceil>) = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  "\<tt>\<tt> \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  "n \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  unfolding p2ndf_def one_nd_fun_def less_eq_nd_fun_def times_nd_fun_def plus_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def le_fun_def n_op_nd_fun_def)

text \<open> Lemmas for verification condition generation \<close>

\<comment> \<open> Hoare Triples \<close>

abbreviation ndfunHoare ("\<^bold>{_\<^bold>}_\<^bold>{_\<^bold>}")
  where "\<^bold>{P\<^bold>}X\<^bold>{Q\<^bold>} \<equiv> Hoare \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

lemma ndfun_kat_H: "\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s s'. P s \<longrightarrow> s' \<in> (X\<^sub>\<bullet>) s \<longrightarrow> Q s')"
  unfolding Hoare_def p2ndf_def less_eq_nd_fun_def times_nd_fun_def kcomp_def
  by (auto simp add: le_fun_def n_op_nd_fun_def)

\<comment> \<open> Skip \<close>

abbreviation "skip \<equiv> (1::'a nd_fun)"

lemma sH_skip[simp]: "\<^bold>{P\<^bold>} skip \<^bold>{Q\<^bold>} \<longleftrightarrow> \<lceil>P\<rceil> \<le> \<lceil>Q\<rceil>"
  unfolding ndfun_kat_H by (simp add: one_nd_fun_def)

lemma H_skip: "\<^bold>{P\<^bold>} skip \<^bold>{P\<^bold>}"
  by simp

\<comment> \<open> Tests \<close>

lemma sH_test[simp]: "\<^bold>{P\<^bold>} \<lceil>R\<rceil> \<^bold>{Q\<^bold>} = (\<forall>s. P s \<longrightarrow> R s \<longrightarrow> Q s)"
  by (subst ndfun_kat_H, simp add: p2ndf_def)

\<comment> \<open> Abort \<close>

abbreviation "abort \<equiv> (0::'a nd_fun)"

lemma sH_abort[simp]: "\<^bold>{P\<^bold>} abort \<^bold>{Q\<^bold>} \<longleftrightarrow> True"
  unfolding ndfun_kat_H by (simp add: zero_nd_fun_def)

lemma H_abort: "\<^bold>{P\<^bold>} abort \<^bold>{Q\<^bold>}"
  by simp

\<comment> \<open> Assignments \<close>

definition assign :: "'b \<Rightarrow> ('a^'b \<Rightarrow> 'a) \<Rightarrow> ('a^'b) nd_fun" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})\<^sup>\<bullet>"

lemma sH_assign[simp]: "\<^bold>{P\<^bold>} (x ::= e) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> Q (\<chi> j. ((($) s)(x := (e s))) j))"
  unfolding ndfun_kat_H vec_upd_def assign_def by (auto simp: fun_upd_def)

lemma H_assign: "P = (\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j)) \<Longrightarrow> \<^bold>{P\<^bold>} (x ::= e) \<^bold>{Q\<^bold>}"
  by simp

\<comment> \<open> Nondeterministic assignments \<close>

definition nondet_assign :: "'b \<Rightarrow> ('a^'b) nd_fun" ("(2_ ::= ? )" [70] 61)
    where "(x ::= ?) = (\<lambda>s. {vec_upd s x k|k. True})\<^sup>\<bullet>"

lemma sH_nondet_assign[simp]:
  "\<^bold>{P\<^bold>} (x ::= ?) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> (\<forall>k. Q (\<chi> j. ((($) s)(x := k)) j)))"
  unfolding ndfun_kat_H vec_upd_def nondet_assign_def by (auto simp: fun_upd_def)

lemma H_nondet_assign: "\<^bold>{\<lambda>s. \<forall>k. P (\<chi> j. ((($) s)(x := k)) j)\<^bold>} (x ::= ?) \<^bold>{P\<^bold>}"
  by simp

\<comment> \<open> Sequential Composition \<close>

abbreviation seq_seq :: "'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" (infixl ";" 75)
  where "f ; g \<equiv> f \<cdot> g"

lemma H_seq: "\<^bold>{P\<^bold>} X \<^bold>{R\<^bold>} \<Longrightarrow> \<^bold>{R\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} X;Y \<^bold>{Q\<^bold>}"
  by (auto intro: H_seq)

lemma sH_seq: "\<^bold>{P\<^bold>} X;Y \<^bold>{Q\<^bold>} = \<^bold>{P\<^bold>} X \<^bold>{\<lambda>s. \<forall>s'. s' \<in> (Y\<^sub>\<bullet>) s \<longrightarrow> Q s'\<^bold>}"
  unfolding ndfun_kat_H by (auto simp: times_nd_fun_def kcomp_def)

lemma H_assignl:
  assumes "\<^bold>{K\<^bold>} X \<^bold>{Q\<^bold>}"
    and "\<forall>s. P s \<longrightarrow> K (vec_lambda ((($) s)(x := e s)))"
  shows "\<^bold>{P\<^bold>} (x ::= e);X \<^bold>{Q\<^bold>}"
  apply(rule H_seq, subst sH_assign)
  using assms by auto

\<comment> \<open> Nondeterministic Choice \<close>

lemma sH_choice: "\<^bold>{P\<^bold>} X + Y \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<and> \<^bold>{P\<^bold>} Y \<^bold>{Q\<^bold>})"
  unfolding ndfun_kat_H by (auto simp: plus_nd_fun_def)

lemma H_choice: "\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} X + Y \<^bold>{Q\<^bold>}"
  using H_choice .

\<comment> \<open> Conditional Statement \<close>

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" ("IF _ THEN _ ELSE _" [64,64] 63)
  where "IF B THEN X ELSE Y \<equiv> kat_cond \<lceil>B\<rceil> X Y"

lemma sH_cond[simp]:
  "\<^bold>{P\<^bold>} (IF B THEN X ELSE Y) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{Q\<^bold>} \<and> \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>} Y \<^bold>{Q\<^bold>})"
  by (auto simp: H_cond_iff ndfun_kat_H)

lemma H_cond:
  "\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (IF B THEN X ELSE Y) \<^bold>{Q\<^bold>}"
  by simp

\<comment> \<open> While Loop \<close>

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" ("WHILE _ INV _ DO _" [64,64,64] 63)
  where "WHILE B INV I DO X \<equiv> kat_while_inv \<lceil>B\<rceil> \<lceil>I\<rceil> X"

lemma sH_whileI: "\<forall>s. P s \<longrightarrow> I s \<Longrightarrow> \<forall>s. I s \<and> \<not> B s \<longrightarrow> Q s \<Longrightarrow> \<^bold>{\<lambda>s. I s \<and> B s\<^bold>} X \<^bold>{I\<^bold>}
  \<Longrightarrow> \<^bold>{P\<^bold>} (WHILE B INV I DO X) \<^bold>{Q\<^bold>}"
  by (rule H_while_inv, simp_all add: ndfun_kat_H)

lemma "\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{\<lambda>s. P s\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (WHILE B INV I DO X) \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>}"
  using H_while[of "\<lceil>P\<rceil>" "\<lceil>B\<rceil>" X]
  unfolding kat_while_inv_def by auto

\<comment> \<open> Finite Iteration \<close>

abbreviation loopi_sugar :: "'a nd_fun \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP X INV I \<equiv> kat_loop_inv X \<lceil>I\<rceil>"

lemma H_loop: "\<^bold>{P\<^bold>} X \<^bold>{P\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (LOOP X INV I) \<^bold>{P\<^bold>}"
  by (auto intro: H_loop)

lemma H_loopI: "\<^bold>{I\<^bold>} X \<^bold>{I\<^bold>} \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<^bold>{P\<^bold>} (LOOP X INV I) \<^bold>{Q\<^bold>}"
  using H_loop_inv[of "\<lceil>P\<rceil>" "\<lceil>I\<rceil>" X "\<lceil>Q\<rceil>"] by auto

subsubsection \<open> Evolution commands \<close>

\<comment> \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> ('b \<Rightarrow> 'a set) \<Rightarrow> 'b nd_fun" ("EVOL")
  where "EVOL \<phi> G U = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G (U s))\<^sup>\<bullet>"

lemma sH_g_evol[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "\<^bold>{P\<^bold>} (EVOL \<phi> G U) \<^bold>{Q\<^bold>} = (\<forall>s. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  unfolding ndfun_kat_H g_evol_def g_orbit_eq by auto

lemma H_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes "P = (\<lambda>s. (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  shows "\<^bold>{P\<^bold>} (EVOL \<phi> G U) \<^bold>{Q\<^bold>}"
  by (simp add: assms)

\<comment> \<open>Verification by providing solutions\<close>

definition g_ode ::"(real \<Rightarrow> ('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a nd_fun" ("(1x\<acute>= _ & _ on _ _ @ _)")
  where "(x\<acute>= f & G on U S @ t\<^sub>0) \<equiv> (\<lambda> s. g_orbital f G U S t\<^sub>0 s)\<^sup>\<bullet>"

lemma H_g_orbital:
  "P = (\<lambda>s. (\<forall>X\<in>ivp_sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t))) \<Longrightarrow>
  \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  unfolding ndfun_kat_H g_ode_def g_orbital_eq by clarsimp

lemma sH_g_orbital: "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>} =
  (\<forall>s. P s \<longrightarrow> (\<forall>X\<in>ivp_sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t)))"
  unfolding g_orbital_eq g_ode_def ndfun_kat_H by auto

context local_flow
begin

lemma sH_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
proof(unfold sH_g_orbital, clarsimp, safe)
  fix s t
  assume hyps: "s \<in> S" "P s" "t \<in> U s" "\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (\<phi> \<tau> s)"
    and main: "\<forall>s. P s \<longrightarrow> (\<forall>X\<in>Sols (\<lambda>t. f) U S 0 s. \<forall>t\<in>U s. (\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)) \<longrightarrow> Q (X t))"
  hence "(\<lambda>t. \<phi> t s) \<in> Sols (\<lambda>t. f) U S 0 s"
    using in_ivp_sols assms by blast
  thus "Q (\<phi> t s)"
    using main hyps by fastforce
next
  fix s X t
  assume hyps: "P s" "X \<in> Sols (\<lambda>t. f) U S 0 s" "t \<in> U s"  "\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
    and main: "\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  hence obs: "s \<in> S"
    using ivp_sols_def[of "\<lambda>t. f"] init_time by auto
  hence "\<forall>\<tau>\<in>down (U s) t. X \<tau> = \<phi> \<tau> s"
    using eq_solution hyps assms by blast
  thus "Q (X t)"
    using hyps main obs by auto
qed

lemma H_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "P = (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  shows "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<^bold>{Q\<^bold>}"
  using assms apply(subst sH_g_ode_subset[OF assms(1)])
  unfolding assms by auto

lemma sH_g_ode: "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  by (subst sH_g_ode_subset, auto simp: init_time interval_time)

lemma sH_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> \<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(subst sH_g_ode_subset; clarsimp, (force)?)
  using init_time interval_time mem_is_interval_1_I by blast

lemma sH_orbit: "\<^bold>{P\<^bold>} \<gamma>\<^sup>\<phi>\<^sup>\<bullet> \<^bold>{Q\<^bold>}  = (\<forall>s \<in> S. P s \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s)))"
  using sH_g_ode unfolding orbit_def g_ode_def by auto

end

\<comment> \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(real \<Rightarrow> ('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on U S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on U S @ t\<^sub>0)"

lemma sH_g_orbital_guard:
  assumes "R = (\<lambda>s. G s \<and> Q s)"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>} = \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{R\<^bold>}"
  using assms unfolding g_orbital_eq ndfun_kat_H ivp_sols_def g_ode_def by auto

lemma sH_g_orbital_inv:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>}" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows " \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  using assms(1) apply(rule_tac p'="\<lceil>I\<rceil>" in H_consl, simp)
  using assms(3) apply(rule_tac q'="\<lceil>I\<rceil>" in H_consr, simp)
  using assms(2) by simp

lemma sH_diff_inv[simp]: "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>} = diff_invariant I f U S t\<^sub>0 G"
  unfolding diff_invariant_eq ndfun_kat_H g_orbital_eq g_ode_def by auto

lemma H_g_ode_inv: "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>} \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow>
  \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0 DINV I) \<^bold>{Q\<^bold>}"
  unfolding g_ode_inv_def apply(rule_tac q'="\<lceil>\<lambda>s. I s \<and> G s\<rceil>" in H_consr, simp)
  apply(subst sH_g_orbital_guard[symmetric], force)
  by (rule_tac I="I" in sH_g_orbital_inv, simp_all)

subsection \<open> Refinement Components \<close>

\<comment> \<open> Skip \<close>

lemma R_skip: "(\<forall>s. P s \<longrightarrow> Q s) \<Longrightarrow> 1 \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (auto simp: spec_def ndfun_kat_H one_nd_fun_def)

\<comment> \<open> Abort \<close>

lemma R_abort: "abort \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R2, simp)

\<comment> \<open> Sequential Composition \<close>

lemma R_seq: "(Ref \<lceil>P\<rceil> \<lceil>R\<rceil>) ; (Ref \<lceil>R\<rceil> \<lceil>Q\<rceil>) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using R_seq by blast

lemma R_seq_law: "X \<le> Ref \<lceil>P\<rceil> \<lceil>R\<rceil> \<Longrightarrow> Y \<le> Ref \<lceil>R\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> X; Y \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding spec_def by (rule H_seq)

lemmas R_seq_mono = mult_isol_var

\<comment> \<open> Nondeterministic Choice \<close>

lemma R_choice: "(Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>) + (Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using R_choice[of "\<lceil>P\<rceil>" "\<lceil>Q\<rceil>"] .

lemma R_choice_law: "X \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> Y \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> X + Y \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using join.le_supI .

lemma R_choice_mono: "P' \<le> P \<Longrightarrow> Q' \<le> Q \<Longrightarrow> P' + Q' \<subseteq> P + Q"
  using set_plus_mono2 .

\<comment> \<open> Assignment \<close>

lemma R_assign: "(x ::= e) \<le> Ref \<lceil>\<lambda>s. P (\<chi> j. ((($) s)(x := e s)) j)\<rceil> \<lceil>P\<rceil>"
  unfolding spec_def by (rule H_assign, clarsimp simp: fun_eq_iff fun_upd_def)

lemma R_assign_law:
  "(\<forall>s. P s \<longrightarrow> Q (\<chi> j. ((($) s)(x := (e s))) j)) \<Longrightarrow> (x ::= e) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_assign[symmetric] spec_def .

lemma R_assignl:
  "P = (\<lambda>s. R (\<chi> j. ((($) s)(x := e s)) j)) \<Longrightarrow> (x ::= e) ; Ref \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law)
  by (rule_tac R_assign_law, simp_all)

lemma R_assignr:
  "R = (\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j)) \<Longrightarrow> Ref \<lceil>P\<rceil> \<lceil>R\<rceil>; (x ::= e) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_assign_law, simp)

lemma "(x ::= e) ; Ref \<lceil>Q\<rceil> \<lceil>Q\<rceil> \<le> Ref \<lceil>(\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j))\<rceil> \<lceil>Q\<rceil>"
  by (rule R_assignl) simp

lemma "Ref \<lceil>Q\<rceil> \<lceil>(\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j))\<rceil>; (x ::= e) \<le> Ref \<lceil>Q\<rceil> \<lceil>Q\<rceil>"
  by (rule R_assignr) simp

\<comment> \<open> Nondeterministic Assignment \<close>

lemma R_nondet_assign: "(x ::= ?) \<le> Ref \<lceil>\<lambda>s. \<forall>k. P (\<chi> j. ((($) s)(x := k)) j)\<rceil> \<lceil>P\<rceil>"
  unfolding spec_def by (rule H_nondet_assign)

lemma R_nondet_assign_law:
  "(\<forall>s. P s \<longrightarrow> (\<forall>k. Q (\<chi> j. ((($) s)(x := k)) j))) \<Longrightarrow> (x ::= ?) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_nondet_assign[symmetric] by (rule R2)

\<comment> \<open> Conditional Statement \<close>

lemma R_cond:
  "(IF B THEN Ref \<lceil>\<lambda>s. B s \<and> P s\<rceil> \<lceil>Q\<rceil> ELSE Ref \<lceil>\<lambda>s. \<not> B s \<and> P s\<rceil> \<lceil>Q\<rceil>) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using R_cond[of "\<lceil>B\<rceil>" "\<lceil>P\<rceil>" "\<lceil>Q\<rceil>"] by simp

lemma R_cond_mono: "X \<le> X' \<Longrightarrow> Y \<le> Y' \<Longrightarrow> (IF P THEN X ELSE Y) \<le> IF P THEN X' ELSE Y'"
  unfolding kat_cond_def times_nd_fun_def plus_nd_fun_def n_op_nd_fun_def
  by (auto simp: kcomp_def less_eq_nd_fun_def p2ndf_def le_fun_def)

lemma R_cond_law: "X \<le> Ref \<lceil>\<lambda>s. B s \<and> P s\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> Y \<le> Ref \<lceil>\<lambda>s. \<not> B s \<and> P s\<rceil> \<lceil>Q\<rceil> \<Longrightarrow>
  (IF B THEN X ELSE Y) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule order_trans; (rule R_cond_mono)?, (rule R_cond)?) auto

\<comment> \<open> While loop \<close>

lemma R_while: "K = (\<lambda>s. P s \<and> \<not> B s) \<Longrightarrow>
  WHILE B INV I DO (Ref \<lceil>\<lambda>s. P s \<and> B s\<rceil> \<lceil>P\<rceil>) \<le> Ref \<lceil>P\<rceil> \<lceil>K\<rceil>"
  unfolding kat_while_inv_def using R_while[of "\<lceil>B\<rceil>" "\<lceil>P\<rceil>"] by simp

lemma R_whileI:
  "X \<le> Ref \<lceil>I\<rceil> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>\<lambda>s. I s \<and> B s\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> \<not> B s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  WHILE B INV I DO X \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R2, rule H_while_inv, auto simp: ndfun_kat_H spec_def)

lemma R_while_mono: "X \<le> X' \<Longrightarrow> (WHILE P INV I DO X) \<le> WHILE P INV I DO X'"
  by (simp add: kat_while_inv_def kat_while_def mult_isol mult_isor star_iso)

lemma R_while_law: "X \<le> Ref \<lceil>\<lambda>s. P s \<and> B s\<rceil> \<lceil>P\<rceil> \<Longrightarrow> Q = (\<lambda>s. P s \<and> \<not> B s) \<Longrightarrow>
  (WHILE B INV I DO X) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule order_trans; (rule R_while_mono)?, (rule R_while)?)

\<comment> \<open> Finite Iteration \<close>

lemma R_loop: "X \<le> Ref \<lceil>I\<rceil> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> LOOP X INV I \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding spec_def using H_loopI by blast

lemma R_loopI: "X \<le> Ref \<lceil>I\<rceil> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> LOOP X INV I \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding spec_def using H_loopI by blast

lemma R_loop_mono: "X \<le> X' \<Longrightarrow> LOOP X INV I \<le> LOOP X' INV I"
  unfolding kat_loop_inv_def by (simp add: star_iso)

\<comment> \<open> Evolution command (flow) \<close>

lemma R_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "(EVOL \<phi> G U) \<le> Ref \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s)\<rceil> \<lceil>P\<rceil>"
  unfolding spec_def by (rule H_g_evol, simp)

lemma R_g_evol_law:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "(\<forall>s. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (EVOL \<phi> G U) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_evol[symmetric] spec_def .

lemma R_g_evoll:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "P = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s)) \<Longrightarrow>
  (EVOL \<phi> G U) ; Ref \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law)
  by (rule_tac R_g_evol_law, simp_all)

lemma R_g_evolr:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "R = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)) \<Longrightarrow>
  Ref \<lceil>P\<rceil> \<lceil>R\<rceil>; (EVOL \<phi> G U) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_g_evol_law, simp)

lemma
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "EVOL \<phi> G U ; Ref \<lceil>Q\<rceil> \<lceil>Q\<rceil> \<le>
  Ref \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_evoll) simp

lemma
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "Ref \<lceil>Q\<rceil> \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil>; EVOL \<phi> G U \<le> Ref \<lceil>Q\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_evolr) simp

\<comment> \<open> Evolution command (ode) \<close>

context local_flow
begin

lemma R_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "(x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<le>
  Ref \<lceil>\<lambda>s. s\<in>S \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s))\<rceil> \<lceil>P\<rceil>"
  unfolding spec_def by (rule H_g_ode_subset[OF assms], auto)

lemma R_g_ode_rule_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "(\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding spec_def by (subst sH_g_ode_subset[OF assms], auto)

lemma R_g_odel_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "P = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s))"
  shows "(x\<acute>= (\<lambda>t. f) & G on U S @ 0) ; Ref \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (rule_tac R=R in R_seq_law, rule_tac R_g_ode_rule_subset)
  by (simp_all add: assms)

lemma R_g_oder_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "R = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "Ref \<lceil>P\<rceil> \<lceil>R\<rceil>; (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_g_ode_rule_subset, simp_all add: assms)

lemma R_g_ode: "(x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le>
  Ref \<lceil>\<lambda>s. s\<in>S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s))\<rceil> \<lceil>P\<rceil>"
  by (rule R_g_ode_subset, auto simp: init_time interval_time)

lemma R_g_ode_law: "(\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_ode[symmetric] by (rule R2)

lemma R_g_odel: "P = (\<lambda>s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s)) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) ; Ref \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_odel_subset, auto simp: init_time interval_time)

lemma R_g_oder: "R = (\<lambda>s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)) \<Longrightarrow>
  Ref \<lceil>P\<rceil> \<lceil>R\<rceil>; (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_oder_subset, auto simp: init_time interval_time)

lemma R_g_ode_ivl:
  "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_ode_ivl[symmetric] by (rule R2)

end

\<comment> \<open> Evolution command (invariants) \<close>

lemma R_g_ode_inv: "diff_invariant I f T S t\<^sub>0 G \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  (x\<acute>=f & G on T S @ t\<^sub>0 DINV I) \<le> Ref \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding spec_def by (auto simp: H_g_ode_inv)

subsection \<open> Derivation of the rules of dL \<close>

text \<open> We derive rules of differential dynamic logic (dL). This allows the components to reason
in the style of that logic. \<close>

abbreviation g_dl_ode ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _)")
  where "(x\<acute>=f & G) \<equiv> (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0)"

abbreviation g_dl_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _ DINV _)")
  where "(x\<acute>= f & G DINV I) \<equiv> (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0 DINV I)"

lemma diff_solve_rule1:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G) \<^bold>{Q\<^bold>}"
  using assms by(subst local_flow.sH_g_ode_subset, auto)

lemma diff_solve_rule2:
  fixes c::"'a::{heine_borel, banach}"
  assumes "\<forall>s. P s \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> Q (s + t *\<^sub>R c))"
  shows "\<^bold>{P\<^bold>} (x\<acute>=(\<lambda>s. c) & G) \<^bold>{Q\<^bold>}"
  apply(subst local_flow.sH_g_ode_subset[where T=UNIV and \<phi>="(\<lambda> t x. x + t *\<^sub>R c)"])
  using line_is_local_flow assms by auto

lemma diff_weak_rule:
  assumes "\<lceil>G\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  using assms unfolding g_orbital_eq ndfun_kat_H ivp_sols_def g_ode_def by auto

lemma diff_cut_rule:
  assumes wp_C:"Hoare \<lceil>P\<rceil> (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>C\<rceil>"
    and wp_Q:"Hoare \<lceil>P\<rceil> (x\<acute>= f & (\<lambda> s. G s \<and> C s) on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
proof(subst ndfun_kat_H, simp add: g_orbital_eq p2ndf_def g_ode_def, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s
  assume "P s" and "t \<in> U s"
    and x_ivp:"X \<in> ivp_sols f U S t\<^sub>0 s"
    and guard_x:"\<forall>x. x \<in> U s \<and> x \<le> t \<longrightarrow> G (X x)"
  have "\<forall>t\<in>(down (U s) t). X t \<in> g_orbital f G U S t\<^sub>0 s"
    using g_orbitalI[OF x_ivp] guard_x by auto
  hence "\<forall>t\<in>(down (U s) t). C (X t)"
    using wp_C \<open>P s\<close> by (subst (asm) ndfun_kat_H, auto simp: g_ode_def)
  hence "X t \<in> g_orbital f (\<lambda>s. G s \<and> C s) U S t\<^sub>0 s"
    using guard_x \<open>t \<in> U s\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "Q (X t)"
    using \<open>P s\<close> wp_Q by (subst (asm) ndfun_kat_H) (auto simp: g_ode_def)
qed

lemma diff_inv_rule:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "diff_invariant I f U S t\<^sub>0 G" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  apply(subst g_ode_inv_def[symmetric, where I=I], rule H_g_ode_inv)
  unfolding sH_diff_inv using assms by auto

end