(* Author: Tobias Nipkow *)

theory Abs_Int1_const_ITP
imports Abs_Int1_ITP "../Abs_Int_Tests"
begin

subsection "Constant Propagation"

datatype const = Const val | Any

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

fun plus_const where
"plus_const (Const m) (Const n) = Const(m+n)" |
"plus_const _ _ = Any"

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

instantiation const :: SL_top
begin

fun le_const where
"_ \<sqsubseteq> Any = True" |
"Const n \<sqsubseteq> Const m = (n=m)" |
"Any \<sqsubseteq> Const _ = False"

fun join_const where
"Const m \<squnion> Const n = (if n=m then Const m else Any)" |
"_ \<squnion> _ = Any"

definition "\<top> = Any"

instance
proof
  case goal1 thus ?case by (cases x) simp_all
next
  case goal2 thus ?case by(cases z, cases y, cases x, simp_all)
next
  case goal3 thus ?case by(cases x, cases y, simp_all)
next
  case goal4 thus ?case by(cases y, cases x, simp_all)
next
  case goal5 thus ?case by(cases z, cases y, cases x, simp_all)
next
  case goal6 thus ?case by(simp add: Top_const_def)
qed

end

global_interpretation Val_abs
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
proof
  case goal1 thus ?case
    by(cases a, cases b, simp, simp, cases b, simp, simp)
next
  case goal2 show ?case by(simp add: Top_const_def)
next
  case goal3 show ?case by simp
next
  case goal4 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"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test1_const))"
value "show_acom_opt (AI_const test1_const)"

value "show_acom_opt (AI_const test2_const)"
value "show_acom_opt (AI_const test3_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test4_const))"
value "show_acom_opt (AI_const test4_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^4) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^5) (\<bottom>\<^sub>c test5_const))"
value "show_acom_opt (AI_const test5_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^4) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^5) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^6) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^7) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^8) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^9) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^10) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^11) (\<bottom>\<^sub>c test6_const))"
value "show_acom_opt (AI_const test6_const)"

text{* Monotonicity: *}

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

text{* Termination: *}

definition "m_const x = (case x of Const _ \<Rightarrow> 1 | Any \<Rightarrow> 0)"

lemma measure_const:
  "(strict{(x::const,y). x \<sqsubseteq> y})^-1 \<subseteq> measure m_const"
by(auto simp: m_const_def split: const.splits)

lemma measure_const_eq:
  "\<forall> x y::const. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m_const x = m_const y"
by(auto simp: m_const_def split: const.splits)

lemma "EX c'. AI_const c = Some c'"
by(rule AI_Some_measure[OF measure_const measure_const_eq])

end


(*  Title:   HPProg.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology

*)
section \<open> Formalization of PPV \<close>

text \<open> We formalize PPV(Probabilistic Programming Verification framework)~\cite{Sato_2019}.\<close>

subsection \<open> Language: HPProg \<close>

theory HPProg
  imports "../Quasi_Borel_Spaces/Measure_as_QuasiBorel_Measure"
begin

definition hpprog_typing :: "['cont quasi_borel, 'cont \<Rightarrow> 'typ, 'typ quasi_borel] \<Rightarrow> bool" where
"hpprog_typing \<Gamma> e T \<equiv> e \<in> \<Gamma> \<rightarrow>\<^sub>Q T"

syntax
 "_hpprog_typing" :: "any \<Rightarrow> 'cont quasi_borel \<Rightarrow> ('cont \<Rightarrow> 'typ) \<Rightarrow> 'typ quasi_borel \<Rightarrow> bool" ("_ \<turnstile>\<^sub>t _ ;; _" 60)

translations
 "\<Gamma> \<turnstile>\<^sub>t e ;; T" \<rightleftharpoons> "CONST hpprog_typing \<Gamma> e T"

definition hpprog_context :: "['a quasi_borel,'b quasi_borel] \<Rightarrow> ('a \<times> 'b) quasi_borel" (infixl ",," 78)  where
"hpprog_context \<equiv> pair_qbs"

definition empty_context :: "unit quasi_borel" ("\<emptyset>\<^sub>C") where
"empty_context \<equiv> unit_quasi_borel"

abbreviation monadP_qbs_type ("P\<^sub>t") where "monadP_qbs_type \<equiv> monadP_qbs"

declare empty_context_def[simplified]

definition unit_x :: "'a quasi_borel \<Rightarrow> (unit \<times> 'a) quasi_borel" (",_" [79] 79)where
"unit_x X \<equiv> unit_quasi_borel \<Otimes>\<^sub>Q X"

lemma hp_unit_context[simp] :
 ",X = unit_quasi_borel ,, X"
  by(simp add: unit_x_def hpprog_context_def)

definition hp_lift :: "['a \<Rightarrow> 'b, 'cont \<Rightarrow> 'a] \<Rightarrow> 'cont \<Rightarrow> 'b" where
"hp_lift f x \<equiv> (\<lambda>env. f (x env))"
definition hp_lift2 :: "['a \<Rightarrow> 'b \<Rightarrow> 'c, 'cont \<Rightarrow> 'a, 'cont \<Rightarrow> 'b] \<Rightarrow> 'cont \<Rightarrow> 'c" where
"hp_lift2 f x y \<equiv> (\<lambda>env. f (x env) (y env))"

declare hp_lift_def[simp]
declare hp_lift2_def[simp]

lemma hpt_addcont:
  assumes "t' = (\<lambda>(env,x). t env)"
      and "\<Gamma> \<turnstile>\<^sub>t t ;; T"
    shows "\<Gamma>,,X \<turnstile>\<^sub>t t' ;; T"
  using qbs_morphism_fst''[OF assms(2)[simplified hpprog_typing_def],of X]
  by(simp add: assms(1) hpprog_typing_def hpprog_context_def split_beta')

subsubsection \<open> Variables \<close>
definition var1 :: "'a \<times> 'b \<Rightarrow> 'b" where
"var1 \<equiv> snd"

definition var2 :: "('a \<times> 'b) \<times> 'c \<Rightarrow> 'b" where
"var2 \<equiv> snd \<circ> fst"

definition var3 :: "(('a \<times> 'b) \<times> 'c) \<times> 'd \<Rightarrow> 'b" where
"var3 \<equiv> snd \<circ> fst \<circ> fst"

definition var4 :: "((('a \<times> 'b) \<times> 'c) \<times> 'd) \<times> 'e \<Rightarrow> 'b" where
"var4 \<equiv> snd \<circ> fst \<circ> fst \<circ> fst"

definition var5 :: "(((('a \<times> 'b) \<times> 'c) \<times> 'd) \<times> 'e) \<times> 'f \<Rightarrow> 'b" where
"var5 \<equiv> snd \<circ> fst \<circ> fst \<circ> fst \<circ> fst"

definition var6 :: "((((('a \<times> 'b) \<times> 'c) \<times> 'd) \<times> 'e) \<times> 'f) \<times> 'g  \<Rightarrow> 'b" where
"var6 = snd \<circ> fst \<circ> fst \<circ> fst \<circ> fst \<circ> fst"

definition var7 :: "(((((('a \<times> 'b) \<times> 'c) \<times> 'd) \<times> 'e) \<times> 'f) \<times> 'g) \<times> 'h  \<Rightarrow> 'b" where
"var7 = snd \<circ> fst \<circ> fst \<circ> fst \<circ> fst \<circ> fst \<circ> fst"

lemma hpt_var1:
 "\<Gamma>,,Z  \<turnstile>\<^sub>t var1 ;; Z"
  using snd_qbs_morphism
  by(auto simp add: hpprog_typing_def hpprog_context_def var1_def)

lemma hpt_var2:
 "\<Gamma>,,Z,,Y \<turnstile>\<^sub>t var2 ;; Z"
  unfolding var2_def hpprog_typing_def hpprog_context_def
  using qbs_morphism_comp[OF fst_qbs_morphism snd_qbs_morphism]
  by auto

lemma hpt_var3:
 "\<Gamma>,,Z,,Y,,X \<turnstile>\<^sub>t var3 ;; Z"
  unfolding var3_def hpprog_typing_def hpprog_context_def
  using qbs_morphism_comp[OF fst_qbs_morphism qbs_morphism_comp[OF fst_qbs_morphism snd_qbs_morphism]]
  by auto

lemma hpt_var4:
 "\<Gamma>,,Z,,Y,,X,,W \<turnstile>\<^sub>t var4 ;; Z"
  unfolding var4_def hpprog_typing_def hpprog_context_def
  by (meson fst_qbs_morphism qbs_morphism_comp snd_qbs_morphism)

lemma hpt_var5:
 "\<Gamma>,,Z,,Y,,X,,W,,V \<turnstile>\<^sub>t var5 ;; Z"
  unfolding var5_def hpprog_typing_def hpprog_context_def
  by (meson fst_qbs_morphism qbs_morphism_comp snd_qbs_morphism)

lemma hpt_var6:
 "\<Gamma>,,Z,,Y,,X,,W,,V,,U \<turnstile>\<^sub>t var6 ;; Z"
  unfolding var6_def hpprog_typing_def hpprog_context_def
  by (meson fst_qbs_morphism qbs_morphism_comp snd_qbs_morphism)

lemma hpt_var7:
 "\<Gamma>,,Z,,Y,,X,,W,,V,,U,,T \<turnstile>\<^sub>t var7 ;; Z"
  unfolding var7_def hpprog_typing_def hpprog_context_def
  by (meson fst_qbs_morphism qbs_morphism_comp snd_qbs_morphism)

definition "hp_context \<equiv> fst"

subsubsection \<open> Constants \<close>
definition hp_const :: "'a \<Rightarrow> 'env \<Rightarrow> 'a" where
"hp_const k \<equiv> (\<lambda>env. k)"

(*
  --------------------
       \<Gamma> |- n : \<nat>     *)
lemma hpt_natc:
  "\<Gamma> \<turnstile>\<^sub>t (hp_const (n :: nat)) ;; \<nat>\<^sub>Q"
  using qbs_morphism_const[of n nat_quasi_borel \<Gamma>]
  by(simp add: hpprog_typing_def hp_const_def)

(*
  --------------------
      \<Gamma> |- r : \<real>     *)
lemma hpt_realc:
  "\<Gamma> \<turnstile>\<^sub>t (hp_const (r :: real)) ;; \<real>\<^sub>Q"
  using qbs_morphism_const[of r "\<real>\<^sub>Q" \<Gamma>]
  by(simp add: hpprog_typing_def hp_const_def)

(*
  ----------------------
      \<Gamma> |- r : ennreal *)
lemma hpt_ennrealc:
  "\<Gamma> \<turnstile>\<^sub>t (hp_const (r :: ennreal)) ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using qbs_morphism_const[of r ennreal_quasi_borel \<Gamma>]
  by(simp add: hpprog_typing_def hp_const_def)

(*
  ---------------------
      \<Gamma> |- () : unit  *)
lemma hpt_unitc:
  "\<Gamma> \<turnstile>\<^sub>t (hp_const ()) ;; unit_quasi_borel"
  using to_unit_quasi_borel_morphism[of \<Gamma>]
  by(simp add: hpprog_typing_def hp_const_def to_unit_quasi_borel_def)

definition "hp_constf \<equiv> hp_lift hp_const"
(*       \<Gamma> |- t : Y
   ----------------------(x \<notin> t)
     \<Gamma> |- \<lambda>x. t : X \<Rightarrow> Y       *)
lemma hpt_constf:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; Y"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_constf t ;; exp_qbs X Y"
proof -
  have 1:"case_prod (hp_constf t) = t \<circ> fst"
    by(auto simp add: hp_constf_def hp_const_def)
  have "case_prod (hp_constf t) \<in> \<Gamma> \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>QY"
    using qbs_morphism_comp[of fst "\<Gamma> \<Otimes>\<^sub>Q X" \<Gamma> t Y] assms fst_qbs_morphism[of \<Gamma> X]
    by(simp add: hpprog_typing_def 1)
  thus ?thesis
    using curry_preserves_morphisms[of "case_prod (hp_constf t)" \<Gamma> X Y]
    by(simp add: hpprog_typing_def)
qed

subsubsection \<open> Lambda Abstraction \<close>
definition hp_lambda ("\<lambda>\<^sub>t")
  where "hp_lambda \<equiv> curry"

(*   x : X, \<Gamma> |- t : T
   -----------------------
    \<Gamma> |- (\<lambda>x. t) : X \<Rightarrow> T *)
lemma hpt_abs:
  assumes "\<Gamma>,,X \<turnstile>\<^sub>t t ;; T"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_lambda t ;; X \<Rightarrow>\<^sub>Q T"
  using curry_preserves_morphisms[of t] assms
  by(simp add: hpprog_typing_def hpprog_context_def hp_lambda_def)

subsubsection \<open> Function Application \<close>
definition hp_app :: "['cont \<Rightarrow> 'a \<Rightarrow> 'b, 'cont \<Rightarrow> 'a] \<Rightarrow> 'cont \<Rightarrow> 'b" (infixr "$\<^sub>t" 1) where
"hp_app f x \<equiv> qbs_eval \<circ> (\<lambda>env. (f env,x env))"

(* \<Gamma> |- f : T1 \<Rightarrow> T2   \<Gamma> |- x : T1
   ---------------------------------
           \<Gamma> |- f x : T2            *)
lemma hpt_app:
  assumes "\<Gamma> \<turnstile>\<^sub>t f ;; (exp_qbs X Y)"
      and "\<Gamma> \<turnstile>\<^sub>t x ;; X"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_app f x ;; Y"
  unfolding hp_app_def hpprog_typing_def
  by(rule qbs_morphism_comp[OF qbs_morphism_tuple[OF assms[simplified hpprog_typing_def]] qbs_eval_morphism])

subsubsection \<open> Pair \<close>
definition "hp_pair \<equiv> hp_lift2 Pair"

(* \<Gamma> |- t1 : X    \<Gamma> |- t2 Y
  ---------------------------
     \<Gamma> |- (t1,t2) : X \<times> Y  *)
lemma hpt_pair:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; X"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; Y"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_pair t1 t2 ;; X \<Otimes>\<^sub>Q Y"
  using assms qbs_morphism_tuple[of t1 \<Gamma> X t2 Y]
  by(simp add: hpprog_typing_def hp_pair_def)

subsubsection \<open> Projections \<close>
definition "hp_fst \<equiv> hp_lift fst"
definition "hp_snd \<equiv> hp_lift snd"

(*  \<Gamma> |- s : X \<times> Y
  ------------------
    \<Gamma> |- fst s : X *)
lemma hpt_fst:
  assumes "\<Gamma> \<turnstile>\<^sub>t s ;; X \<Otimes>\<^sub>Q Y"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_fst s ;; X"
  using assms fst_qbs_morphism qbs_morphism_comp[of s \<Gamma> _ fst X]
  by(auto simp: hp_fst_def hpprog_typing_def o_def)

(*  \<Gamma> |- s : X \<times> Y
   ------------------
    \<Gamma> |- snd s : X  *)
lemma hpt_snd:
  assumes "\<Gamma> \<turnstile>\<^sub>t s ;; X \<Otimes>\<^sub>Q Y"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_snd s ;; Y"
  using assms snd_qbs_morphism qbs_morphism_comp[of s \<Gamma> "X \<Otimes>\<^sub>Q Y" snd Y]
  by(auto simp: hp_snd_def hpprog_typing_def o_def)

subsubsection \<open> Copair \<close>
definition "hp_inl \<equiv> hp_lift Inl"
definition "hp_inr \<equiv> hp_lift Inr"

(*      \<Gamma> |- t : X
   ---------------------
     \<Gamma> |- inl t : X + Y *)
lemma hpt_inl:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; X"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_inl t ;; X <+>\<^sub>Q Y"
  using assms Inl_qbs_morphism[of X Y] qbs_morphism_comp[of t \<Gamma> X Inl]
  by(auto simp: hp_inl_def hpprog_typing_def o_def)

(*      \<Gamma> |- t : X
   ---------------------
     \<Gamma> |- inr t : X + Y *)
lemma hpt_inr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; Y"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_inr t ;; X <+>\<^sub>Q Y"
  using assms qbs_morphism_comp[OF _ Inr_qbs_morphism[of Y X]]
  by(auto simp: hp_inr_def hpprog_typing_def comp_def)

subsubsection \<open> Cases \<close>
definition hp_case :: "[ 'cont \<Rightarrow> 'a + 'b, 'cont \<times> 'a \<Rightarrow> 'c, 'cont \<times> 'b \<Rightarrow> 'c] \<Rightarrow> 'cont \<Rightarrow> 'c" where
"hp_case t t1 t2 \<equiv> (\<lambda>env. case_sum (curry t1 env) (curry t2 env) (t env))"

(* \<Gamma> |- t : X + Y    x : X, \<Gamma> |- t1 : Z   y ; Y, \<Gamma> |- t2 : Z
   ------------------------------------------------------------
         \<Gamma> |- case t with
              | inl x \<Rightarrow> t1
              | inr y \<Rightarrow> t2 : Z                                 *)
lemma hpt_case:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; X <+>\<^sub>Q Y"
          "\<Gamma>,,X \<turnstile>\<^sub>t t1 ;; Z"
      and "\<Gamma>,,Y \<turnstile>\<^sub>t t2 ;; Z"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_case t t1 t2 ;; Z"
proof -
  have "(\<lambda>env. case_sum (curry t1 env) (curry t2 env) (t env)) = case_prod (case_prod case_sum) \<circ> (\<lambda>env. ((curry t1 env,curry t2 env),t env))"
    by auto
  also have "... \<in> \<Gamma> \<rightarrow>\<^sub>Q Z"
    using assms
    by(auto intro!: qbs_morphism_comp[where Y="(exp_qbs X Z \<Otimes>\<^sub>Q exp_qbs Y Z) \<Otimes>\<^sub>Q (X <+>\<^sub>Q Y)"] qbs_morphism_tuple curry_preserves_morphisms uncurry_preserves_morphisms case_sum_morphism
              simp: hpprog_typing_def hpprog_context_def)
  finally show ?thesis
    by(simp add: hp_case_def hpprog_typing_def)
qed

subsubsection \<open> List \<close>
abbreviation "list \<equiv> list_qbs"
definition hp_nil :: "'env \<Rightarrow> 'a list" ("[]\<^sub>t") where
"hp_nil \<equiv> hp_const []"

lemma hpt_nil:
 "\<Gamma> \<turnstile>\<^sub>t hp_nil ;; list X"
  unfolding hp_nil_def hpprog_typing_def hp_const_def
  by(auto intro!: qbs_morphismI qbs_closed2_dest simp: list_qbs_space)

definition hp_cons' :: "['env, 'a, 'a list] \<Rightarrow> 'a list" where
"hp_cons' \<equiv> hp_const Cons"

lemma hpt_cons':
 "\<Gamma> \<turnstile>\<^sub>t hp_cons' ;; exp_qbs X (exp_qbs (list X) (list X))"
  unfolding hpprog_typing_def hp_cons'_def hp_const_def
  by(rule qbs_morphism_const,simp add: cons_qbs_morphism)

definition "hp_cons hx hl \<equiv> hp_app (hp_app hp_cons' hx) hl"
lemma hpt_cons:
  assumes "\<Gamma> \<turnstile>\<^sub>t l ;; list X"
      and "\<Gamma> \<turnstile>\<^sub>t x ;; X"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_cons x l ;; list X"
  unfolding hp_cons_def
  apply(rule hpt_app)+
    apply(rule hpt_cons')
   apply fact+
  done

syntax
  "_hp_list" :: "args => 'env \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)"    ("[(_)]\<^sub>t")

translations
  "[x, xs]\<^sub>t" == "CONST hp_cons x [xs]\<^sub>t"
  "[x]\<^sub>t" == "CONST hp_cons x []\<^sub>t"

lemma
  "\<Gamma>,,\<real>\<^sub>Q,,\<real>\<^sub>Q \<turnstile>\<^sub>t [var1, hp_const 1, var2]\<^sub>t ;; list \<real>\<^sub>Q"
  apply(rule hpt_cons)+
     apply(rule hpt_nil)
    apply(rule hpt_var2)
   apply(rule hpt_realc)
  apply(rule hpt_var1)
  done

subsubsection \<open> Return \<close>
definition hp_return :: "[ 'a quasi_borel,'cont \<Rightarrow> 'a] \<Rightarrow> 'cont \<Rightarrow> 'a qbs_prob_space" where
"hp_return X t \<equiv> (\<lambda>env. qbs_return X (t env))"

(*        \<Gamma> |- t : T
   -------------------------
      \<Gamma> |- return T t : P T *)
lemma hpt_return:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; T"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_return T t ;; (monadP_qbs T)"
  using assms qbs_return_morphism[of T] qbs_morphism_comp[of t \<Gamma> T "qbs_return T" "monadP_qbs T"]
  by(simp add: hpprog_typing_def o_def hp_return_def)

subsubsection \<open> Bind \<close>
definition hp_bind (infixl "\<bind>\<^sub>t" 54) where "hp_bind \<equiv> hp_lift2 qbs_bind"

adhoc_overloading Monad_Syntax.bind hp_bind

(*  \<Gamma> |- s : P T1     \<Gamma> |- f : T1 \<Rightarrow> P T2
    --------------------------------------
           \<Gamma> |- s \<bind> f : P T2            *)
lemma hpt_bind:
 assumes "\<Gamma> \<turnstile>\<^sub>t s ;; (monadP_qbs T1)"
     and "\<Gamma> \<turnstile>\<^sub>t f ;; (exp_qbs T1 (monadP_qbs T2))"
    shows "\<Gamma> \<turnstile>\<^sub>t s \<bind>\<^sub>t f ;; (monadP_qbs T2)"
  using qbs_bind_morphism[of s \<Gamma> T1] assms
  by (simp add: hpprog_typing_def hp_bind_def)

subsubsection \<open> Normal Distribution \<close>
definition "hp_normal' \<equiv> hp_const qbs_normal_distribution"
definition "hp_normal \<equiv> (\<lambda>\<mu> \<sigma>. hp_app (hp_app hp_normal' \<mu>) \<sigma>)"
lemma hpt_normal':
  "\<Gamma> \<turnstile>\<^sub>t hp_normal' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q))"
  using qbs_morphism_const[of qbs_normal_distribution "exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q))" \<Gamma>]
  by(simp add: hp_normal'_def hpprog_typing_def hp_const_def qbs_normal_distribution_morphism)

lemma hpt_normal:
  assumes "\<Gamma> \<turnstile>\<^sub>t \<mu> ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t \<sigma> ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_normal \<mu> \<sigma> ;; monadP_qbs \<real>\<^sub>Q"
  unfolding hp_normal_def
  apply(rule hpt_app,rule hpt_app,rule hpt_normal')
  by fact+

subsubsection \<open> Uniform Distribution \<close>
definition "hp_uniform' \<equiv> hp_const qbs_interval_uniform_distribution"
definition "hp_uniform \<equiv> (\<lambda>a b. hp_app (hp_app hp_uniform' a) b)"
lemma hpt_uniform':
  "\<Gamma> \<turnstile>\<^sub>t hp_uniform' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q))"
  unfolding hp_uniform'_def hp_const_def hpprog_typing_def
  using qbs_morphism_const[of qbs_interval_uniform_distribution "exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q))" \<Gamma>] qbs_interval_uniform_distribution_morphism
  by simp

lemma hpt_uniform:
  assumes "\<Gamma> \<turnstile>\<^sub>t a ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t b ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_uniform a b ;; monadP_qbs \<real>\<^sub>Q"
  unfolding hp_uniform_def
  apply(rule hpt_app,rule hpt_app,rule hpt_uniform')
  by fact+

subsubsection \<open>Bernoulli Distribution\<close>
definition "hp_bernoulli' \<equiv> hp_const qbs_bernoulli"
definition "hp_bernoulli \<equiv> (\<lambda>x. hp_app hp_bernoulli' x)"
lemma hpt_bernoulli':
  "\<Gamma> \<turnstile>\<^sub>t hp_bernoulli' ;; exp_qbs \<real>\<^sub>Q (monadP_qbs \<bool>\<^sub>Q)"
  using qbs_morphism_const[of qbs_bernoulli " exp_qbs \<real>\<^sub>Q (monadP_qbs \<bool>\<^sub>Q)"]
  by(auto simp add: hp_bernoulli'_def hpprog_typing_def hp_const_def qbs_bernoulli_morphism)

lemma hpt_bernoulli:
  assumes "\<Gamma> \<turnstile>\<^sub>t r ;; \<real>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_bernoulli r ;; monadP_qbs \<bool>\<^sub>Q"
  unfolding hp_bernoulli_def
  by(rule hpt_app,rule hpt_bernoulli',fact)

subsubsection \<open> Numeral Functions \<close>

definition "hp_suc' \<equiv> hp_const Suc"
definition "hp_suc \<equiv> hp_app hp_suc'"

definition "hp_real' \<equiv> hp_const real"
definition "hp_real \<equiv> hp_app hp_real'"

definition "hp_enn2real' \<equiv> hp_const enn2real"
definition "hp_enn2real \<equiv> hp_app hp_enn2real'"

definition "hp_abs' \<equiv> hp_const abs"
definition hp_abs :: "('cont \<Rightarrow> 'b::abs) \<Rightarrow> 'cont \<Rightarrow> 'b" ("\<bar>_\<bar>\<^sub>t") where
"hp_abs \<equiv> hp_app hp_abs'"

definition "hp_ennreal' \<equiv> hp_const ennreal"
definition "hp_ennreal \<equiv> hp_app hp_ennreal'"

consts
  hp_plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+\<^sub>t" 65)
consts
  hp_minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "-\<^sub>t" 65)
consts
  hp_uminus :: "'a \<Rightarrow> 'a"  ("-\<^sub>t _" [81] 80)
consts
  hp_times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*\<^sub>t" 70)
consts
  hp_div :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/\<^sub>t" 70)

definition "hp_plus'' \<equiv> hp_const plus"
definition "hp_plus' x y \<equiv> (hp_app (hp_app hp_plus'' x) y)"

definition "hp_minus'' \<equiv> hp_const minus"
definition "hp_minus' x y \<equiv> (hp_app (hp_app hp_minus'' x) y)"

definition "hp_uminus'' \<equiv> hp_const uminus"
definition "hp_uminus' \<equiv> hp_app hp_uminus''"

definition "hp_times'' \<equiv> hp_const times"
definition "hp_times' x y \<equiv> hp_app (hp_app hp_times'' x) y"

definition "hp_div'' \<equiv> hp_const inverse_divide"
definition "hp_div' x y \<equiv> hp_app (hp_app hp_div'' x) y"

definition "hp_power'' \<equiv> hp_const power"

fun hp_power' :: "['env \<Rightarrow> ('a :: monoid_mult), nat] \<Rightarrow> 'env \<Rightarrow> 'a" (infixr "^\<^sup>t" 80) where
"hp_power' hn 0       = hp_const 1" |
"hp_power' hn (Suc n) = hp_times' hn (hp_power' hn n)"

definition "hp_funplus' \<equiv> hp_lift2 hp_plus'"
definition "hp_funtimes' \<equiv> hp_lift2 hp_times'"
definition "hp_fundiv' \<equiv> hp_lift2 hp_div'"

adhoc_overloading hp_plus hp_plus'
adhoc_overloading hp_plus hp_funplus'
adhoc_overloading hp_minus hp_minus'
adhoc_overloading hp_uminus hp_uminus'
adhoc_overloading hp_times hp_times'
adhoc_overloading hp_times hp_funtimes'
adhoc_overloading hp_div hp_div'
adhoc_overloading hp_div hp_fundiv'

lemma hp_power_one:
 "t^\<^sup>t1 = t"
  by(simp add: hp_times'_def hp_const_def hp_app_def qbs_eval_def hp_times''_def comp_def)

lemma hp_power_square:
 "t^\<^sup>t2 = t *\<^sub>t t"
  by(simp add: hp_times'_def numeral_2_eq_2 hp_const_def  hp_app_def qbs_eval_def hp_times''_def comp_def)

lemma hpt_suc':
  "\<Gamma> \<turnstile>\<^sub>t hp_suc' ;; exp_qbs \<nat>\<^sub>Q \<nat>\<^sub>Q"
  unfolding hp_suc'_def hpprog_typing_def hp_const_def
  by(rule qbs_morphism_const,simp add: nat_qbs_morphism)

lemma hpt_suc:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<nat>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_suc t ;; \<nat>\<^sub>Q"
  unfolding hp_suc_def
  by(rule hpt_app,rule hpt_suc',fact)

lemma hpt_plusn':
 "\<Gamma> \<turnstile>\<^sub>t hp_plus'' ;; exp_qbs \<nat>\<^sub>Q (exp_qbs \<nat>\<^sub>Q \<nat>\<^sub>Q)"
  unfolding hp_plus''_def hpprog_typing_def hp_const_def
  apply(rule qbs_morphism_const,simp)
  apply(rule nat_qbs_morphism,simp)
  apply(rule nat_qbs_morphism,simp)
  done

lemma hpt_plusn:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 +\<^sub>t t2 ;; \<nat>\<^sub>Q"
  unfolding hp_plus'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_plusn')
  by fact+

lemma hpt_minusn':
 "\<Gamma> \<turnstile>\<^sub>t hp_minus'' ;; exp_qbs \<nat>\<^sub>Q (exp_qbs \<nat>\<^sub>Q \<nat>\<^sub>Q)"
  unfolding hp_minus''_def hpprog_typing_def hp_const_def
  apply(rule qbs_morphism_const,simp)
  apply(rule nat_qbs_morphism,simp)
  apply(rule nat_qbs_morphism,simp)
  done

lemma hpt_minusn:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 -\<^sub>t t2 ;; \<nat>\<^sub>Q"
  unfolding hp_minus'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_minusn')
  by fact+

lemma hpt_timesn':
 "\<Gamma> \<turnstile>\<^sub>t hp_times'' ;; exp_qbs \<nat>\<^sub>Q (exp_qbs \<nat>\<^sub>Q \<nat>\<^sub>Q)"
  unfolding hp_times''_def hpprog_typing_def hp_const_def
  apply(rule qbs_morphism_const,simp)
  apply(rule nat_qbs_morphism,simp)
  apply(rule nat_qbs_morphism,simp)
  done

lemma hpt_timesn:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 *\<^sub>t t2 ;; \<nat>\<^sub>Q"
  unfolding hp_times'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_timesn')
  by fact+

lemma hpt_powern:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<nat>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t t^\<^sup>t n ;; \<nat>\<^sub>Q"
  by(induction n; simp add: hpt_natc hpt_timesn assms)

lemma hpt_real':
 "\<Gamma> \<turnstile>\<^sub>t hp_real' ;; exp_qbs \<nat>\<^sub>Q \<real>\<^sub>Q"
  unfolding hp_real'_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule nat_qbs_morphism,simp)
  done

lemma hpt_real:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<nat>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_real t ;; \<real>\<^sub>Q"
  unfolding hp_real_def
  apply(rule hpt_app,rule hpt_real')
  by fact

lemma hpt_ennreal':
 "\<Gamma> \<turnstile>\<^sub>t hp_ennreal' ;; exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_ennreal'_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const)
  by auto

lemma hpt_ennreal:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_ennreal t ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_ennreal_def
  apply(rule hpt_app,rule hpt_ennreal')
  by fact

lemma hpt_absr':
 "\<Gamma> \<turnstile>\<^sub>t hp_abs' ;; exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q"
  unfolding hp_abs'_def hpprog_typing_def hp_const_def
  apply(rule qbs_morphism_const)
  by auto

lemma hpt_absr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t \<bar>t\<bar>\<^sub>t ;; \<real>\<^sub>Q"
  unfolding hp_abs_def
  apply(rule hpt_app,rule hpt_absr')
  by fact

lemma hpt_plusr':
  "\<Gamma> \<turnstile>\<^sub>t hp_plus'' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)"
  unfolding hp_plus''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (+)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_plusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 +\<^sub>t t2 ;; \<real>\<^sub>Q"
  unfolding hp_plus'_def
  apply(rule hpt_app,rule hpt_app, rule hpt_plusr')
  by fact+

lemma hpt_minusr':
  "\<Gamma> \<turnstile>\<^sub>t hp_minus'' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)"
  unfolding hp_minus''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (-)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_minusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 -\<^sub>t t2 ;; \<real>\<^sub>Q"
  unfolding hp_minus'_def
  apply(rule hpt_app,rule hpt_app, rule hpt_minusr')
  by fact+

lemma hpt_uminusr':
  "\<Gamma> \<turnstile>\<^sub>t hp_uminus'' ;; exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q"
  unfolding hp_uminus''_def hpprog_typing_def hp_const_def
  apply(rule qbs_morphism_const)
  by auto

lemma hp_uminusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q"
  shows"\<Gamma> \<turnstile>\<^sub>t -\<^sub>t t ;; \<real>\<^sub>Q"
  unfolding hp_uminus'_def
  apply(rule hpt_app,rule hpt_uminusr')
  by fact

lemma hpt_timesr':
  "\<Gamma> \<turnstile>\<^sub>t hp_times'' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)"
  unfolding hp_times''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (*)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_timesr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 *\<^sub>t t2 ;; \<real>\<^sub>Q"
  unfolding hp_times'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_timesr')
  by fact+

lemma hpt_divr':
  "\<Gamma> \<turnstile>\<^sub>t hp_div'' ;; exp_qbs \<real>\<^sub>Q (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)"
  unfolding hp_div''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (/)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_divr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 /\<^sub>t t2 ;; \<real>\<^sub>Q"
  unfolding hp_div'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_divr')
  by fact+

lemma hpt_powerr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t t^\<^sup>tn ;; \<real>\<^sub>Q"
  by(induction n; simp add: hpt_realc assms hpt_timesr)

lemma hpt_enn2real':
  "\<Gamma> \<turnstile>\<^sub>t hp_enn2real' ;; exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<real>\<^sub>Q"
  unfolding hpprog_typing_def hp_enn2real'_def hp_const_def
  apply(rule qbs_morphism_const)
  by auto

lemma hpt_enn2real:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "\<Gamma> \<turnstile>\<^sub>t hp_enn2real t ;; \<real>\<^sub>Q"
  unfolding hp_enn2real_def
  apply(rule hpt_app,rule hpt_enn2real')
  by fact

interpretation ennreal_ennreal : pair_standard_borel_space_UNIV ennreal_borel ennreal_borel
  by standard

lemma hpt_plusennr':
  "\<Gamma> \<turnstile>\<^sub>t hp_plus'' ;; exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 (exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"
  unfolding hp_plus''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (+)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_plusennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 +\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_plus'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_plusennr')
  by fact+

lemma hpt_minusennr':
  "\<Gamma> \<turnstile>\<^sub>t hp_minus'' ;; exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 (exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"
  unfolding hp_minus''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (-)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_minusennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 -\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_minus'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_minusennr')
  by fact+

lemma hpt_timesennr':
  "\<Gamma> \<turnstile>\<^sub>t hp_times'' ;; exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 (exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"
  unfolding hp_times''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (*)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_timesennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 *\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_times'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_timesennr')
  by fact+

lemma hpt_divennr':
  "\<Gamma> \<turnstile>\<^sub>t hp_div'' ;; exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 (exp_qbs \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"
  unfolding hp_div''_def hp_const_def hpprog_typing_def
  apply(rule qbs_morphism_const,simp)
  apply(rule curry_preserves_morphisms[where f="case_prod (/)",simplified curry_def split_beta',simplified])
  by auto

lemma hpt_divennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t1 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t t1 /\<^sub>t t2 ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  unfolding hp_div'_def
  apply(rule hpt_app,rule hpt_app,rule hpt_divennr')
  by fact+

lemma hpt_powerennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "\<Gamma> \<turnstile>\<^sub>t t^\<^sup>tn ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  by(induction n; simp add: hpt_ennrealc assms hpt_timesennr)

lemma hpt_function:
  assumes "\<And>(\<Gamma>::('a \<times> 'b) quasi_borel) t1 t2.
      (\<Gamma> \<turnstile>\<^sub>t t1 ;; T) \<Longrightarrow> (\<Gamma> \<turnstile>\<^sub>t t2 ;; T) \<Longrightarrow> (\<Gamma> \<turnstile>\<^sub>t hp_lift2 f t1 t2 ;; T)"
          "(\<Gamma>::'a quasi_borel) \<turnstile>\<^sub>t f1 ;; exp_qbs (K:: 'b quasi_borel) T "
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs K T"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_lift2 (hp_lift2 f) f1 f2 ;; exp_qbs K T"
  using assms
proof -
  have "\<Gamma>,,K  \<turnstile>\<^sub>t (\<lambda>(l,k). f1 l k) ;; T"
       "\<Gamma>,,K  \<turnstile>\<^sub>t (\<lambda>(l,k). f2 l k) ;; T"
    using assms(2,3) uncurry_preserves_morphisms[of f1 \<Gamma> K T] uncurry_preserves_morphisms[of f2 \<Gamma> K T]
    by(auto simp add: hpprog_typing_def hpprog_context_def)
  hence "\<Gamma>,,K \<turnstile>\<^sub>t hp_lift2 f (\<lambda>(l,k). f1 l k) (\<lambda>(l,k). f2 l k) ;; T"
    using assms(1)[of "\<Gamma>,,K"] by simp
  hence "\<Gamma> \<turnstile>\<^sub>t curry (hp_lift2 f (\<lambda>(l,k). f1 l k) (\<lambda>(l,k). f2 l k)) ;; exp_qbs K T"
    using curry_preserves_morphisms[of _ \<Gamma> K T]
    by(simp add: hpprog_typing_def hpprog_context_def)
  moreover have "curry (hp_lift2 f (\<lambda>(l,k). f1 l k) (\<lambda>(l,k). f2 l k)) = hp_lift2 (hp_lift2 f) f1 f2"
    by(rule ext,auto)
  ultimately show ?thesis by simp
qed

lemma hpt_funplusn:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 +\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
  using hpt_function[OF _ assms] hpt_plusn
  by(auto simp add: hp_funplus'_def hp_plus'_def hp_plus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funplusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 +\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2)] hpt_plusr
  by(auto simp add: hp_funplus'_def hp_plus'_def hp_plus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funplusennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 +\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using hpt_function[OF _ assms(1) assms(2)] hpt_plusennr
  by(auto simp add: hp_funplus'_def hp_plus'_def hp_plus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funminusn:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 -\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2),of minus] hpt_minusn
  by(auto simp add: hp_minus'_def fun_diff_def hp_minus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funminusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 -\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2)] hpt_minusr
  by(auto simp add: hp_minus'_def fun_diff_def hp_minus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funuminusr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f ;; exp_qbs T \<real>\<^sub>Q"
  shows "\<Gamma> \<turnstile>\<^sub>t -\<^sub>t f ;; exp_qbs T \<real>\<^sub>Q"
proof -
  have "(\<lambda>z. f (fst z) (snd z)) \<in> borel_measurable (qbs_to_measure (\<Gamma> \<Otimes>\<^sub>Q T))"
    using uncurry_preserves_morphisms[OF assms[simplified hpprog_typing_def]]
    by(auto simp: case_prod_beta')
  hence "(\<lambda>z. - f (fst z) (snd z)) \<in> borel_measurable (qbs_to_measure (\<Gamma> \<Otimes>\<^sub>Q T))"
    by simp
  hence "(\<lambda>z. - f (fst z) (snd z)) \<in> \<Gamma> \<Otimes>\<^sub>Q T \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    by auto
  thus ?thesis
    using curry_preserves_morphisms[of "\<lambda>z. - f (fst z) (snd z)" \<Gamma> T "\<real>\<^sub>Q",simplified curry_def,simplified]
    by(simp add: hpprog_typing_def hp_uminus'_def fun_Compl_def hp_uminus''_def hp_const_def hp_app_def qbs_eval_def comp_def)
qed

lemma hpt_funminusennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 -\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using hpt_function[OF _ assms(1) assms(2)] hpt_minusennr
  by(auto simp add: hp_minus'_def fun_diff_def hp_minus''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funtimesn:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<nat>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 *\<^sub>t f2 ;; exp_qbs T \<nat>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2)] hpt_timesn
  by(auto simp add: hp_funtimes'_def hp_times'_def hp_times''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funtimesr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 *\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2)] hpt_timesr
  by(auto simp add: hp_funtimes'_def hp_times'_def hp_times''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_funtimesennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 *\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using hpt_function[OF _ assms(1) assms(2)] hpt_timesennr
  by(auto simp add: hp_funtimes'_def hp_times'_def hp_times''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_fundivr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 /\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q"
  using hpt_function[OF _ assms(1) assms(2)] hpt_divr
  by(auto simp add: hp_fundiv'_def hp_div'_def hp_div''_def hp_const_def hp_app_def qbs_eval_def comp_def)

lemma hpt_fundivennr:
  assumes "\<Gamma> \<turnstile>\<^sub>t f1 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "\<Gamma> \<turnstile>\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t f1 /\<^sub>t f2 ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using hpt_function[OF _ assms(1) assms(2)] hpt_divennr
  by(auto simp add: hp_fundiv'_def hp_div'_def hp_div''_def hp_const_def hp_app_def qbs_eval_def comp_def)

subsubsection \<open> Primitive Recursive Functions \<close>

definition "hp_rec_nat \<equiv> hp_lift2 rec_nat"

lemma hp_rec_nat_simp:
 "hp_rec_nat t0 f k 0       = t0 k"
 "hp_rec_nat t0 f k (Suc n) = f k n (hp_rec_nat t0 f k n)"
  by(auto simp add: hp_rec_nat_def)

lemma hp_rec_nat_simp':
 "hp_app (hp_rec_nat t0 f) (hp_const 0) = t0"
 "hp_app (hp_rec_nat t0 f) (hp_suc e) = hp_app (hp_app f e) (hp_app (hp_rec_nat t0 f) e) "
  by(auto simp add: hp_app_def hp_rec_nat_def hp_const_def qbs_eval_def hp_suc_def hp_suc'_def)

(* \<Gamma> |- t0 : T     \<Gamma> |- f : \<nat> \<Rightarrow> T \<Rightarrow> T
   ---------------------------------------
          \<Gamma> |- rec t0 f : \<nat> \<Rightarrow> T          *)
lemma hpt_recnat:
  assumes "\<Gamma>  \<turnstile>\<^sub>t t0 ;; T"
      and "\<Gamma>  \<turnstile>\<^sub>t f ;; (exp_qbs \<nat>\<^sub>Q (exp_qbs T T))"
    shows "\<Gamma>  \<turnstile>\<^sub>t hp_rec_nat t0 f ;; (exp_qbs \<nat>\<^sub>Q T)"
  unfolding hpprog_typing_def
proof(rule arg_swap_morphism,rule nat_qbs_morphism,auto)
  fix n
  show "(\<lambda>y. hp_rec_nat t0 f y n) \<in> \<Gamma> \<rightarrow>\<^sub>Q T"
    unfolding hp_rec_nat_def hp_lift2_def
  proof(induction n)
    case 0
    then show ?case
      using assms(1) by(simp add: hpprog_typing_def)
  next
    case ih:(Suc n')
    have "(\<lambda>y. f y n' (rec_nat (t0 y) (f y) n')) = case_prod (case_prod f) \<circ> (\<lambda>y. ((y,n'),rec_nat (t0 y) (f y) n'))"
      by auto
    also have "... \<in> \<Gamma> \<rightarrow>\<^sub>Q T"
      apply(rule qbs_morphism_comp[of _ _ "(\<Gamma> \<Otimes>\<^sub>Q \<nat>\<^sub>Q) \<Otimes>\<^sub>Q T"],rule qbs_morphism_tuple,rule qbs_morphism_tuple)
      using qbs_morphism_ident[of \<Gamma>] qbs_morphism_const[of n' "\<nat>\<^sub>Q"] ih uncurry_preserves_morphisms[of f \<Gamma>] uncurry_preserves_morphisms[of "case_prod f"] assms(2)
         by(auto simp add: id_def hpprog_typing_def)
    finally show ?case by simp
  qed
qed

lemma hpt_recnat':
  assumes "\<Gamma>  \<turnstile>\<^sub>t t0 ;; T"
      and "\<Gamma> ,, \<nat>\<^sub>Q,, T \<turnstile>\<^sub>t e ;; T"
    shows "\<Gamma>  \<turnstile>\<^sub>t hp_rec_nat t0 (hp_lambda (hp_lambda e)) ;; (exp_qbs \<nat>\<^sub>Q T)"
  by(rule hpt_recnat[OF assms(1) hpt_abs[OF hpt_abs[OF assms(2)]]])

definition "hp_rec_list \<equiv> hp_lift2 rec_list"

(*  \<Gamma> |- t0 : T     \<Gamma> |- f : X \<Rightarrow> list X \<Rightarrow> T \<Rightarrow> T
   ---------------------------------------
          \<Gamma> |- rec t0 f : list X \<Rightarrow> T          *)
lemma hpt_reclist:
  assumes "\<Gamma>  \<turnstile>\<^sub>t t0 ;; T"
      and "\<Gamma>  \<turnstile>\<^sub>t f ;; (exp_qbs X (exp_qbs (list X) (exp_qbs T T)))"
    shows "\<Gamma>  \<turnstile>\<^sub>t hp_rec_list t0 f ;; (exp_qbs (list X) T)"
  unfolding hpprog_typing_def hp_rec_list_def
  by(auto intro!: qbs_morphism_comp[OF qbs_morphism_tuple[OF assms(1)[simplified hpprog_typing_def] assms(2)[simplified hpprog_typing_def]],of "case_prod rec_list",simplified comp_def split_beta fst_conv snd_conv] uncurry_preserves_morphisms rec_list_morphism[simplified])

lemma hpt_reclist':
  assumes "\<Gamma>  \<turnstile>\<^sub>t t0 ;; T"
      and "\<Gamma> ,, X ,, list X ,, T \<turnstile>\<^sub>t e ;; T"
    shows "\<Gamma>  \<turnstile>\<^sub>t hp_rec_list t0 (hp_lambda (hp_lambda (hp_lambda e))) ;; (exp_qbs (list X) T)"
  by(rule hpt_reclist[OF assms(1) hpt_abs[OF hpt_abs[OF hpt_abs[OF assms(2)]]]])

subsubsection \<open> Ennriched Expressions \<close>
definition "hp_integrable \<equiv> hp_lift2 qbs_integrable"
definition "hp_expect \<equiv> hp_lift2 qbs_prob_integral"
definition "hp_ennexpect \<equiv> hp_lift2 qbs_prob_ennintegral"
definition "hp_var \<equiv> hp_lift2 qbs_prob_var"
term hp_powerr
lemma hp_var_def2:
  "hp_var t e = hp_expect t ( (e -\<^sub>t hp_constf (hp_expect t e)) *\<^sub>t (e -\<^sub>t hp_constf (hp_expect t e)))"
  by(simp add: hp_var_def hp_expect_def hp_constf_def hp_funtimes'_def qbs_prob_var_def power2_eq_square hp_const_def hp_times'_def hp_minus'_def hp_app_def hp_times''_def hp_minus''_def qbs_eval_def comp_def)

(* \<Gamma> |- m : P T    \<Gamma> |- f : T \<Rightarrow> ennreal
   ---------------------------------------
         \<Gamma> |- E_x~m [f x] : ennreal      *)
lemma hpt_ennexpect:
  assumes "\<Gamma> \<turnstile>\<^sub>t m ;; monadP_qbs T"
      and "\<Gamma> \<turnstile>\<^sub>t f ;; exp_qbs T \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_ennexpect m f ;; \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  using qbs_prob_ennintegral_morphism[OF assms(1)[simplified hpprog_typing_def] assms(2)[simplified hpprog_typing_def]]
  by(simp add: hpprog_typing_def hp_ennexpect_def)

(* \<Gamma> |- m : P T    \<Gamma> |- f : T \<Rightarrow> \<real>    f : integrable w.r.t. m
   -----------------------------------------------------------
                 \<Gamma> |- E_x~m [f x] : \<real>                         *)
lemma hpt_expect:
  assumes "\<Gamma> \<turnstile>\<^sub>t m ;; monadP_qbs T"
          "\<Gamma> \<turnstile>\<^sub>t f ;; exp_qbs T \<real>\<^sub>Q"
      and "\<And>x. x \<in> qbs_space \<Gamma> \<Longrightarrow> hp_integrable m f x"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_expect m f ;; \<real>\<^sub>Q"
  using qbs_prob_integral_morphism[OF assms(1)[simplified hpprog_typing_def] assms(2)[simplified hpprog_typing_def]] assms(3)
  by(simp add: hpprog_typing_def hp_expect_def hp_integrable_def)

subsubsection \<open> Product Measure \<close>
definition hp_pair_measure (infixr "\<Otimes>\<^sub>Q\<^sub>t" 80) where
"hp_pair_measure \<equiv> hp_lift2 qbs_prob_pair_measure"

lemma hpt_pair_measure:
  assumes "\<Gamma> \<turnstile>\<^sub>t m ;; monadP_qbs M"
      and "\<Gamma> \<turnstile>\<^sub>t n ;; monadP_qbs N"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_pair_measure m n ;; monadP_qbs (M \<Otimes>\<^sub>Q N)"
  using qbs_morphism_comp[OF qbs_morphism_tuple[OF assms[simplified hpprog_typing_def]] qbs_prob_pair_measure_morphism]
  by(simp add: hpprog_typing_def comp_def hp_pair_measure_def)

definition "hp_id \<equiv> hp_const id"
lemma hpt_id:
 "\<Gamma> \<turnstile>\<^sub>t hp_id ;; exp_qbs X X"
  unfolding hpprog_typing_def hp_id_def hp_const_def
  by(rule qbs_morphism_const[of _ "exp_qbs X X",simplified,OF qbs_morphism_ident])

definition "hp_comp \<equiv> hp_lift2 comp"
lemma hpt_comp:
  assumes "\<Gamma> \<turnstile>\<^sub>t f ;; exp_qbs X Y"
      and "\<Gamma> \<turnstile>\<^sub>t g ;; exp_qbs Y Z"
    shows "\<Gamma> \<turnstile>\<^sub>t hp_comp g f ;; exp_qbs X Z"
  using exp_qbs_comp_morphism[of f \<Gamma> X Y g Z] assms
  by(simp add: hpprog_typing_def hp_comp_def)

text \<open> The followings are examples. \<close>
lemma "\<Gamma>,, Y \<turnstile>\<^sub>t \<lambda>\<^sub>t var1 $\<^sub>t var1 ;; Y"
  apply(rule hpt_app)
   apply(rule hpt_abs)
   apply(rule hpt_var1)
  apply(rule hpt_var1)
  done

lemma "\<Gamma> \<turnstile>\<^sub>t \<lambda>\<^sub>t (\<lambda>\<^sub>t (hp_normal var2 var1)) ;; \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q \<Rightarrow>\<^sub>Q P\<^sub>t \<real>\<^sub>Q"
  apply(rule hpt_abs)
  apply(rule hpt_abs)
  apply(rule hpt_normal)
   apply(rule hpt_var2)
  apply(rule hpt_var1)
  done

end


theory Natpartial_Nat
imports "$HETS_LIB/Isabelle/MainHCPairs" "Primes" "Parity"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"ga_function_monotonicity\", \"ga_function_monotonicity_1\",
     \"ga_function_monotonicity_2\", \"ga_function_monotonicity_3\",
     \"ga_function_monotonicity_4\", \"ga_function_monotonicity_5\",
     \"ga_embedding_injectivity\", \"ga_projection_injectivity\",
     \"ga_projection\", \"ga_selector_pre\", \"ga_injective_suc\",
     \"ga_disjoint_0_suc\", \"ga_selector_undef_pre_0\", \"X1_def_Nat\",
     \"X2_def_Nat\", \"X3_def_Nat\", \"X4_def_Nat\", \"X5_def_Nat\",
     \"X6_def_Nat\", \"X7_def_Nat\", \"X8_def_Nat\", \"X9_def_Nat\",
     \"decimal_def\", \"ga_comm___XPlus__\", \"ga_assoc___XPlus__\",
     \"ga_right_unit___XPlus__\", \"ga_left_unit___XPlus__\",
     \"ga_left_comm___XPlus__\", \"ga_comm___Xx__\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"ga_left_comm___Xx__\", \"ga_comm_min\",
     \"ga_assoc_min\", \"ga_left_comm_min\", \"ga_comm_max\",
     \"ga_assoc_max\", \"ga_right_unit_max\", \"ga_left_unit_max\",
     \"ga_left_comm_max\", \"leq_def1_Nat\", \"dvd_def_Nat\",
     \"leq_def2_Nat\", \"leq_def3_Nat\", \"geq_def_Nat\",
     \"less_def_Nat\", \"greater_def_Nat\", \"even_0_Nat\",
     \"even_suc_Nat\", \"odd_def_Nat\", \"factorial_0\",
     \"factorial_suc\", \"add_0_Nat\", \"add_suc_Nat\", \"mult_0_Nat\",
     \"mult_suc_Nat\", \"power_0_Nat\", \"power_suc_Nat\",
     \"min_def_Nat\", \"max_def_Nat\", \"subTotal_def1_Nat\",
     \"subTotal_def2_Nat\", \"sub_dom_Nat\", \"sub_def_Nat\",
     \"divide_dom_Nat\", \"divide_0_Nat\", \"divide_Pos_Nat\",
     \"div_dom_Nat\", \"div_Nat\", \"mod_dom_Nat\", \"mod_Nat\",
     \"distr1_Nat\", \"distr2_Nat\", \"Pos_def\", \"X1_as_Pos_def\",
     \"min_0\", \"div_mod_Nat\", \"power_Nat\", \"Ax1\", \"Ax2\",
     \"Ax3\", \"Ax4\", \"Ax5\"]"

typedecl Pos

datatype X_Nat = X0 ("0''") | sucX1 "X_Nat" ("suc''/'(_')" [3] 999)

consts
X1X1 :: "X_Nat" ("1''")
X1X2 :: "Pos" ("1''''")
X2 :: "X_Nat" ("2''")
X3 :: "X_Nat" ("3''")
X4 :: "X_Nat" ("4''")
X5 :: "X_Nat" ("5''")
X6 :: "X_Nat" ("6''")
X7 :: "X_Nat" ("7''")
X8 :: "X_Nat" ("8''")
X9 :: "X_Nat" ("9''")
X__XAtXAt__X :: "X_Nat => X_Nat => X_Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__X :: "X_Nat => X_Nat => X_Nat" ("(_/ ^''/ _)" [54,54] 52)
X__XExclam :: "X_Nat => X_Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__X :: "X_Nat => X_Nat => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "X_Nat => X_Nat => bool" ("(_/ >''/ _)" [44,44] 42)
X__XLtXEq__X :: "X_Nat => X_Nat => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "X_Nat => X_Nat => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinusXExclam__X :: "X_Nat => X_Nat => X_Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ -?/ _)" [54,54] 52)
X__XPlus__XX1 :: "X_Nat => X_Nat => X_Nat" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "X_Nat => Pos => Pos" ("(_/ +''''/ _)" [54,54] 52)
X__XPlus__XX3 :: "Pos => X_Nat => Pos" ("(_/ +'_3/ _)" [54,54] 52)
X__XSlashXQuest__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ '/?/ _)" [54,54] 52)
X__Xx__XX1 :: "X_Nat => X_Nat => X_Nat" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Pos => Pos => Pos" ("(_/ *''''/ _)" [54,54] 52)
X__div__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ div''/ _)" [54,54] 52)
X__dvd__X :: "X_Nat => X_Nat => bool" ("(_/ dvd''/ _)" [44,44] 42)
X__mod__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ mod''/ _)" [54,54] 52)
X_even :: "X_Nat => bool" ("even''/'(_')" [3] 999)
X_gn_inj_Pos_Nat :: "Pos => X_Nat" ("gn'_inj'_Pos'_Nat/'(_')" [3] 999)
X_gn_proj_Nat_Pos :: "X_Nat => Pos partial" ("gn'_proj'_Nat'_Pos/'(_')" [3] 999)
X_max :: "X_Nat => X_Nat => X_Nat" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "X_Nat => X_Nat => X_Nat" ("min''/'(_,/ _')" [3,3] 999)
X_odd :: "X_Nat => bool" ("odd''/'(_')" [3] 999)
X_pre :: "X_Nat => X_Nat partial" ("pre/'(_')" [3] 999)
sucX2 :: "X_Nat => Pos" ("suc''''/'(_')" [3] 999)

section "Extension of Naturals"
(* we introduce some new symbols *)
consts combine_nat :: "nat => nat => nat" ("(_/ @@@/ _)" [54,54] 52)
consts part_div :: "nat => nat => nat partial" ("(_/ '/??/ _)" [54,54] 52)
consts part_minus :: "nat => nat => nat partial" ("(_/ '-??/ _)" [54,54] 52)

primrec pre_nat
where
  pre_nat_0: "pre_nat 0 = noneOp"
  | pre_nat_suc: "pre_nat (Suc n) = makePartial n"

axioms

decimal_def_nat [rule_format] :
"ALL m. ALL X_n. m @@@ X_n = (m * Suc(9)) + X_n"
part_div_def : "x /??y = (if (x mod y = 0) then makePartial(x div y) else noneOp)"
part_minus_def : "x -?? y = (if (x>=y) then makePartial(x-y) else noneOp)"

ga_function_monotonicity [rule_format] : "1' = gn_inj_Pos_Nat(1'')"

ga_function_monotonicity_1 [rule_format] :
"ALL x1.
 ALL x2.
 gn_inj_Pos_Nat(x1) *' gn_inj_Pos_Nat(x2) =
 gn_inj_Pos_Nat(x1 *'' x2)"

ga_function_monotonicity_2 [rule_format] :
"ALL x1.
 ALL x2. x1 +' gn_inj_Pos_Nat(x2) = gn_inj_Pos_Nat(x1 +'' x2)"

ga_function_monotonicity_3 [rule_format] :
"ALL x1.
 ALL x2. gn_inj_Pos_Nat(x1) +' x2 = gn_inj_Pos_Nat(x1 +_3 x2)"

ga_function_monotonicity_4 [rule_format] :
"ALL x1.
 ALL x2. gn_inj_Pos_Nat(x1) +'' x2 = x1 +_3 gn_inj_Pos_Nat(x2)"

ga_function_monotonicity_5 [rule_format] :
"ALL x1. suc'(x1) = gn_inj_Pos_Nat(suc''(x1))"

ga_embedding_injectivity [rule_format] :
"ALL x. ALL y. gn_inj_Pos_Nat(x) = gn_inj_Pos_Nat(y) --> x = y"

ga_projection_injectivity [rule_format] :
"ALL x. ALL y. gn_proj_Nat_Pos(x) =e= gn_proj_Nat_Pos(y) --> x = y"

ga_projection [rule_format] :
"ALL x. gn_proj_Nat_Pos(gn_inj_Pos_Nat(x)) = makePartial x"

ga_selector_pre [rule_format] :
"ALL XX1. pre(suc'(XX1)) = makePartial XX1"

ga_injective_suc [rule_format] :
"ALL XX1. ALL Y1. suc'(XX1) = suc'(Y1) = (XX1 = Y1)"

ga_disjoint_0_suc [rule_format] : "ALL Y1. ~ 0' = suc'(Y1)"

ga_selector_undef_pre_0 [rule_format] : "~ defOp (pre(0'))"

X1_def_Nat [rule_format] : "1' = suc'(0')"

X2_def_Nat [rule_format] : "2' = suc'(1')"

X3_def_Nat [rule_format] : "3' = suc'(2')"

X4_def_Nat [rule_format] : "4' = suc'(3')"

X5_def_Nat [rule_format] : "5' = suc'(4')"

X6_def_Nat [rule_format] : "6' = suc'(5')"

X7_def_Nat [rule_format] : "7' = suc'(6')"

X8_def_Nat [rule_format] : "8' = suc'(7')"

X9_def_Nat [rule_format] : "9' = suc'(8')"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *' suc'(9')) +' X_n"

ga_comm___XPlus__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___XPlus__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___XPlus__ [rule_format] : "ALL x. 0' +' x = x"

ga_left_comm___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. x +' (y +' z) = y +' (x +' z)"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x *' y = y *' x"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 1' *' x = x"

ga_left_comm___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. x *' (y *' z) = y *' (x *' z)"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_right_unit_max [rule_format] : "ALL x. max'(x, 0') = x"

ga_left_unit_max [rule_format] : "ALL x. max'(0', x) = x"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

leq_def1_Nat [rule_format] : "ALL X_n. 0' <=' X_n"

dvd_def_Nat [rule_format] :
"ALL m. ALL X_n. (m dvd' X_n) = (EX k. X_n = m *' k)"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc'(X_n) <=' 0'"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc'(m) <=' suc'(X_n)) = (m <=' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_0_Nat [rule_format] : "even'(0')"

even_suc_Nat [rule_format] : "ALL m. even'(suc'(m)) = odd'(m)"

odd_def_Nat [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

factorial_0 [rule_format] : "0' !' = 1'"

factorial_suc [rule_format] :
"ALL X_n. suc'(X_n) !' = suc'(X_n) *' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0' +' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc'(X_n) +' m = suc'(X_n +' m)"

mult_0_Nat [rule_format] : "ALL m. 0' *' m = 0'"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc'(X_n) *' m = (X_n *' m) +' m"

power_0_Nat [rule_format] : "ALL m. m ^' 0' = 1'"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^' suc'(X_n) = m *' (m ^' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >' X_n --> X_n -! m = 0'"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <=' X_n --> makePartial (X_n -! m) = X_n -? m"

sub_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >=' X_n)"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = makePartial r = (m = r +' X_n)"

divide_dom_Nat [rule_format] :
"ALL m.
 ALL X_n.
 defOp (m /? X_n) = (~ X_n = 0' & m mod' X_n = makePartial 0')"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /? 0')"

divide_Pos_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r. X_n >' 0' --> m /? X_n = makePartial r = (m = r *' X_n)"

div_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = makePartial r =
 (EX s. m = (X_n *' r) +' s & s <' X_n)"

mod_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod' X_n = makePartial s =
 (EX r. m = (X_n *' r) +' s & s <' X_n)"

distr1_Nat [rule_format] :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"

distr2_Nat [rule_format] :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"

Pos_def [rule_format] :
"ALL p. defOp (gn_proj_Nat_Pos(p)) = (p >' 0')"

X1_as_Pos_def [rule_format] : "1'' = suc''(0')"

min_0 [rule_format] : "ALL m. min'(m, 0') = 0'"

div_mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 makePartial m =
 (let (Xb5, Xc0) =
      let (Xb4, Xc3) = m div' X_n
      in if Xb4 then makePartial (Xc3 *' X_n) else noneOp
  in if Xb5
        then let (Xb2, Xc1) = m mod' X_n
             in if Xb2 then makePartial (Xc0 +' Xc1) else noneOp
        else noneOp)"

power_Nat [rule_format] :
"ALL m. ALL r. ALL s. m ^' (r +' s) = (m ^' r) *' (m ^' s)"

declare ga_projection [simp]
declare ga_selector_pre [simp]
declare ga_selector_undef_pre_0 [simp]
declare ga_comm___XPlus__ [simp]
declare ga_assoc___XPlus__ [simp]
declare ga_right_unit___XPlus__ [simp]
declare ga_left_unit___XPlus__ [simp]
declare ga_left_comm___XPlus__ [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare ga_left_comm___Xx__ [simp]
declare ga_comm_min [simp]
declare ga_assoc_min [simp]
declare ga_left_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_max [simp]
declare ga_right_unit_max [simp]
declare ga_left_unit_max [simp]
declare ga_left_comm_max [simp]
declare leq_def1_Nat [simp]
declare dvd_def_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare geq_def_Nat [simp]
declare less_def_Nat [simp]
declare greater_def_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare odd_def_Nat [simp]
declare factorial_0 [simp]
declare factorial_suc [simp]
declare add_0_Nat [simp]
declare add_suc_Nat [simp]
declare mult_0_Nat [simp]
declare mult_suc_Nat [simp]
declare power_0_Nat [simp]
declare power_suc_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare sub_dom_Nat [simp]
declare divide_0_Nat [simp]
declare min_0 [simp]

section "Strong Equality"

lemma strong_equality : "!! (t::'a partial) (s::'a partial) . (t =s= s)  =  (! x . ((t = makePartial x) <-> (s = makePartial x)))"
apply (rule iffI)
defer
apply (unfold makePartial_def)
apply (unfold strongEqualOp_def)
apply (auto)
done

lemma normal2strong: "!!a b. (a=b) ==> (a =s= b)"
apply (unfold strongEqualOp_def)
apply (auto)
done

lemma makepartial_intro : "(s=makePartial t) = (defOp(s) & (snd(s)=t))"
apply (rule iffI)
apply (simp add: makePartial_def)
apply (subst defOp_def)
apply (simp)
apply (simp add: makePartial_def)
apply (case_tac "s")
apply (simp add: defOp_def)
done

lemma makepartial_intro_downfold : "(s=makePartial t) = (defOp(s) & (defOp(s) --> (snd(s)=t)))"
apply (rule iffI)
apply (simp add: makePartial_def)
apply (subst defOp_def)
apply (simp)
apply (simp add: makePartial_def)
apply (case_tac "s")
apply (simp add: defOp_def)
done

lemma makepartial_intro_weak: "(s=makePartial t) ==> (snd(s)=t)"
apply (simp add: makePartial_def)
done

lemma makePartialproj [simp]: "snd (makePartial x) = x"
apply (simp add: makePartial_def)
done

section "Definition of the Isomorphism"

primrec Nat2nat
where
  Nat2nat_0: "Nat2nat  0' = 0 "
  | Nat2nat_suc: "Nat2nat  (suc'(x)) = Suc (Nat2nat x)"

primrec nat2Nat
where
  nat2Nat_0: "nat2Nat 0 = 0'"
| nat2Nat_Suc: "nat2Nat (Suc x) = suc' (nat2Nat x)"

lemma iso1 [simp] : "! x . nat2Nat(Nat2nat x) = x"
apply (auto)
apply (induct_tac x)
apply (auto)
done

lemma iso2 [simp] : "! x. Nat2nat(nat2Nat x) = x"
apply (auto)
apply (induct_tac x)
apply (auto)
done

lemma nat2Nat_injectivity : "nat2Nat(x) = nat2Nat(y) ==> x = y"
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (simp)
done

lemma Nat2nat_injectivity : "Nat2nat(x) = Nat2nat(y) ==>  x = y"
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (simp)
done

lemma nat2Nat_injectivity_negated : "nat2Nat(x) ~= nat2Nat(y) ==> x ~= y"
apply (auto)
done

lemma Nat2nat_injectivity_negated : "Nat2nat(x) ~= Nat2nat(y) ==>  x ~= y"
apply (auto)
done

(* ask Lutz which version to use *)
lemma inj_predefined : "inj Nat2nat"
apply (simp add: inj_on_def)
apply (auto)
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (simp)
done

section "Simple Definitions"

(* the numbers need special treatment. we use the following strategy: 1' is manually proved
   for subsequent numbers: apply definition for n' -> suc( [n-1]'), use theorem for [n-1]', ripple out via nat2Nat_Suc *)

(* ============================== 1 ============================== *)

(*by (auto simp add: X1_def_Nat)*)
theorem nat2Nat_1_def_Nat[simp] : "nat2Nat(1) = 1'"
apply (simp)
apply (subst X1_def_Nat)
apply (auto)
done

(* get backwards direction via the iso (already in the simplifier) and the other direction *)
theorem Nat2nat_1_def_Nat[simp] : "Nat2nat(1')=1"
apply (simp add: nat2Nat_1_def_Nat[THEN sym])
done

(* ============================== 2 ============================== *)

theorem nat2Nat_2_def_Nat[simp] : "nat2Nat(2) =2'"
apply (subst X2_def_Nat)
apply (subst nat2Nat_1_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (subgoal_tac "Suc 1 = 2")
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (auto)
done

theorem two_2[simp]  : "Nat2nat(2') = 2"
apply (subst nat2Nat_2_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 3 ============================== *)

theorem nat2Nat_3_def_Nat[simp] : "nat2Nat(3) = 3'"
apply (subst X3_def_Nat)
apply (subst nat2Nat_2_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem nat2Nat_3_def_nat[simp] : "Nat2nat(3') = 3"
apply (subst nat2Nat_3_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 4 ============================== *)

theorem nat2Nat_4_def_Nat[simp] : "nat2Nat(4) = 4'"
apply (subst X4_def_Nat)
apply (subst nat2Nat_3_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_4_def_Nat : "Nat2nat(4') = 4"
apply (subst nat2Nat_4_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 5 ============================== *)

theorem nat2Nat_5_def_Nat[simp] : "nat2Nat(5) = 5'"
apply (subst X5_def_Nat)
apply (subst nat2Nat_4_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_5_def_Nat[simp] : "Nat2nat(5') = 5"
apply (subst nat2Nat_5_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 6 ============================== *)

theorem nat2Nat_6_def_Nat[simp] : "nat2Nat(6) = 6'"
apply (subst X6_def_Nat)
apply (subst nat2Nat_5_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_6_def_Nat[simp] : "Nat2nat(6') = 6"
apply (subst nat2Nat_6_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 7 ============================== *)

theorem nat2Nat_7_def_Nat[simp] : "nat2Nat(7)=7'"
apply (subst X7_def_Nat)
apply (subst nat2Nat_6_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_7_def_Nat[simp] : "Nat2nat(7') = 7"
apply (subst nat2Nat_7_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 8 ============================== *)

theorem nat2Nat_8_def_Nat[simp] : "nat2Nat(8) = 8'"
apply (subst X8_def_Nat)
apply (subst nat2Nat_7_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_8_def_Nat[simp] : "Nat2nat(8') = 8 "
apply (subst nat2Nat_8_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 9 ============================== *)

theorem nat2Nat_9_def_Nat[simp] : "nat2Nat(9) = 9'"
apply (subst X9_def_Nat)
apply (subst nat2Nat_8_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_9_def_Nat[simp] : "Nat2nat(9') = 9"
apply (subst nat2Nat_9_def_Nat[THEN sym])
apply (simp only: iso2)
done

section "Recursive Definitions"

theorem nat2Nat_add [simp] : "nat2Nat (x + y) = (nat2Nat x) +' (nat2Nat y)"
apply (induct_tac x)
apply (auto simp only: nat2Nat_Suc nat2Nat_0 add_Suc add_0 add_suc_Nat add_0_Nat)
done

theorem Nat2nat_add[simp] : "Nat2nat (x +' y) = (Nat2nat x) + (Nat2nat y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_mul [simp] : "nat2Nat (x * y) = (nat2Nat x) *' (nat2Nat y)"
apply (induct_tac x)
apply (auto simp only: nat2Nat_Suc nat2Nat_0 nat2Nat_add mult_Suc mult_0 mult_suc_Nat mult_0_Nat)
apply (auto)
done

theorem Nat2nat_mul [simp] : "Nat2nat (x *' y) = (Nat2nat x) * (Nat2nat y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_power [simp] : "nat2Nat(x ^ y) = nat2Nat(x) ^' nat2Nat(y)"
apply (induct_tac y)
apply (auto)
apply (simp add: X1_def_Nat)
done

theorem Nat2nat_power [simp]: "Nat2nat(x ^' y) = Nat2nat(x) ^ Nat2nat(y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_fac [simp] : "nat2Nat(fact(x)) = nat2Nat(x)!'"
apply (induct_tac x)
apply (simp add: X1_def_Nat)
apply (subst fact.simps)
apply (simp only: nat2Nat_mul nat2Nat_Suc factorial_suc)
done

theorem Nat2nat_fac [simp] : "Nat2nat(x!') = fact(Nat2nat(x))"
apply (rule nat2Nat_injectivity)
apply auto
done

section "Predicates"

subsection "ordering"

lemma no_le_zero [simp] : "(x <=' 0') = (x = 0')"
apply (case_tac x)
by (auto)

lemma no_nat2Nat_zero [simp] : "!!x. nat2Nat x = 0' ==> x = 0"
apply (rule nat2Nat_injectivity)
apply simp
done

theorem nat2Nat_lt_equal [simp] : "nat2Nat(x) <=' nat2Nat(y) <->x <= y "
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_lt_equal [simp] : "(Nat2nat(x) <= Nat2nat(y)) <-> (x <=' y)"
apply (subst nat2Nat_lt_equal[THEN sym])
apply (simp only: iso1)
done

theorem nat2Nat_lt [simp] : "nat2Nat(x) <' nat2Nat(y) <-> x < y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_lt [simp] : "Nat2nat(x) < Nat2nat(y) <-> x <' y"
apply (subst nat2Nat_lt[THEN sym])
apply (simp only: iso1)
done

theorem nat2Nat_gt [simp] : " nat2Nat(x) >' nat2Nat(y) <-> x > y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_gt [simp] : "Nat2nat(x) > Nat2nat(y) <-> x >' y "
apply (subst nat2Nat_gt[THEN sym])
apply (simp)
done

theorem nat2Nat_gt_equal [simp] : "nat2Nat(x) >=' nat2Nat(y) <-> x >= y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_gt_equal [simp] : "Nat2nat(x) >= Nat2nat(y) <-> x >=' y"
apply (subst nat2Nat_gt_equal[THEN sym])
apply(auto)
done

subsection "Even and Odd"

lemma suc_even_nat: "even(x) ==> even(Suc(Suc(x)))"
apply (auto)
done

theorem nat2Nat_even [simp] : "((even(Nat2nat(x)) <-> even'(x)) & (odd(Nat2nat(x)) <-> odd'(x)))"
apply (induct x)
apply (simp)
apply (rule conjI)
apply (simp)
apply (simp)
done

theorem Nat2nat_even [simp] : "(even'(nat2Nat(x)) <-> (even(x)) & (odd'(nat2Nat(x)) <-> odd(x)))"
apply (insert nat2Nat_even [of "nat2Nat(x)"])
apply (auto)
done

theorem nat2Nat_dvd [simp] : "(nat2Nat(x) dvd' nat2Nat(y)) <-> (x dvd y)"
apply (subst dvd_def_Nat)
apply (subst dvd_def)
apply (rule iffI)
apply (simp)
apply (erule exE)
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (simp (no_asm_use) only: Nat2nat_mul iso2)
apply (auto)
done

theorem Nat2nat_dvd : "(Nat2nat(x) dvd Nat2nat(y)) = (x dvd' y)"
apply (auto)
apply (subst (asm) nat2Nat_dvd [THEN sym])
apply (auto)
done

section "Simple Functions"

theorem nat2Nat_max [simp]: "nat2Nat(max x y) = max'(nat2Nat(x),nat2Nat(y))"
apply (simp add: max_def_Nat max_def)
done

theorem Nat2nat_max : "Nat2nat(max'(x,y)) = (max (Nat2nat(x)) (Nat2nat(y)))"
apply (simp add: max_def_Nat max_def)
done

theorem nat2Nat_min : "nat2Nat(min x y) = min' (nat2Nat(x), nat2Nat(y))"
apply (simp add: min_def_Nat min_def)
done

theorem Nat2nat_min : "Nat2nat(min'(x,y)) = (min (Nat2nat(x)) (Nat2nat(y)))"
apply (simp add: min_def_Nat min_def)
done

(* ============================================================================= *)
(* ============================== cut off minus ================================ *)
(* ============================================================================= *)

lemma anything_part_minus_zero [simp] : "x -? 0' = makePartial x"
apply (simp add: sub_def_Nat)
done

lemma add_partiality  : "x=y <-> makePartial x = makePartial y"
apply (simp add: makePartial_def)
done

lemma anything_minus_zero [simp] : "x -! 0' = x"
(* here the problem is that the defined rewrite rule is only applicable for makePartial x-!y *)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (simp)
apply (subst anything_part_minus_zero)
apply (simp)
done

lemma not_greater_zero : "~ x>'0' <-> x <=' 0'"
apply (simp)
apply (auto)
done

lemma zero_minus_anything [simp] : "0' -! x = 0'"
apply (case_tac "x>'0'")
apply (simp only: subTotal_def1_Nat)
apply (subst (asm) not_greater_zero)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (auto)
done

lemma not_iff : "(A<->B) <-> (~A <-> ~B)"
apply (auto)
done

lemma not_greater_suc : "~ (x>'y) <-> x <' suc'(y)"
apply (insert Nat2nat_gt)
apply (subst (asm) not_iff)
apply (subst (asm) not_less_eq)
apply (subst (asm) Nat2nat_suc [rule_format, THEN sym])
apply (subst (asm) Nat2nat_lt )
apply (auto)
done

lemma not_greater_isa : "~((x::nat) > (y::nat)) <-> x<=y"
apply (arith)
done

lemma minus_Suc : "(Suc(x) - Suc(y))=(x-y)"
apply (auto)
done

lemma not_greater : " ~ (x>'y) <-> x<='y"
sorry

lemma minus_neutral : "(x <=' y) ==> y = (y -! x) +' x"
apply (drule subTotal_def2_Nat)
apply (drule sym)
apply (subst (asm) sub_def_Nat)
apply (auto)
done

(*forward reasoning anstatt makePartial einfügen ist hilfreich*)

lemma minus_suc : "(suc'(x) -! suc'(y))=(x-!y)"
apply (case_tac "y>'x")
apply (simp)
apply (subst (asm) not_greater)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (simp)
apply (subst sub_def_Nat)
apply (subst ga_comm___XPlus__)
apply (subst add_suc_Nat)
apply (subst ga_injective_suc)
apply (subst ga_comm___XPlus__)
apply (rule minus_neutral)
apply (simp)
done

theorem nat2Nat_minus: "nat2Nat (x - y) = (nat2Nat(x) -! nat2Nat (y))"
apply (rule diff_induct)
apply (simp)
apply (simp only: nat2Nat_0 nat2Nat_Suc diff_0_eq_0 zero_minus_anything)
apply (subst minus_Suc)
apply (simp)
apply (subst minus_suc)
apply (auto)
done

theorem Nat2nat_minus: "Nat2nat (x -! y) = (Nat2nat (x) - Nat2nat(y))"
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_minus)
apply (auto)
done

section "Partial Functions"

theorem iso2_negated: "~(nat2Nat(x)=nat2Nat(y)) ==> ~(x=y)"
apply (auto)
done

theorem iso1_negated1: "x~=y ==> ~(Nat2nat(x)=Nat2nat(y))"
apply (auto)
apply (drule Nat2nat_injectivity)
apply (auto)
done

section "Non-canonical Mappings"

theorem nat2Nat_at : "nat2Nat(x @@@ y) = nat2Nat(x) @@ nat2Nat(y)"
apply (auto simp add: decimal_def decimal_def_nat)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_mul Nat2nat_add Nat2nat_9_def_Nat[rule_format, THEN sym])
by (auto)

theorem Nat2nat_at  : "Nat2nat( x @@ y) = Nat2nat(x) @@@ Nat2nat(y)"
apply (simp only: decimal_def decimal_def_nat)
apply (simp only: Nat2nat_mul Nat2nat_suc Nat2nat_add Nat2nat_9_def_Nat[rule_format, THEN sym])
done

theorem Nat2nat_pre : "!!x. x > 0 --> nat2Nat(snd (pre_nat(x))) = snd (pre (nat2Nat(x)))"
apply (case_tac x)
apply (simp)
apply (simp add: makePartial_def)
done

theorem nat2Nat_pre : "!!x. x >' 0' --> ( Nat2nat(snd (pre(x)))  = snd(pre_nat (Nat2nat x)))"
apply (case_tac x)
apply (simp)
apply (simp add: makePartial_def)
done

theorem nat2Nat_div [simp] : " y ~= 0 ==> nat2Nat(x div y) = snd(nat2Nat(x) div' nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst div_Nat)
apply (rule_tac x="nat2Nat (x mod y)" in exI)
apply (rule conjI)
apply (rule Nat2nat_injectivity)
apply (simp only: iso2 Nat2nat_add Nat2nat_mul)
apply (arith)
apply (subst nat2Nat_lt)
apply (rule mod_less_divisor)
apply (arith)
done

theorem Nat2nat_div [simp] : " y ~= 0' ==> Nat2nat(snd (x div' y)) = Nat2nat(x) div Nat2nat(y)"
apply (frule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_div)
apply (simp)
apply (simp)
done

theorem nat2Nat_mod [simp] : "~(y = 0) ==> nat2Nat(x mod y) =snd (nat2Nat(x) mod' nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
(*apply (subst nat2Nat_mod_mp[rule_format,THEN sym])*)
apply (simp)
apply (subst mod_Nat)
apply (rule_tac x="nat2Nat (x div y)" in exI)
apply (rule conjI)
apply (subst nat2Nat_mul[rule_format,THEN sym])
apply (subst nat2Nat_add[rule_format,THEN sym])
apply (rule_tac f="nat2Nat" in arg_cong)
apply (simp)
apply (subst Nat2nat_lt[THEN sym])
apply (simp only: iso2)
apply (rule mod_less_divisor)
apply (auto)
done

theorem Nat2nat_mod[simp] : "~(y = 0') ==>  Nat2nat (snd (x mod' y)) = (Nat2nat(x) mod Nat2nat(y))"
apply (frule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_mod)
apply (simp)
apply (simp)
done

theorem nat2Nat_pdiv[simp] : "[|~ y = 0 ; x mod y = 0|] ==> nat2Nat(snd(x /?? y)) =snd(nat2Nat(x) /? nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst divide_Pos_Nat)
apply (subst Nat2nat_gt[THEN sym])
apply (simp)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_mul iso2)
apply (subst part_div_def)
apply (simp add: makePartialproj)
apply (auto)
done

theorem Nat2nat_pdiv[simp] : "[|~ y = 0' ; x mod' y = makePartial 0'|] ==> Nat2nat(snd(x /? y)) =snd(Nat2nat(x) /?? Nat2nat(y))"
apply (drule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (drule_tac f="%x. snd(x)" in arg_cong)
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (subst (asm) Nat2nat_mod)
apply (simp add: iso1_negated1)
apply (rule Nat2nat_injectivity_negated)
apply (simp)
apply (simp  only: makePartialproj Nat2nat_0 Nat2nat_mod)
apply (rule nat2Nat_injectivity)
apply (drule nat2Nat_pdiv)
apply (simp)
apply (simp)
done

theorem nat2Nat_pminus [simp]: "(x >= y) ==> nat2Nat(snd (x -?? y)) = snd(nat2Nat(x) -? nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst sub_def_Nat)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_add iso2)
apply (subst part_minus_def)
apply (simp add: makePartialproj)
done

theorem Nat2nat_pminus[simp] : "(x >=' y) ==> Nat2nat(snd(x -? y)) = snd(Nat2nat(x) -?? Nat2nat(y))"
apply (subst (asm) Nat2nat_gt_equal[THEN sym])
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_pminus)
apply (simp)
apply (simp)
done

lemma gt_sym: "(m <= n) = (n >= m)"
apply (auto)
done

lemma gt_sym2: "(m <= n) ==> (n >= m)"
apply (auto)
done

theorem Ax2 : "5' -? 2' = makePartial 3'"
apply (subst makepartial_intro)
apply (simp)
apply (subst Nat2nat_lt_equal[THEN sym])
apply (simp)
apply (rule Nat2nat_injectivity)
apply (simp)

apply (subst makepartial_intro_downfold)
apply (rule conjI)
apply (simp)
apply (subst Nat2nat_lt_equal[THEN sym])
apply (simp)
apply (rule impI)
apply (rule Nat2nat_injectivity)
apply (subst (asm) sub_dom_Nat)
apply (simp del: geq_def_Nat add: part_minus_def)
done

theorem Ax1 :
"ALL X_n. pre(gn_inj_Pos_Nat(suc''(X_n))) = makePartial X_n"
apply (rule allI)
apply (subst makepartial_intro_downfold)
apply (rule conjI)
apply (subst ga_function_monotonicity_5[THEN sym])
apply (simp add: defOp_def makePartial_def)
apply (simp add: defOp_def ga_function_monotonicity_5[THEN sym])
done

theorem Ax3 :
"ALL a.
 ALL b.
 ALL c.
 (a *' b) mod' c =s=
 (let (Xb3, Xc0) =
      let (Xb2, Xc1) = b mod' c
      in if Xb2 then makePartial (a *' Xc1) else noneOp
  in if Xb3 then Xc0 mod' c else noneOp)"
apply (subst strong_equality)
apply (rule allI)
apply (rule allI)
apply (rule allI)
apply (rule allI)
apply (rule iffI)
apply (subst (asm) makepartial_intro)
apply (frule conjunct1)
apply (drule conjunct2)
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (subst (asm) mod_dom_Nat)
apply (simp add: Let_def)
apply (case_tac "b mod' c")
apply (insert mod_dom_Nat [of "b" "0'",THEN sym])
(*apply (subst (asm) mod_dom_Nat[THEN sym]) (* defOp (m mod' X_n) = (~ X_n = 0')"*)*)
apply (rule conjI)
apply (case_tac "b mod' c")
apply (simp)
apply (subst makepartial_intro)
apply (subst makePartial_intro)
apply (subst makePartial_def)
apply (simp)
apply (simp only: Let_def)
apply (simp)

lemma makepartial_intro : "(s=makePartial t) = (defOp(s) & (snd(s)=t))"
apply (simp)
ML "Header.record \"Ax3\""

theorem Ax4 :
"ALL a.
 ALL b.
 ALL c.
 (a *' b) mod' c =s=
 (let (Xb3, Xc0) = a mod' c
  in if Xb3
        then let (Xb2, Xc1) = b mod' c
             in if Xb2 then makePartial (Xc0 *' Xc1) else noneOp
        else noneOp)"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat
      X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def Pos_def
      X1_as_Pos_def
by auto

ML "Header.record \"Ax4\""

theorem Ax5 :
"ALL a.
 ALL b.
 ALL c.
 (a *' b) mod' c =s=
 (let (Xb5, Xc0) =
      let (Xb4, Xc1) = a mod' c
      in if Xb4
            then let (Xb3, Xc2) = b mod' c
                 in if Xb3 then makePartial (Xc1 *' Xc2) else noneOp
            else noneOp
  in if Xb5 then Xc0 mod' c else noneOp)"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat
      X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def Pos_def
      X1_as_Pos_def
by auto

ML "Header.record \"Ax5\""

end


theory nsmap_theory
imports "$HETS_LIB/Isabelle/MainHC" "List"
uses "$HETS_LIB/Isabelle/prelude"
begin

consts
X_all :: "('a => bool) => 'a list => bool"
X_map :: "('a => 'b partial) => 'a list => 'b list partial"
nsMap :: "('a => 'b partial) => 'a list => 'b partial list"
X_filter :: "'a list => ('a => bool) => 'a list"

axioms
Ax1 [rule_format] : "ALL f. X_map f [] = makePartial []"

(*nsMap_nil : "nsMap f nil = nil"
nsMap_cons : "nsMap f (cons x l) = cons (f x) (nsMap f l)"*)

Ax2 [rule_format] :
"ALL f.
 ALL l.
 ALL x.
 X_map f (Cons x l) =
 restrictOp
 (makePartial (Cons (makeTotal (f x)) (makeTotal (X_map f l))))
 (defOp (f x) & defOp (X_map f l))"

Ax3 [rule_format] : "ALL P. X_all P nil"

Ax4 [rule_format] :
"ALL P. ALL l. ALL x. X_all P (Cons x l) = (P x & X_all P l)"

Ax5 [rule_format] :
"ALL P.
 ALL s.
 (X_filter (Cons x l) P) = (if (P x) then (Cons x (X_filter l P)) else (Cons x (X_filter l P)))"

Ax6 [rule_format] :
"ALL P. ALL s. X_filter [] P = []"

theorem restrict1 : "restrictOp (restrictOp a (defOp b)) c = restrictOp (restrictOp a c) (defOp (restrictOp b c))"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_trivial_rule[simp]: "b ==> restrictOp u b = u"
apply (simp add: restrictOp_def)
done

theorem restrict_trivial [simp]: "restrictOp u True = u"
apply (simp)
done

theorem restrict_assoc[simp] : "restrictOp a (defOp (restrictOp b c)) = restrictOp (restrictOp a (defOp b)) c"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def noneOp_def defOp.simps)
sorry

theorem restrict_out[simp] : "restrictOp (u b) b = restrictOp (u True) b"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem mkpartial_cancel [simp]: "makeTotal(makePartial x) = x"
apply (simp add: makeTotal_def makePartial_def)
done

theorem mkpartial_cancel2 [simp]: "defOp(x) ==> makePartial(makeTotal x) = x"
apply (simp add: makeTotal_def makePartial_def)
apply (case_tac x)
apply (simp)
apply (simp)
done

theorem mkpartial_cancel3 [simp] : "((makePartial x) = (makePartial y)) = (x = y)"
apply (simp add: makePartial_def)
done

theorem defOp_trivial [simp]: "defOp(makePartial x) = True"
apply (simp add: makePartial_def makeTotal_def)
done

(* Some more stuff about removing extraneous restrictions *)

theorem total_restrict2 [simp]:
"(c ==> b) ==> restrictOp (u (makeTotal  (restrictOp a b))) c =
	   restrictOp (u (makeTotal a)) c"
apply (simp add: makeTotal_def restrictOp_def defOp.simps undefinedOp_def)
done

theorem def_restrict [simp]:
"defOp (restrictOp a b) = (defOp a & b)"
apply (simp add:  restrictOp_def defOp.simps undefinedOp_def split: split_if)
done

theorem total_restrict [simp]:
"restrictOp (u (makeTotal  (restrictOp a b))) (defOp (restrictOp a b)) =
	   restrictOp (u (makeTotal a)) (defOp a & b)"
apply simp
done

lemma restrictOp_cong [cong]:
  "b = b' ==> (b' ==> a = a') ==> restrictOp a b = restrictOp a' b'"
  apply (simp add: restrictOp_def defOp.simps undefinedOp_def)
done

lemma test: "((restrictOp a c) = (restrictOp b c)) = (c --> (a = b))"
apply (simp add: restrictOp_def)
done

lemma res_overlap[simp]: "restrictOp (restrictOp a b) c = restrictOp a (b & c)"
apply (simp add: restrictOp_def)
done

(*theorem normaleq_1[simp]: "[|def a & b = def c & d; b & d --> a = c|]==> (restrictOp a b = restrictOp c d)"*)
lemma normalizeeq_1: "b=c ==> ((restrictOp a b) = (restrictOp a c))"
apply (simp)
done

theorem Ax1_1 :
"ALL f.
 ALL g.
 X_map (% y. restrictOp (g (makeTotal (f y))) (defOp (f y))) =
 (% k. restrictOp (X_map g (makeTotal (X_map f k)))
       (defOp (X_map f k)))"
apply (auto)
apply (rule ext)
apply (induct_tac "k")
apply (simp add: Ax1)
apply (simp add: Ax2 conj_ac)
done

term "(X_filter l (P o f))"
term "(map f l)"
term "X_filter (map f l) P"
term "(makeTotal (X_map f (X_filter l (P o f))))"
term "X_filter (makeTotal (X_map f l)) P"

lemma mapdef: "defOp (X_map f list) --> defOp(X_map f (X_filter list P))"
apply (induct_tac list)
apply (auto simp add: Ax1 Ax6 Ax5 Ax2)
done

theorem mapfilter: "defOp(X_map f l) --> (makeTotal (X_map f (X_filter l P))) = (X_filter (makeTotal (X_map f l)) P)"
apply (induct_tac "l")
apply (simp add: Ax1 Ax6)
apply (auto simp add: Ax5 Ax2 mapdef)
done

theorem Ax2_1 :
"ALL f. ALL l. defOp (X_map f l) = X_all (% y. defOp (f y)) l"

oops


(*  Title:      HOL/MicroJava/DFA/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section {* Products as Semilattices *}

theory Product
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a * 'b) ord" where
"le rA rB == %(a,b) (a',b'). a <=_rA a' & b <=_rB b'"

definition sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a * 'b)ebinop" where
"sup f g == %(a1,b1)(a2,b2). Err.sup Pair (a1 +_f a2) (b1 +_g b2)"

definition esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a * 'b ) esl" where
"esl == %(A,rA,fA) (B,rB,fB). (A <*> B, le rA rB, sup fA fB)"

abbreviation
  lesubprod_sntax :: "'a * 'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'a * 'b \<Rightarrow> bool"
       ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
  where "p <=(rA,rB) q == p <=_(le rA rB) q"

lemma unfold_lesub_prod:
  "p <=(rA,rB) q == le rA rB p q"
  by (simp add: lesub_def)

lemma le_prod_Pair_conv [iff]:
  "((a1,b1) <=(rA,rB) (a2,b2)) = (a1 <=_rA a2 & b1 <=_rB b2)"
  by (simp add: lesub_def le_def)

lemma less_prod_Pair_conv:
  "((a1,b1) <_(Product.le rA rB) (a2,b2)) =
  (a1 <_rA a2 & b1 <=_rB b2 | a1 <=_rA a2 & b1 <_rB b2)"
apply (unfold lesssub_def)
apply simp
apply blast
done

lemma order_le_prod [iff]:
  "order(Product.le rA rB) = (order rA & order rB)"
apply (unfold Semilat.order_def)
apply simp
apply blast
done

lemma acc_le_prodI [intro!]:
  "\<lbrakk> acc r\<^sub>A; acc r\<^sub>B \<rbrakk> \<Longrightarrow> acc(Product.le r\<^sub>A r\<^sub>B)"
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done

lemma unfold_plussub_lift2:
  "e1 +_(lift2 f) e2 == lift2 f e1 e2"
  by (simp add: plussub_def)

lemma plus_eq_Err_conv [simp]:
  assumes "x:A" and "y:A"
    and "semilat(err A, Err.le r, lift2 f)"
  shows "(x +_f y = Err) = (~(? z:A. x <=_r z & y <=_r z))"
proof -
  have plus_le_conv2:
    "\<And>r f z. \<lbrakk> z : err A; semilat (err A, r, f); OK x : err A; OK y : err A;
                 OK x +_f OK y <=_r z\<rbrakk> \<Longrightarrow> OK x <=_r z \<and> OK y <=_r z"
    by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x +_f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def closed_def)
  apply simp
  done
qed

lemma err_semilat_Product_esl:
  "\<And>L1 L2. \<lbrakk> err_semilat L1; err_semilat L2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L1 L2)"
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done

end


(* Title:   Compose_SST_Transducer.thy
   Author:  Akama Hitoshi
*)

theory Compose_SST_Transducer
  imports Main HOL.List HOL.Option "../Core/Update" "../Core/Transducer" "../Core/SST"
begin

section \<open>Composition of SST and Transducer\<close>
subsection \<open>Definition of a strange transducer and its property\<close>

(* Combine two transition function (q \<times> x \<Rightarrow> q and q \<times> b \<Rightarrow> q) into a new trans fun *)
fun delta2f ::
  "('q, 'x) trans => ('q, 'b) trans => ('q, 'x + 'b) trans" where
  "delta2f f g (q, Inl x) = f (q, x)" |
  "delta2f f g (q, Inr a) = g (q, a)"

(* eta2f is a function described in Akama's graduate thesis *)
fun eta2f ::
  "('q, 'b, 'c) Transducer.out => ('q, 'x + 'b, 'q \<times> 'x + 'c) Transducer.out" where
  "eta2f e2 (q, Inl x) = [Inl (q, x)]" |
  "eta2f e2 (q, Inr a) = map Inr (e2 (q, a))"

definition \<Delta> :: "('q, 'b) trans
              \<Rightarrow> ('q, 'x) trans \<times> ('z, 'x, 'b) update' \<Rightarrow> ('q, 'z) trans"
  where "\<Delta> t = (\<lambda>(f, \<theta>). (\<lambda>(q, a). hat1 (delta2f f t) (q, \<theta> a)))"

definition H :: "('q, 'b) trans \<Rightarrow> ('q, 'b, 'c) out
              \<Rightarrow> ('q, 'x) trans \<times> ('a, 'x, 'b) update' \<Rightarrow> ('q \<times> 'a, 'q \<times> 'x, 'c) update'"
  where "H tr to = (\<lambda>(f, \<theta>). (\<lambda>(q, a). Transducer.hat2 (delta2f f tr) (eta2f to) (q, \<theta> a)))"

proposition \<Delta>_assoc_string:
  "hat1 (delta2f (\<lambda>(q, a). hat1 (delta2f f tr) (q, theta a)) tr) (q, u) =
   hat1 (delta2f f tr) (q, hat_hom theta u)"
  by (induct u arbitrary: q rule: xa_induct, simp_all)

lemma \<Delta>_assoc: "\<Delta> t (f, \<phi> \<bullet> \<psi>) = \<Delta> t (\<Delta> t (f, \<phi>), \<psi>)"
  by (auto simp add: \<Delta>_def compU_apply \<Delta>_assoc_string)

proposition H_assoc_string:
  "hat_hom (\<lambda>(q2, x1). Transducer.hat2 (delta2f f t_trans) (eta2f t_out) (q2, theta x1))
     (Transducer.hat2 (delta2f (\<lambda>(q2, x1). hat1 (delta2f f t_trans) (q2, theta x1)) t_trans) (eta2f t_out) (q, u)) =
   Transducer.hat2 (delta2f f t_trans) (eta2f t_out) (q, hat_hom theta u)"
  by (induct u arbitrary: q rule: xa_induct, simp_all add: Transducer.eta_append)

lemma H_assoc: "H tr to (f, \<phi> \<bullet> \<psi>) = H tr to (f, \<phi>) \<bullet> H tr to (\<Delta> tr (f, \<phi>), \<psi>)"
  by (auto simp add: \<Delta>_def H_def compU_apply H_assoc_string)

subsection \<open>Construction\<close>

definition compose_\<delta> :: "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'b, 'c) transducer \<Rightarrow>
                             ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'a) trans" where
  "compose_\<delta> sst td = (\<lambda>((q1, f), a). (delta sst (q1, a),
                                         \<Delta> (delta td) (f, eta sst (q1, a))))"

definition compose_\<eta> :: "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'b, 'c) transducer \<Rightarrow>
                             ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'q2 \<times> 'x1, 'a, 'c) updator" where
  "compose_\<eta> sst td = (\<lambda>((q1, f), a). H (delta td) (Transducer.eta td) (f, eta sst (q1, a)))"

definition compose_final :: "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'b, 'c) transducer \<Rightarrow>
                             ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2) \<Rightarrow> ('q2 \<times> 'x1 + 'c) list option)" where
  "compose_final sst td = (\<lambda>(q1, f).
     case final sst q1 of
       Some u \<Rightarrow>
         if Transducer.final td (\<Delta> (delta td) (f, \<lambda>x. u) (initial td, ()))
         then Some (H (delta td) (Transducer.eta td) (f, \<lambda>x. u)
                      (initial td, ()))
         else None |
       None \<Rightarrow> None)"

definition compose_SST_Transducer ::
  "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'b, 'c) transducer \<Rightarrow>
   ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'q2 \<times> 'x1, 'a, 'c) SST" where
  "compose_SST_Transducer sst td = \<lparr>
    initial = (initial sst, \<lambda>(q2, x1). q2),
    delta   = compose_\<delta> sst td,
    eta     = compose_\<eta> sst td,
    final   = compose_final sst td
   \<rparr>"

lemma compose_\<delta>_hat: "hat1 (compose_\<delta> sst td) ((q, f), w) =
        (delta_hat sst (q, w),
         \<Delta> (delta td) (f, eta_hat sst (q, w)))"
proof (induct w arbitrary: q f)
  case Nil then show ?case by (simp add: idU_def \<Delta>_def)
next
  case (Cons a u) then show ?case by (simp add: compose_\<delta>_def \<Delta>_assoc)
qed

lemma compose_\<eta>_hat:
  "hat2 (compose_\<delta> sst td) (compose_\<eta> sst td) ((q, f), w) =
   H (delta td) (Transducer.eta td) (f, eta_hat sst (q, w))"
proof (induct w arbitrary: q f)
  case Nil then show ?case by (simp add: idU_def H_def)
next
  case (Cons a u) then show ?case by (simp add: compose_\<delta>_def compose_\<eta>_def H_assoc)
qed

subsection \<open>Property of valuation\<close>

lemma valuate_delta_hat_string: "hat1 (delta2f (\<lambda>(q, x). q) tr) (q, w) = hat1 tr (q, valuate w)"
  by (induct w arbitrary: q rule: xa_induct, simp_all add: empty_def)

lemma valuate_delta_hat: "hat1 tr (q, valuate (u x)) = \<Delta> tr (\<lambda>(q, x). q, u) (q, x)"
  by (simp add: comp_def \<Delta>_def valuate_delta_hat_string)

lemma valuate_eta_hat_string:
  "valuate (Transducer.hat2 (delta2f (\<lambda>(q2, x). q2) tr) (eta2f td) (q, w))
 = Transducer.hat2 tr td (q, valuate w)"
  by (induct w arbitrary: q rule: xa_induct, simp_all)

lemma valuate_eta_hat: "Transducer.hat2 tr td (q, valuate (u x)) = valuate (H tr td (\<lambda>(q, x). q, u) (q, x))"
  by (simp add: H_def valuate_eta_hat_string)

subsection \<open>Main results\<close>

theorem can_compose_SST_Transducer:
  fixes sst :: "('q1, 'x, 'a, 'b) SST"
  fixes td  :: "('q2, 'b, 'c) transducer"
  shows "SST.run (compose_SST_Transducer sst td) w
       = Option.bind (SST.run sst w) (Transducer.run td)"
proof (cases "SST.final sst (delta_hat sst (initial sst, w))")
  case None then show ?thesis
    by (simp add: compose_SST_Transducer_def SST.run_def Transducer.run_def compose_final_def compose_\<delta>_hat)
next
  case (Some output_final1)
  let ?output_of_1st_sst =
    "valuate ((SST.eta_hat sst (initial sst, w) \<bullet> (\<lambda>x. output_final1)) ())"
  show ?thesis
  proof (cases "transducer.final td (delta_hat td (initial td, ?output_of_1st_sst))")
    case False then show ?thesis
      by (simp add: SST.run_def Transducer.run_def Some
            compose_SST_Transducer_def compose_\<delta>_hat compose_final_def valuate_delta_hat \<Delta>_assoc)
  next
    case True then show ?thesis
      by (simp add: SST.run_def compose_SST_Transducer_def compose_final_def
                       Transducer.run_def compose_\<delta>_hat compose_\<eta>_hat Some
                       \<Delta>_assoc valuate_delta_hat
                       compU_ignore
                       valuate_eta_hat
                       H_assoc)
  qed
qed

end


theory Stream_applicative
  imports Main "$HIPSTER_HOME/IsaHipster"
    "../itp2018/types/Stream"
    "../itp2018/Smap"
begin
setup Tactic_Data.set_coinduct_sledgehammer

text_raw \<open>\DefineSnippet{streamapplicative}{\<close>
(* Lifting *)
primcorec spure :: "'a \<Rightarrow> 'a Stream" where
  "shd (spure x) = x"
| "stl (spure x) = spure x"

(* Sequential application *)
primcorec sapp :: " ('a \<Rightarrow> 'b) Stream \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "shd (sapp fs xs) = (shd fs) (shd xs)"
| "stl (sapp fs xs) = sapp (stl fs) (stl xs)"
text_raw \<open>}%EndSnippet\<close>
(*cohipster smap spure sapp*)
(* Discovered in ca 40 seconds *)
text_raw \<open>\DefineSnippet{streamapplout}{\<close>
lemma lemma_ac [thy_expl]: "sapp (spure z) x2 = smap z x2"
  by (coinduction arbitrary: x2 z rule: Stream.Stream.coinduct_strong)
  auto

text_raw \<open>}%EndSnippet\<close>

lemma lemma_ad [thy_expl]: "smap y (spure z) = spure (y z)"
  by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ae [thy_expl]: "smap z (SCons y (spure x2)) = SCons (z y) (spure (z x2))"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_ad)

lemma lemma_af [thy_expl]: "sapp (SCons y (spure z)) (spure x2) = SCons (y x2) (spure (z x2))"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: Stream_applicative.lemma_ac lemma_ad)
end