section \<open>Abstract syntax for Logic\<close>

theory syntax_sl
  imports
    Main HOL.Real
    Ordinary_Differential_Equations.ODE_Analysis
begin

text \<open>States\<close>

type_synonym 'a eval = "real^('a :: finite)"

type_synonym 'a state = "'a eval"

definition update :: "'a :: finite state \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a state"
  where "update u a r = (\<chi> i. if i = a then r else  u $ i)"

definition Vagree :: "('a :: finite) state \<Rightarrow> 'a state \<Rightarrow> 'a set \<Rightarrow> bool"
  where "Vagree u v V ==
     (\<forall> i.  i \<in> V \<longrightarrow>  u $ i =  v $ i)"

lemma Vagree_eq:"Vagree \<nu> \<omega> UNIV \<Longrightarrow> \<nu> = \<omega>"
  unfolding Vagree_def
  by (simp add: vec_eq_iff prod.expand)

type_synonym 'a exp = "'a state \<Rightarrow> real"

text \<open>first-order formulas\<close>
type_synonym 'a fform = "'a state => bool"
definition fTrue :: "'a fform" where "fTrue \<equiv> \<lambda>s. True"
definition fFalse :: "'a fform" where "fFalse \<equiv> \<lambda>s. False"
declare fTrue_def [simp]
declare fFalse_def [simp]

definition fEqual :: "'a exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  (infixl "[=]" 50) where
  "e [=] f \<equiv> \<lambda>s. e s = f s"

definition fLess :: "'a exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  ("(_/ [<] _)"  [51, 51] 50) where
  "e [<] f \<equiv> \<lambda>s. (e s < f s)"

definition fAnd :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[&]" 35) where
  "P [&] Q \<equiv> \<lambda>s. P s \<and> Q s"

definition fOr :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[\<or>]" 30) where
  "P [\<or>] Q \<equiv> \<lambda>s. P s \<or> Q s"

definition fNot :: "'a fform \<Rightarrow> 'a fform"  ("[\<not>]_" [40] 40) where
  "[\<not>]P \<equiv> \<lambda>s. \<not> P s"

definition fImp :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[\<longrightarrow>]" 25) where
  "P [\<longrightarrow>] Q \<equiv> \<lambda>s. P s \<longrightarrow> Q s"

definition fLessEqual :: "'a  exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  ("(_/ [\<le>] _)"  [51, 51] 50) where
  "e [\<le>] f \<equiv> (e [=] f) [\<or>] (e [<] f)"

definition fGreaterEqual :: "'a exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"   ("(_/ [\<ge>] _)"  [51, 51] 50) where
  "e [\<ge>] f \<equiv> \<lambda>s. (e s \<ge> f s)"

definition fGreater :: "'a exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"   ("(_/ [>] _)"  [51, 51] 50) where
  "e [>] f == [\<not>](e [\<le>] f)"

text \<open>Types for defining HCSP\<close>
type_synonym cname = string
type_synonym time = real
type_synonym var = string

text \<open>Communication processes of HCSP\<close>
datatype 'a comm =
  Send cname "'a exp"         ("_[!]_" [110,108] 100)
  | Receive cname 'a      ("_[?]_" [110,108] 100)

datatype 'a ODE =
  ODE "'a set" "'a \<Rightarrow> 'a exp"

fun ODE_vars :: "'a ODE \<Rightarrow> 'a set" where
  "ODE_vars (ODE S f) = S"

text \<open>HCSP processes\<close>
datatype 'a proc =
  Cm "'a comm"
| Skip
| Ass 'a "'a exp"             ("_ ::= _" [99,95] 94)
| Seq "'a proc" "'a proc"           ("_; _" [91,90] 90)
| Cond "'a fform" "'a proc"         ("IF _ _" [95,94] 93)
| IFELSE "'a fform" "'a proc" "'a proc"     ("IFELSE _ _ _" [95,94] 93)
(*| Pref comm proc          ("_\<rightarrow>_" [95,94] 93)*)
| IChoice "'a proc" "'a proc"          (infixr "\<sqinter>" 90)
| EChoice "'a comm" "'a proc" "'a comm" "'a proc"          ("_ \<rightarrow>  _ [] _ \<rightarrow> _" [92,91,92,91] 90)
\<comment> \<open>Repetition is annotated with invariant\<close>
| Rep "'a proc" "'a fform"          ("_*&&_" [91] 90)
| RepN "'a proc" nat           ("_* NUM _" [91, 90] 90)
\<comment> \<open>Continuous evolution is annotated with invariant.\<close>
| Cont "'a ODE" "'a fform" "'a fform"  ("<_&&_&_>" [95,95,96] 94)
| InterOne "'a proc" "'a comm" "'a proc"       ("_ |> _ \<rightarrow> _" [95,94,94] 94)
| InterTwo "'a proc" "'a comm" "'a proc" "'a comm" "'a proc"         ("_ |>> _ \<rightarrow> _, _ \<rightarrow> _" [95,94,94,94,94] 94)

text \<open>We assume parallel composition only occurs in the topmost level.\<close>
datatype 'a procP = Par "'a proc"  "'a proc"  (infixr "||" 89)

type_synonym now = real

type_synonym 'a history = "time \<Rightarrow> 'a state"
fun extend_history :: "'a::finite history \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a history" where
  "extend_history f a d = (\<lambda> t. if t > a \<and> t \<le> a + d then f a else f t)"

subsection \<open>Five kinds of events for HCSP processes\<close>
datatype event =
  Tau
| In cname real
| Out cname real
| IO cname real
| Delay time

subsection \<open>Auxiliary functions needed to be introduced first.\<close>

text \<open>Two events are compatible if they are In-Out pairs.\<close>
primrec compat :: "event \<Rightarrow> event \<Rightarrow> bool" where
  "compat Tau ev = False"
| "compat (In ch val) ev = (if ev = Out ch val then True else False)"
| "compat (Out ch val) ev = (if ev = In ch val then True else False)"
| "compat (IO ch val) ev = False"
| "compat (Delay d) ev = False"

text \<open>handshake between an In-Out pair is an IO event.\<close>
primrec handshake :: "event \<Rightarrow> event \<Rightarrow> event" where
  "handshake Tau ev = Tau"
| "handshake (In ch val) ev = (if ev = Out ch val then IO ch val else Tau)"
| "handshake (Out ch val) ev = (if ev = In ch val then IO ch val else Tau)"
| "handshake (IO ch val) ev = Tau"
| "handshake (Delay d) ev = Tau"

text \<open>Set of channels of a procedure\<close>
primrec chansetC :: "'a comm => string set" where
  "chansetC (ch[!]e) = {ch}"
| "chansetC (ch[?]e) = {ch}"

primrec chanset :: "'a proc \<Rightarrow> string set" where
  "chanset (Cm r) = chansetC r"
| "chanset Skip = {}"
| "chanset (e ::= f) = {}"
| "chanset (P; Q) = chanset P \<union> chanset Q"
| "chanset (IF b P) = chanset P"
| "chanset (IFELSE b P Q) = chanset P \<union> chanset Q"
| "chanset (P \<sqinter> Q) = chanset P \<union> chanset Q"
| "chanset (c \<rightarrow> P [] d \<rightarrow> Q) = chansetC c  \<union> chansetC d  \<union> chanset P \<union> chanset Q"
| "chanset (P *&& Inv) = chanset P"
| "chanset (P * NUM n) = chanset P"
| "chanset (<ODEs && Inv & b>) = {}"
| "chanset (P |> c \<rightarrow> Q) = chanset P \<union> chanset Q \<union> chansetC c"
| "chanset (P |>> c \<rightarrow> Q, d \<rightarrow> F) = chanset P \<union> chanset Q \<union> chansetC c \<union> chansetC d \<union> chanset F"

subsection \<open>Definitions for ODEs\<close>

text \<open>the value of vector field\<close>
fun ODE2Vec :: "('a :: finite) ODE \<Rightarrow> 'a state \<Rightarrow> 'a state" where
  "ODE2Vec (ODE S f) s = (\<chi> a. if a \<in> S then f a s else 0)"

definition ODEsol :: "('a :: finite) ODE \<Rightarrow> (real \<Rightarrow> 'a state) \<Rightarrow>real \<Rightarrow> bool" where
  "ODEsol ode p d = ((d\<ge>0) \<and> ((p has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {0 .. d}))"

definition ODEstate :: "('a :: finite) ODE \<Rightarrow> real \<Rightarrow> 'a state \<Rightarrow> 'a state \<Rightarrow> bool" where
  "ODEstate ode d u v = (d\<ge>0 \<and> (\<exists> f . ODEsol ode f d \<and> u = f 0 \<and> v = f d ))"

lemma veclim:"((\<lambda>y. v y) \<longlongrightarrow> 0) (at t within D) \<Longrightarrow> ((\<lambda>y. v y $ i) \<longlongrightarrow> 0) (at t within D)"
  using tendsto_vec_nth by fastforce

lemma proj:
  assumes "(p has_vector_derivative q t) (at t within D) "
  shows "((\<lambda>t. p t $ i) has_vector_derivative q t $ i) (at t within D) "
  using assms unfolding has_vector_derivative_def has_derivative_def
  apply (simp add: bounded_linear_scaleR_left)
  using veclim by fastforce

lemma mvt_real_eq:
  fixes p :: "real \<Rightarrow>real"
 assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
  and "d\<ge>0"
  and "\<forall>t\<in>{0 .. d}. \<forall>s. q t s = 0"
  and "x\<in>{0 .. d}"
  shows "p 0 = p x"
proof-
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (meson atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_within_subset in_mono order_refl)
  then show ?thesis
  using assms
  using mvt_simple[of 0 x p q]
  by force
qed

lemma mvt_real_ge:
  fixes p :: "real \<Rightarrow>real"
 assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
  and "d\<ge>0"
  and "\<forall>t\<in>{0 .. d}. \<forall>s\<ge>0. q t s \<ge> 0"
  and "x\<in>{0 .. d}"
  shows "p 0 \<le> p x "
  proof-
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (meson atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_within_subset in_mono order_refl)
  then show ?thesis
  using assms
  using mvt_simple[of 0 x p q]
  by (smt atLeastAtMost_iff greaterThanLessThan_iff)
qed

lemma mvt_real_le:
  fixes p :: "real \<Rightarrow>real"
 assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
  and "d\<ge>0"
  and "\<forall>t\<in>{0 .. d}. \<forall>s\<ge>0 . q t s \<le> 0"
    and "x\<in>{0 .. d}"
  shows "p 0 \<ge> p x "
  proof-
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (meson atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_within_subset in_mono order_refl)
  then show ?thesis
  using assms
  using mvt_simple[of 0 x p q]
  by (smt atLeastAtMost_iff greaterThanLessThan_iff)
qed

lemma mvt_vector:
  fixes p :: "real \<Rightarrow> ('a :: finite) state"
  assumes "\<forall>t\<in>{0 .. d}. ((p has_vector_derivative q t) (at t within {0 .. d}) \<and> q t $ i = 0)"
  and "d\<ge>0"
  shows "p 0 $ i = p d $ i"
proof-
  have step1:"\<forall>t\<in>{0 .. d}. ((\<lambda>t. p t $ i) has_vector_derivative q t $ i) (at t within {0 .. d})"
    using assms proj by blast
  have step2:"\<forall>t\<in>{0 .. d}. q t $ i = 0"
    using assms by auto
  show ?thesis
    using assms step1 step2 unfolding has_vector_derivative_def
    using mvt_simple [where f="(\<lambda>t. p t $ i)" and f'="(\<lambda>t. \<lambda> x. x *\<^sub>R q t $ i)" and a="0" and b="d"]
    by force
qed

lemma odeVagree:
  assumes "ODEstate (ODE S f) d u v "
  shows "Vagree u v (-S)"
proof -
  from assms obtain p  where ode_sol: "ODEsol (ODE S f) p d" "u = p 0" "v = p d" "d\<ge>0"
    using ODEstate_def by blast
  have "u $ i = v $ i" if cond:"i \<notin> S" for i
    using ode_sol cond
    unfolding ODEsol_def has_vderiv_on_def
    using mvt_vector[where p="p" and i="i"  and d="d" and q="\<lambda>x. ODE2Vec (ODE S f) (p x)"]
    by auto
  then show ?thesis
    unfolding Vagree_def by auto
qed

  term "Deriv.has_vector_derivative"
  term "at x within (S::real set)"

lemma chainrule:
  assumes "\<forall> x. ((g :: ('a :: finite) exp ) has_derivative g' x ) (at x within UNIV)"
      and "ODEsol ode p d"
      and "t\<in>{0 .. d}"
    shows "((\<lambda>t. g (p t)) has_derivative (\<lambda>s. g'(p t) (s*\<^sub>R(ODE2Vec ode (p t))))) (at t within {0 .. d}) "
proof-
  have step1:"(\<And>x. x \<in> UNIV \<Longrightarrow> (g has_derivative g' x) (at x))"
    using assms(1) by auto
  have step2:"0 \<le> t \<and> t \<le> d"
    using assms(3) by auto
  have step3:"(p has_derivative (\<lambda>s. s *\<^sub>R ODE2Vec ode (p t))) (at t within {0..d})"
    using step2 assms(2) unfolding ODEsol_def has_vderiv_on_def has_vector_derivative_def by auto
  show ?thesis
  using step1 step2 step3 has_derivative_in_compose2[of UNIV g g' p "{0 .. d}" t "\<lambda>s. (s*\<^sub>R(ODE2Vec ode(p t)))"]
  by auto
qed

lemma derivconst:"((\<lambda>t. c) has_derivative (\<lambda>t. 0)) (at x)"
  unfolding has_derivative_def by auto
lemma derivcoord:"((\<lambda>t. t$i) has_derivative (\<lambda>t. t$i)) (at x)"
  unfolding has_derivative_def by auto

definition INV :: " ('a :: finite) fform  \<Rightarrow> (real \<Rightarrow> 'a state) \<Rightarrow> real \<Rightarrow> bool" where
"INV Inv p d  \<equiv>  ((d \<ge> 0) \<and> (\<forall>t. 0\<le>t\<and>t\<le>d \<longrightarrow> Inv (p t)))"

subsection \<open>Big-step semantics\<close>

text \<open>Continuous evolution domain: assume b is an open formula, otherwise
the escaping point cannot be found.\<close>

inductive semB :: "'a :: finite proc \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> bool" where
  skipB: "semB Skip now f now f"
| assignB: "semB (x ::= e) now f
    now (\<lambda>t. if t = now then update (f t) x ( e (f t)) else f t)"
| continuous: "d \<ge> 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow>
    (\<forall> t. (t \<ge> 0 \<and> t < d \<longrightarrow> b (p t))) \<Longrightarrow> \<not> b (p d) \<Longrightarrow> f now = p 0 \<Longrightarrow>
    semB (<ode && Inv&b>) now f
      (now + d) (\<lambda>t. if t \<le> now + d \<and> t \<ge> now then
                       p (t-now)
                     else f t)"
| sequenceB: "semB P now f now' f' \<and> semB Q now' f' now'' f'' \<Longrightarrow> semB (P; Q) now f now'' f''"
| conditionBT: " b (f now) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (IF b P) now f now_d f_d"
| conditionBF: "\<not>b (f now) \<Longrightarrow> semB (IF b P) now f now f"
| IFELSET: " b (f now) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (IFELSE b P Q) now f now_d f_d"
| IFELSEF: "\<not>b (f now) \<Longrightarrow> semB Q now f now_d f_d \<Longrightarrow> semB (IFELSE b P Q) now f now_d f_d"
| IChoiceBL: "semB P now f now' f' \<Longrightarrow> semB (P \<sqinter> Q) now f now' f'"
| IChoiceBR: "semB Q now f now' f' \<Longrightarrow> semB (P \<sqinter> Q) now f now' f'"
| EChoiceL: "d \<ge> 0 \<Longrightarrow> semB P (now + d) (extend_history f now d) now' f' \<Longrightarrow>
             semB (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f now' f'"
| EChoiceR: "d \<ge> 0 \<Longrightarrow> semB (x ::= (\<lambda>_. c); Q) (now + d) (extend_history f now d) now' f' \<Longrightarrow>
             semB (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f now' f'"
| repetitionN0B: "N = (0::nat) \<Longrightarrow> semB (P * NUM N) now f now f"
| repetitionNkB: "N > (0::nat) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (P * NUM (N-1)) now_d f_d now_dd f_dd \<Longrightarrow>
                  semB (P * NUM N) now f now_dd f_dd"
| repetitionB: "\<exists>N. semB (P * NUM N) now f now_dd f_dd \<Longrightarrow> semB (P*&&Inv) now f now_dd f_dd"
(*| outputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch[!]e)) now f (now+d) (extend_history f now d)"
| inputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch[?]x)) now f (now + d)
            (\<lambda>t. if t < now + d \<and> t > now then f now
                 else if t = now + d then update (f now) x c
                 else f t)"
*)
(*Notice: no real meaning of c in the inputBC. It will not be used actually without a synchronized output.*)

inductive_cases SkipE[elim!]:
  "semB Skip now f now' f'"
inductive_cases AssignE[elim!]:
  "semB (x ::= e) now f now' f'"
inductive_cases SeqE[elim!]:
  "semB (P; Q) now f now' f'"
inductive_cases CondE[elim!]:
  "semB (IF b P) now f  now' f'"
inductive_cases IFELSEE[elim!]:
  "semB (IFELSE b P Q) now f  now' f'"
inductive_cases IChE[elim!]:
  "semB (P \<sqinter> Q) now f now' f'"
inductive_cases ContE[elim!]:
  "semB (<ode && Inv&b>) now f now' f'"
inductive_cases RepE[elim!]:
  "semB (P*&&Inv) now f now' f'"
inductive_cases RepNE[elim!]:
  "semB (P* NUM N) now f now' f'"
thm ContE

text \<open>There are four cases for semantics of parallel composition.\<close>
inductive semBP :: "'a::finite procP \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> bool" where
  parallelB1: "semB P nowp fp nowp' fp' \<Longrightarrow> semB Q nowq fq nowq' fq' \<Longrightarrow> chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
               semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"
| parallelB2: "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semB U nowp' fp' nowu' fu' \<Longrightarrow> semB V nowq' fq' nowv' fv' \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
               chanset U = {} \<and> chanset V = {} \<Longrightarrow>
               semBP ((P; U) || (Q; V)) nowp fp nowq fq  nowu' fu' nowv' fv'"
(*B3 and B4 are symmetric*)
| parallelB3: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semBP (P; Cm (ch[?]x) || Q; Cm (ch[!]e)) nowp fp nowq fq
               (max nowp' nowq')
               (\<lambda>t. if nowp' < t \<and> t < max nowp' nowq' then fp' nowp'
                    else if t = max nowp' nowq' then update (fp' nowp') x ( e (fp' nowp'))
                    else fp' t)
               (max nowp' nowq')
               (\<lambda>t. if nowq' < t \<and> t \<le> max nowp' nowq' then fq' nowq' else fq' t)"
| parallelB4: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semBP (P; Cm (ch[!]e) || Q; Cm (ch[?]x)) nowp fp nowq fq
               (max nowp' nowq')
               (\<lambda>t. if nowp' < t \<and> t \<le> max nowp' nowq' then fp' nowp' else fp' t)
               (max nowp' nowq')
               (\<lambda>t. if nowq' < t \<and> t < max nowp' nowq' then fq' nowq'
                    else if t = max nowp' nowq' then update (fq' nowq') x ( e (fq' nowq'))
                    else fq' t)"
(*P terminates after Q, so ode is not executed*)
| parallelB5:  "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' \<ge> nowq' \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[!]e \<rightarrow> E)) || (Q; Cm (ch[?]x))) nowp fp nowq fq
               nowp' fp' nowp'
               (\<lambda>t. if nowq' < t \<and> t < nowp' then fq' nowq'
                    else if t = nowp' then update (fq' nowq') x (e (fp' nowp'))
                    else fq' t)"
(*P terminates earlier than Q and b is true when the communication is ready to occur, so E will be executed*)
| parallelB6: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' < nowq' \<Longrightarrow>
                d = (nowq' - nowp') \<Longrightarrow>
               ODEsol ode sol d \<Longrightarrow> ((\<forall> t. (t \<ge> 0 \<and> t \<le> d \<longrightarrow> b (sol t)))) \<Longrightarrow>
               semB E nowq' (\<lambda>t. if nowp' < t \<and> t \<le> nowq' then sol (t - nowp')
                    else fp' t) nowp'' fp'' \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[!]e \<rightarrow> E)) || (Q; Cm (ch[?]x))) nowp fp nowq fq
               nowp'' fp''
               nowq' (\<lambda>t. if t = nowq' then update (fq' nowq') x (e (sol d))
                    else fq' t)"
(*P terminates earlier than Q and b turns false before the communication becomes ready.*)
| parallelB7: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' < nowq' \<Longrightarrow>
                d \<ge> 0 \<Longrightarrow> d < (nowq' - nowp') \<Longrightarrow>
               ODEsol ode sol d \<Longrightarrow> ((\<forall> t. (t \<ge> 0 \<and> t < d \<longrightarrow> b (sol t)))) \<Longrightarrow> \<not>b (sol d) \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[!]e \<rightarrow> E)) || (Q; Cm (ch[?]x))) nowp fp nowq fq
               (nowp'+ d) (\<lambda>t. if nowp' < t \<and> t \<le> nowp'+d then sol (t - nowp')
                    else fp' t)
               nowq' fq'"
(*The following three rules are symmetric with the above B5, B6 and B7*)
(*P terminates after Q, so ode is not executed*)
| parallelB8:  "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' \<ge> nowq' \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[?]x \<rightarrow> E)) || (Q; Cm (ch[!]e))) nowp fp nowq fq
               nowp' (\<lambda>t. if t = nowp' then update (fp' nowp') x (e (fq' nowq'))
                      else fp' t)
               nowp' (\<lambda>t. if nowq' < t \<and> t \<le> nowp' then fq' nowq'
                      else fq' t)"
(*P terminates earlier than Q and b is true when the communication is ready to occur, so E will be executed*)
| parallelB9: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' < nowq' \<Longrightarrow>
                d = (nowq' - nowp') \<Longrightarrow>
               ODEsol ode sol d \<Longrightarrow> ((\<forall> t. (t \<ge> 0 \<and> t \<le> d \<longrightarrow> b (sol t)))) \<Longrightarrow>
               semB E nowq' (\<lambda>t. if nowp' < t \<and> t < nowq' then sol (t - nowp')
                    else if t = nowq' then update (sol d) x (e (fq' nowq'))
                    else fp' t) nowp'' fp'' \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[?]x \<rightarrow> E)) || (Q; Cm (ch[!]e))) nowp fp nowq fq
               nowp'' fp''
               nowq' fq'"
(*P terminates earlier than Q and b turns false before the communication becomes ready.*)
| parallelB10: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp' < nowq' \<Longrightarrow>
                d \<ge> 0 \<Longrightarrow> d < (nowq' - nowp') \<Longrightarrow>
               ODEsol ode sol d \<Longrightarrow> ((\<forall> t. (t \<ge> 0 \<and> t < d \<longrightarrow> b (sol t)))) \<Longrightarrow> \<not>b (sol d) \<Longrightarrow>
               semBP (((P; (<ode&&Inv&b>)|> ch[?]x \<rightarrow> E)) || (Q; Cm (ch[!]e))) nowp fp nowq fq
               (nowp'+d) (\<lambda>t. if nowp' < t \<and> t \<le> nowp'+d then sol (t - nowp')
                    else fp' t)
               nowq' fq'"

inductive_cases ParaE[elim!]:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"

lemma sem1:
  "semB P now f now' f' \<Longrightarrow> now \<le> now'"
  by (induct rule: semB.induct, auto)

lemma semB1:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp \<le> nowp' \<and> nowq \<le> nowq'"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case  using sem1 by blast
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case  by (metis order_trans sem1)
next
  case (parallelB3 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch x e)
  then show ?case
    by linarith
next
  case (parallelB4 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch e x)
  then show ?case
    by linarith
next
  case (parallelB5 P Q nowp fp nowq fq nowp' fp' nowq' fq' ode Inv b ch e E x)
  then show ?case
    by auto
next
  case (parallelB6 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b E nowp'' fp'' Inv ch e x)
  then show ?case
    by (smt sem1)
next
  case (parallelB7 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b Inv ch e E x)
  then show ?case
    by linarith

next
  case (parallelB8 P Q nowp fp nowq fq nowp' fp' nowq' fq' ode Inv b ch x E e)
  then show ?case by auto
next
  case (parallelB9 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b E x e nowp'' fp'' Inv ch)
then show ?case by (smt sem1)
next
  case (parallelB10 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b Inv ch e E x)
  then show ?case by linarith
qed

lemma sem2:
  "semB P now f now' f' \<Longrightarrow> \<forall>t. t < now \<or> t > now' \<longrightarrow> f t = f' t"
proof (induct rule: semB.induct)
   case (sequenceB P now f now' f' Q now'' f'')
  then show ?case by (metis (full_types) le_less_trans not_le sem1)
next
   case (EChoiceL d P now f now' f' ch e dh x Q)
  then show ?case
    by (smt extend_history.simps sem1)
next
  case (EChoiceR d x c Q now f now' f' ch e P dh)
  then show ?case by (smt extend_history.simps sem1)
next
  case (repetitionNkB N P now f now_d f_d now_dd f_dd)
  then show ?case  by (metis (full_types) le_less_trans less_eq_real_def sem1)
qed auto

lemma semB2:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
    (\<forall>t. t < nowp \<or> t > nowp' \<longrightarrow> (fp t = fp' t)) \<and>
    (\<forall>t. t < nowq \<or> t > nowq' \<longrightarrow> (fq t = fq' t))"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case
    using sem2 by blast
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case  by (smt sem1 sem2 semB1)
next
  case (parallelB3 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch x e)
  then show ?case by (smt semB1)
next
  case (parallelB4 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch e x)
  then show ?case by (smt semB1)
next
  case (parallelB5 P Q nowp fp nowq fq nowp' fp' nowq' fq' ode Inv b ch e E x)
  then show ?case sorry
next
  case (parallelB6 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b E nowp'' fp'' Inv ch e x)
  then show ?case sorry
next
  case (parallelB7 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b Inv ch e E x)
  then show ?case sorry
next
  case (parallelB8 P Q nowp fp nowq fq nowp' fp' nowq' fq' ode Inv b ch x E e)
  then show ?case sorry
next
  case (parallelB9 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b E x e nowp'' fp'' Inv ch)
  then show ?case sorry
next
  case (parallelB10 P Q nowp fp nowq fq nowp' fp' nowq' fq' d ode sol b Inv ch x E e)
  then show ?case sorry
qed

lemma semB3:
  "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
   chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
   semB P nowp fp nowp' fp' \<and> semB Q nowq fq nowq' fq'"
  by (induct rule: semBP.cases; simp add: chanset_def)

text \<open>history formulas\<close>
type_synonym now_dash = real
type_synonym 'a dform = "'a history \<Rightarrow> now \<Rightarrow> now_dash \<Rightarrow> bool"

text \<open>The dform formula is only decided by the interval between now and now_dash\<close>
definition well_DC :: "'a dform \<Rightarrow> bool" where
"well_DC df == (\<forall> now now' h h'. (now \<le> now' \<and> (\<forall>t. t > now \<and> t < now' \<longrightarrow> h t = h' t)) \<longrightarrow> df h now now' = df h' now now')"

subsection \<open>Duration Calculus operators and lemmas proved\<close>
text \<open>almost P, P holds everywhere except for the rightmost point, not almost everywhere, over the interval.
The reason is that, for continuous evolution, it escapes whenever a violation is met.
A special case is that, if using almost everywhere, the differential cut rule will not hold anymore.\<close>
definition almost :: "'a fform \<Rightarrow> 'a dform"  where
"almost P \<equiv> \<lambda>h n nd. (nd-n > 0) \<and> (\<forall>t. t \<ge> n \<and> t < nd \<longrightarrow> P (h (t)))"

definition chop :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[^]" 40) where
  "H [^] M \<equiv> \<lambda>h n nd. \<exists>nm. nm \<ge> n \<and> nm \<le> nd \<and> H h n nm \<and> M h nm nd"

text \<open>The length of the interval l is equal to, greater than, less than T.\<close>
definition elE :: "real \<Rightarrow> 'a dform" where
  "elE T \<equiv> \<lambda>h n nd. (nd-n) = T"
definition elG :: "real \<Rightarrow> 'a dform" where
  "elG T \<equiv> \<lambda>h n nd. (nd-n) > T"
definition elL :: "real \<Rightarrow> 'a dform" where
  "elL T \<equiv> \<lambda>h n nd. (nd-n) < T"

definition dAnd :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[&]]" 35) where
  "P [[&]] Q \<equiv> \<lambda>h n m. P h n m \<and> Q h n m"
definition dOr :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[\<or>]]" 30) where
  "P [[\<or>]] Q \<equiv> \<lambda>h n m. P h n m \<or> Q h n m"
definition dNot :: "'a dform \<Rightarrow> 'a dform"  ("[[\<not>]]_" 40) where
  "[[\<not>]]P \<equiv> \<lambda>h n m. \<not> P h n m"
definition dImp :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[\<longrightarrow>]]" 25) where
  "P [[\<longrightarrow>]] Q \<equiv> \<lambda>h n m. P h n m \<longrightarrow> Q h n m"

declare almost_def [simp]
declare chop_def [simp]
declare elE_def [simp]
declare elG_def [simp]
declare elL_def [simp]

text \<open>True holds almost everywhere\<close>
lemma almostf:
  "\<forall>h n nd. nd - n \<le> 0 \<or> almost fTrue h n nd"
  apply simp
  by (metis dense not_le)

text \<open>almost P \<Leftrightarrow> chop almost P almost P\<close>
lemma chopfb:
  "chop (almost P) (almost P) h n nd \<Longrightarrow> almost P h n nd"
  unfolding chop_def almost_def
  apply (rule conjI, auto)
  by (metis (poly_guards_query) less_eq_real_def less_trans not_less)

text \<open>chop (almost P \/ l = 0) (almost P \/ l = 0) ==> almost P \/ l = 0 \<close>
lemma chopfor:
  "chop (elE 0 [[\<or>]] almost P) (elE 0 [[\<or>]] almost P) h n nd \<Longrightarrow> (elE 0 [[\<or>]] almost P) h n nd"
  unfolding dOr_def
  apply (rule disjCI, auto)
  by (metis less_eq_real_def less_trans not_less)

lemma chopf:
  "almost P h n nd \<Longrightarrow> chop (almost P) (almost P) h n nd"
  unfolding almost_def chop_def
  apply (rule exI[where x = "(n+nd)/2"])
  by auto

lemma chop0L: "chop (almost P) (elE 0) h n nd \<Longrightarrow> almost P h n nd"
  by auto

lemma chop0R: "almost P h n nd \<Longrightarrow> chop (almost P) (elE 0) h n nd"
  by auto

lemma chop_well_DC: "well_DC Ha \<Longrightarrow> well_DC Hb \<Longrightarrow> well_DC (Ha [^] Hb)"
  unfolding chop_def well_DC_def
  apply auto
  apply smt
  apply smt
  done

text \<open>Monotonicity: s \<Rightarrow> t \<Longrightarrow> almost s \<Rightarrow> almost t\<close>
lemma almostmono:
  "\<forall>s. P s \<longrightarrow> Q s \<Longrightarrow> \<forall>h n nd. almost P h n nd \<longrightarrow> almost Q h n nd"
  by auto

lemma almostint:
  "now < nowf \<Longrightarrow> \<forall>t. (t\<ge>now \<and> t<nowf) \<longrightarrow> P (f t) \<Longrightarrow> almost P f now nowf"
  by auto

end


(*  Title:      HOL/HOLCF/IMP/Denotational.thy
    Author:     Tobias Nipkow and Robert Sandner, TUM
    Copyright   1996 TUM
*)

section "Denotational Semantics of Commands in HOLCF"

theory Denotational imports HOLCF "HOL-IMP.Big_Step" begin

subsection "Definition"

definition
  dlift :: "(('a::type) discr -> 'b::pcpo) => ('a lift -> 'b)" where
  "dlift f = (LAM x. case x of UU \<Rightarrow> UU | Def y \<Rightarrow> f\<cdot>(Discr y))"

primrec D :: "com \<Rightarrow> state discr \<rightarrow> state lift"
where
  "D(SKIP) = (LAM s. Def(undiscr s))"
| "D(X ::= a) = (LAM s. Def((undiscr s)(X := aval a (undiscr s))))"
| "D(c0 ;; c1) = (dlift(D c1) oo (D c0))"
| "D(IF b THEN c1 ELSE c2) =
        (LAM s. if bval b (undiscr s) then (D c1)\<cdot>s else (D c2)\<cdot>s)"
| "D(WHILE b DO c) =
        fix\<cdot>(LAM w s. if bval b (undiscr s) then (dlift w)\<cdot>((D c)\<cdot>s)
                      else Def(undiscr s))"

subsection
  "Equivalence of Denotational Semantics in HOLCF and Evaluation Semantics in HOL"

lemma dlift_Def [simp]: "dlift f\<cdot>(Def x) = f\<cdot>(Discr x)"
  by (simp add: dlift_def)

lemma cont_dlift [iff]: "cont (%f. dlift f)"
  by (simp add: dlift_def)

lemma dlift_is_Def [simp]:
    "(dlift f\<cdot>l = Def y) = (\<exists>x. l = Def x \<and> f\<cdot>(Discr x) = Def y)"
  by (simp add: dlift_def split: lift.split)

lemma eval_implies_D: "(c,s) \<Rightarrow> t \<Longrightarrow> D c\<cdot>(Discr s) = (Def t)"
apply (induct rule: big_step_induct)
      apply (auto)
 apply (subst fix_eq)
 apply simp
apply (subst fix_eq)
apply simp
done

lemma D_implies_eval: "\<forall>s t. D c\<cdot>(Discr s) = (Def t) \<longrightarrow> (c,s) \<Rightarrow> t"
apply (induct c)
    apply fastforce
   apply fastforce
  apply force
 apply (simp (no_asm))
 apply force
apply (simp (no_asm))
apply (rule fix_ind)
  apply (fast intro!: adm_lemmas adm_chfindom ax_flat)
 apply (simp (no_asm))
apply (simp (no_asm))
apply force
done

theorem D_is_eval: "(D c\<cdot>(Discr s) = (Def t)) = ((c,s) \<Rightarrow> t)"
by (fast elim!: D_implies_eval [rule_format] eval_implies_D)

end


theory Exceptions
imports
  Main
  "List-Index.List_Index"
  List_extra
begin

datatype ltype=
Unit | Fun ltype ltype (infixr "\<rightarrow>"  225) | VariantType "string list" "ltype list"("<(_):=(_)>" [201,200]225) |
Ty string | ListT ltype ("\<lambda>List (_)" 225) | Bool

datatype lterm=
  LTrue
| LFalse
| LVar nat
| LApp lterm lterm
| LAbs ltype lterm
| unit
| error
| Lnil ltype
| Lcons ltype lterm lterm
| Lisnil ltype lterm
| Lhead ltype lterm
| Ltail ltype lterm

fun shift_L :: "int \<Rightarrow> nat \<Rightarrow> lterm \<Rightarrow> lterm" where
 "shift_L d c (LVar k)    = LVar (if k < c then k else nat (int k + d))" |
 "shift_L d c (LApp t t1) = LApp (shift_L d c t) (shift_L d c t1)" |
 "shift_L d c (LAbs T t)  = LAbs T (shift_L d (Suc c) t)" |
  "shift_L d c (Lisnil A t) = Lisnil A (shift_L d c t)"|
  "shift_L d c (Lcons A t t') = Lcons A (shift_L d c t) (shift_L d c t')"|
  "shift_L d c (Lhead A t) = Lhead A (shift_L d c t)"|
  "shift_L d c (Ltail A t) = Ltail A (shift_L d c t)" |
  "shift_L d c t = t"

fun subst_L :: "nat \<Rightarrow> lterm \<Rightarrow> lterm \<Rightarrow> lterm" where
 "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)" |
 "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
 "subst_L j s (LAbs T t) = LAbs T (subst_L (Suc j) (shift_L 1 0 s) t)"|
  "subst_L j s (Lisnil A t) = Lisnil A (subst_L j s t)"|
  "subst_L j s (Lcons A t t') = Lcons A (subst_L j s t) (subst_L j s t')"|
  "subst_L j s (Lhead A t) = Lhead A (subst_L j s t)" |
  "subst_L j s (Ltail A t) = Ltail A (subst_L j s t)"|
  "subst_L j s t = t"

inductive is_value_L :: "lterm \<Rightarrow> bool" where
  "is_value_L LTrue"|
  "is_value_L LFalse"|
  "is_value_L unit"|
  "is_value_L (LAbs T t)"|
  VNil  :"is_value_L (Lnil A)"|
  VCons :"is_value_L v1 \<Longrightarrow> is_value_L v2 \<Longrightarrow> is_value_L (Lcons A v1 v2)"

inductive eval1_L :: "lterm \<Rightarrow> lterm \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LApp t1 t2) (LApp t1' t2)" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 t2' \<Longrightarrow> eval1_L (LApp v1 t2) (LApp v1 t2')" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T t12) v2)
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12))" |
  eval1_LErrApp1:
    "eval1_L (LApp error t) error"|
  eval1_LErrApp2:
    "is_value_L v \<Longrightarrow> eval1_L (LApp v error) error" |
   eval1_Lcons1:
    "eval1_L t t1 \<Longrightarrow> eval1_L (Lcons A t t') (Lcons A t1 t')"|
  eval1_Lcons2:
    "is_value_L v \<Longrightarrow> eval1_L t' t1 \<Longrightarrow> eval1_L (Lcons A v t') (Lcons A v t1)"|
  eval1_LErrCons1:
    "eval1_L (Lcons A error t) error"|
  eval1_LErrCons2:
    "is_value_L v \<Longrightarrow> eval1_L (Lcons A v error) error" |
  eval1_Lisnil_nil:
    "eval1_L (Lisnil A (Lnil A)) LTrue"|
   eval1_Lisnil_cons:
    "is_value_L v1 \<Longrightarrow> is_value_L v2 \<Longrightarrow> eval1_L (Lisnil A (Lcons A v1 v2)) LFalse"|
  eval1_Lisnil_step:
    "eval1_L t t' \<Longrightarrow> eval1_L (Lisnil A t) (Lisnil A t')"|
  eval1_Lisnil_error:
    "eval1_L (Lisnil A error) error"|
  eval1_Lhead_cons:
    "is_value_L v1 \<Longrightarrow> is_value_L v2 \<Longrightarrow> eval1_L (Lhead A (Lcons A v1 v2)) v1" |
  eval1_Lhead_step:
    "eval1_L t t1 \<Longrightarrow> eval1_L (Lhead A t) (Lhead A t1)"|
  eval1_Lhead_nil:
    "eval1_L (Lhead A (Lnil B)) error"|
  eval1_Lhead_error:
    "eval1_L (Lhead A error) error" |
  eval1_Ltail_cons:
    "is_value_L v1 \<Longrightarrow> is_value_L v2 \<Longrightarrow> eval1_L (Ltail A (Lcons A v1 v2)) v2" |
  eval1_Ltail_step:
    "eval1_L t t1 \<Longrightarrow> eval1_L (Ltail A t) (Ltail A t1)"|
  eval1_Ltail_nil:
    " eval1_L (Ltail A (Lnil B)) error"|
  eval1_Ltail_error:
    "eval1_L (Ltail A error) error"

type_synonym lcontext = "ltype list"

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T \<equiv> T # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

inductive  has_type_L :: "lcontext \<Rightarrow> lterm \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile> (_)/ |:| (_))" [150, 150, 150] 150) where
  has_type_LTrue:
    "\<Gamma> \<turnstile> LTrue |:| Bool" |
  has_type_LFalse:
    "\<Gamma> \<turnstile> LFalse |:| Bool" |
  has_type_Lunit:
    "\<Gamma> \<turnstile> unit |:| Unit" |
  has_type_LVar:
    "(x, T) |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> (LVar x) |:| T" |
  has_type_LAbs:
    "(\<Gamma> |,| T1) \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile> (LAbs T1 t2) |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma> \<turnstile> t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile> (LApp t1 t2) |:| T12" |
  has_type_error:
    "\<Gamma> \<turnstile> error |:| T"|
  has_type_Nil:
    "\<Gamma> \<turnstile>  Lnil A  |:| \<lambda>List A"|
  has_type_isNil:
    "\<Gamma> \<turnstile>  t |:| \<lambda>List A \<Longrightarrow>\<Gamma> \<turnstile>  Lisnil A t |:| Bool"|
  has_type_head:
    "\<Gamma> \<turnstile> t |:| \<lambda>List A \<Longrightarrow>\<Gamma> \<turnstile> Lhead A t |:| A"|
  has_type_tail:
    "\<Gamma> \<turnstile> t |:| \<lambda>List A \<Longrightarrow>\<Gamma> \<turnstile> Ltail A t |:| \<lambda>List A"|
  has_type_cons:
    "\<Gamma> \<turnstile> t |:| A \<Longrightarrow> \<Gamma> \<turnstile> t' |:| \<lambda>List A \<Longrightarrow>
      \<Gamma> \<turnstile> Lcons A t t' |:| \<lambda>List A"

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Bool \<Longrightarrow> v = LTrue \<or> v = LFalse"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Unit \<Longrightarrow> v = unit"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| \<lambda>List A \<Longrightarrow> (\<exists>v1 v2. v = Lcons A v1 v2 \<and> is_value_L v1 \<and> is_value_L v2) \<or>
                                          v = Lnil A"
proof -
  assume "is_value_L v" "\<Gamma> \<turnstile> v |:| \<lambda>List A"
  then show "(\<exists>v1 v2. v = Lcons A v1 v2 \<and> is_value_L v1 \<and> is_value_L v2) \<or>
                                          v = Lnil A"
    by (induction rule:"is_value_L.induct") (auto elim: has_type_L.cases)
qed (auto elim: has_type_L.cases is_value_L.cases)

primrec FV :: "lterm \<Rightarrow> nat set" where
 "FV LTrue = {}" |
 "FV LFalse = {}" |
 "FV unit = {}" |
 "FV error = {}" |
 "FV (LVar x) = {x}" |
 "FV (LAbs T t) = image (\<lambda>x. x - 1) (FV t - {0})" |
 "FV (LApp t1 t2) = FV t1 \<union> FV t2"|
  "FV (Lcons A t t') = FV t \<union> FV t'"|
  "FV (Ltail A t) = FV t"|
  "FV (Lhead A t) = FV t"|
  "FV (Lisnil A t) = FV t"|
  "FV (Lnil A) = {}"

definition is_closed :: "lterm \<Rightarrow> bool" where
  "is_closed t \<equiv> FV t = {}"

theorem progress:
   "\<emptyset> \<turnstile> t |:| T \<Longrightarrow> is_closed t \<Longrightarrow> (\<forall>t'.\<not> eval1_L t t') \<Longrightarrow> is_value_L t \<or> t=error"
proof (induction t T rule: has_type_L.induct)
  case (has_type_LApp \<Gamma> t1 T11 T12 t2)
    thus ?case
      by (cases "is_value_L t1", cases "is_value_L t2")
          (auto intro: eval1_L.intros dest: canonical_forms simp: is_closed_def)
next
  case (has_type_isNil \<Gamma> t A)
    note hyps=this
    show ?case
      using hyps(2,3,4) eval1_L.intros(10-13)
            canonical_forms(4)[OF _ hyps(1)] is_closed_def
      by (cases "\<exists>t'. eval1_L t t'")(blast, metis FV.simps(11))
next
  case (has_type_head \<Gamma> t A)
    note hyps=this
    show ?case
      using hyps(2,3,4) eval1_L.intros(14-17)
            canonical_forms(4)[OF _ hyps(1)] is_closed_def
      by (cases "\<exists>t'. eval1_L t t'")(blast,metis FV.simps(10))
next
  case (has_type_tail \<Gamma> t A)
    note hyps=this
    show ?case
      using hyps(2,3,4) eval1_L.intros(18-)
            canonical_forms(4)[OF _ hyps(1)] is_closed_def
      by (cases "\<exists>t'. eval1_L t t'")(blast,metis FV.simps(9))
qed  (auto intro!: is_value_L.intros eval1_L.intros dest: canonical_forms simp: is_closed_def)+

lemma simpl1: "nat (int x + 1) = Suc x" by simp
lemma simpl2: "nat (1 + int x) = Suc x" by simp
lemma simpl3: "nat (int x - 1) = x - 1" by simp

lemma gr_Suc_conv: "Suc x \<le> n \<longleftrightarrow> (\<exists>m. n = Suc m \<and> x \<le> m)"
  by (cases n) auto

lemma FV_shift:
  "FV (shift_L (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV t)"
proof (induction t arbitrary: c rule: lterm.induct)
  case (LAbs T t)
  thus ?case  by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemmas int_1 = of_nat_1[where 'a=int]

lemma FV_subst:
  "FV (subst_L n t u) = (if n \<in> FV u then (FV u - {n}) \<union> FV t else FV u)"
proof (induction u arbitrary: n t rule: lterm.induct)
  case (LAbs T u)
    have A: "Suc n \<in> FV u \<Longrightarrow> \<exists>x\<in>FV u - {0}. n = x - Suc 0 \<Longrightarrow>
              {y. \<exists>x\<in>FV u - {Suc n} \<union> {y. \<exists>x\<in>FV t. y = Suc x} - {0}. y = x - Suc 0} =
              {y. \<exists>x\<in>FV u - {0}. y = x - Suc 0} - {n} \<union> FV t"
      by (rule, force)
          (rule, simp, metis (mono_tags, lifting) Diff_iff Un_iff diff_Suc_Suc
                              diff_zero mem_Collect_eq nat.simps(3) singletonD)
    have " Suc n \<in> FV u \<Longrightarrow>
          \<forall>x\<in>FV u - {0}. n \<noteq> x - Suc 0 \<Longrightarrow>
          {y. \<exists>x\<in>FV u - {Suc n} \<union> {y. \<exists>x\<in>FV t. y = Suc x} - {0}. y = x - Suc 0} =
          {y. \<exists>x\<in>FV u - {0}. y = x - Suc 0}"
      by (rule, rule ,simp , metis (mono_tags, lifting) Diff_iff diff_Suc_Suc diff_zero nat.simps(3) singletonD)+

    with A LAbs show ?case
      by (auto simp:gr0_conv_Suc image_iff image_def FV_shift[of 1, unfolded int_1])
qed (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1])

lemma weakening:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n U \<Gamma> \<turnstile> shift_L 1 n t |:| T"
proof (induction \<Gamma> t T arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t T2)
    from has_type_LAbs has_type_LAbs.hyps
      has_type_LAbs.IH[where n="Suc n"]
    show ?case
      by (auto intro: has_type_L.intros)
qed (auto simp: nth_append min_def simpl1 simpl2 simpl3 intro: has_type_L.intros)

lemma substitution:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> \<Gamma> \<turnstile> LVar n |:| U \<Longrightarrow> \<Gamma> \<turnstile> s |:| U \<Longrightarrow>
    \<Gamma> \<turnstile> subst_L n s t |:| T"
proof (induction \<Gamma> t T arbitrary: s n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t T2)
    note hyps=this

    show ?case
      using hyps  has_type_L.simps[of _ "LVar _", simplified]
            weakening[where n=0, simplified]
      by (force intro!: "has_type_L.has_type_LAbs")
qed (auto intro!: has_type_L.intros simp: has_type_L.simps[of _ "LVar _" _, simplified])

lemma shift_down:
  "insert_nth n U \<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> \<Gamma> \<turnstile> shift_L (- 1) n t |:| T"
proof (induction "insert_nth n U \<Gamma>" t T arbitrary: \<Gamma> n rule: has_type_L.induct)
  case (has_type_LAbs  V t T \<Gamma>)
    note hyps=this
    show ?case
      using hyps hyps(2)[of "Suc n" "\<Gamma>|,|V"]
      by (fastforce intro!: has_type_L.intros)
qed (fastforce intro: has_type_L.intros simp: nth_append min_def simpl1 simpl2 simpl3)+

method inv_eval = (match premises in "eval1_L t t1" for t t1 \<Rightarrow>
                    \<open> insert eval1_L.simps[of t t1] \<close>)

lemma preservation:
  "\<Gamma> \<turnstile> t |:| T\<Longrightarrow> eval1_L t t' \<Longrightarrow> \<Gamma> \<turnstile> t' |:| T"
proof (induction arbitrary: t' rule: has_type_L.induct)
  case (has_type_LApp \<Gamma> t1 T1 T2 t2)
    note hyps=this
    have "\<And>L TL T t12. t1 = LAbs T t12 \<Longrightarrow> t'=shift_L (-1) 0 (subst_L 0 (shift_L 1 0 t2) t12) \<Longrightarrow> ?case"
      proof -
        fix L TL T t12
        assume t'_def:"t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t12)"
               and Abs_t1: "t1 = LAbs T t12"
        have t12_type:"\<Gamma> |,| T1 \<turnstile> t12 |:| T2"
          using hyps(1)[unfolded Abs_t1, simplified]
                has_type_L.simps[of \<Gamma> "LAbs T  t12" "T1\<rightarrow>T2", simplified]
          by blast+
        have not_free0:"\<And>x. x \<in> FV (subst_L 0 (shift_L 1 0 t2) t12) \<Longrightarrow> x \<noteq> 0"
          using FV_subst[of 0 "shift_L 1 0 t2" t12]
                FV_shift[of 1 0 t2, unfolded int_1]
          by (cases "0\<in>FV t12") force+
        from t'_def show ?case
          using substitution[OF t12_type, of 0 T1 "shift_L 1 0 t2"]
                shift_down[of 0 T1 \<Gamma> _ T2, simplified, unfolded neq0_conv[symmetric]]
                weakening[OF hyps(2),of 0 T1, simplified]
                not_free0
                "has_type_L.simps"[of "\<Gamma>|,|T1" "LVar 0" T1,simplified]
          by blast
      qed

    then show ?case
      using hyps(1-4) hyps(5)[unfolded eval1_L.simps[of "LApp _ _", simplified]]
            has_type_L.intros(4,6,7)
      by blast
next
  case (has_type_head \<Gamma> t A t')
    note hyps=this and inv=this(3)[unfolded eval1_L.simps[of "Lhead _ _", simplified]]
    show ?case
      using inv has_type_L.intros(10)[OF hyps(2)] hyps(1)
            has_type_L.simps[of \<Gamma> "Lcons _ _ _" "\<lambda>List A", simplified]
            has_type_error
      by blast
next
  case (has_type_tail \<Gamma> t A t')
    note hyps=this and inv=this(3)[unfolded eval1_L.simps[of "Ltail _ _", simplified]]
    show ?case
      using inv has_type_L.intros(11)[OF hyps(2)] hyps(1)
            has_type_L.simps[of \<Gamma> "Lcons _ _ _" "\<lambda>List A", simplified]
            has_type_error
      by blast
next
  case (has_type_isNil \<Gamma> t A)
     note hyps=this and inv=this(3)[unfolded eval1_L.simps[of "Lisnil _ _", simplified]]
    show ?case
      using inv has_type_L.intros(1,2) has_type_L.intros(9)[OF hyps(2)] hyps(1)
            has_type_error
      by meson
qed (inv_eval, force intro!: has_type_L.intros)+

datatype lterm1=
  LVar1 nat
| LApp1 lterm1 lterm1
| LAbs1 ltype "string list" "ltype list" lterm1 ("LAbs1/ (_)/ <(_):=(_)>/ (_)" [200,201,200,200] 220)
| unit1
| trapp lterm1 lterm1 ("try/ (_)/ with/ (_)" [181,180]220)
| raise lterm1
| S string
| Variant string lterm1 ltype ("<(_)::=(_)>/ as/ (_)" [201,200] 220)

fun shift_L1 :: "int \<Rightarrow> nat \<Rightarrow> lterm1 \<Rightarrow> lterm1" where
 "shift_L1 d c (LVar1 k)    = LVar1 (if k < c then k else nat (int k + d))" |
 "shift_L1 d c (LApp1 t t1) = LApp1 (shift_L1 d c t) (shift_L1 d c t1)" |
 "shift_L1 d c (LAbs1 T <L:=TL> t)  = LAbs1 T <L:=TL> (shift_L1 d (Suc c) t)" |
 "shift_L1 d c unit1 = unit1" |
 "shift_L1 d c (try t with t1) = try (shift_L1 d c t) with (shift_L1 d c t1)"|
 "shift_L1 d c (raise t) = raise (shift_L1 d c t)"|
 "shift_L1 d c (<s::=t> as A) = <s::=(shift_L1 d c t)> as A"|
 "shift_L1 d c t = t"

fun subst_L1 :: "nat \<Rightarrow> lterm1 \<Rightarrow> lterm1 \<Rightarrow> lterm1" where
 "subst_L1 j s (LApp1 t1 t2) = LApp1 (subst_L1 j s t1) (subst_L1 j s t2)" |
 "subst_L1 j s (LVar1 k) = (if k = j then s else LVar1 k)" |
 "subst_L1 j s (LAbs1 T <L:=TL> t) =  LAbs1 T <L:=TL> (subst_L1 (Suc j) (shift_L1 1 0 s) t)"|
 "subst_L1 j s unit1 = unit1" |
 "subst_L1 j s (try t with t1) = try (subst_L1 j s t) with (subst_L1 j s t1)"|
 "subst_L1 j s (raise t) = raise (subst_L1 j s t)"|
 "subst_L1 j s (<s1::=t> as A) = <s1::=(subst_L1 j s t)> as A"|
 "subst_L1 j s t = t"

primrec FV1 :: "lterm1 \<Rightarrow> nat set" where
 "FV1 unit1 = {}" |
 "FV1 (LVar1 x) = {x}" |
 "FV1 (LAbs1 T <L:=TL> t) = image (\<lambda>x. x - 1) (FV1 t - {0})" |
 "FV1 (LApp1 t1 t2) = FV1 t1 \<union> FV1 t2"|
 "FV1 (try t with t1) = FV1 t \<union> FV1 t1"|
 "FV1 (raise t) = FV1 t"|
 "FV1 (<s::=t> as A) = FV1 t"|
 "FV1 (S _) = {}"

inductive is_value_L1 :: "lterm1 \<Rightarrow> bool" where
  "is_value_L1 unit1"|"is_value_L1 (S _)"|
  "is_value_L1 (LAbs1 T <L:=TL> t)"
  |"is_value_L1 v \<Longrightarrow> is_value_L1 (<s::=v> as A)"

inductive eval1_L1 :: "lterm1 \<Rightarrow> lterm1 \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_L1App1:
    "eval1_L1 t1 t1' \<Longrightarrow> eval1_L1 (LApp1 t1 t2) (LApp1 t1' t2)" |
  eval1_L1App2:
    "is_value_L1 v1 \<Longrightarrow> eval1_L1 t2 t2' \<Longrightarrow> eval1_L1 (LApp1 v1 t2) (LApp1 v1 t2')" |
  eval1_L1App_LAbs:
    "is_value_L1 v2 \<Longrightarrow> eval1_L1 (LApp1 (LAbs1 T <L:=TL> t12) v2)
      (shift_L1 (-1) 0 (subst_L1 0 (shift_L1 1 0 v2) t12))" |
  eval1_VE:
    "eval1_L1 t t' \<Longrightarrow> eval1_L1 (<s::=t> as A) (<s::=t'> as A)"|
  eval1_L1TryV:
    "is_value_L1 v \<Longrightarrow> eval1_L1 (try v with t) v" |
  eval1_L1TryE:
    "eval1_L1 t1 t2 \<Longrightarrow> eval1_L1 (try t1 with t) (try t2 with t)"|
  eval1_L1AppRaise1:
    "is_value_L1 v \<Longrightarrow> eval1_L1 (LApp1 (raise v) t) (raise v)"|
  eval1_L1AppRaise2:
    "is_value_L1 v \<Longrightarrow> is_value_L1 v1 \<Longrightarrow> eval1_L1 (LApp1 v (raise v1)) (raise v1)"|
  eval1_RaiseE:
    "eval1_L1 t t1 \<Longrightarrow> eval1_L1 (raise t) (raise t1)"|
  eval1_RaiseRaise:
    "is_value_L1 v \<Longrightarrow> eval1_L1 (raise (raise v)) (raise v)"|
  eval1_TryRaise:
    "is_value_L1 v \<Longrightarrow> eval1_L1 (try (raise v) with t2) (LApp1 t2 v)"

inductive  has_type1_L :: "ltype \<Rightarrow> lcontext \<Rightarrow> lterm1 \<Rightarrow> ltype \<Rightarrow> bool" ("((_)|*|(_)/ \<turnstile>\<^sub>1 (_)/ |:| (_))" [150, 150, 150] 150) where
  has_type1_Lunit:
    "T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 unit1 |:| Unit" |
  has_type1_LString:
    "T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 (S s) |:| Ty ''str''"|
  has_type1_LVar:
    "(x, T) |\<in>| \<Gamma> \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 (LVar1 x) |:| T" |
  has_type1_LAbs:
    " distinct L \<Longrightarrow> length L = length TL \<Longrightarrow> <L:=TL>|*|(\<Gamma> |,| T1) \<turnstile>\<^sub>1 t2 |:| T2 \<Longrightarrow>
      <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 (LAbs1 T1 <L:=TL> t2) |:| (T1 \<rightarrow> T2)" |
  has_type1_LApp:
    "T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t2 |:| T11 \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 (LApp1 t1 t2) |:| T12" |
  has_type1_Variant:
    "i<length L \<Longrightarrow> length L = length TL \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| (TL!i) \<Longrightarrow>T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 <(L!i)::=t> as (<L:=TL>) |:| <L:=TL>" |
  has_type1_try:
    "length L = length TL \<Longrightarrow> <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 t1 |:| T \<Longrightarrow> <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 t2 |:| (<L:=TL>)\<rightarrow>T \<Longrightarrow> <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 try t1 with t2 |:| T" |
  has_type1_raise:
    "length L > 0 \<Longrightarrow> length L = length TL \<Longrightarrow> <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| (<L:=TL>) \<Longrightarrow> <L:=TL>|*|\<Gamma> \<turnstile>\<^sub>1 raise t |:| T"

method invert_type = (match premises in H:"Ta|*|\<Gamma> \<turnstile>\<^sub>1 Te |:| A" for Ta \<Gamma> Te A \<Rightarrow>
                        \<open> insert has_type1_L.simps[of Ta \<Gamma> Te A, simplified]\<close>)

thm has_type1_L.induct

lemma canonical_forms1:
  "is_value_L1 v \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 v |:| Unit \<Longrightarrow> v = unit1"
  "is_value_L1 v \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t L TL. v = LAbs1 T1 <L:=TL> t"
  "is_value_L1 v \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 v |:| <L:=TL> \<Longrightarrow> \<exists>i t. v = (<(L!i)::= t> as (<L:=TL>)) \<and> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| (TL!i)"
proof -
  assume val:"is_value_L1 v" and type:"T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 v |:| <L:=TL>"
  then show "\<exists>i t. v = (<(L!i)::= t> as (<L:=TL>)) \<and> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| (TL!i)"
    by (induction rule: is_value_L1.induct) (invert_type, blast)+
qed (blast elim: "is_value_L1.cases" has_type1_L.cases)+

lemma progress1:
  "<\<emptyset>:=\<emptyset>>|*|\<emptyset> \<turnstile>\<^sub>1 t |:| T \<Longrightarrow> is_value_L1 t \<or> (\<exists>t'. eval1_L1 t t') \<or> (\<exists>t1. t=raise t1 \<and> is_value_L1 t1) "
proof (induction "<\<emptyset>:=\<emptyset>>::ltype" "\<emptyset>::lcontext" t T rule: has_type1_L.induct)
  case (has_type1_LApp t1 T1 T2 t2)
    note hyps=this
    show ?case
      using hyps(2,4) eval1_L1.intros(1-3,7-8)
            canonical_forms1(2)[OF _ hyps(1)]
      by metis
next
  case (has_type1_Variant i L TL t)
    note hyps=this
    show ?case
      using hyps(3,4) "is_value_L1.intros"(4)[of t "L!i"]
            eval1_VE[of t _ "L!i"] has_type1_L.simps[of "<\<emptyset>:=\<emptyset>>" \<emptyset> "raise _", simplified]
      by meson
next
  case (has_type1_try t1 T t2)
    note hyps=this
    show ?case
      using hyps(3) eval1_L1TryV eval1_L1TryE eval1_TryRaise
      by blast
qed (simp_all add: is_value_L1.intros)

lemma FV1_shift:
  "FV1 (shift_L1 (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV1 t)"
proof (induction t arbitrary: c rule: lterm1.induct)
  case (LAbs1 T E t)
  thus ?case  by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemma FV1_subst:
  "FV1 (subst_L1 n t u) = (if n \<in> FV1 u then (FV1 u - {n}) \<union> FV1 t else FV1 u)"
proof (induction u arbitrary: n t rule: lterm1.induct)
  case (LAbs1 T L TL u)
    have A: "Suc n \<in> FV1 u \<Longrightarrow> \<exists>x\<in>FV1 u - {0}. n = x - Suc 0 \<Longrightarrow>
              {y. \<exists>x\<in>FV1 u - {Suc n} \<union> {y. \<exists>x\<in>FV1 t. y = Suc x} - {0}. y = x - Suc 0} =
              {y. \<exists>x\<in>FV1 u - {0}. y = x - Suc 0} - {n} \<union> FV1 t"
      by (rule, force)
          (rule, simp, metis (mono_tags, lifting) Diff_iff Un_iff diff_Suc_Suc
                              diff_zero mem_Collect_eq nat.simps(3) singletonD)
    have " Suc n \<in> FV1 u \<Longrightarrow>
          \<forall>x\<in>FV1 u - {0}. n \<noteq> x - Suc 0 \<Longrightarrow>
          {y. \<exists>x\<in>FV1 u - {Suc n} \<union> {y. \<exists>x\<in>FV1 t. y = Suc x} - {0}. y = x - Suc 0} =
          {y. \<exists>x\<in>FV1 u - {0}. y = x - Suc 0}"
      by (rule, rule ,simp , metis (mono_tags, lifting) Diff_iff diff_Suc_Suc diff_zero nat.simps(3) singletonD)+

    with A LAbs1 show ?case
      by (auto simp:gr0_conv_Suc image_iff image_def FV1_shift[of 1, unfolded int_1])
qed (auto simp: gr0_conv_Suc image_iff FV1_shift[of 1, unfolded int_1])

lemma weakening1:
  "T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> T\<alpha>|*|insert_nth n U \<Gamma> \<turnstile>\<^sub>1 shift_L1 1 n t |:| T"
proof (induction T\<alpha> \<Gamma> t T arbitrary: n rule: has_type1_L.induct)
  case (has_type1_LAbs L TL \<Gamma> T1 t T2)
    from has_type1_LAbs has_type1_LAbs.hyps
      has_type1_LAbs.IH[where n="Suc n"]
    show ?case
      by (auto intro: has_type1_L.intros)
qed (auto simp: nth_append min_def simpl1 simpl2 simpl3 intro: has_type1_L.intros)

lemma substitution1:
  "T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| T \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 LVar1 n |:| U \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 s |:| U \<Longrightarrow>
    T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 subst_L1 n s t |:| T"
proof (induction T\<alpha> \<Gamma> t T arbitrary: s n rule: has_type1_L.induct)
  case (has_type1_LAbs L TL T\<alpha> \<Gamma> T1 t T2)
    note hyps=this

    show ?case
      using hyps(1,2,4-)  has_type1_L.simps[of _ _ "LVar1 _", simplified]
            weakening1[where n=0, simplified]
      by (force intro!: "has_type1_L.has_type1_LAbs")
qed (auto intro!: has_type1_L.intros simp: has_type1_L.simps[of _ _ "LVar1 _" _, simplified])

lemma shift_down1:
  "T\<alpha>|*|(insert_nth n U \<Gamma>) \<turnstile>\<^sub>1 t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV1 t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 shift_L1 (- 1) n t |:| T"
proof (induction T\<alpha> "insert_nth n U \<Gamma>" t T arbitrary: \<Gamma> n rule: has_type1_L.induct)
  case (has_type1_LAbs L TL V t T \<Gamma>)
    note hyps=this
    show ?case
      using hyps(1,2,5-) hyps(4)[of "Suc n" "\<Gamma>|,|V"]
      by (fastforce intro: has_type1_L.intros )
qed (fastforce intro: has_type1_L.intros simp: nth_append min_def simpl1 simpl2 simpl3)+

method invert_eval1 = (match premises in H:"eval1_L1 Te Te1" (multi) for Te Te1::lterm1 \<Rightarrow>
                        \<open> insert eval1_L1.simps[of Te Te1, simplified]\<close>)

method raise_solve = (match conclusion in "Ta|*|\<Gamma> \<turnstile>\<^sub>1 raise t |:| A"for Ta \<Gamma> t A \<Rightarrow>
                        \<open> match premises in H:"Ta|*|\<Gamma> \<turnstile>\<^sub>1 raise t |:| B" for B \<Rightarrow>
                           \<open>insert has_type1_L.simps[of Ta \<Gamma> "raise t" B, simplified]
                             \<close>\<close>, (fastforce intro:has_type1_L.intros))

lemma preservation1:
  " T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t |:| T\<Longrightarrow> eval1_L1 t t' \<Longrightarrow> T\<alpha>|*|\<Gamma> \<turnstile>\<^sub>1 t' |:| T"
proof (induction arbitrary: t' rule: has_type1_L.induct)
  case (has_type1_try L TL \<Gamma> t1 T1 t2)
    note H=this(1-5) and inv_eval= this(6)[unfolded eval1_L1.simps[of "try t1 with t2", simplified]]
    thus ?case
      by (meson has_type1_L.intros
                has_type1_L.simps[of "<L:=TL>" \<Gamma> "raise _" T1, simplified])
next
  case (has_type1_LApp T\<alpha> \<Gamma> t1 T1 T2 t2)
    note hyps=this
    have "\<And>L TL T t12. t1 = LAbs1 T <L:=TL> t12 \<Longrightarrow> t'=shift_L1 (-1) 0 (subst_L1 0 (shift_L1 1 0 t2) t12) \<Longrightarrow> ?case"
      proof -
        fix L TL T t12
        assume t'_def:"t' = shift_L1 (- 1) 0 (subst_L1 0 (shift_L1 1 0 t2) t12)"
               and Abs_t1: "t1 = LAbs1 T <L:=TL> t12"
        have t12_type:"<L:=TL>|*|\<Gamma> |,| T1 \<turnstile>\<^sub>1 t12 |:| T2" and
              T\<alpha>_def : "T\<alpha> = <L:=TL>"
          using hyps(1)[unfolded Abs_t1, simplified]
                has_type1_L.simps[of T\<alpha> \<Gamma> "LAbs1 T <L:=TL> t12" "T1\<rightarrow>T2", simplified]
          by blast+
        have not_free0:"\<And>x. x \<in> FV1 (subst_L1 0 (shift_L1 1 0 t2) t12) \<Longrightarrow> x \<noteq> 0"
          using FV1_subst[of 0 "shift_L1 1 0 t2" t12]
                FV1_shift[of 1 0 t2, unfolded int_1]
          by (cases "0\<in>FV1 t12") force+
        from t'_def show ?case
          using T\<alpha>_def substitution1[OF t12_type, of 0 T1 "shift_L1 1 0 t2"]
                shift_down1[of _ 0 T1 \<Gamma> _ T2, simplified, unfolded neq0_conv[symmetric]]
                weakening1[OF hyps(2),of 0 T1, simplified]
                not_free0
                "has_type1_L.simps"[of "<L:=TL>" "\<Gamma>|,|T1" "LVar1 0" T1,simplified]
          by blast
      qed

    with has_type1_LApp show ?case
      by simp (invert_eval1, (meson has_type1_L.intros;(raise_solve|blast)))

qed (raise_solve|(invert_eval1, meson has_type1_L.intros), (raise_solve?))+

end


theory OrdRec
  imports "../GZF/GZF_Base" Ordinal "../Functions/Functions"
begin

syntax
  "_lam_ord" :: "[pttrn, 'a, 'a] => 'a" (\<open>(3\<lambda>_<_./ _)\<close> 10)
translations
  "\<lambda>i < j. F" \<rightleftharpoons> "CONST lam (CONST predSet j) (\<lambda>i. F)"

syntax
  "_RepFun_ord"  :: "['a, pttrn, 'a] => 'a"    (\<open>(1{ _ |/ _<_ })\<close> [51,0,51])
  "_Collect_ord" :: "[pttrn, 'a, bool ] \<Rightarrow> 'a" (\<open>(1{ _<_ |/ _ })\<close>)
  "_Union_ord"   :: "[pttrn, 'a, 'a] \<Rightarrow> 'a"    (\<open>(3\<Union>_<_./ _)\<close> 10)
translations
  "{c | i < j}" \<rightleftharpoons> "CONST RepFun (CONST predSet j) (\<lambda>i. c)"
  "{i < j | P}" \<rightleftharpoons> "CONST Collect (CONST predSet j) (\<lambda>i. P)"
  "\<Union> i<j. B"   \<rightleftharpoons> "CONST Union {B | i < j}"

context OrdRec begin

thm predset_typ supord_typ
thm predset_ax supord_ax

lemmas predset_setof = funE[OF predset_typ]
lemmas predset_set = setof_set[OF predset_setof]
lemmas lim_predset_set = predset_set[OF limit_ord]
lemmas repfun_ord_setof = repfun_setof[OF predset_set]
lemmas repfun_union_ord_set = union_set[OF repfun_ord_setof]

lemma predset_mem_ord :
  assumes "j : Ord"
  shows "i \<in> predSet j \<Longrightarrow> i : Ord"
  using setof_mem[OF predset_setof[OF assms]] by auto

lemma predset_iff :
  assumes "i : Ord" "j : Ord"
  shows "i \<in> predSet j \<longleftrightarrow> i < j"
  using predset_ax assms by auto

lemma predsetI :
  assumes "i : Ord" "j : Ord"
  shows "i < j \<Longrightarrow> i \<in> predSet j"
  using predset_iff[OF assms] by auto

lemma predsetE :
  assumes j:"j : Ord"
  shows "i \<in> predSet j \<Longrightarrow> i < j"
  using predset_iff[OF _ j] setof_mem[OF predset_setof[OF j]] by auto

lemma mem_predset_succ :
  assumes i:"i : Ord"
  shows "i \<in> predSet (succ i)"
  by (rule predsetI, use succ_ord leq_refl i in auto)

lemma predsetD :
  assumes j:"j : Ord"
  shows "i \<in> predSet j \<Longrightarrow> i : Ord \<and> i < j"
  using predset_iff[OF _ j] setof_mem[OF predset_setof[OF j]] by auto

lemma supord_iff :
  assumes x : "x : SetOf Ord" and i : "i \<in> x"
  shows "i \<le> supOrd x"
  using supord_ax assms by auto

lemmas supord_ord = funE[OF supord_typ]

lemma ord_setmem :
  assumes i:"i : Ord"
  shows "i : SetMem"
  by (rule setmemI[OF setof_set],
      use predset_setof[OF succ_ord] mem_predset_succ i in auto)

lemma ord_model_case_typ :
  assumes j : "j : Ord"
  shows "caseof_ord {0} {j} {j} j : SetOf Ord"
  by (rule case_ordE[OF j],
      rule sng_setof[OF ord_setmem[OF zero_ord] zero_ord],
      rule sng_setof[OF ord_setmem[OF j] j],
      rule sng_setof[OF ord_setmem[OF j] j])

lemma ordrec_succ :
  assumes "b : Ord"
    shows "OrdRec G F A (succ b) =
    F (succ b) (OrdRec G F A b)"
  using ordrec_succ_ax assms by auto

lemma ordrec_lim :
  assumes "u : Limit"
    shows "OrdRec G F A u =
    G u (\<lambda>j. if j : Ord \<and> j < u then OrdRec G F A j else OrdRec_default)"
  using ordrec_lim_ax assms by auto

lemmas repfun_ord_set = repfun_set[OF predset_set]
lemmas repfun_lim_set = repfun_ord_set[OF limit_ord]

lemma repfun_ordrec_lim_restrict :
  assumes u : "u : Limit"
    shows "{ (if j : Ord \<and> j < u then OrdRec G F A j else OrdRec_default) | j < u } =
           { OrdRec G F A j | j < u}"
   by (rule repfun_cong[OF lim_predset_set[OF u] lim_predset_set[OF u]],
       rule refl, drule predsetD[OF limit_ord[OF u]], auto)
(*

definition if_ord3 :: "('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" where
  "if_ord3 G F A \<beta> x \<equiv>
      if \<beta> = 0 then A else if \<exists>\<beta>'. \<beta> = succ \<beta>' then F \<beta> x else if Limit \<beta> then G \<beta> x else \<emptyset>"

lemma if_ord_0 : "if_ord3 G F A 0 x = A" unfolding if_ord3_def by auto
lemma if_ord_succ : assumes "Ord \<beta>" shows "if_ord3 G F A (succ \<beta>) = F (succ \<beta>)" unfolding if_ord3_def
  using exI[of \<open>(\<lambda>\<beta>'. succ \<beta> = succ \<beta>')\<close> \<open>\<beta>\<close>, OF refl] succ_nonzero[OF assms] by auto
lemma if_ord_lim : assumes "Limit \<mu>" shows "if_ord3 G F A \<mu> = G \<mu>"
  unfolding if_ord3_def using Limit_nonzero not_succ_Limit assms by auto

lemma if_set : assumes "Set x" "Set y" shows "Set (if P then x else y)" using assms by simp

lemma if_ord3_set : assumes "Set A" "\<And>\<beta>. Ord \<beta> \<Longrightarrow> Set x \<Longrightarrow> Set (F (succ \<beta>) x)"
                                    "\<And>\<mu>. Limit \<mu> \<Longrightarrow> Set x \<Longrightarrow> Set (G \<mu> x)"
                    shows "Ord \<beta> \<Longrightarrow> Set x \<Longrightarrow> Set (if_ord3 G F A \<beta> x)"
  unfolding if_ord3_def using assms by auto

thm if_True if_False Eq_TrueI Eq_FalseI
thm if_P if_not_P
thm refl succ_nonzero
thm not_sym[OF lt_neq]
thm succ_lt[OF zero_ord]
thm lt_trans_pure[OF lt_trans_pure[OF lt_trans_pure],
                  of \<open>0\<close> \<open>succ 0\<close> \<open>succ (succ 0)\<close> \<open>succ (succ (succ 0))\<close> \<open>succ (succ (succ (succ 0)))\<close>,
                  OF le_refl[OF zero_ord] le_refl[OF succ_ord[OF zero_ord]]
                     le_refl[OF succ_ord[OF succ_ord[OF zero_ord]]]
                     le_refl[OF succ_ord[OF succ_ord[OF succ_ord[OF zero_ord]]]]]

thm lt_trans_pure[OF le_refl[of 0] lt_trans_pure[OF le_refl]]
ML \<open>fun mk_ord_thm z _ 0 = z
      | mk_ord_thm z s n = s OF [mk_ord_thm z s (n-1)]\<close>

ML \<open>fun le_trans r t 0 = r
      | le_trans r t j = t OF [le_trans r t (j-1)]\<close>

ML \<open>fun ord_le (z,s,r,t) i j = le_trans r t (j-i) OF (map (fn n => if n = i then mk_ord_thm z s n else r OF [mk_ord_thm z s n]) (i upto j))\<close>
ML \<open>fun ord_neq thms neq i j = @{thm not_sym} OF [neq] OF [ord_le thms i (j-1)]\<close>

ML \<open>fun ops_alpha thms neq i j =
      if i = j then @{thm if_P} OF [@{thm refl}]
      else @{thm trans} OF [@{thm if_not_P} OF [ord_neq thms neq i j],
                            ops_alpha thms neq (i+1) j]\<close>

(*Ops 0*)
thm if_P[OF refl[of 0]]
(*Ops 1*)
thm trans[OF if_not_P[OF succ_neq[OF zero_ord]] if_P[OF refl[of \<open>succ 0\<close>]]]
(*Ops 2*)
thm trans[OF if_not_P[OF succ_neq[OF zero_ord]] if_P[OF refl[of \<open>succ (succ 0)\<close>]]] *)

end
end


(*  Title:      HOL/Nitpick_Examples/Refute_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Refute examples adapted to Nitpick.
*)

section \<open>Refute Examples Adapted to Nitpick\<close>

theory Refute_Nits
imports Main
begin

nitpick_params [verbose, card = 1-6, max_potential = 0,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

lemma "P \<and> Q"
apply (rule conjI)
nitpick [expect = genuine] 1
nitpick [expect = genuine] 2
nitpick [expect = genuine]
nitpick [card = 5, expect = genuine]
nitpick [sat_solver = SAT4J, expect = genuine] 2
oops

subsection \<open>Examples and Test Cases\<close>

subsubsection \<open>Propositional logic\<close>

lemma "True"
nitpick [expect = none]
apply auto
done

lemma "False"
nitpick [expect = genuine]
oops

lemma "P"
nitpick [expect = genuine]
oops

lemma "\<not> P"
nitpick [expect = genuine]
oops

lemma "P \<and> Q"
nitpick [expect = genuine]
oops

lemma "P \<or> Q"
nitpick [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "(P::bool) = Q"
nitpick [expect = genuine]
oops

lemma "(P \<or> Q) \<longrightarrow> (P \<and> Q)"
nitpick [expect = genuine]
oops

subsubsection \<open>Predicate logic\<close>

lemma "P x y z"
nitpick [expect = genuine]
oops

lemma "P x y \<longrightarrow> P y x"
nitpick [expect = genuine]
oops

lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
nitpick [expect = genuine]
oops

subsubsection \<open>Equality\<close>

lemma "P = True"
nitpick [expect = genuine]
oops

lemma "P = False"
nitpick [expect = genuine]
oops

lemma "x = y"
nitpick [expect = genuine]
oops

lemma "f x = g x"
nitpick [expect = genuine]
oops

lemma "(f::'a\<Rightarrow>'b) = g"
nitpick [expect = genuine]
oops

lemma "(f::('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
nitpick [expect = genuine]
oops

lemma "distinct [a, b]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

subsubsection \<open>First-Order Logic\<close>

lemma "\<exists>x. P x"
nitpick [expect = genuine]
oops

lemma "\<forall>x. P x"
nitpick [expect = genuine]
oops

lemma "\<exists>!x. P x"
nitpick [expect = genuine]
oops

lemma "Ex P"
nitpick [expect = genuine]
oops

lemma "All P"
nitpick [expect = genuine]
oops

lemma "Ex1 P"
nitpick [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
nitpick [expect = genuine]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
nitpick [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
nitpick [expect = genuine]
oops

text \<open>A true statement (also testing names of free and bound variables being identical)\<close>

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
nitpick [expect = none]
apply fast
done

text \<open>"A type has at most 4 elements."\<close>

lemma "\<not> distinct [a, b, c, d, e]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

lemma "distinct [a, b, c, d]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

text \<open>"Every reflexive and symmetric relation is transitive."\<close>

lemma "\<lbrakk>\<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x\<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
nitpick [expect = genuine]
oops

text \<open>The ``Drinker's theorem''\<close>

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
nitpick [expect = none]
apply (auto simp add: ext)
done

text \<open>And an incorrect version of it\<close>

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
nitpick [expect = genuine]
oops

text \<open>"Every function has a fixed point."\<close>

lemma "\<exists>x. f x = x"
nitpick [expect = genuine]
oops

text \<open>"Function composition is commutative."\<close>

lemma "f (g x) = g (f x)"
nitpick [expect = genuine]
oops

text \<open>"Two functions that are equivalent wrt.\ the same predicate 'P' are equal."\<close>

lemma "((P::('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
nitpick [expect = genuine]
oops

subsubsection \<open>Higher-Order Logic\<close>

lemma "\<exists>P. P"
nitpick [expect = none]
apply auto
done

lemma "\<forall>P. P"
nitpick [expect = genuine]
oops

lemma "\<exists>!P. P"
nitpick [expect = none]
apply auto
done

lemma "\<exists>!P. P x"
nitpick [expect = genuine]
oops

lemma "P Q \<or> Q x"
nitpick [expect = genuine]
oops

lemma "x \<noteq> All"
nitpick [expect = genuine]
oops

lemma "x \<noteq> Ex"
nitpick [expect = genuine]
oops

lemma "x \<noteq> Ex1"
nitpick [expect = genuine]
oops

text \<open>``The transitive closure of an arbitrary relation is non-empty.''\<close>

definition "trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans P \<equiv> (ALL x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition
"subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"subset P Q \<equiv> (ALL x y. P x y \<longrightarrow> Q x y)"

definition
"trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans_closure P Q \<equiv> (subset Q P) \<and> (trans P) \<and> (ALL R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
nitpick [expect = genuine]
oops

text \<open>``The union of transitive closures is equal to the transitive closure of unions.''\<close>

lemma "(\<forall>x y. (P x y \<or> R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y \<or> R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
 \<longrightarrow> trans_closure TP P
 \<longrightarrow> trans_closure TR R
 \<longrightarrow> (T x y = (TP x y \<or> TR x y))"
nitpick [expect = genuine]
oops

text \<open>``Every surjective function is invertible.''\<close>

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
nitpick [expect = genuine]
oops

text \<open>``Every invertible function is surjective.''\<close>

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [expect = genuine]
oops

text \<open>``Every point is a fixed point of some function.''\<close>

lemma "\<exists>f. f x = x"
nitpick [card = 1-7, expect = none]
apply (rule_tac x = "\<lambda>x. x" in exI)
apply simp
done

text \<open>Axiom of Choice: first an incorrect version\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nitpick [expect = genuine]
oops

text \<open>And now two correct ones\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
nitpick [card = 1-4, expect = none]
apply (simp add: choice)
done

lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nitpick [card = 1-3, expect = none]
apply auto
 apply (simp add: ex1_implies_ex choice)
apply (fast intro: ext)
done

subsubsection \<open>Metalogic\<close>

lemma "\<And>x. P x"
nitpick [expect = genuine]
oops

lemma "f x \<equiv> g x"
nitpick [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "\<lbrakk>P; Q; R\<rbrakk> \<Longrightarrow> S"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> Pure.all) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> (op \<equiv>)) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> (op \<Longrightarrow>)) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

subsubsection \<open>Schematic Variables\<close>

schematic_goal "?P"
nitpick [expect = none]
apply auto
done

schematic_goal "x = ?y"
nitpick [expect = none]
apply auto
done

subsubsection \<open>Abstractions\<close>

lemma "(\<lambda>x. x) = (\<lambda>x. y)"
nitpick [expect = genuine]
oops

lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
nitpick [expect = genuine]
oops

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
nitpick [expect = none]
apply simp
done

subsubsection \<open>Sets\<close>

lemma "P (A::'a set)"
nitpick [expect = genuine]
oops

lemma "P (A::'a set set)"
nitpick [expect = genuine]
oops

lemma "{x. P x} = {y. P y}"
nitpick [expect = none]
apply simp
done

lemma "x \<in> {x. P x}"
nitpick [expect = genuine]
oops

lemma "P (op \<in>)"
nitpick [expect = genuine]
oops

lemma "P (op \<in> x)"
nitpick [expect = genuine]
oops

lemma "P Collect"
nitpick [expect = genuine]
oops

lemma "A Un B = A Int B"
nitpick [expect = genuine]
oops

lemma "(A Int B) Un C = (A Un C) Int B"
nitpick [expect = genuine]
oops

lemma "Ball A P \<longrightarrow> Bex A P"
nitpick [expect = genuine]
oops

subsubsection \<open>@{const undefined}\<close>

lemma "undefined"
nitpick [expect = genuine]
oops

lemma "P undefined"
nitpick [expect = genuine]
oops

lemma "undefined x"
nitpick [expect = genuine]
oops

lemma "undefined undefined"
nitpick [expect = genuine]
oops

subsubsection \<open>@{const The}\<close>

lemma "The P"
nitpick [expect = genuine]
oops

lemma "P The"
nitpick [expect = genuine]
oops

lemma "P (The P)"
nitpick [expect = genuine]
oops

lemma "(THE x. x=y) = z"
nitpick [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

subsubsection \<open>@{const Eps}\<close>

lemma "Eps P"
nitpick [expect = genuine]
oops

lemma "P Eps"
nitpick [expect = genuine]
oops

lemma "P (Eps P)"
nitpick [expect = genuine]
oops

lemma "(SOME x. x=y) = z"
nitpick [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
nitpick [expect = none]
apply (auto simp add: someI)
done

subsubsection \<open>Operations on Natural Numbers\<close>

lemma "(x::nat) + y = 0"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x + x"
nitpick [expect = genuine]
oops

lemma "(x::nat) - y + y = x"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x * x"
nitpick [expect = genuine]
oops

lemma "(x::nat) < x + y"
nitpick [card = 1, expect = genuine]
oops

text \<open>\<times>\<close>

lemma "P (x::'a\<times>'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a\<times>'b. P x"
nitpick [expect = genuine]
oops

lemma "P (x, y)"
nitpick [expect = genuine]
oops

lemma "P (fst x)"
nitpick [expect = genuine]
oops

lemma "P (snd x)"
nitpick [expect = genuine]
oops

lemma "P Pair"
nitpick [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> f a b)"
nitpick [expect = genuine]
oops

subsubsection \<open>Subtypes (typedef), typedecl\<close>

text \<open>A completely unspecified non-empty subset of @{typ "'a"}:\<close>

definition "myTdef = insert (undefined::'a) (undefined::'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
unfolding myTdef_def by auto

lemma "(x::'a myTdef) = y"
nitpick [expect = genuine]
oops

typedecl myTdecl

definition "T_bij = {(f::'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
unfolding T_bij_def by auto

lemma "P (f::(myTdecl myTdef) T_bij)"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductive Datatypes\<close>

text \<open>unit\<close>

lemma "P (x::unit)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::unit. P x"
nitpick [expect = genuine]
oops

lemma "P ()"
nitpick [expect = genuine]
oops

lemma "P (case x of () \<Rightarrow> u)"
nitpick [expect = genuine]
oops

text \<open>option\<close>

lemma "P (x::'a option)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a option. P x"
nitpick [expect = genuine]
oops

lemma "P None"
nitpick [expect = genuine]
oops

lemma "P (Some x)"
nitpick [expect = genuine]
oops

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
nitpick [expect = genuine]
oops

text \<open>+\<close>

lemma "P (x::'a+'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a+'b. P x"
nitpick [expect = genuine]
oops

lemma "P (Inl x)"
nitpick [expect = genuine]
oops

lemma "P (Inr x)"
nitpick [expect = genuine]
oops

lemma "P Inl"
nitpick [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
nitpick [expect = genuine]
oops

text \<open>Non-recursive datatypes\<close>

datatype T1 = A | B

lemma "P (x::T1)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::T1. P x"
nitpick [expect = genuine]
oops

lemma "P A"
nitpick [expect = genuine]
oops

lemma "P B"
nitpick [expect = genuine]
oops

lemma "rec_T1 a b A = a"
nitpick [expect = none]
apply simp
done

lemma "rec_T1 a b B = b"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T1 a b x)"
nitpick [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
nitpick [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x::'a T2)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a T2. P x"
nitpick [expect = genuine]
oops

lemma "P D"
nitpick [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
nitpick [expect = none]
apply simp
done

lemma "rec_T2 c d (D x) = d x"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T2 c d x)"
nitpick [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
nitpick [expect = genuine]
oops

datatype ('a, 'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x::('a, 'b) T3)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::('a, 'b) T3. P x"
nitpick [expect = genuine]
oops

lemma "P E"
nitpick [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
nitpick [card = 1-4, expect = none]
apply simp
done

lemma "P (rec_T3 e x)"
nitpick [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
nitpick [expect = genuine]
oops

text \<open>Recursive datatypes\<close>

text \<open>nat\<close>

lemma "P (x::nat)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::nat. P x"
nitpick [expect = genuine]
oops

lemma "P (Suc 0)"
nitpick [expect = genuine]
oops

lemma "P Suc"
nitpick [card = 1-7, expect = none]
oops

lemma "rec_nat zero suc 0 = zero"
nitpick [expect = none]
apply simp
done

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_nat zero suc x)"
nitpick [expect = genuine]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
nitpick [expect = genuine]
oops

text \<open>'a list\<close>

lemma "P (xs::'a list)"
nitpick [expect = genuine]
oops

lemma "\<forall>xs::'a list. P xs"
nitpick [expect = genuine]
oops

lemma "P [x, y]"
nitpick [expect = genuine]
oops

lemma "rec_list nil cons [] = nil"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_list nil cons xs)"
nitpick [expect = genuine]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
nitpick [expect = genuine]
oops

lemma "(xs::'a list) = ys"
nitpick [expect = genuine]
oops

lemma "a # xs = b # xs"
nitpick [expect = genuine]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x::BitList)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::BitList. P x"
nitpick [expect = genuine]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
nitpick [expect = genuine]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_BitList nil bit0 bit1 x)"
nitpick [expect = genuine]
oops

datatype 'a BinTree = Leaf 'a | Node "'a BinTree" "'a BinTree"

lemma "P (x::'a BinTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a BinTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (Leaf x) (Leaf y))"
nitpick [expect = genuine]
oops

lemma "rec_BinTree l n (Leaf x) = l x"
nitpick [expect = none]
apply simp
done

lemma "rec_BinTree l n (Node x y) = n x y (rec_BinTree l n x) (rec_BinTree l n y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_BinTree l n x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Leaf a \<Rightarrow> l a | Node a b \<Rightarrow> n a b)"
nitpick [expect = genuine]
oops

text \<open>Mutually recursive datatypes\<close>

datatype 'a aexp = Number 'a | ITE "'a bexp" "'a aexp" "'a aexp"
 and 'a bexp = Equal "'a aexp" "'a aexp"

lemma "P (x::'a aexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a aexp. P x"
nitpick [expect = genuine]
oops

lemma "P (ITE (Equal (Number x) (Number y)) (Number x) (Number y))"
nitpick [expect = genuine]
oops

lemma "P (x::'a bexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a bexp. P x"
nitpick [expect = genuine]
oops

lemma "rec_aexp number ite equal (Number x) = number x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_aexp number ite equal (ITE x y z) = ite x y z (rec_bexp number ite equal x) (rec_aexp number ite equal y) (rec_aexp number ite equal z)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_aexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Number a \<Rightarrow> number a | ITE b a1 a2 \<Rightarrow> ite b a1 a2)"
nitpick [expect = genuine]
oops

lemma "rec_bexp number ite equal (Equal x y) = equal x y (rec_aexp number ite equal x) (rec_aexp number ite equal y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_bexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Equal a1 a2 \<Rightarrow> equal a1 a2)"
nitpick [expect = genuine]
oops

datatype X = A | B X | C Y and Y = D X | E Y | F

lemma "P (x::X)"
nitpick [expect = genuine]
oops

lemma "P (y::Y)"
nitpick [expect = genuine]
oops

lemma "P (B (B A))"
nitpick [expect = genuine]
oops

lemma "P (B (C F))"
nitpick [expect = genuine]
oops

lemma "P (C (D A))"
nitpick [expect = genuine]
oops

lemma "P (C (E F))"
nitpick [expect = genuine]
oops

lemma "P (D (B A))"
nitpick [expect = genuine]
oops

lemma "P (D (C F))"
nitpick [expect = genuine]
oops

lemma "P (E (D A))"
nitpick [expect = genuine]
oops

lemma "P (E (E F))"
nitpick [expect = genuine]
oops

lemma "P (C (D (C F)))"
nitpick [expect = genuine]
oops

lemma "rec_X a b c d e f A = a"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (B x) = b x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (C y) = c y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (D x) = d x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (E y) = e y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f F = f"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_X a b c d e f x)"
nitpick [expect = genuine]
oops

lemma "P (rec_Y a b c d e f y)"
nitpick [expect = genuine]
oops

text \<open>Other datatype examples\<close>

text \<open>Indirect recursion is implemented via mutual recursion.\<close>

datatype XOpt = CX "XOpt option" | DX "bool \<Rightarrow> XOpt option"

lemma "P (x::XOpt)"
nitpick [expect = genuine]
oops

lemma "P (CX None)"
nitpick [expect = genuine]
oops

lemma "P (CX (Some (CX None)))"
nitpick [expect = genuine]
oops

lemma "P (rec_X cx dx n1 s1 n2 s2 x)"
nitpick [expect = genuine]
oops

datatype 'a YOpt = CY "('a \<Rightarrow> 'a YOpt) option"

lemma "P (x::'a YOpt)"
nitpick [expect = genuine]
oops

lemma "P (CY None)"
nitpick [expect = genuine]
oops

lemma "P (CY (Some (\<lambda>a. CY None)))"
nitpick [expect = genuine]
oops

datatype Trie = TR "Trie list"

lemma "P (x::Trie)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::Trie. P x"
nitpick [expect = genuine]
oops

lemma "P (TR [TR []])"
nitpick [expect = genuine]
oops

datatype InfTree = Leaf | Node "nat \<Rightarrow> InfTree"

lemma "P (x::InfTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::InfTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (\<lambda>n. Leaf))"
nitpick [expect = genuine]
oops

lemma "rec_InfTree leaf node Leaf = leaf"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_InfTree leaf node (Node g) = node ((\<lambda>InfTree. (InfTree, rec_InfTree leaf node InfTree)) \<circ> g)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_InfTree leaf node x)"
nitpick [expect = genuine]
oops

datatype 'a lambda = Var 'a | App "'a lambda" "'a lambda" | Lam "'a \<Rightarrow> 'a lambda"

lemma "P (x::'a lambda)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a lambda. P x"
nitpick [expect = genuine]
oops

lemma "P (Lam (\<lambda>a. Var a))"
nitpick [card = 1-5, expect = none]
nitpick [card 'a = 4, card "'a lambda" = 5, expect = genuine]
oops

lemma "rec_lambda var app lam (Var x) = var x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (App x y) = app x y (rec_lambda var app lam x) (rec_lambda var app lam y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (Lam x) = lam ((\<lambda>lambda. (lambda, rec_lambda var app lam lambda)) \<circ> x)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_lambda v a l x)"
nitpick [expect = genuine]
oops

text \<open>Taken from "Inductive datatypes in HOL", p. 8:\<close>

datatype (dead 'a, 'b) T = C "'a \<Rightarrow> bool" | D "'b list"
datatype 'c U = E "('c, 'c U) T"

lemma "P (x::'c U)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'c U. P x"
nitpick [expect = genuine]
oops

lemma "P (E (C (\<lambda>a. True)))"
nitpick [expect = genuine]
oops

subsubsection \<open>Records\<close>

record ('a, 'b) point =
  xpos :: 'a
  ypos :: 'b

lemma "(x::('a, 'b) point) = y"
nitpick [expect = genuine]
oops

record ('a, 'b, 'c) extpoint = "('a, 'b) point" +
  ext :: 'c

lemma "(x::('a, 'b, 'c) extpoint) = y"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductively Defined Sets\<close>

inductive_set undefinedSet :: "'a set" where
"undefined \<in> undefinedSet"

lemma "x \<in> undefinedSet"
nitpick [expect = genuine]
oops

inductive_set evenCard :: "'a set set"
where
"{} \<in> evenCard" |
"\<lbrakk>S \<in> evenCard; x \<notin> S; y \<notin> S; x \<noteq> y\<rbrakk> \<Longrightarrow> S \<union> {x, y} \<in> evenCard"

lemma "S \<in> evenCard"
nitpick [expect = genuine]
oops

inductive_set
even :: "nat set"
and odd :: "nat set"
where
"0 \<in> even" |
"n \<in> even \<Longrightarrow> Suc n \<in> odd" |
"n \<in> odd \<Longrightarrow> Suc n \<in> even"

lemma "n \<in> odd"
nitpick [expect = genuine]
oops

consts f :: "'a \<Rightarrow> 'a"

inductive_set a_even :: "'a set" and a_odd :: "'a set" where
"undefined \<in> a_even" |
"x \<in> a_even \<Longrightarrow> f x \<in> a_odd" |
"x \<in> a_odd \<Longrightarrow> f x \<in> a_even"

lemma "x \<in> a_odd"
nitpick [expect = genuine]
oops

subsubsection \<open>Examples Involving Special Functions\<close>

lemma "card x = 0"
nitpick [expect = genuine]
oops

lemma "finite x"
nitpick [expect = none]
oops

lemma "xs @ [] = ys @ []"
nitpick [expect = genuine]
oops

lemma "xs @ ys = ys @ xs"
nitpick [expect = genuine]
oops

lemma "f (lfp f) = lfp f"
nitpick [card = 2, expect = genuine]
oops

lemma "f (gfp f) = gfp f"
nitpick [card = 2, expect = genuine]
oops

lemma "lfp f = gfp f"
nitpick [card = 2, expect = genuine]
oops

subsubsection \<open>Axiomatic Type Classes and Overloading\<close>

text \<open>A type class without axioms:\<close>

class classA

lemma "P (x::'a::classA)"
nitpick [expect = genuine]
oops

text \<open>An axiom with a type variable (denoting types which have at least two elements):\<close>

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x::'a::classC)"
nitpick [expect = genuine]
oops

lemma "\<exists>x y. (x::'a::classC) \<noteq> y"
nitpick [expect = none]
sorry

text \<open>A type class for which a constant is defined:\<close>

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x::'a::classD)"
nitpick [expect = genuine]
oops

text \<open>A type class with multiple superclasses:\<close>

class classE = classC + classD

lemma "P (x::'a::classE)"
nitpick [expect = genuine]
oops

text \<open>OFCLASS:\<close>

lemma "OFCLASS('a::type, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::classC, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::type, classC_class)"
nitpick [expect = genuine]
oops

text \<open>Overloading:\<close>

consts inverse :: "'a \<Rightarrow> 'a"

overloading inverse_bool \<equiv> "inverse :: bool \<Rightarrow> bool"
begin
  definition "inverse (b::bool) \<equiv> \<not> b"
end

overloading inverse_set \<equiv> "inverse :: 'a set \<Rightarrow> 'a set"
begin
  definition "inverse (S::'a set) \<equiv> -S"
end

overloading inverse_pair \<equiv> "inverse :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
begin
  definition "inverse_pair p \<equiv> (inverse (fst p), inverse (snd p))"
end

lemma "inverse b"
nitpick [expect = genuine]
oops

lemma "P (inverse (S::'a set))"
nitpick [expect = genuine]
oops

lemma "P (inverse (p::'a\<times>'b))"
nitpick [expect = genuine]
oops

end