theory TypedLambdaOrig
imports Main Tools "~~/src/HOL/Proofs/Lambda/ListOrder"
begin

declare [[syntax_ambiguity_warning = false]]

subsection {* Lambda-terms in de Bruijn notation and substitution *}

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

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

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

declare subst_Var [simp del]

subsection {* Beta-reduction *}

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

abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
  "s ->> t == beta^** s t"

notation (latex)
  beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)

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

declare if_not_P [simp] not_less_eq [simp]
  \<comment> \<open>don't add @{text "r_into_rtrancl[intro!]"}\<close>

subsection {* Congruence rules *}

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

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

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

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

subsection {* Substitution-lemmas *}

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

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

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

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

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

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

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

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

subsection {* Preservation theorems *}

text {* Not used in Church-Rosser proof, but in Strong
  Normalization. \medskip *}

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

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

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

abbreviation
  list_application :: "dB => dB list => dB"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts == foldl (\<degree>) t ts"

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply auto
  done

lemma Abs_eq_apps_conv [iff]:
    "(Abs r = s \<degree>\<degree> ss) = (Abs r = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_apps_eq_Abs_apps_conv [iff]:
    "(Abs r \<degree>\<degree> rs = Abs s \<degree>\<degree> ss) = (r = s \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma Abs_App_neq_Var_apps [iff]:
    "Abs s \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) auto

lemma lift_map [simp]:
    "lift (t \<degree>\<degree> ts) i = lift t i \<degree>\<degree> map (\<lambda>t. lift t i) ts"
  by (induct ts arbitrary: t) simp_all

lemma subst_map [simp]:
    "subst (t \<degree>\<degree> ts) u i = subst t u i \<degree>\<degree> map (\<lambda>t. subst t u i) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

subsection {* Environments *}

definition
  shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"  ("_<_:_>" [90, 0, 0] 91) where
  "e<i:a> = (\<lambda>j. if j < i then e j else if j = i then a else e (j - 1))"

notation (xsymbols)
  shift  ("_\<langle>_:_\<rangle>" [90, 0, 0] 91)

notation (HTML output)
  shift  ("_\<langle>_:_\<rangle>" [90, 0, 0] 91)

lemma shift_gt [simp]: "j < i \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e j"
  by (simp add: shift_def)

lemma shift_lt [simp]: "i < j \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e (j - 1)"
  by (simp add: shift_def)

lemma shift_commute [simp]: "e\<langle>i:U\<rangle>\<langle>0:T\<rangle> = e\<langle>0:T\<rangle>\<langle>Suc i:U\<rangle>"
  by (rule ext) (simp_all add: shift_def split: nat.split)

subsection {* Types and typing rules *}

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

inductive typing :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "env x = T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "env\<langle>0:T\<rangle> \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

inductive_cases typing_elims [elim!]:
  "e \<turnstile> Var i : T"
  "e \<turnstile> t \<degree> u : T"
  "e \<turnstile> Abs t : T"

primrec
  typings :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
where
    "typings e [] Ts = (Ts = [])"
  | "typings e (t # ts) Ts =
      (case Ts of
        [] \<Rightarrow> False
      | T # Ts \<Rightarrow> e \<turnstile> t : T \<and> typings e ts Ts)"

abbreviation
  typings_rel :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
    ("_ ||- _ : _" [50, 50, 50] 50) where
  "env ||- ts : Ts == typings env ts Ts"

notation (latex)
  typings_rel  ("_ \<tturnstile> _ : _" [50, 50, 50] 50)

abbreviation
  funs :: "type list \<Rightarrow> type \<Rightarrow> type"  (infixr "=>>" 200) where
  "Ts =>> T == foldr Fun Ts T"

notation (latex)
  funs  (infixr "\<Rrightarrow>" 200)

subsection {* Lists of types *}

lemma lists_typings:
    "e \<tturnstile> ts : Ts \<Longrightarrow> listsp (\<lambda>t. \<exists>T. e \<turnstile> t : T) ts"
  apply (induct ts arbitrary: Ts)
   apply (case_tac Ts)
     apply simp
     apply (rule listsp.Nil)
    apply simp
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (rule listsp.Cons)
   apply blast
  apply blast
  done

lemma types_snoc_eq: "e \<tturnstile> ts @ [t] : Ts @ [T] =
  (e \<tturnstile> ts : Ts \<and> e \<turnstile> t : T)"
  apply (induct ts arbitrary: Ts)
  apply (case_tac Ts)
  apply simp+
  apply (case_tac Ts)
  apply (case_tac "ts @ [t]")
  apply simp+
  done

lemma rev_exhaust2 [extraction_expand]:
  obtains (Nil) "xs = []"  |  (snoc) ys y where "xs = ys @ [y]"
  \<comment> \<open>Cannot use @{text rev_exhaust} from the @{text List}
    theory, since it is not constructive\<close>
  apply (subgoal_tac "\<forall>ys. xs = rev ys \<longrightarrow> thesis")
  apply (erule_tac x="rev xs" in allE)
  apply simp
  apply (rule allI)
  apply (rule impI)
  apply (case_tac ys)
  apply simp
  apply simp
  done

lemma types_snocE: "e \<tturnstile> ts @ [t] : Ts \<Longrightarrow>
  (\<And>Us U. Ts = Us @ [U] \<Longrightarrow> e \<tturnstile> ts : Us \<Longrightarrow> e \<turnstile> t : U \<Longrightarrow> P) \<Longrightarrow> P"
  apply (cases Ts rule: rev_exhaust2)
  apply simp
  apply (case_tac "ts @ [t]")
  apply (simp add: types_snoc_eq)+
  done

subsection {* n-ary function types *}

lemma list_app_typeD:
    "e \<turnstile> t \<degree>\<degree> ts : T \<Longrightarrow> \<exists>Ts. e \<turnstile> t : Ts \<Rrightarrow> T \<and> e \<tturnstile> ts : Ts"
proof (induction ts arbitrary: t T)
case Nil thus ?case by simp
next case (Cons a ts) thus ?case
  apply simp
  apply atomize
  apply (erule_tac x = "t \<degree> a" in allE)
  apply (erule_tac x = T in allE)
  apply (erule impE)
   close assumption
  apply (elim exE conjE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (rule_tac x = "T # Ts" in exI)
  by simp
qed

lemma list_app_typeE:
  "e \<turnstile> t \<degree>\<degree> ts : T \<Longrightarrow> (\<And>Ts. e \<turnstile> t : Ts \<Rrightarrow> T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow> C) \<Longrightarrow> C"
  by (insert list_app_typeD) fast

lemma list_app_typeI:
    "e \<turnstile> t : Ts \<Rrightarrow> T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow> e \<turnstile> t \<degree>\<degree> ts : T"
  apply (induct ts arbitrary: t T Ts)
   apply simp
  apply (rename_tac a b t T Ts)
  apply atomize
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (erule_tac x = "t \<degree> a" in allE)
  apply (erule_tac x = T in allE)
  apply (rename_tac list)
  apply (erule_tac x = list in allE)
  apply (erule impE)
   apply (erule conjE)
   apply (erule typing.App)
   apply assumption
  apply blast
  done

subsection {* Lifting preserves well-typedness *}

lemma lift_type [intro!]: "e \<turnstile> t : T \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> lift t i : T"
  by (induct arbitrary: i U set: typing) auto

lemma lift_types:
  "e \<tturnstile> ts : Ts \<Longrightarrow> e\<langle>i:U\<rangle> \<tturnstile> (map (\<lambda>t. lift t i) ts) : Ts"
  apply (induct ts arbitrary: Ts)
   apply simp
  apply (case_tac Ts)
   apply auto
  done

subsection {* Substitution lemmas *}

lemma subst_lemma:
    "e \<turnstile> t : T \<Longrightarrow> e' \<turnstile> u : U \<Longrightarrow> e = e'\<langle>i:U\<rangle> \<Longrightarrow> e' \<turnstile> t[u/i] : T"
  apply (induct arbitrary: e' i U u set: typing)
    apply (rule_tac x = x and y = i in linorder_cases)
      apply auto
  apply blast
  done

lemma substs_lemma:
  "e \<turnstile> u : T \<Longrightarrow> e\<langle>i:T\<rangle> \<tturnstile> ts : Ts \<Longrightarrow>
     e \<tturnstile> (map (\<lambda>t. t[u/i]) ts) : Ts"
  apply (induct ts arbitrary: Ts)
   apply (case_tac Ts)
    apply simp
   apply simp
  apply atomize
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (erule conjE)
  apply (erule (1) subst_lemma)
  apply (rule refl)
  done

subsection {* Subject reduction *}

lemma subject_reduction: "e \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> e \<turnstile> t' : T"
proof (induct arbitrary: t' set: typing)
case Var thus ?case by blast
next case Abs thus ?case by blast
next case (App env s T U t) thus ?case apply atomize
  using App.prems proof (cases)
  case (beta s0)
    have "env<0:T> \<turnstile> s0 : U"
      by (smt2 App.hyps(1) local.beta(1) type.inject(2) typing_elims(3))
    show ?thesis
    by (metis App.hyps(1) App.hyps(3) dB.distinct(3) dB.distinct(5) dB.inject(3) local.beta(1) local.beta(2) subst_lemma type.inject(2) typing.cases)
  next case appL with App show ?thesis by auto
  next case appR with App show ?thesis by auto
qed

  from App have ?case  apply atomize
  apply (ind_cases "s \<degree> t \<rightarrow>\<^sub>\<beta> t'" for s t t')
    apply hypsubst
    apply (ind_cases "env \<turnstile> Abs t : T \<Rightarrow> U" for env t T U)
    apply (rule subst_lemma)
      apply assumption
     apply assumption
    apply (rule ext)
    apply (case_tac x)
     apply auto
  done
qed

subsection {* Alternative induction rule for types *}

lemma type_induct [induct type]:
  assumes
  "(\<And>T. (\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> P T1) \<Longrightarrow>
    (\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> P T2) \<Longrightarrow> P T)"
  shows "P T"
proof (induct T)
  case Atom
  show ?case by (rule assms) simp_all
next
  case Fun
  show ?case by (rule assms) (insert Fun, simp_all)
qed

text {*
  Lifting beta-reduction to lists of terms, reducing exactly one element.
*}

abbreviation
  list_beta :: "dB list => dB list => bool"  (infixl "=>" 50) where
  "rs => ss == step1 beta rs ss"

lemma head_Var_reduction:
  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs => ss \<and> v = Var n \<degree>\<degree> ss"
  apply (induct u == "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
     close simp
    apply (rule_tac xs = rs in rev_exhaust)
     close simp
    close (atomize, force intro: append_step1I)
   apply (rule_tac xs = rs in rev_exhaust)
    close simp
    apply (auto 0 3 intro: disjI2 [THEN append_step1I])
  done

lemma apps_betasE [elim!]:
  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    and cases: "!!r'. [| r \<rightarrow>\<^sub>\<beta> r'; s = r' \<degree>\<degree> rs |] ==> R"
      "!!rs'. [| rs => rs'; s = r \<degree>\<degree> rs' |] ==> R"
      "!!t u us. [| r = Abs t; rs = u # us; s = t[u/0] \<degree>\<degree> us |] ==> R"
  shows R
proof -
  from major have
   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    (\<exists>rs'. rs => rs' \<and> s = r \<degree>\<degree> rs') \<or>
    (\<exists>t u us. r = Abs t \<and> rs = u # us \<and> s = t[u/0] \<degree>\<degree> us)"
  proof (induct u == "r \<degree>\<degree> rs" s arbitrary: r rs set: beta)
  case beta thus ?case
       apply (case_tac r)
         close simp
        apply (simp add: App_eq_foldl_conv)
        apply (split split_if_asm)
         apply simp
         close blast
        close simp
       apply (simp add: App_eq_foldl_conv)
       apply (split split_if_asm)
        close simp
       by simp
  next case appL thus ?case
      apply auto
      apply (drule App_eq_foldl_conv [THEN iffD1])
      apply (split split_if_asm)
       apply simp
       close blast
      by (force intro!: disjI1 [THEN append_step1I])
  next case appR thus ?case
     apply auto
     apply (drule App_eq_foldl_conv [THEN iffD1])
     apply (split split_if_asm)
      apply simp
      close blast
     by (clarify, auto 0 3 del: exI intro!: exI intro: append_step1I)
  next case abs thus ?case by auto
  qed
  with cases show ?thesis by blast
qed

lemma apps_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
  by (induct ss rule: rev_induct) auto

lemma apps_preserves_beta2 [simp]:
    "r ->> s ==> r \<degree>\<degree> ss ->> s \<degree>\<degree> ss"
  apply (induct set: rtranclp)
   apply blast
  apply (blast intro: apps_preserves_beta rtranclp.rtrancl_into_rtrancl)
  done

lemma apps_preserves_betas [simp]:
    "rs => ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
  apply simp
  apply (rule_tac xs = ss in rev_exhaust)
   apply simp
  apply simp
  apply (drule Snoc_step1_SnocD)
  apply blast
  done

subsection {* Terminating lambda terms *}

inductive IT :: "dB => bool"
  where
    Var [intro]: "listsp IT rs ==> IT (Var n \<degree>\<degree> rs)"
  | Lambda [intro]: "IT r ==> IT (Abs r)"
  | Beta [intro]: "IT ((r[s/0]) \<degree>\<degree> ss) ==> IT s ==> IT ((Abs r \<degree> s) \<degree>\<degree> ss)"

subsection {* Every term in @{text "IT"} terminates *}

lemma double_induction_lemma [rule_format]:
  "termip beta s ==> \<forall>t. termip beta t -->
    (\<forall>r ss. t = r[s/0] \<degree>\<degree> ss --> termip beta (Abs r \<degree> s \<degree>\<degree> ss))"
  apply (erule accp_induct)
  apply (rule allI)
  apply (rule impI)
  apply (erule thin_rl)
  apply (erule accp_induct)
  apply clarify
  apply (rule accp.accI)
  apply (safe del: apps_betasE elim!: apps_betasE)
    apply (blast intro: subst_preserves_beta apps_preserves_beta)
   apply (blast intro: apps_preserves_beta2 subst_preserves_beta2 rtranclp_converseI
     dest: accp_downwards)  (* FIXME: acc_downwards can be replaced by acc(R ^* ) = acc(r) *)
  apply (blast dest: apps_preserves_betas)
  done

lemma IT_implies_termi: "IT t ==> termip beta t"
proof (induct set: IT)
case Var thus ?case
    apply (drule_tac rev_predicate1D [OF _ listsp_mono [where B="termip beta"]])
    close (fast del: predicate1I intro!: predicate1I)
    apply (drule lists_accD)
    apply (erule accp_induct)
    apply (rule accp.accI)
    by (blast dest: head_Var_reduction)
next case Lambda thus ?case
   apply (erule_tac accp_induct)
   apply (rule accp.accI)
   by blast
next case Beta thus ?case
  by (blast intro: double_induction_lemma)
qed

subsection {* Every terminating term is in @{text "IT"} *}

inductive_cases [elim!]:
  "IT (Var n \<degree>\<degree> ss)"
  "IT (Abs t)"
  "IT (Abs r \<degree> s \<degree>\<degree> ts)"

(*
theorem termi_implies_IT: "termip beta r ==> IT r"
  apply (erule accp_induct)
  apply (rename_tac r)
  apply (erule thin_rl)
  apply (erule rev_mp)
  apply simp
  apply (rule_tac t = r in Apps_dB_induct)
   apply clarify
   apply (rule IT.intros)
   apply clarify
   apply (drule bspec, assumption)
   apply (erule mp)
   apply clarify
   apply (drule_tac r=beta in conversepI)
   apply (drule_tac r="beta^--1" in ex_step1I, assumption)
   apply clarify
   apply (rename_tac us)
   apply (erule_tac x = "Var n \<degree>\<degree> us" in allE)
   apply force
   apply (rename_tac u ts)
   apply (case_tac ts)
    apply simp
    apply blast
   apply (rename_tac s ss)
   apply simp
   apply clarify
   apply (rule IT.intros)
    apply (blast intro: apps_preserves_beta)
   apply (erule mp)
   apply clarify
   apply (rename_tac t)
   apply (erule_tac x = "Abs u \<degree> t \<degree>\<degree> ss" in allE)
   apply force
   done
*)

text {*
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes \cite{Matthes-Joachimski-AML}.
*}

subsection {* Properties of @{text IT} *}

lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
  apply (induct arbitrary: i set: IT)
    apply (simp (no_asm))
    apply (rule conjI)
     apply
      (rule impI,
       rule IT.Var,
       erule listsp.induct,
       simp (no_asm),
       simp (no_asm),
       rule listsp.Cons,
       blast,
       assumption)+
     apply auto
   done

lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
  apply (induct arbitrary: i j set: IT)
    txt {* Case @{term Var}: *}
    apply (simp (no_asm) add: subst_Var)
    apply
    ((rule conjI impI)+,
      rule IT.Var,
      erule listsp.induct,
      simp (no_asm),
      simp (no_asm),
      rule listsp.Cons,
      fast,
      assumption)+
   txt {* Case @{term Lambda}: *}
   apply atomize
   apply simp
   apply (rule IT.Lambda)
   apply fast
  txt {* Case @{term Beta}: *}
  apply atomize
  apply (simp (no_asm_use) add: subst_subst [symmetric])
  apply (rule IT.Beta)
   apply auto
  done

lemma Var_IT: "IT (Var n)"
  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule IT.Var)
  apply (rule listsp.Nil)
  done

lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
proof (induct set: IT)
case Var thus ?case
    apply (subst app_last)
    apply (rule IT.Var)
    apply simp
    apply (rule listsp.Cons)
     close (rule Var_IT)
    by (rule listsp.Nil)
next case Lambda show ?case
  apply (insert Lambda)
  apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
  close (erule subst_Var_IT)
  by (rule Var_IT)
next case Beta thus ?case
  apply (subst app_last)
  apply (rule IT.Beta)
   apply (subst app_last [symmetric])
   close assumption
  by assumption
qed

subsection {* Well-typed substitution preserves termination *}

lemma subst_type_IT:
  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "IT t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i
    assume uIT: "IT u"
    assume uT: "e \<turnstile> u : T"
    {
      case (Var rs n e1 T'1 u1 i1)
      assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
      let ?R = "\<lambda>t. \<forall>e T' u i.
        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
      proof (cases "n = i")
        case True
        show ?thesis
        proof (cases rs)
          case Nil
          with uIT True show ?thesis by simp
        next
          case (Cons a as)
          with nT have "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a \<degree>\<degree> as : T'" by simp
          then obtain Ts
              where headT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a : Ts \<Rrightarrow> T'"
              and argsT: "e\<langle>i:T\<rangle> \<tturnstile> as : Ts"
            by (rule list_app_typeE)
          from headT obtain T''
              where varT: "e\<langle>i:T\<rangle> \<turnstile> Var n : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
              and argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''"
            by cases simp_all
          from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
          proof (rule MI2)
            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
            proof (rule MI1)
              have "IT (lift u 0)" by (rule lift_IT [OF uIT])
              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
              show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
              proof (rule typing.App)
                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
                  by (rule lift_type) (rule uT')
                show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''"
                  by (rule typing.Var) simp
              qed
              from Var have "?R a" by cases (simp_all add: Cons)
              with argT uIT uT show "IT (a[u/i])" by simp
              from argT uT show "e \<turnstile> a[u/i] : T''"
                by (rule subst_lemma) simp
            qed
            thus "IT (u \<degree> a[u/i])" by simp
            from Var have "listsp ?R as"
              by cases (simp_all add: Cons)
            moreover from argsT have "listsp ?ty as"
              by (rule lists_typings)
            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
              by simp
            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
              (is "listsp IT (?ls as)")
            proof induct
              case Nil
              show ?case by fastforce
            next
              case (Cons b bs)
              hence I: "?R b" by simp
              from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
              with uT uIT I have "IT (b[u/i])" by simp
              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
                by (rule listsp.Cons) (rule Cons)
              thus ?case by simp
            qed
            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
              by (rule typing.Var) simp
            moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
              by (rule substs_lemma)
            hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> ?ls as : Ts"
              by (rule lift_types)
            ultimately show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> ?ls as : T'"
              by (rule list_app_typeI)
            from argT uT have "e \<turnstile> a[u/i] : T''"
              by (rule subst_lemma) (rule refl)
            with uT' show "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'"
              by (rule typing.App)
          qed
          with Cons True show ?thesis
            by (simp add: comp_def)
        qed
      next
        case False
        from Var have "listsp ?R rs" by simp
        moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
          by (rule list_app_typeE)
        hence "listsp ?ty rs" by (rule lists_typings)
        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
          by simp
        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
        proof induct
          case Nil
          show ?case by fastforce
        next
          case (Cons a as)
          hence I: "?R a" by simp
          from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
          with uT uIT I have "IT (a[u/i])" by simp
          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
            by (rule listsp.Cons) (rule Cons)
          thus ?case by simp
        qed
        with False show ?thesis by (auto simp add: subst_Var)
      qed
    next
      case (Lambda r e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
        and "\<And>e T' u i. PROP ?Q r e T' u i T"
      with uIT uT show "IT (Abs r[u/i])"
        by fastforce
    next
      case (Beta r a as e1 T'1 u1 i1)
      assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
      assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
      assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
      proof (rule IT.Beta)
        have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
          by (rule apps_preserves_beta) (rule beta.beta)
        with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
          by (rule subject_reduction)
        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
          using uIT uT by (rule SI1)
        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
          by (simp del: subst_map add: subst_subst subst_map [symmetric])
        from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
          by (rule list_app_typeE) fast
        then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
        thus "IT (a[u/i])" using uIT uT by (rule SI2)
      qed
      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
    }
  qed
qed

subsection {* Well-typed terms are strongly normalizing *}

lemma type_implies_IT:
  assumes "e \<turnstile> t : T"
  shows "IT t"
  using assms
proof induct
  case Var
  show ?case by (rule Var_IT)
next
  case Abs
  show ?case by (rule IT.Lambda) (rule Abs)
next
  case (App e s T U t)
  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
  proof (rule subst_type_IT)
    have "IT (lift t 0)" using `IT t` by (rule lift_IT)
    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
    also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
    finally show "IT \<dots>" .
    have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
      by (rule typing.Var) simp
    moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
      by (rule lift_type) (rule App.hyps)
    ultimately show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t 0 : U"
      by (rule typing.App)
    show "IT s" by fact
    show "e \<turnstile> s : T \<Rightarrow> U" by fact
  qed
  thus ?case by simp
qed

theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termip beta t"
proof -
  assume "e \<turnstile> t : T"
  hence "IT t" by (rule type_implies_IT)
  thus ?thesis by (rule IT_implies_termi)
qed

end


(*  Title:      HOL/Library/Prefix_Order.thy
    Author:     Tobias Nipkow and Markus Wenzel, TU Muenchen
*)

section \<open>Prefix order on lists as order class instance\<close>

theory Prefix_Order
imports Sublist
begin

instantiation list :: (type) order
begin

definition "xs \<le> ys \<equiv> prefix xs ys" for xs ys :: "'a list"
definition "xs < ys \<equiv> xs \<le> ys \<and> \<not> (ys \<le> xs)" for xs ys :: "'a list"

instance
  by standard (auto simp: less_eq_list_def less_list_def)

end

lemma less_list_def': "xs < ys \<longleftrightarrow> strict_prefix xs ys" for xs ys :: "'a list"
  by (simp add: less_eq_list_def order.strict_iff_order prefix_order.less_le)

lemmas prefixI [intro?] = prefixI [folded less_eq_list_def]
lemmas prefixE [elim?] = prefixE [folded less_eq_list_def]
lemmas strict_prefixI' [intro?] = strict_prefixI' [folded less_list_def']
lemmas strict_prefixE' [elim?] = strict_prefixE' [folded less_list_def']
lemmas strict_prefixI [intro?] = strict_prefixI [folded less_list_def']
lemmas strict_prefixE [elim?] = strict_prefixE [folded less_list_def']
lemmas Nil_prefix [iff] = Nil_prefix [folded less_eq_list_def]
lemmas prefix_Nil [simp] = prefix_Nil [folded less_eq_list_def]
lemmas prefix_snoc [simp] = prefix_snoc [folded less_eq_list_def]
lemmas Cons_prefix_Cons [simp] = Cons_prefix_Cons [folded less_eq_list_def]
lemmas same_prefix_prefix [simp] = same_prefix_prefix [folded less_eq_list_def]
lemmas same_prefix_nil [iff] = same_prefix_nil [folded less_eq_list_def]
lemmas prefix_prefix [simp] = prefix_prefix [folded less_eq_list_def]
lemmas prefix_Cons = prefix_Cons [folded less_eq_list_def]
lemmas prefix_length_le = prefix_length_le [folded less_eq_list_def]
lemmas strict_prefix_simps [simp, code] = strict_prefix_simps [folded less_list_def']
lemmas not_prefix_induct [consumes 1, case_names Nil Neq Eq] =
  not_prefix_induct [folded less_eq_list_def]

end


(*
  File:   Prime_Harmonic_Misc.thy
  Author: Manuel Eberl <manuel@pruvisto.org>

*)

section \<open>Auxiliary lemmas\<close>
theory Prime_Harmonic_Misc
imports
  Complex_Main
  "HOL-Number_Theory.Number_Theory"
begin

lemma sum_list_nonneg: "\<forall>x\<in>set xs. x \<ge> 0 \<Longrightarrow> sum_list xs \<ge> (0 :: 'a :: ordered_ab_group_add)"
  by (induction xs) auto

lemma sum_telescope':
  assumes "m \<le> n"
  shows   "(\<Sum>k = Suc m..n. f k - f (Suc k)) = f (Suc m) - (f (Suc n) :: 'a :: ab_group_add)"
  by (rule dec_induct[OF assms]) (simp_all add: algebra_simps)

lemma dvd_prodI:
  assumes "finite A" "x \<in> A"
  shows   "f x dvd prod f A"
proof -
  from assms have "prod f A = f x * prod f (A - {x})"
    by (intro prod.remove) simp_all
  thus ?thesis by simp
qed

lemma dvd_prodD: "finite A \<Longrightarrow> prod f A dvd x \<Longrightarrow> a \<in> A \<Longrightarrow> f a dvd x"
  by (erule dvd_trans[OF dvd_prodI])

lemma multiplicity_power_nat:
  "prime p \<Longrightarrow> n > 0 \<Longrightarrow> multiplicity p (n ^ k :: nat) = k * multiplicity p n"
  by (induction k) (simp_all add: prime_elem_multiplicity_mult_distrib)

lemma multiplicity_prod_prime_powers_nat':
  "finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow>
     multiplicity p (\<Prod>S :: nat) = (if p \<in> S then 1 else 0)"
  using multiplicity_prod_prime_powers[of S p "\<lambda>_. 1"] by simp

lemma prod_prime_subset:
  assumes "finite A" "finite B"
  assumes "\<And>x. x \<in> A \<Longrightarrow> prime (x::nat)"
  assumes "\<And>x. x \<in> B \<Longrightarrow> prime x"
  assumes "\<Prod>A dvd \<Prod>B"
  shows   "A \<subseteq> B"
proof
  fix x assume x: "x \<in> A"
  from assms(4)[of 0] have "0 \<notin> B" by auto
  with assms have nonzero: "\<forall>z\<in>B. z \<noteq> 0" by (intro ballI notI) auto

  from x assms have "1 = multiplicity x (\<Prod>A)"
    by (subst multiplicity_prod_prime_powers_nat') simp_all
  also from assms nonzero have "\<dots> \<le> multiplicity x (\<Prod>B)" by (intro dvd_imp_multiplicity_le) auto
  finally have "multiplicity x (\<Prod>B) > 0" by simp
  moreover from assms x have "prime x" by simp
  ultimately show "x \<in> B" using assms(2,4)
    by (subst (asm) multiplicity_prod_prime_powers_nat') (simp_all split: if_split_asm)
qed

lemma prod_prime_eq:
  assumes "finite A" "finite B" "\<And>x. x \<in> A \<Longrightarrow> prime (x::nat)" "\<And>x. x \<in> B \<Longrightarrow> prime x" "\<Prod>A = \<Prod>B"
  shows   "A = B"
  using assms by (intro equalityI prod_prime_subset) simp_all

lemma ln_ln_nonneg:
  assumes x: "x \<ge> (3 :: real)"
  shows   "ln (ln x) \<ge> 0"
proof -
  have "exp 1 \<le> (3::real)" by (rule  exp_le)
  hence "ln (exp 1) \<le> ln (3 :: real)" by (subst ln_le_cancel_iff) simp_all
  also from x have "\<dots> \<le> ln x" by (subst ln_le_cancel_iff) simp_all
  finally have "ln 1 \<le> ln (ln x)" using x by (subst ln_le_cancel_iff) simp_all
  thus ?thesis by simp
qed

end


(*  Title:      HOL/Nonstandard_Analysis/HDeriv.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>Differentiation (Nonstandard)\<close>

theory HDeriv
  imports HLim
begin

text \<open>Nonstandard Definitions.\<close>

definition nsderiv :: "['a::real_normed_field \<Rightarrow> 'a, 'a, 'a] \<Rightarrow> bool"
    ("(NSDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
  where "NSDERIV f x :> D \<longleftrightarrow>
    (\<forall>h \<in> Infinitesimal - {0}. (( *f* f)(star_of x + h) - star_of (f x)) / h \<approx> star_of D)"

definition NSdifferentiable :: "['a::real_normed_field \<Rightarrow> 'a, 'a] \<Rightarrow> bool"
    (infixl "NSdifferentiable" 60)
  where "f NSdifferentiable x \<longleftrightarrow> (\<exists>D. NSDERIV f x :> D)"

definition increment :: "(real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> hypreal \<Rightarrow> hypreal"
  where "increment f x h =
    (SOME inc. f NSdifferentiable x \<and> inc = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x))"

subsection \<open>Derivatives\<close>

lemma DERIV_NS_iff: "(DERIV f x :> D) \<longleftrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: DERIV_def LIM_NSLIM_iff)

lemma NS_DERIV_D: "DERIV f x :> D \<Longrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: DERIV_def LIM_NSLIM_iff)

lemma hnorm_of_hypreal: "\<And>r. hnorm (( *f* of_real) r::'a::real_normed_div_algebra star) = \<bar>r\<bar>"
  by transfer (rule norm_of_real)

lemma Infinitesimal_of_hypreal:
  "x \<in> Infinitesimal \<Longrightarrow> (( *f* of_real) x::'a::real_normed_div_algebra star) \<in> Infinitesimal"
  apply (rule InfinitesimalI2)
  apply (drule (1) InfinitesimalD2)
  apply (simp add: hnorm_of_hypreal)
  done

lemma of_hypreal_eq_0_iff: "\<And>x. (( *f* of_real) x = (0::'a::real_algebra_1 star)) = (x = 0)"
  by transfer (rule of_real_eq_0_iff)

lemma NSDeriv_unique: "NSDERIV f x :> D \<Longrightarrow> NSDERIV f x :> E \<Longrightarrow> D = E"
  apply (subgoal_tac "( *f* of_real) \<epsilon> \<in> Infinitesimal - {0::'a star}")
   apply (simp only: nsderiv_def)
   apply (drule (1) bspec)+
   apply (drule (1) approx_trans3)
   apply simp
  apply (simp add: Infinitesimal_of_hypreal Infinitesimal_epsilon)
  apply (simp add: of_hypreal_eq_0_iff hypreal_epsilon_not_zero)
  done

text \<open>First \<open>NSDERIV\<close> in terms of \<open>NSLIM\<close>.\<close>

text \<open>First equivalence.\<close>
lemma NSDERIV_NSLIM_iff: "(NSDERIV f x :> D) \<longleftrightarrow> (\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  apply (auto simp add: nsderiv_def NSLIM_def)
   apply (drule_tac x = xa in bspec)
    apply (rule_tac [3] ccontr)
    apply (drule_tac [3] x = h in spec)
    apply (auto simp add: mem_infmal_iff starfun_lambda_cancel)
  done

text \<open>Second equivalence.\<close>
lemma NSDERIV_NSLIM_iff2: "(NSDERIV f x :> D) \<longleftrightarrow> (\<lambda>z. (f z - f x) / (z - x)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S D"
  by (simp add: NSDERIV_NSLIM_iff DERIV_LIM_iff LIM_NSLIM_iff [symmetric])

text \<open>While we're at it!\<close>
lemma NSDERIV_iff2:
  "(NSDERIV f x :> D) \<longleftrightarrow>
    (\<forall>w. w \<noteq> star_of x & w \<approx> star_of x \<longrightarrow> ( *f* (%z. (f z - f x) / (z-x))) w \<approx> star_of D)"
  by (simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

(* FIXME delete *)
lemma hypreal_not_eq_minus_iff: "x \<noteq> a \<longleftrightarrow> x - a \<noteq> (0::'a::ab_group_add)"
  by auto

lemma NSDERIVD5:
  "(NSDERIV f x :> D) \<Longrightarrow>
   (\<forall>u. u \<approx> hypreal_of_real x \<longrightarrow>
     ( *f* (\<lambda>z. f z - f x)) u \<approx> hypreal_of_real D * (u - hypreal_of_real x))"
  apply (auto simp add: NSDERIV_iff2)
  apply (case_tac "u = hypreal_of_real x", auto)
  apply (drule_tac x = u in spec, auto)
  apply (drule_tac c = "u - hypreal_of_real x" and b = "hypreal_of_real D" in approx_mult1)
   apply (drule_tac [!] hypreal_not_eq_minus_iff [THEN iffD1])
   apply (subgoal_tac [2] "( *f* (%z. z-x)) u \<noteq> (0::hypreal) ")
    apply (auto simp: approx_minus_iff [THEN iffD1, THEN mem_infmal_iff [THEN iffD2]]
      Infinitesimal_subset_HFinite [THEN subsetD])
  done

lemma NSDERIVD4:
  "(NSDERIV f x :> D) \<Longrightarrow>
    (\<forall>h \<in> Infinitesimal.
      ( *f* f)(hypreal_of_real x + h) - hypreal_of_real (f x) \<approx> hypreal_of_real D * h)"
  apply (auto simp add: nsderiv_def)
  apply (case_tac "h = 0")
   apply auto
  apply (drule_tac x = h in bspec)
   apply (drule_tac [2] c = h in approx_mult1)
    apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD])
  done

lemma NSDERIVD3:
  "(NSDERIV f x :> D) \<Longrightarrow>
    \<forall>h \<in> Infinitesimal - {0}.
      (( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)) \<approx> hypreal_of_real D * h"
  apply (auto simp add: nsderiv_def)
  apply (rule ccontr, drule_tac x = h in bspec)
   apply (drule_tac [2] c = h in approx_mult1)
    apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD] simp add: mult.assoc)
  done

text \<open>Differentiability implies continuity nice and simple "algebraic" proof.\<close>
lemma NSDERIV_isNSCont: "NSDERIV f x :> D \<Longrightarrow> isNSCont f x"
  apply (auto simp add: nsderiv_def isNSCont_NSLIM_iff NSLIM_def)
  apply (drule approx_minus_iff [THEN iffD1])
  apply (drule hypreal_not_eq_minus_iff [THEN iffD1])
  apply (drule_tac x = "xa - star_of x" in bspec)
   prefer 2 apply (simp add: add.assoc [symmetric])
   apply (auto simp add: mem_infmal_iff [symmetric] add.commute)
  apply (drule_tac c = "xa - star_of x" in approx_mult1)
   apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD] simp add: mult.assoc)
  apply (drule_tac x3=D in
      HFinite_star_of [THEN [2] Infinitesimal_HFinite_mult, THEN mem_infmal_iff [THEN iffD1]])
  apply (auto simp add: mult.commute intro: approx_trans approx_minus_iff [THEN iffD2])
  done

text \<open>Differentiation rules for combinations of functions
  follow from clear, straightforard, algebraic manipulations.\<close>

text \<open>Constant function.\<close>

(* use simple constant nslimit theorem *)
lemma NSDERIV_const [simp]: "NSDERIV (\<lambda>x. k) x :> 0"
  by (simp add: NSDERIV_NSLIM_iff)

text \<open>Sum of functions- proved easily.\<close>

lemma NSDERIV_add:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x + g x) x :> Da + Db"
  apply (auto simp add: NSDERIV_NSLIM_iff NSLIM_def)
  apply (auto simp add: add_divide_distrib diff_divide_distrib dest!: spec)
  apply (drule_tac b = "star_of Da" and d = "star_of Db" in approx_add)
   apply (auto simp add: ac_simps algebra_simps)
  done

text \<open>Product of functions - Proof is trivial but tedious
  and long due to rearrangement of terms.\<close>

lemma lemma_nsderiv1: "(a * b) - (c * d) = (b * (a - c)) + (c * (b - d))"
  for a b c d :: "'a::comm_ring star"
  by (simp add: right_diff_distrib ac_simps)

lemma lemma_nsderiv2: "(x - y) / z = star_of D + yb \<Longrightarrow> z \<noteq> 0 \<Longrightarrow>
  z \<in> Infinitesimal \<Longrightarrow> yb \<in> Infinitesimal \<Longrightarrow> x - y \<approx> 0"
  for x y z :: "'a::real_normed_field star"
  apply (simp add: nonzero_divide_eq_eq)
  apply (auto intro!: Infinitesimal_HFinite_mult2 HFinite_add
      simp add: mult.assoc mem_infmal_iff [symmetric])
  apply (erule Infinitesimal_subset_HFinite [THEN subsetD])
  done

lemma NSDERIV_mult:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow>
    NSDERIV (\<lambda>x. f x * g x) x :> (Da * g x) + (Db * f x)"
  apply (auto simp add: NSDERIV_NSLIM_iff NSLIM_def)
  apply (auto dest!: spec simp add: starfun_lambda_cancel lemma_nsderiv1)
  apply (simp (no_asm) add: add_divide_distrib diff_divide_distrib)
  apply (drule bex_Infinitesimal_iff2 [THEN iffD2])+
  apply (auto simp add: times_divide_eq_right [symmetric]
      simp del: times_divide_eq_right times_divide_eq_left)
  apply (drule_tac D = Db in lemma_nsderiv2, assumption+)
  apply (drule_tac approx_minus_iff [THEN iffD2, THEN bex_Infinitesimal_iff2 [THEN iffD2]])
  apply (auto intro!: approx_add_mono1 simp: distrib_right distrib_left mult.commute add.assoc)
  apply (rule_tac b1 = "star_of Db * star_of (f x)" in add.commute [THEN subst])
  apply (auto intro!: Infinitesimal_add_approx_self2 [THEN approx_sym]
      Infinitesimal_add Infinitesimal_mult Infinitesimal_star_of_mult Infinitesimal_star_of_mult2
      simp add: add.assoc [symmetric])
  done

text \<open>Multiplying by a constant.\<close>
lemma NSDERIV_cmult: "NSDERIV f x :> D \<Longrightarrow> NSDERIV (\<lambda>x. c * f x) x :> c * D"
  apply (simp only: times_divide_eq_right [symmetric] NSDERIV_NSLIM_iff
      minus_mult_right right_diff_distrib [symmetric])
  apply (erule NSLIM_const [THEN NSLIM_mult])
  done

text \<open>Negation of function.\<close>
lemma NSDERIV_minus: "NSDERIV f x :> D \<Longrightarrow> NSDERIV (\<lambda>x. - f x) x :> - D"
proof (simp add: NSDERIV_NSLIM_iff)
  assume "(\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D"
  then have deriv: "(\<lambda>h. - ((f(x+h) - f x) / h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by (rule NSLIM_minus)
  have "\<forall>h. - ((f (x + h) - f x) / h) = (- f (x + h) + f x) / h"
    by (simp add: minus_divide_left)
  with deriv have "(\<lambda>h. (- f (x + h) + f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by simp
  then show "(\<lambda>h. (f (x + h) - f x) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S D \<Longrightarrow> (\<lambda>h. (f x - f (x + h)) / h) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S - D"
    by simp
qed

text \<open>Subtraction.\<close>
lemma NSDERIV_add_minus:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x + - g x) x :> Da + - Db"
  by (blast dest: NSDERIV_add NSDERIV_minus)

lemma NSDERIV_diff:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x - g x) x :> Da - Db"
  using NSDERIV_add_minus [of f x Da g Db] by simp

text \<open>Similarly to the above, the chain rule admits an entirely
  straightforward derivation. Compare this with Harrison's
  HOL proof of the chain rule, which proved to be trickier and
  required an alternative characterisation of differentiability-
  the so-called Carathedory derivative. Our main problem is
  manipulation of terms.\<close>

subsection \<open>Lemmas\<close>

lemma NSDERIV_zero:
  "NSDERIV g x :> D \<Longrightarrow> ( *f* g) (star_of x + xa) = star_of (g x) \<Longrightarrow>
    xa \<in> Infinitesimal \<Longrightarrow> xa \<noteq> 0 \<Longrightarrow> D = 0"
  apply (simp add: nsderiv_def)
  apply (drule bspec)
   apply auto
  done

text \<open>Can be proved differently using \<open>NSLIM_isCont_iff\<close>.\<close>
lemma NSDERIV_approx:
  "NSDERIV f x :> D \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> h \<noteq> 0 \<Longrightarrow>
    ( *f* f) (star_of x + h) - star_of (f x) \<approx> 0"
  apply (simp add: nsderiv_def)
  apply (simp add: mem_infmal_iff [symmetric])
  apply (rule Infinitesimal_ratio)
    apply (rule_tac [3] approx_star_of_HFinite, auto)
  done

text \<open>From one version of differentiability

        \<open>f x - f a\<close>
      \<open>-------------- \<approx> Db\<close>
          \<open>x - a\<close>
\<close>

lemma NSDERIVD1: "[| NSDERIV f (g x) :> Da;
         ( *f* g) (star_of(x) + xa) \<noteq> star_of (g x);
         ( *f* g) (star_of(x) + xa) \<approx> star_of (g x)
      |] ==> (( *f* f) (( *f* g) (star_of(x) + xa))
                   - star_of (f (g x)))
              / (( *f* g) (star_of(x) + xa) - star_of (g x))
             \<approx> star_of(Da)"
  by (auto simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

text \<open>From other version of differentiability

      \<open>f (x + h) - f x\<close>
     \<open>------------------ \<approx> Db\<close>
             \<open>h\<close>
\<close>

lemma NSDERIVD2: "[| NSDERIV g x :> Db; xa \<in> Infinitesimal; xa \<noteq> 0 |]
      ==> (( *f* g) (star_of(x) + xa) - star_of(g x)) / xa
          \<approx> star_of(Db)"
  by (auto simp add: NSDERIV_NSLIM_iff NSLIM_def mem_infmal_iff starfun_lambda_cancel)

lemma lemma_chain: "z \<noteq> 0 \<Longrightarrow> x * y = (x * inverse z) * (z * y)"
  for x y z :: "'a::real_normed_field star"
proof -
  assume z: "z \<noteq> 0"
  have "x * y = x * (inverse z * z) * y" by (simp add: z)
  then show ?thesis by (simp add: mult.assoc)
qed

text \<open>This proof uses both definitions of differentiability.\<close>
lemma NSDERIV_chain:
  "NSDERIV f (g x) :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (f \<circ> g) x :> Da * Db"
  apply (simp (no_asm_simp) add: NSDERIV_NSLIM_iff NSLIM_def mem_infmal_iff [symmetric])
  apply clarify
  apply (frule_tac f = g in NSDERIV_approx)
    apply (auto simp add: starfun_lambda_cancel2 starfun_o [symmetric])
  apply (case_tac "( *f* g) (star_of (x) + xa) = star_of (g x) ")
   apply (drule_tac g = g in NSDERIV_zero)
      apply (auto simp add: divide_inverse)
  apply (rule_tac z1 = "( *f* g) (star_of (x) + xa) - star_of (g x) " and y1 = "inverse xa" in lemma_chain [THEN ssubst])
   apply (erule hypreal_not_eq_minus_iff [THEN iffD1])
  apply (rule approx_mult_star_of)
   apply (simp_all add: divide_inverse [symmetric])
   apply (blast intro: NSDERIVD1 approx_minus_iff [THEN iffD2])
  apply (blast intro: NSDERIVD2)
  done

text \<open>Differentiation of natural number powers.\<close>
lemma NSDERIV_Id [simp]: "NSDERIV (\<lambda>x. x) x :> 1"
  by (simp add: NSDERIV_NSLIM_iff NSLIM_def del: divide_self_if)

lemma NSDERIV_cmult_Id [simp]: "NSDERIV (op * c) x :> c"
  using NSDERIV_Id [THEN NSDERIV_cmult] by simp

lemma NSDERIV_inverse:
  fixes x :: "'a::real_normed_field"
  assumes "x \<noteq> 0" \<comment> \<open>can't get rid of @{term "x \<noteq> 0"} because it isn't continuous at zero\<close>
  shows "NSDERIV (\<lambda>x. inverse x) x :> - (inverse x ^ Suc (Suc 0))"
proof -
  {
    fix h :: "'a star"
    assume h_Inf: "h \<in> Infinitesimal"
    from this assms have not_0: "star_of x + h \<noteq> 0"
      by (rule Infinitesimal_add_not_zero)
    assume "h \<noteq> 0"
    from h_Inf have "h * star_of x \<in> Infinitesimal"
      by (rule Infinitesimal_HFinite_mult) simp
    with assms have "inverse (- (h * star_of x) + - (star_of x * star_of x)) \<approx>
      inverse (- (star_of x * star_of x))"
      apply -
      apply (rule inverse_add_Infinitesimal_approx2)
      apply (auto dest!: hypreal_of_real_HFinite_diff_Infinitesimal
        simp add: inverse_minus_eq [symmetric] HFinite_minus_iff)
      done
    moreover from not_0 \<open>h \<noteq> 0\<close> assms
    have "inverse (- (h * star_of x) + - (star_of x * star_of x)) =
      (inverse (star_of x + h) - inverse (star_of x)) / h"
      apply (simp add: division_ring_inverse_diff nonzero_inverse_mult_distrib [symmetric]
          nonzero_inverse_minus_eq [symmetric] ac_simps ring_distribs)
      apply (subst nonzero_inverse_minus_eq [symmetric])
      using distrib_right [symmetric, of h "star_of x" "star_of x"] apply simp
      apply (simp add: field_simps)
      done
    ultimately have "(inverse (star_of x + h) - inverse (star_of x)) / h \<approx>
      - (inverse (star_of x) * inverse (star_of x))"
      using assms by simp
  }
  then show ?thesis by (simp add: nsderiv_def)
qed

subsubsection \<open>Equivalence of NS and Standard definitions\<close>

lemma divideR_eq_divide: "x /\<^sub>R y = x / y"
  by (simp add: divide_inverse mult.commute)

text \<open>Now equivalence between \<open>NSDERIV\<close> and \<open>DERIV\<close>.\<close>
lemma NSDERIV_DERIV_iff: "NSDERIV f x :> D \<longleftrightarrow> DERIV f x :> D"
  by (simp add: DERIV_def NSDERIV_NSLIM_iff LIM_NSLIM_iff)

text \<open>NS version.\<close>
lemma NSDERIV_pow: "NSDERIV (\<lambda>x. x ^ n) x :> real n * (x ^ (n - Suc 0))"
  by (simp add: NSDERIV_DERIV_iff DERIV_pow)

text \<open>Derivative of inverse.\<close>
lemma NSDERIV_inverse_fun:
  "NSDERIV f x :> d \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow>
    NSDERIV (\<lambda>x. inverse (f x)) x :> (- (d * inverse (f x ^ Suc (Suc 0))))"
  for x :: "'a::{real_normed_field}"
  by (simp add: NSDERIV_DERIV_iff DERIV_inverse_fun del: power_Suc)

text \<open>Derivative of quotient.\<close>
lemma NSDERIV_quotient:
  fixes x :: "'a::real_normed_field"
  shows "NSDERIV f x :> d \<Longrightarrow> NSDERIV g x :> e \<Longrightarrow> g x \<noteq> 0 \<Longrightarrow>
    NSDERIV (\<lambda>y. f y / g y) x :> (d * g x - (e * f x)) / (g x ^ Suc (Suc 0))"
  by (simp add: NSDERIV_DERIV_iff DERIV_quotient del: power_Suc)

lemma CARAT_NSDERIV:
  "NSDERIV f x :> l \<Longrightarrow> \<exists>g. (\<forall>z. f z - f x = g z * (z - x)) \<and> isNSCont g x \<and> g x = l"
  by (auto simp add: NSDERIV_DERIV_iff isNSCont_isCont_iff CARAT_DERIV mult.commute)

lemma hypreal_eq_minus_iff3: "x = y + z \<longleftrightarrow> x + - z = y"
  for x y z :: hypreal
  by auto

lemma CARAT_DERIVD:
  assumes all: "\<forall>z. f z - f x = g z * (z - x)"
    and nsc: "isNSCont g x"
  shows "NSDERIV f x :> g x"
proof -
  from nsc have "\<forall>w. w \<noteq> star_of x \<and> w \<approx> star_of x \<longrightarrow>
       ( *f* g) w * (w - star_of x) / (w - star_of x) \<approx> star_of (g x)"
    by (simp add: isNSCont_def)
  with all show ?thesis
    by (simp add: NSDERIV_iff2 starfun_if_eq cong: if_cong)
qed

subsubsection \<open>Differentiability predicate\<close>

lemma NSdifferentiableD: "f NSdifferentiable x \<Longrightarrow> \<exists>D. NSDERIV f x :> D"
  by (simp add: NSdifferentiable_def)

lemma NSdifferentiableI: "NSDERIV f x :> D \<Longrightarrow> f NSdifferentiable x"
  by (force simp add: NSdifferentiable_def)

subsection \<open>(NS) Increment\<close>

lemma incrementI:
  "f NSdifferentiable x \<Longrightarrow>
    increment f x h = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)"
  by (simp add: increment_def)

lemma incrementI2:
  "NSDERIV f x :> D \<Longrightarrow>
    increment f x h = ( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)"
  by (erule NSdifferentiableI [THEN incrementI])

text \<open>The Increment theorem -- Keisler p. 65.\<close>
lemma increment_thm:
  "NSDERIV f x :> D \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> h \<noteq> 0 \<Longrightarrow>
    \<exists>e \<in> Infinitesimal. increment f x h = hypreal_of_real D * h + e * h"
  apply (frule_tac h = h in incrementI2, simp add: nsderiv_def)
  apply (drule bspec, auto)
  apply (drule bex_Infinitesimal_iff2 [THEN iffD2], clarify)
  apply (frule_tac b1 = "hypreal_of_real D + y" in mult_right_cancel [THEN iffD2])
   apply (erule_tac [2]
      V = "(( *f* f) (hypreal_of_real x + h) - hypreal_of_real (f x)) / h = hypreal_of_real (D) + y"
      in thin_rl)
   apply assumption
  apply (simp add: times_divide_eq_right [symmetric])
  apply (auto simp add: distrib_right)
  done

lemma increment_thm2:
  "NSDERIV f x :> D \<Longrightarrow> h \<approx> 0 \<Longrightarrow> h \<noteq> 0 \<Longrightarrow>
    \<exists>e \<in> Infinitesimal. increment f x h = hypreal_of_real D * h + e * h"
  by (blast dest!: mem_infmal_iff [THEN iffD2] intro!: increment_thm)

lemma increment_approx_zero: "NSDERIV f x :> D \<Longrightarrow> h \<approx> 0 \<Longrightarrow> h \<noteq> 0 \<Longrightarrow> increment f x h \<approx> 0"
  apply (drule increment_thm2)
    apply (auto intro!: Infinitesimal_HFinite_mult2 HFinite_add
      simp add: distrib_right [symmetric] mem_infmal_iff [symmetric])
  apply (erule Infinitesimal_subset_HFinite [THEN subsetD])
  done

end