theory Typechecking
  imports Typed "../01Source/Named" "../00Utils/Unification/Unification"
begin

datatype hexpr =
  HVar var
  | HConst nat
  | HLam var uexpr hexpr
  | HApp hexpr hexpr

primrec hsubst :: "subst \<Rightarrow> hexpr \<Rightarrow> hexpr" where
  "hsubst sub (HVar x) = HVar x"
| "hsubst sub (HConst k) = HConst k"
| "hsubst sub (HLam x t e) = HLam x (subst sub t) (hsubst sub e)"
| "hsubst sub (HApp e\<^sub>1 e\<^sub>2) = HApp (hsubst sub e\<^sub>1) (hsubst sub e\<^sub>2)"

primrec erase :: "texpr \<Rightarrow> nexpr" where
  "erase (TVar x) = NVar x"
| "erase (TConst k) = NConst k"
| "erase (TLam x t e) = NLam x (erase e)"
| "erase (TApp e\<^sub>1 e\<^sub>2) = NApp (erase e\<^sub>1) (erase e\<^sub>2)"

primrec htvars :: "hexpr \<Rightarrow> var set" where
  "htvars (HVar x) = {}"
| "htvars (HConst k) = {}"
| "htvars (HLam x t e) = vars t \<union> htvars e"
| "htvars (HApp e\<^sub>1 e\<^sub>2) = htvars e\<^sub>1 \<union> htvars e\<^sub>2"

definition env_subst :: "subst \<Rightarrow> subst \<Rightarrow> subst" where
  "env_subst sub \<Gamma> = map_option (subst sub) \<circ> \<Gamma>"

primrec typecheck' :: "subst \<Rightarrow> var set \<Rightarrow> nexpr \<Rightarrow> hexpr \<times> uexpr \<times> var set \<times> (uexpr \<times> uexpr) list"
    where
  "typecheck' \<Gamma> vs (NVar x) = (case \<Gamma> x of
      Some t \<Rightarrow> (HVar x, t, vs, [])
    | None \<Rightarrow> (HVar x, Ctor ''Base'' [], vs, fail))"
| "typecheck' \<Gamma> vs (NConst k) = (HConst k, Ctor ''Base'' [], vs, [])"
| "typecheck' \<Gamma> vs (NLam x e) = (
    let v = fresh vs
    in let (e', t, vs', con) = typecheck' (\<Gamma>(x \<mapsto> Var v)) (insert v vs) e
    in (HLam x (Var v) e', Ctor ''Arrow'' [Var v, t], vs', con))"
| "typecheck' \<Gamma> vs (NApp e\<^sub>1 e\<^sub>2) = (
    let v = fresh vs
    in let (e\<^sub>1', t\<^sub>1, vs', con\<^sub>1) = typecheck' \<Gamma> (insert v vs) e\<^sub>1
    in let (e\<^sub>2', t\<^sub>2, vs'', con\<^sub>2) = typecheck' \<Gamma> vs' e\<^sub>2
    in (HApp e\<^sub>1' e\<^sub>2', Var v, vs'', con\<^sub>1 @ con\<^sub>2 @ [(t\<^sub>1, Ctor ''Arrow'' [t\<^sub>2, Var v])]))"

fun typeify :: "uexpr \<Rightarrow> ty" where
  "typeify (Var v) = TyVar v"
| "typeify (Ctor k []) = (if k = ''Base'' then Base else undefined)"
| "typeify (Ctor k [t\<^sub>1, t\<^sub>2]) =
    (if k = ''Arrow'' then Arrow (typeify t\<^sub>1) (typeify t\<^sub>2) else undefined)"
| "typeify (Ctor k ts) = undefined"

primrec untypify :: "ty \<Rightarrow> uexpr" where
  "untypify (TyVar v) = Var v"
| "untypify Base = Ctor ''Base'' []"
| "untypify (Arrow t\<^sub>1 t\<^sub>2) = Ctor ''Arrow'' [untypify t\<^sub>1, untypify t\<^sub>2]"

primrec solidify :: "hexpr \<Rightarrow> texpr" where
  "solidify (HVar x) = TVar x"
| "solidify (HConst k) = TConst k"
| "solidify (HLam x t e) = TLam x (typeify t) (solidify e)"
| "solidify (HApp e\<^sub>1 e\<^sub>2) = TApp (solidify e\<^sub>1) (solidify e\<^sub>2)"

fun tsubsts :: "subst \<Rightarrow> ty \<Rightarrow> ty" where
  "tsubsts sub (TyVar y) = (case sub y of Some t \<Rightarrow> typeify t | None \<Rightarrow> TyVar y)"
| "tsubsts sub Base = Base"
| "tsubsts sub (Arrow t\<^sub>1 t\<^sub>2) = Arrow (tsubsts sub t\<^sub>1) (tsubsts sub t\<^sub>2)"

primrec tsubstt :: "subst \<Rightarrow> texpr \<Rightarrow> texpr" where
  "tsubstt sub (TVar x) = TVar x"
| "tsubstt sub (TConst k) = TConst k"
| "tsubstt sub (TLam x t e) = TLam x (tsubsts sub t) (tsubstt sub e)"
| "tsubstt sub (TApp e\<^sub>1 e\<^sub>2) = TApp (tsubstt sub e\<^sub>1) (tsubstt sub e\<^sub>2)"

fun typecheck :: "nexpr \<rightharpoonup> texpr \<times> ty" where
  "typecheck e = (
    let (e', t, vs, con) = typecheck' Map.empty {} e
    in case unify' con of
        Some sub \<Rightarrow> Some (tsubstt sub (solidify e'), tsubsts sub (typeify t))
      | None \<Rightarrow> None)"

fun valid_ty_uexpr' :: "string \<Rightarrow> nat \<Rightarrow> bool" where
  "valid_ty_uexpr' k 0 = (k = ''Base'')"
| "valid_ty_uexpr' k (Suc 0) = False"
| "valid_ty_uexpr' k (Suc (Suc 0)) = (k = ''Arrow'')"
| "valid_ty_uexpr' k (Suc (Suc (Suc x))) = False"

primrec valid_ty_uexpr :: "uexpr \<Rightarrow> bool" where
  "valid_ty_uexpr (Var v) = True"
| "valid_ty_uexpr (Ctor k ts) = (valid_ty_uexpr' k (length ts) \<and> list_all valid_ty_uexpr ts)"

definition valid_ty_uexprs :: "(uexpr \<times> uexpr) list \<Rightarrow> bool" where
  "valid_ty_uexprs ts = list_all (\<lambda>(t\<^sub>1, t\<^sub>2). valid_ty_uexpr t\<^sub>1 \<and> valid_ty_uexpr t\<^sub>2) ts"

definition valid_ty_subst :: "subst \<Rightarrow> bool" where
  "valid_ty_subst \<Gamma> = (\<forall>t \<in> ran \<Gamma>. valid_ty_uexpr t)"

primrec valid_ty_hexpr :: "hexpr \<Rightarrow> bool" where
  "valid_ty_hexpr (HVar x) = True"
| "valid_ty_hexpr (HConst k) = True"
| "valid_ty_hexpr (HLam x t e) = (valid_ty_uexpr t \<and> valid_ty_hexpr e)"
| "valid_ty_hexpr (HApp e\<^sub>1 e\<^sub>2) = (valid_ty_hexpr e\<^sub>1 \<and> valid_ty_hexpr e\<^sub>2)"

lemma typecheck_induct [consumes 1, case_names NVarS NVarN NConst NLam NApp]: "
  typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow>
  (\<And>\<Gamma> vs t x. \<Gamma> x = Some t \<Longrightarrow> P \<Gamma> vs (NVar x) (HVar x) t vs []) \<Longrightarrow>
  (\<And>\<Gamma> vs x. \<Gamma> x = None \<Longrightarrow> P \<Gamma> vs (NVar x) (HVar x) (Ctor ''Base'' [])  vs fail) \<Longrightarrow>
  (\<And>\<Gamma> vs k. P \<Gamma> vs (NConst k) (HConst k) (Ctor ''Base'' []) vs []) \<Longrightarrow>
  (\<And>\<Gamma> vs vs' con x e\<^sub>1 e\<^sub>1' t' v. v = fresh vs \<Longrightarrow> typecheck' (\<Gamma>(x \<mapsto> Var v)) (insert v vs) e\<^sub>1 =
    (e\<^sub>1', t', vs', con) \<Longrightarrow> P (\<Gamma>(x \<mapsto> Var v)) (insert v vs) e\<^sub>1 e\<^sub>1' t' vs' con \<Longrightarrow>
      P \<Gamma> vs (NLam x e\<^sub>1) (HLam x (Var v) e\<^sub>1') (Ctor ''Arrow'' [Var v, t']) vs' con) \<Longrightarrow>
  (\<And>\<Gamma> vs vs' e\<^sub>1 e\<^sub>2 v e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 e\<^sub>2' t\<^sub>2 con\<^sub>2. v = fresh vs \<Longrightarrow>
    typecheck' \<Gamma> (insert v vs) e\<^sub>1 = (e\<^sub>1', t\<^sub>1, vs'', con\<^sub>1) \<Longrightarrow>
      typecheck' \<Gamma> vs'' e\<^sub>2 = (e\<^sub>2', t\<^sub>2, vs', con\<^sub>2) \<Longrightarrow> P \<Gamma> (insert v vs) e\<^sub>1 e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 \<Longrightarrow>
        P \<Gamma> vs'' e\<^sub>2 e\<^sub>2' t\<^sub>2 vs' con\<^sub>2 \<Longrightarrow> P \<Gamma> vs (NApp e\<^sub>1 e\<^sub>2) (HApp e\<^sub>1' e\<^sub>2') (Var v) vs'
          (con\<^sub>1 @ con\<^sub>2 @ [(t\<^sub>1, Ctor ''Arrow'' [t\<^sub>2, Var v])])) \<Longrightarrow>
    P \<Gamma> vs e e' t vs' con"
  by (induction e arbitrary: \<Gamma> vs e' t vs' con)
     (auto simp add: Let_def split: option.splits prod.splits)

lemma [simp]: "vars (untypify t) = tvars t"
  by (induction t) simp_all

lemma [simp]: "valid_ty_uexpr (untypify t)"
  by (induction t) simp_all

lemma [simp]: "valid_ty_uexpr t \<Longrightarrow> tvars (typeify t) = vars t"
  by (induction t rule: typeify.induct) simp_all

lemma [simp]: "tsubsts Map.empty e = e"
  by (induction e) simp_all

lemma [simp]: "valid_ty_uexpr t \<Longrightarrow> typeify (subst sub t) = tsubsts sub (typeify t)"
  by (induction t rule: typeify.induct) (simp_all split: option.splits)

lemma [simp]: "x \<notin> htvars e \<Longrightarrow> hsubst [x \<mapsto> t] e = e"
  by (induction e) simp_all

lemma valid_empty [simp]: "valid_ty_subst Map.empty"
  by (simp add: valid_ty_subst_def)

lemma [simp]: "valid_ty_uexpr e \<Longrightarrow> typeify (subst sub e) = tsubsts sub (typeify e)"
  by (induction e rule: typeify.induct) (auto split: option.splits)

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow>
    map_option (typeify \<circ> subst sub) (\<Gamma> x) = map_option (tsubsts sub \<circ> typeify) (\<Gamma> x)"
  by (cases "\<Gamma> x") (auto simp add: valid_ty_subst_def ran_def)

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow>
    map_option (typeify \<circ> subst sub) \<circ> \<Gamma> = map_option (tsubsts sub \<circ> typeify) \<circ> \<Gamma>"
  by auto

lemma [simp]: "valid_ty_hexpr e \<Longrightarrow> solidify (hsubst sub e) = tsubstt sub (solidify e)"
  by (induction e) simp_all

lemma [simp]: "erase (solidify (hsubst sub e)) = erase (solidify e)"
  by (induction e) simp_all

lemma [simp]: "erase (tsubstt sub e) = erase e"
  by (induction e) simp_all

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_uexpr t \<Longrightarrow> valid_ty_subst (\<Gamma>(x \<mapsto> t))"
  by (auto simp add: valid_ty_subst_def ran_def)

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_subst \<Gamma>' \<Longrightarrow> valid_ty_subst (\<Gamma>(x := \<Gamma>' y))"
  by (auto simp add: valid_ty_subst_def ran_def)

lemma [simp]: "valid_ty_uexpr (subst s e) \<Longrightarrow> valid_ty_subst s \<Longrightarrow>
    valid_ty_subst (extend_subst x e s)"
  by (auto simp add: valid_ty_subst_def extend_subst_def ran_def)

lemma [simp]: "valid_ty_uexpr e \<Longrightarrow> valid_ty_uexpr e' \<Longrightarrow> valid_ty_uexpr (subst [x \<mapsto> e'] e)"
  and [simp]: "list_all valid_ty_uexpr es \<Longrightarrow> valid_ty_uexpr e' \<Longrightarrow>
    list_all valid_ty_uexpr (map (subst [x \<mapsto> e']) es)"
proof (induction e and es rule: vars_varss.induct)
  case (2 k es)
  thus ?case
  proof (induction es)
    case (Cons a es)
    thus ?case
    proof (induction es)
      case (Cons b es)
      thus ?case by (induction es) simp_all
    qed simp_all
  qed simp_all
qed simp_all

lemma [simp]: "valid_ty_uexpr e \<Longrightarrow> valid_ty_uexprs ess \<Longrightarrow> valid_ty_uexprs (list_subst x e ess)"
  by (induction ess rule: list_subst.induct) (auto simp add: valid_ty_uexprs_def)

lemma [simp]: "valid_ty_uexpr t \<Longrightarrow> valid_ty_subst sub \<Longrightarrow> valid_ty_uexpr (subst sub t)"
  and [simp]: "list_all valid_ty_uexpr ts \<Longrightarrow> valid_ty_subst sub \<Longrightarrow>
    list_all valid_ty_uexpr (map (subst sub) ts)"
  by (induction t and ts rule: vars_varss.induct)
     (auto simp add: valid_ty_subst_def ran_def split: option.splits)

lemma [elim]: "valid_ty_subst \<Gamma> \<Longrightarrow> \<Gamma> x = Some t \<Longrightarrow> valid_ty_uexpr t"
  by (auto simp add: valid_ty_subst_def ran_def)

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_subst sub\<^sub>2 \<Longrightarrow>
  map_option (typeify \<circ> subst sub\<^sub>1 \<circ> subst sub\<^sub>2) (\<Gamma> x) =
    map_option (tsubsts sub\<^sub>1 \<circ> tsubsts sub\<^sub>2 \<circ> typeify) (\<Gamma> x)"
proof (cases "\<Gamma> x")
  case (Some e)
  moreover assume "valid_ty_subst \<Gamma>"
  ultimately have E: "valid_ty_uexpr e" by auto
  assume "valid_ty_subst sub\<^sub>2"
  with Some E show ?thesis by simp
qed simp_all

lemma [simp]: "valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_subst sub\<^sub>2 \<Longrightarrow>
  map_option (typeify \<circ> subst sub\<^sub>1 \<circ> subst sub\<^sub>2) \<circ> \<Gamma> =
    map_option (tsubsts sub\<^sub>1 \<circ> tsubsts sub\<^sub>2 \<circ> typeify) \<circ> \<Gamma>"
  by auto

lemma [elim]: "valid_ty_uexprs ts \<Longrightarrow> unify' ts = Some sub \<Longrightarrow> valid_ty_subst sub"
proof (induction ts arbitrary: sub rule: unify'.induct)
  case (2 k\<^sub>1 es\<^sub>1 k\<^sub>2 es\<^sub>2 ess)
  moreover hence "list_all valid_ty_uexpr es\<^sub>1" by (auto simp add: valid_ty_uexprs_def)
  moreover from 2 have "list_all valid_ty_uexpr es\<^sub>2" by (auto simp add: valid_ty_uexprs_def)
  ultimately show ?case by (simp add: valid_ty_uexprs_def split: if_splits)
next
  case (4 x e ess)
  thus ?case
  proof (cases "e = Var x")
    case False note F = False
    with 4 show ?thesis
    proof (cases "x \<in> vars e")
      case False
      with 4 F obtain sub' where S: "unify' (list_subst x e ess) = Some sub' \<and>
        sub = extend_subst x e sub'" by auto
      from 4 have "valid_ty_uexpr e \<and> valid_ty_uexprs ess" by (simp add: valid_ty_uexprs_def)
      hence "valid_ty_uexprs (list_subst x e ess)" by simp
      with 4 F False S show ?thesis by (simp add: valid_ty_uexprs_def)
    qed simp_all
  qed (simp_all add: valid_ty_uexprs_def)
qed (auto simp add: valid_ty_uexprs_def)

lemma [elim]: "valid_ty_uexpr t\<^sub>1 \<Longrightarrow> valid_ty_uexpr t\<^sub>2 \<Longrightarrow> unify t\<^sub>1 t\<^sub>2 = Some sub \<Longrightarrow>
  valid_ty_subst sub"
proof (unfold unify_def)
  assume "valid_ty_uexpr t\<^sub>1" and "valid_ty_uexpr t\<^sub>2"
  hence "valid_ty_uexprs [(t\<^sub>1, t\<^sub>2)]" by (simp add: valid_ty_uexprs_def)
  moreover assume "unify' [(t\<^sub>1, t\<^sub>2)] = Some sub"
  ultimately show "valid_ty_subst sub" by auto
qed

lemma [simp]: "valid_ty_subst sub \<Longrightarrow> valid_ty_hexpr e \<Longrightarrow> valid_ty_hexpr (hsubst sub e)"
  by (induction e) simp_all

lemma tc_tsubstt [simp]: "\<Gamma> \<turnstile>\<^sub>n e : t \<Longrightarrow>
  map_option (tsubsts sub) \<circ> \<Gamma> \<turnstile>\<^sub>n tsubstt sub e : tsubsts sub t"
proof (induction \<Gamma> e t rule: typecheckn.induct)
  case (tcn_lam \<Gamma> x t\<^sub>1 e t\<^sub>2)
  hence "map_option (tsubsts sub) \<circ> \<Gamma>(x \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n tsubstt sub e : tsubsts sub t\<^sub>2" by blast
  hence "map_option (tsubsts sub) \<circ> \<Gamma> \<turnstile>\<^sub>n tsubstt sub (TLam x t\<^sub>1 e) : tsubsts sub (Arrow t\<^sub>1 t\<^sub>2)"
    by simp
  thus ?case by blast
qed simp_all

lemma valid_ty_uexpr_structrual [simp]: "structural valid_ty_uexpr"
  by (auto simp add: structural_def)

lemma [simp]: "valid_ty_subst sub \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_subst (env_subst sub \<Gamma>)"
  by (auto simp add: valid_ty_subst_def env_subst_def ran_def)

lemma [simp]: "valid_ty_subst s1 \<Longrightarrow> valid_ty_subst s2 \<Longrightarrow> valid_ty_subst (combine_subst s1 s2)"
proof (unfold valid_ty_subst_def combine_subst_def ran_def, rule)
  fix x
  assume S1: "\<forall>x \<in> {b. \<exists>a. s1 a = Some b}. valid_ty_uexpr x"
  assume S2: "\<forall>x \<in> {b. \<exists>a. s2 a = Some b}. valid_ty_uexpr x"
  assume "x \<in> {b. \<exists>a. (case s2 a of None \<Rightarrow> s1 a | Some e \<Rightarrow> Some (subst s1 e)) = Some b}"
  then obtain y where Y: "(case s2 y of None \<Rightarrow> s1 y | Some e \<Rightarrow> Some (subst s1 e)) = Some x"
    by auto
  from S1 S2 Y show "valid_ty_uexpr x"
  proof (cases "s2 y")
    case (Some e)
    from S1 have "valid_ty_subst s1" by (auto simp add: valid_ty_subst_def ran_def)
    with S2 Y Some show ?thesis by auto
  qed auto
qed

lemma [simp]: "hsubst (combine_subst s t) e = hsubst s (hsubst t e)"
  by (induction e) simp_all

lemma [elim]: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_uexpr t"
  by (induction rule: typecheck_induct) auto

lemma [elim]: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> valid_ty_hexpr e'"
  by (induction rule: typecheck_induct) auto

lemma typecheck_succeeds [simp]: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow>
  valid_ty_subst \<Gamma> \<Longrightarrow> unify' con = Some sub' \<Longrightarrow> sub extends sub' \<Longrightarrow>
    map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub e') : typeify (subst sub t)"
proof (induction arbitrary: sub' rule: typecheck_induct)
  case (NVarS \<Gamma> vs t x)
  thus ?case by simp
next
  case (NLam \<Gamma> vs vs' con x e\<^sub>1 e\<^sub>1' t' v)
  hence "valid_ty_subst (\<Gamma>(x \<mapsto> Var v))" by simp
  with NLam have "map_option (typeify \<circ> subst sub) \<circ> \<Gamma>(x \<mapsto> Var v) \<turnstile>\<^sub>n solidify (hsubst sub e\<^sub>1') :
      typeify (subst sub t')" by blast
  hence "map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub (HLam x (Var v) e\<^sub>1')) :
    typeify (subst sub (Ctor ''Arrow'' [Var v, t']))" by simp
  thus ?case by blast
next
  case (NApp \<Gamma> vs vs' e\<^sub>1 e\<^sub>2 v e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 e\<^sub>2' t\<^sub>2 con\<^sub>2)
  then obtain s\<^sub>2 where S2: "unify' (con\<^sub>1 @ con\<^sub>2) = Some s\<^sub>2 \<and> sub' extends s\<^sub>2" by fastforce
  then obtain s\<^sub>3 where S3: "unify' con\<^sub>1 = Some s\<^sub>3 \<and> s\<^sub>2 extends s\<^sub>3" by fastforce
  with NApp S2 have "sub extends s\<^sub>3" by auto
  with NApp S2 S3 have T: "map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub e\<^sub>1') :
    typeify (subst sub t\<^sub>1)" by blast
  from NApp have "sub' unifies\<^sub>l (con\<^sub>1 @ con\<^sub>2 @ [(t\<^sub>1, Ctor ''Arrow'' [t\<^sub>2, Var v])])"
    by (metis unify_some)
  hence "sub' unifies t\<^sub>1 and Ctor ''Arrow'' [t\<^sub>2, Var v]" by simp
  with NApp have X: "sub unifies t\<^sub>1 and Ctor ''Arrow'' [t\<^sub>2, Var v]" by fastforce
  from S2 obtain s\<^sub>4 where S4: "unify' con\<^sub>2 = Some s\<^sub>4 \<and> s\<^sub>2 extends s\<^sub>4"
    using unify_append_snd by blast
  with NApp S2 have "sub extends s\<^sub>4" by auto
  with NApp S4 have "map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub e\<^sub>2') :
    typeify (subst sub t\<^sub>2)" by blast
  with T X have "map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub (HApp e\<^sub>1' e\<^sub>2')) :
    typeify (subst sub (Var v))" by simp
  thus ?case by blast
qed simp_all

lemma [simp]: "typecheck e = Some (e\<^sub>t, t) \<Longrightarrow> Map.empty \<turnstile>\<^sub>n e\<^sub>t : t"
proof -
  assume "typecheck e = Some (e\<^sub>t, t)"
  then obtain e' tt vs con sub where T: "typecheck' Map.empty {} e = (e', tt, vs, con) \<and>
    unify' con = Some sub \<and> e\<^sub>t = tsubstt sub (solidify e') \<and> t = tsubsts sub (typeify tt)"
      by (auto split: option.splits prod.splits)
  moreover hence "map_option (typeify \<circ> subst sub) \<circ> Map.empty \<turnstile>\<^sub>n solidify (hsubst sub e') :
    typeify (subst sub tt)" by (metis typecheck_succeeds valid_empty extends_refl)
  moreover from T have "valid_ty_uexpr tt" and "valid_ty_hexpr e'" by auto
  ultimately show "Map.empty \<turnstile>\<^sub>n e\<^sub>t : t" by simp
qed

lemma [simp]: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow> e = erase (solidify e')"
  by (induction rule: typecheck_induct) auto

lemma [simp]: "typecheck e = Some (e\<^sub>t, t) \<Longrightarrow> e = erase e\<^sub>t"
  by (auto split: option.splits prod.splits)

lemma [dest]: "erase e\<^sub>t = NVar x \<Longrightarrow> e\<^sub>t = TVar x"
  by (induction e\<^sub>t) simp_all

lemma [dest]: "erase e\<^sub>t = NLam x e \<Longrightarrow> \<exists>t e\<^sub>t'. e\<^sub>t = TLam x t e\<^sub>t' \<and> e = erase e\<^sub>t'"
  by (induction e\<^sub>t) simp_all

lemma [dest]: "erase e\<^sub>t = NApp e\<^sub>1 e\<^sub>2 \<Longrightarrow> \<exists>e\<^sub>1' e\<^sub>2'. e\<^sub>t = TApp e\<^sub>1' e\<^sub>2' \<and> e\<^sub>1 = erase e\<^sub>1'\<and> e\<^sub>2 = erase e\<^sub>2'"
  by (induction e\<^sub>t) simp_all

lemma vars_expand: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow> vs \<subseteq> vs'"
  by (induction e arbitrary: \<Gamma> vs e' t vs' con)
     (simp_all add: Let_def split: option.splits prod.splits, fastforce+)

lemma [simp]: "typecheck' \<Gamma> vs e = (e', t, vs', con) \<Longrightarrow> finite vs' = finite vs"
  by (induction e arbitrary: \<Gamma> vs e' t vs' con)
     (simp_all add: Let_def split: option.splits prod.splits)

lemma [simp]: "subst_vars \<Gamma> \<subseteq> vs \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> t \<in> ran (map_option typeify \<circ> \<Gamma>) \<Longrightarrow>
    finite vs \<Longrightarrow> fresh vs \<notin> tvars t"
  by (unfold subst_vars_def valid_ty_subst_def ran_def) fastforce

lemma [simp]: "typecheck' \<Gamma> vs e = (e', t', vs', con) \<Longrightarrow> x \<in> vs \<Longrightarrow> finite vs \<Longrightarrow>
    x \<notin> subst_vars \<Gamma> \<Longrightarrow> x \<notin> htvars e'"
proof (induction rule: typecheck_induct)
  case (NLam \<Gamma> vs vs' con y e\<^sub>1 e\<^sub>1' t' v)
  moreover hence "x \<notin> subst_vars (\<Gamma>(y \<mapsto> Var v))" by (auto simp add: subst_vars_def ran_def)
  ultimately show ?case by simp
next
  case (NApp \<Gamma> vs vs' e\<^sub>1 e\<^sub>2 v e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 e\<^sub>2' t\<^sub>2 con\<^sub>2)
  moreover hence "x \<in> vs''" using vars_expand by fastforce
  ultimately show ?case by simp
qed simp_all

lemma [simp]: "typecheck' \<Gamma> vs e = (e', t', vs', con) \<Longrightarrow> x \<in> vs \<Longrightarrow> finite vs \<Longrightarrow>
    x \<notin> subst_vars \<Gamma> \<Longrightarrow> x \<notin> vars t'"
proof (induction rule: typecheck_induct)
  case (NLam \<Gamma> vs vs' con y e\<^sub>1 e\<^sub>1' t' v)
  moreover hence "x \<notin> subst_vars (\<Gamma>(y \<mapsto> Var v))" by (auto simp add: subst_vars_def ran_def)
  ultimately show ?case by simp
qed (auto simp add: subst_vars_def ran_def)

lemma [simp]: "typecheck' \<Gamma> vs e = (e', t', vs', con) \<Longrightarrow> x \<in> vs \<Longrightarrow> finite vs \<Longrightarrow>
    x \<notin> subst_vars \<Gamma> \<Longrightarrow> x \<notin> list_vars con"
proof (induction rule: typecheck_induct)
  case (NApp \<Gamma> vs vs' e\<^sub>1 e\<^sub>2 v e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 e\<^sub>2' t\<^sub>2 con\<^sub>2)
  moreover hence "x \<in> vs''" using vars_expand by fastforce
  ultimately show ?case by auto
qed fastforce+

lemma [simp]: "typecheck' (\<Gamma>(x \<mapsto> Var y)) vs e = (e', tt, vs', con) \<Longrightarrow> y \<in> vs \<Longrightarrow>
  subst_vars \<Gamma> \<subseteq> vs - {y} \<Longrightarrow> vars t' \<subseteq> vs - {y} \<Longrightarrow> finite vs \<Longrightarrow> typecheck' (\<Gamma>(x \<mapsto> t')) vs e =
    (hsubst [y \<mapsto> t'] e', subst [y \<mapsto> t'] tt, vs', list_subst y t' con)"
proof (induction e arbitrary: \<Gamma> vs e' tt vs' con)
  case (NVar z)
  thus ?case
  proof (cases "x = z")
    case False
    with NVar show ?thesis
    proof (cases "\<Gamma> z")
      case (Some t)
      from NVar have "y \<notin> subst_vars \<Gamma>" by auto
      with NVar False Some have "typecheck' (\<Gamma>(x \<mapsto> t')) vs (NVar z) =
        (hsubst [y \<mapsto> t'] e', subst [y \<mapsto> t'] tt, vs', list_subst y t' con)"
          by auto
      thus ?thesis by blast
    qed auto
  qed auto
next
  case (NLam z e)
  let ?v = "fresh vs"
  from NLam have F: "fresh vs \<noteq> y" using fresh_is_fresh by blast
  obtain e'' tt' vs'' con' where T: "typecheck' (\<Gamma>(x \<mapsto> Var y, z \<mapsto> Var ?v)) (extend_set vs) e =
    (e'', tt', vs'', con')" by (metis prod_cases4)
  show ?case
  proof (cases "x = z")
    case True
    from T NLam(2) have E: "e' = HLam z (Var ?v) e'' \<and> tt = Ctor ''Arrow'' [Var ?v, tt'] \<and>
      vs'' = vs' \<and> con' = con" by (simp only: typecheck'.simps Let_def split: prod.splits) simp
    from T True E have T': "typecheck' (\<Gamma>(z \<mapsto> Var ?v)) (extend_set vs) e = (e'', tt', vs', con)"
      by simp
    from NLam(4) F have "y \<notin> subst_vars (\<Gamma>(z \<mapsto> Var ?v))"
      by (auto simp add: subst_vars_def ran_def)
    with NLam F E T' True T have "typecheck' (\<Gamma>(x \<mapsto> t')) vs (NLam z e) =
      (hsubst [y \<mapsto> t'] e', subst [y \<mapsto> t'] tt, vs', list_subst y t' con)"
        by (simp add: Let_def split: if_splits prod.splits)
    thus ?thesis by blast
  next
    case False
    from NLam have "typecheck' (\<Gamma>(x \<mapsto> Var y)) vs (NLam z e) = (e', tt, vs', con)" by blast
    with T have E: "e' = HLam z (Var ?v) e'' \<and> tt = Ctor ''Arrow'' [Var ?v, tt'] \<and> vs'' = vs' \<and>
      con' = con" by (simp add: Let_def)
    from E T False have X: "typecheck' (\<Gamma>(z \<mapsto> Var ?v, x \<mapsto> Var y)) (extend_set vs) e =
      (e'', tt', vs', con)" by (metis fun_upd_twist)
    have "subst_vars (\<Gamma>(z := None)) \<subseteq> subst_vars \<Gamma>" by simp
    with NLam(4) F have "subst_vars (\<Gamma>(z \<mapsto> Var ?v)) \<subseteq> extend_set vs - {y}" by fastforce
    with NLam X have "typecheck' (\<Gamma>(z \<mapsto> Var ?v, x \<mapsto> t')) (extend_set vs) e =
      (hsubst [y \<mapsto> t'] e'', subst [y \<mapsto> t'] tt', vs', list_subst y t' con)" by blast
    with False have "typecheck' (\<Gamma>(x \<mapsto> t', z \<mapsto> Var ?v)) (extend_set vs) e =
      (hsubst [y \<mapsto> t'] e'', subst [y \<mapsto> t'] tt', vs', list_subst y t' con)"
        by (metis fun_upd_twist)
    with E F have "typecheck' (\<Gamma>(x \<mapsto> t')) vs (NLam z e) =
      (hsubst [y \<mapsto> t'] e', subst [y \<mapsto> t'] tt, vs', list_subst y t' con)"
        by (simp add: Let_def split: if_splits prod.splits)
    thus ?thesis by blast
  qed
next
  case (NApp e1 e2)
  let ?v = "fresh vs"
  obtain e\<^sub>1' t\<^sub>1 vs'' con\<^sub>1 where T1: "typecheck' (\<Gamma>(x \<mapsto> Var y)) (insert ?v vs) e1 =
    (e\<^sub>1', t\<^sub>1, vs'', con\<^sub>1)" by (metis prod_cases4)
  moreover obtain e\<^sub>2' t\<^sub>2 vs''' con\<^sub>2 where T2: "typecheck' (\<Gamma>(x \<mapsto> Var y)) vs'' e2 =
    (e\<^sub>2', t\<^sub>2, vs''', con\<^sub>2)" by (metis prod_cases4)
  moreover from NApp have "typecheck' (\<Gamma>(x \<mapsto> Var y)) vs (NApp e1 e2) = (e', tt, vs', con)" by blast
  ultimately have E: "e' = HApp e\<^sub>1' e\<^sub>2' \<and> tt = Var ?v \<and> vs''' = vs' \<and>
    con = con\<^sub>1 @ con\<^sub>2 @ [(t\<^sub>1, Ctor ''Arrow'' [t\<^sub>2, Var ?v])]" by (auto simp add: Let_def)
  from T1 have V: "vs \<subseteq> vs''" using vars_expand by blast
  from NApp V have A: "y \<in> vs''" by auto
  from NApp V have B: "subst_vars \<Gamma> \<subseteq> vs'' - {y}" by auto
  from NApp V have C: "vars t' \<subseteq> vs'' - {y}" by auto
  from NApp T1 have D: "finite vs''" by simp
  from NApp T1 have T1': "typecheck' (\<Gamma>(x \<mapsto> t')) (insert ?v vs) e1 =
    (hsubst [y \<mapsto> t'] e\<^sub>1', subst [y \<mapsto> t'] t\<^sub>1, vs'', list_subst y t' con\<^sub>1)" by blast
  from NApp T2 A B C D have T2': "typecheck' (\<Gamma>(x \<mapsto> t')) vs'' e2 =
    (hsubst [y \<mapsto> t'] e\<^sub>2', subst [y \<mapsto> t'] t\<^sub>2, vs''', list_subst y t' con\<^sub>2)" by blast
  from NApp E T1' T2' have "typecheck' (\<Gamma>(x \<mapsto> t')) vs (NApp e1 e2) =
    (hsubst [y \<mapsto> t'] e', subst [y \<mapsto> t'] tt, vs', list_subst y t' con)" by (auto simp add: Let_def)
  thus ?case by blast
qed auto

lemma typecheck_fails' [simp]: "map_option typeify \<circ> \<Gamma> \<turnstile>\<^sub>n e\<^sub>t : t \<Longrightarrow>
  typecheck' \<Gamma> vs (erase e\<^sub>t) = (e', tt, vs', con) \<Longrightarrow> unify' con = None \<Longrightarrow> finite vs \<Longrightarrow>
    subst_vars \<Gamma> \<subseteq> vs \<Longrightarrow> tvarst e\<^sub>t \<subseteq> vs \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> False"
proof (induction "map_option typeify \<circ> \<Gamma>" e\<^sub>t t arbitrary: \<Gamma> vs e' tt vs' con rule: typecheckn.induct)
  case (tcn_lam x t\<^sub>1 e t\<^sub>2)
  let ?v = "fresh vs"
  from tcn_lam(3) obtain ee t' where "e' = HLam x (Var ?v) ee \<and>
    tt = Ctor ''Arrow'' [Var ?v, t'] \<and> typecheck' (\<Gamma>(x \<mapsto> Var ?v)) (insert ?v vs) (erase e) =
      (ee, t', vs', con)" by (simp add: Let_def split: prod.splits) blast
  with tcn_lam(5, 6, 7) have T: "typecheck' (\<Gamma>(x \<mapsto> untypify t\<^sub>1)) (extend_set vs) (erase e) =
    (hsubst [?v \<mapsto> untypify t\<^sub>1] ee, subst [?v \<mapsto> untypify t\<^sub>1] t', vs',
      list_subst ?v (untypify t\<^sub>1) con)" by simp
  have X: "(map_option typeify \<circ> \<Gamma>)(x \<mapsto> t\<^sub>1) = map_option typeify \<circ> \<Gamma>(x \<mapsto> untypify t\<^sub>1)" by simp
  from tcn_lam have Y: "finite (insert ?v vs)" by simp
  from tcn_lam have "subst_vars \<Gamma> \<subseteq> extend_set vs" by auto
  with tcn_lam have Z: "subst_vars (\<Gamma>(x \<mapsto> untypify t\<^sub>1)) \<subseteq> insert ?v vs" by auto
  from tcn_lam have W: "tvarst e \<subseteq> insert ?v vs" by auto
  from tcn_lam have V: "valid_ty_subst (\<Gamma>(x \<mapsto> untypify t\<^sub>1))" by simp
  from tcn_lam have "unify' (list_subst ?v (untypify t\<^sub>1) con) = None" by simp
  with tcn_lam T X Y Z W V show ?case by blast
next
  case (tcn_app e\<^sub>1 t\<^sub>1 t\<^sub>2 e\<^sub>2)
  let ?v = "fresh vs"
  obtain e\<^sub>1' tt\<^sub>1 vs'' con\<^sub>1 where T1: "typecheck' \<Gamma> (extend_set vs) (erase e\<^sub>1) =
    (e\<^sub>1', tt\<^sub>1, vs'', con\<^sub>1)" by (metis prod_cases4)
  obtain e\<^sub>2' tt\<^sub>2 vs''' con\<^sub>2 where T2: "typecheck' \<Gamma> vs'' (erase e\<^sub>2) = (e\<^sub>2', tt\<^sub>2, vs''', con\<^sub>2)"
    by (metis prod_cases4)
  from tcn_app T1 T2 have E: "e' = HApp e\<^sub>1' e\<^sub>2' \<and> tt = Var ?v \<and> vs''' = vs' \<and>
    con = con\<^sub>1 @ con\<^sub>2 @ [(tt\<^sub>1, Ctor ''Arrow'' [tt\<^sub>2, Var ?v])]" by (auto simp add: Let_def)

  from tcn_app T1 have VH: "valid_ty_hexpr e\<^sub>1'" by auto
  from tcn_app T1 have VT: "valid_ty_uexpr tt\<^sub>1" by auto

  from tcn_app have "tvarst e\<^sub>1 \<subseteq> extend_set vs" by auto
  with tcn_app T1 obtain s\<^sub>1 where S1: "unify' con\<^sub>1 = Some s\<^sub>1" by blast
  with tcn_app T1 have "sub extends s\<^sub>1 \<Longrightarrow>
    map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub e\<^sub>1') : typeify (subst sub tt\<^sub>1)"
      by (metis typecheck_succeeds)
  with tcn_app VH VT have "sub extends s\<^sub>1 \<Longrightarrow> map_option (tsubsts sub) \<circ> map_option typeify \<circ> \<Gamma> \<turnstile>\<^sub>n
    tsubstt sub (solidify e\<^sub>1') : tsubsts sub (typeify tt\<^sub>1)" by simp

  from T1 have "extend_set vs \<subseteq> vs''" by (metis vars_expand)
  with tcn_app T1 have "finite vs'' \<and> subst_vars \<Gamma> \<subseteq> vs'' \<and> tvarst e\<^sub>2 \<subseteq> vs''" by auto
  with tcn_app T2 obtain s\<^sub>2 where "unify' con\<^sub>2 = Some s\<^sub>2" by fastforce
  with tcn_app T2 have "sub extends s\<^sub>2 \<Longrightarrow>
    map_option (typeify \<circ> subst sub) \<circ> \<Gamma> \<turnstile>\<^sub>n solidify (hsubst sub e\<^sub>2') : typeify (subst sub tt\<^sub>2)"
      by (metis typecheck_succeeds)

  from tcn_app have "map_option typeify \<circ> \<Gamma> \<turnstile>\<^sub>n e\<^sub>1 : Arrow t\<^sub>1 t\<^sub>2" by simp
  from tcn_app have "map_option typeify \<circ> \<Gamma> \<turnstile>\<^sub>n e\<^sub>2 : t\<^sub>1" by simp
  from tcn_app have "finite vs" by simp
  from tcn_app have "subst_vars \<Gamma> \<subseteq> vs" by simp
  from tcn_app have "tvarst e\<^sub>1 \<subseteq> vs" by simp
  from tcn_app have "tvarst e\<^sub>2 \<subseteq> vs" by simp
  from tcn_app have "valid_ty_subst \<Gamma>" by simp

  from tcn_app have "?v \<notin> subst_vars \<Gamma>" by auto
  with tcn_app T1 have "?v \<notin> list_vars con\<^sub>1" by simp
  with S1 have "?v \<notin> dom s\<^sub>1" using unify_dom by blast
  hence V: "s\<^sub>1 ?v = None" by auto

  from tcn_app E have "unify' (con\<^sub>1 @ (con\<^sub>2 @ [(tt\<^sub>1, Ctor ''Arrow'' [tt\<^sub>2, Var ?v])])) = None" by simp
  hence "unify' con\<^sub>1 = None \<or> (\<exists>s. unify' con\<^sub>1 = Some s \<and>
    unify' (map (pair_subst s) (con\<^sub>2 @ [(tt\<^sub>1, Ctor ''Arrow'' [tt\<^sub>2, Var ?v])])) = None)"
      by (metis unify_append_none)
  with S1 V have "unify' (map (pair_subst s\<^sub>1) con\<^sub>2 @
    [(subst s\<^sub>1 tt\<^sub>1, Ctor ''Arrow'' [subst s\<^sub>1 tt\<^sub>2, Var ?v])]) = None" by simp
  hence "unify' (map (pair_subst s\<^sub>1) con\<^sub>2) = None \<or>
    (\<exists>s. unify' (map (pair_subst s\<^sub>1) con\<^sub>2) = Some s \<and>
      unify' (map (pair_subst s) [(subst s\<^sub>1 tt\<^sub>1, Ctor ''Arrow'' [subst s\<^sub>1 tt\<^sub>2, Var ?v])]) = None)"
        by (metis unify_append_none)

  have False by simp
  thus ?case by simp
qed auto

lemma typecheck_fails [simp]: "typecheck e = None \<Longrightarrow>
  \<nexists>e\<^sub>t t. (Map.empty \<turnstile>\<^sub>n e\<^sub>t : t) \<and> tvarst e\<^sub>t = {} \<and> e = erase e\<^sub>t"
proof
  assume "typecheck e = None"
  then obtain e' tt vs' con where X: "typecheck' Map.empty {} e = (e', tt, vs', con) \<and>
    unify' con = None" by (auto split: prod.splits option.splits)
  assume "\<exists>e\<^sub>t t. (Map.empty \<turnstile>\<^sub>n e\<^sub>t : t) \<and> tvarst e\<^sub>t = {} \<and> e = erase e\<^sub>t"
  then obtain e\<^sub>t t where Y: "(map_option typeify \<circ> Map.empty \<turnstile>\<^sub>n e\<^sub>t : t) \<and> tvarst e\<^sub>t = {} \<and>
    e = erase e\<^sub>t" by fastforce
  hence Z: "tvarst e\<^sub>t \<subseteq> {}" by simp
  have W: "subst_vars Map.empty \<subseteq> {}" by simp
  have "valid_ty_subst Map.empty" by simp
  with X Y Z W show "False" by (metis typecheck_fails' finite.emptyI)
qed

lemma [simp]: "valn (erase e) = valt e"
  by (induction e) simp_all

lemma [simp]: "all_vars (erase e) = all_varst e"
  by (induction e) simp_all

lemma [simp]: "erase (subst_vart x y e) = subst_var x y (erase e)"
  by (induction e) simp_all

lemma [simp]: "erase (substt x e' e) = substn x (erase e') (erase e)"
  by (induction x e' e rule: substt.induct) (simp_all add: Let_def)

theorem completeness [simp]: "e \<Down>\<^sub>t v \<Longrightarrow> erase e \<Down> erase v"
  by (induction e v rule: evalt.induct) simp_all

lemma [simp]: "all_varst (tsubstt sub e) = all_varst e"
  by (induction e) simp_all

lemma [simp]: "tsubstt sub (subst_vart y x e) = subst_vart y x (tsubstt sub e)"
  by (induction e) simp_all

lemma [simp]: "tsubstt sub (substt x v e) = substt x (tsubstt sub v) (tsubstt sub e)"
  by (induction x v e rule: substt.induct) (simp_all add: Let_def)

lemma [simp]: "e \<Down>\<^sub>t v \<Longrightarrow> tsubstt sub e \<Down>\<^sub>t tsubstt sub v"
  by (induction e v rule: evalt.induct) simp_all

(*
lemma correctness' [simp]: "e \<Down> v \<Longrightarrow> typecheck' \<Gamma> vs e = (e\<^sub>t, t1, vs1, uni1) \<Longrightarrow>
  typecheck' \<Gamma> vs v = (v\<^sub>t, t2, vs2, uni2) \<Longrightarrow> valid_ty_subst \<Gamma> \<Longrightarrow> unify' uni1 = Some sub1 \<Longrightarrow>
    unify' uni2 = Some sub2 \<Longrightarrow> tsubsts sub1 (typeify t1) = tsubsts sub2 (typeify t2) \<and>
      tsubstt sub1 (solidify e\<^sub>t) \<Down>\<^sub>t tsubstt sub2 (solidify v\<^sub>t)"
proof (induction e v arbitrary: vs e\<^sub>t t1 vs1 uni1 sub1 v\<^sub>t t2 vs2 uni2 sub2 rule: evaln.induct)
  case (evn_app e\<^sub>1 x e\<^sub>1' e\<^sub>2 v\<^sub>2 v)
  let ?v = "fresh vs"
  let ?v2 = "fresh (insert ?v vs)"
  obtain e\<^sub>1\<^sub>t t\<^sub>1 vs' con\<^sub>1 where E1: "typecheck' \<Gamma> (insert ?v vs) e\<^sub>1 = (e\<^sub>1\<^sub>t, t\<^sub>1, vs', con\<^sub>1)"
    by (cases "typecheck' \<Gamma> (insert ?v vs) e\<^sub>1")
  obtain e\<^sub>2\<^sub>t t\<^sub>2 vs'' con\<^sub>2 where E2: "typecheck' \<Gamma> vs' e\<^sub>2 = (e\<^sub>2\<^sub>t, t\<^sub>2, vs'', con\<^sub>2)"
    by (cases "typecheck' \<Gamma> vs' e\<^sub>2")
  with evn_app E1 have E: "e\<^sub>t = HApp e\<^sub>1\<^sub>t e\<^sub>2\<^sub>t \<and> t1 = Var ?v \<and> vs1 = vs'' \<and>
    uni1 = (t\<^sub>1, Ctor ''Arrow'' [t\<^sub>2, Var ?v]) # con\<^sub>1 @ con\<^sub>2"
      by (auto simp add: Let_def)

  from evn_app have "e\<^sub>1 \<Down> NLam x e\<^sub>1'" by simp
  from evn_app have "e\<^sub>2 \<Down> v\<^sub>2" by simp
  from evn_app have "substn x v\<^sub>2 e\<^sub>1' \<Down> v" by simp

  from evn_app E2 have "typecheck' \<Gamma> vs' v\<^sub>2 = (xv\<^sub>t, xt20, xvs20, xuni2) \<Longrightarrow>
    unify' con\<^sub>2 = Some xsub10 \<Longrightarrow>
    unify' xuni2 = Some xsub20 \<Longrightarrow>
    tsubsts xsub10 (typeify t\<^sub>2) = tsubsts xsub20 (typeify xt20) \<and>
    tsubstt xsub10 (solidify e\<^sub>2\<^sub>t) \<Down>\<^sub>t tsubstt xsub20 (solidify xv\<^sub>t)" by simp
  from evn_app have "typecheck' \<Gamma> xvs (substn x v\<^sub>2 e\<^sub>1') = (xe\<^sub>t, xt10, xvs10, xuni1) \<Longrightarrow>
    typecheck' \<Gamma> xvs v = (xv\<^sub>t, xt20, xvs20, xuni2) \<Longrightarrow>
    valid_ty_subst \<Gamma> \<Longrightarrow>
    unify' xuni1 = Some xsub10 \<Longrightarrow>
    unify' xuni2 = Some xsub20 \<Longrightarrow>
    tsubsts xsub10 (typeify xt10) = tsubsts xsub20 (typeify xt20) \<and>
    tsubstt xsub10 (solidify xe\<^sub>t) \<Down>\<^sub>t tsubstt xsub20 (solidify xv\<^sub>t)" by simp
  from evn_app have "typecheck' \<Gamma> vs v = (v\<^sub>t, t2, vs2, uni2)" by simp
  from evn_app have "valid_ty_subst \<Gamma>" by simp
  from evn_app have "unify' uni1 = Some sub1" by simp
  from evn_app have "unify' uni2 = Some sub2" by simp

  have X: "tsubsts sub1 (typeify (Var ?v)) = tsubsts sub2 (typeify t2)" by simp

  obtain e\<^sub>1\<^sub>t' t\<^sub>1' vsx' con\<^sub>1' where "(e\<^sub>1\<^sub>t', t\<^sub>1', vsx', con\<^sub>1') =
    typecheck' (\<Gamma>(x \<mapsto> Var ?v2)) (insert ?v2 (insert ?v vs)) e\<^sub>1'"
      by (cases "typecheck' (\<Gamma>(x \<mapsto> Var ?v2)) (insert ?v2 (insert ?v vs)) e\<^sub>1'") simp_all
  hence "typecheck' \<Gamma> (insert ?v vs) (NLam x e\<^sub>1') =
    (HLam x (Var ?v2) e\<^sub>1\<^sub>t', Ctor ''Arrow'' [Var ?v2, t\<^sub>1'], vsx', con\<^sub>1')"
      by (auto simp add: Let_def split: prod.splits)
  with evn_app E1 have "unify' con\<^sub>1 = Some xsub10 \<Longrightarrow>
    unify' con\<^sub>1' = Some xsub20 \<Longrightarrow>
    tsubsts xsub10 (typeify t\<^sub>1) = tsubsts xsub20 (typeify (Ctor ''Arrow'' [Var ?v2, t\<^sub>1'])) \<and>
    tsubstt xsub10 (solidify e\<^sub>1\<^sub>t) \<Down>\<^sub>t tsubstt xsub20 (solidify (HLam x (Var ?v2) e\<^sub>1\<^sub>t'))" by blast

  have "tsubstt sub1 (solidify e\<^sub>1\<^sub>t) \<Down>\<^sub>t TLam x t xe\<^sub>1' \<Longrightarrow>
        tsubstt sub1 (solidify e\<^sub>2\<^sub>t) \<Down>\<^sub>t xv\<^sub>2 \<Longrightarrow>
        substt x xv\<^sub>2 xe\<^sub>1' \<Down>\<^sub>t tsubstt sub2 (solidify v\<^sub>t) \<Longrightarrow>
        TApp (tsubstt sub1 (solidify e\<^sub>1\<^sub>t)) (tsubstt sub1 (solidify e\<^sub>2\<^sub>t)) \<Down>\<^sub>t tsubstt sub2 (solidify v\<^sub>t)" by simp

  have "TApp (tsubstt sub1 (solidify e\<^sub>1\<^sub>t)) (tsubstt sub1 (solidify e\<^sub>2\<^sub>t)) \<Down>\<^sub>t tsubstt sub2 (solidify v\<^sub>t)" by simp
  with E X show ?case by simp
qed (auto simp add: Let_def split: option.splits prod.splits)

theorem correctness: "e \<Down> v \<Longrightarrow> typecheck e = Some (e\<^sub>t, t) \<Longrightarrow> typecheck v = Some (v\<^sub>t, t) \<Longrightarrow>
    e\<^sub>t \<Down>\<^sub>t v\<^sub>t"
  by (auto split: option.splits prod.splits)
*)

end


theory Exe2p8
  imports Main
begin

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = []" |
"intersperse a (h#t) = h # a # (intersperse a t)"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs)
   apply(auto)
  done

end


(*
 * Copyright 201machine_word_bytes, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory factorial
imports "../CTranslation" "$L4V_ARCH/imports/MachineWords"
begin

declare hrs_simps [simp add]
declare sep_conj_ac [simp add]

consts free_pool :: "nat \<Rightarrow> heap_assert"

primrec
  fac :: "nat \<Rightarrow> machine_word"
where
  "fac 0 = 1"
| "fac (Suc n) = of_nat (Suc n) * fac n"

lemma fac_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac (unat n) = n * fac (unat (n - 1))"
  apply(case_tac "unat n")
   apply simp
  apply(subst unat_minus_one)
   apply(simp only: unat_simps)
   apply(clarify)
   apply simp
  apply clarsimp
  apply(simp only: unat_simps)
  apply(subst mod_less)
   apply (fold len_of_addr_card)
   apply unat_arith
  apply (clarsimp simp: distrib_right split: unat_splits)
  done

primrec
  fac_list :: "nat \<Rightarrow> machine_word list"
where
  "fac_list 0 = [1]"
| "fac_list (Suc n) = fac (Suc n) # fac_list n"

lemma fac_list_length [simp]:
  "length (fac_list n) = n + 1"
  by (induct n) auto

lemma fac_list_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac_list (unat n) = fac (unat n) # fac_list (unat (n - 1))"
  apply(case_tac "unat n")
   apply clarsimp
  apply(subst unat_minus_one)
   apply clarsimp+
  done

primrec
  sep_list :: "machine_word list \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_list [] p = (\<lambda>s. p=NULL \<and> \<box> s)"
| "sep_list (x#xs) p = (\<lambda>s. \<exists>j. ((p \<mapsto> x) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> j \<and>\<^sup>*
      sep_list xs (Ptr j)) s)"

lemma sep_list_NULL [simp]:
  "sep_list xs NULL = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (case_tac xs) auto

definition
  sep_fac_list :: "machine_word \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_fac_list n p \<equiv> sep_list (fac_list (unat n)) p"

lemma sep_fac_list_unfold:
  "((\<lambda>s. unat n \<noteq> 0 \<and> (\<exists>q. (p \<mapsto> fac (unat n) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> q \<and>\<^sup>*
      sep_fac_list (n - 1) (Ptr q)) s)) \<and>\<^sup>* R) s \<Longrightarrow>
      (sep_fac_list n p \<and>\<^sup>* R) s"
  apply (erule sep_globalise)
  apply (simp add: sep_fac_list_def fac_list_unfold)
  done

lemma sep_fac_list_points:
  "sep_points (sep_fac_list n p) s \<Longrightarrow> (p \<hookrightarrow> fac (unat n)) s"
  apply(unfold sep_points_def)
  apply(subst sep_map'_unfold)
  apply(erule sep_conj_impl)
   apply(unfold sep_fac_list_def)
   apply(case_tac "unat n")
    apply simp
    apply(unfold sep_map'_old)
    apply(erule (1) sep_conj_impl)
    apply simp
   apply clarsimp
   apply(subst (asm) sep_conj_assoc [symmetric])+
   apply(erule sep_conj_impl)
    apply simp+
  done

install_C_file memsafe "factorial.c"

thm factorial_global_addresses.factorial_body_def

lemma (in factorial_global_addresses) mem_safe_alloc:
  "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC alloc()) \<Gamma>"
  apply(insert alloc_impl)
  apply(unfold alloc_body_def)
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply(simp_all add: restrict_map_def split: if_split_asm)
  apply(auto simp: whileAnno_def comp_def hrs_comm split_def mono_guard_def)
  done

lemma (in factorial_global_addresses) sep_frame_alloc:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> \<acute>ret__ptr_to_unsigned_long :== PROC alloc() \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  unfolding sep_app_def
  by (rule sep_frame, auto intro!: mem_safe_alloc)

lemma (in alloc_spec) alloc_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>x. free_pool k) ((\<lambda>x. undefined) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
    \<lbrace> ((\<lambda>p s. if k > 0 then (\<turnstile>\<^sub>s p \<and>\<^sup>* \<turnstile>\<^sub>s (p +\<^sub>p 1) \<and>\<^sup>*
        free_pool (k - 1)) s else (free_pool k) s \<and> p = NULL) \<acute>ret__ptr_to_unsigned_long
        \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert alloc_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_alloc)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma (in factorial_global_addresses) mem_safe_free:
  "mem_safe (PROC free(\<acute>p)) \<Gamma>"
  apply(insert free_impl)
  apply(unfold free_body_def)
  apply(subst mem_safe_restrict)
  apply(auto simp: whileAnno_def)
  apply(rule intra_mem_safe)
   apply(auto simp: restrict_map_def split: if_split_asm)
  done

lemma (in factorial_global_addresses) sep_frame_free:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> PROC free(\<acute>p) \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              PROC free(\<acute>p)
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply(simp only: sep_app_def)
  apply(rule sep_frame, auto intro!: mem_safe_free)
  done

lemma (in free_spec) free_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>p. sep_cut' (ptr_val p) (2 * size_of TYPE(machine_word)) \<and>\<^sup>* free_pool k) \<acute>p  \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    PROC free(\<acute>p)
    \<lbrace> ((\<lambda>x. free_pool (k + 1)) ((\<lambda>x. ()) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert free_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_free)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma double_word_sep_cut':
  "(p \<mapsto> x \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> y) s \<Longrightarrow> sep_cut' (ptr_val (p::machine_word ptr)) (2*machine_word_bytes) s"
apply(clarsimp simp: sep_conj_def sep_cut'_def dest!: sep_map_dom)
apply(subgoal_tac "{ptr_val p..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
 apply(subgoal_tac "{ptr_val p+(of_nat machine_word_bytes)..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
  apply rule
   apply (fastforce simp: ptr_add_def)
  apply clarsimp
  apply(drule intvlD)
  apply clarsimp
  apply(case_tac "k < machine_word_bytes")
   apply(erule intvlI)
  apply(erule notE)
  apply(clarsimp simp: intvl_def)
  apply(rule_tac x="k - machine_word_bytes" in exI)
  apply rule
   apply(simp only: unat_simps)
   apply(subst mod_less)
    apply(simp add: addr_card)
   apply (simp add: ptr_add_def addr_card)
  apply simp
 apply(clarsimp simp: intvl_def)
 apply(rule_tac x="machine_word_bytes+k" in exI)
 apply simp
apply(rule intvl_start_le)
apply simp
done

locale specs = factorial_global_addresses + alloc_spec + free_spec

lemma (in specs) factorial_spec:
  shows "factorial_spec"
  apply unfold_locales
  apply(hoare_rule HoarePartial.ProcRec1)
  apply (hoare_rule anno = "factorial_invs_body k" in HoarePartial.annotateI)
   prefer 2
   apply (simp add: whileAnno_def factorial_invs_body_def)
  apply(subst factorial_invs_body_def)
  apply(unfold sep_app_def)
  apply (vcg exspec=alloc_spec' exspec=free_spec')
    apply (fold lift_def)
    apply(clarsimp simp: sep_app_def)
    apply (rule conjI)
     apply clarsimp
     apply(rule_tac x=k in exI)
     apply(rule_tac x="\<lambda>p. \<box>" in exI)
     apply(rule_tac x="\<lambda>s. undefined" in exI)
     apply clarsimp
     apply (rule conjI)
      apply clarsimp
     apply clarsimp
     apply (rename_tac a b ret__ptr_to_unsigned_long)
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_right)
      apply simp
     apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_left)
      apply simp
      apply(subst (asm) sep_conj_assoc [symmetric])+
      apply(drule_tac Q="free_pool (k - Suc 0)" in sep_conj_sep_true_right)
      apply simp
     apply(simp add: tagd_ptr_safe tagd_g c_guard_ptr_aligned c_guard_NULL)
     apply(simp add: sep_fac_list_def)
     apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
     apply(rule sep_heap_update_global')
     apply simp
     apply(rule sep_heap_update_global')
     apply simp
    apply clarsimp
    apply(rule_tac x=k in exI)
    apply clarsimp
    apply(rule_tac x="k - Suc (unat (n - 1))" in exI)
    apply clarsimp
    apply(rule_tac x="\<lambda>(n,p). sep_fac_list (n - 1) p" in exI)
    apply(rule_tac x="\<lambda>s. (n_' s,q_' s)" in exI)
    apply (rule conjI, clarsimp)
    apply clarsimp
    apply (rule conjI)
     apply clarsimp
     apply(simp add: sep_fac_list_def)
     apply(rule_tac x="fac_list (unat (n - 1))" in exI)
     apply clarsimp
    apply clarsimp
    apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         \<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))) =
                         (\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* (\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))))")
      prefer 2
      apply simp
     apply (simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(sep_point_tac sep_fac_list_points)
    apply(simp add: tagd_ptr_safe tagd_g sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
    apply(rule sep_fac_list_unfold)
    apply clarsimp
    apply (rule conjI, unat_arith)
    apply sep_exists_tac
    apply(rule_tac x="ptr_val ret__ptr_to_unsigned_longa" in exI)
    apply clarsimp
    apply(subst fac_unfold)
     apply unat_arith
    apply clarsimp
    apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
    apply(rule sep_heap_update_global')
    apply(sep_select_tac "_ \<mapsto> _")
      apply(rule sep_heap_update_global')
      apply(erule (1) sep_conj_impl)+
      apply clarsimp
   apply clarsimp
   apply(case_tac xs)
    apply simp
   apply clarsimp
   apply sep_exists_tac
   apply clarsimp
   apply sep_point_tac
   apply(simp add: sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
   apply(rule_tac x="k - Suc (length list)" in exI)
   apply(rule_tac x="\<lambda>p. sep_list list (Ptr j)" in exI)
   apply(rule_tac x="\<lambda>x. ()" in exI)
   apply(clarsimp simp: sep_app_def)
   apply (rule conjI)
    apply(subgoal_tac "(q \<mapsto> aa \<and>\<^sup>* sep_list list (Ptr j) \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))) =
                       (sep_list list (Ptr j) \<and>\<^sup>* (q \<mapsto> aa \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))))")
     apply(simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
     apply(subst sep_conj_com)
     apply(subst (asm) sep_conj_assoc [symmetric])+
     apply(erule sep_conj_impl)
      apply simp
      apply(erule double_word_sep_cut'[simplified])
     apply assumption
    apply simp
   apply clarsimp
   apply(subgoal_tac "Suc (k - Suc (length list)) = k - length list")
    apply force
   apply arith
  apply clarsimp
  done

declare hrs_simps [simp del]

lemma (in factorial_global_addresses) mem_safe_factorial:
  shows "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC factorial(\<acute>n)) \<Gamma>"
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply (insert factorial_impl free_impl alloc_impl)
   apply(drule_tac t="Some C" in sym)
   apply(simp_all add: restrict_map_def call_def block_def whileAnno_def
                       free_body_def alloc_body_def factorial_body_def creturn_def
                split: if_split_asm option.splits)
  apply((erule disjE)?, simp,
        (thin_tac "C=x" for x, (thin_tac "\<Gamma> x = y" for x y)+,
        force simp: intra_sc)?)+
  done

end


(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Heap.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory Simpl_Heap
imports Main
begin

subsection "References"

definition "ref = (UNIV::nat set)"

typedef ref = ref by (simp add: ref_def)

code_datatype Abs_ref

lemma finite_nat_ex_max:
  assumes fin: "finite (N::nat set)"
  shows "\<exists>m. \<forall>n\<in>N. n < m"
using fin
proof (induct)
  case empty
  show ?case by auto
next
  case (insert k N)
  have "\<exists>m. \<forall>n\<in>N. n < m" by fact
  then obtain m where m_max: "\<forall>n\<in>N. n < m"..
  show "\<exists>m. \<forall>n\<in>insert k N. n < m"
  proof (rule exI [where x="Suc (max k m)"])
  qed (insert m_max, auto simp add: max_def)
qed

lemma infinite_nat: "\<not>finite (UNIV::nat set)"
proof
  assume fin: "finite (UNIV::nat set)"
  then obtain m::nat where "\<forall>n\<in>UNIV. n < m"
    by (rule finite_nat_ex_max [elim_format] ) auto
  moreover have "m\<in>UNIV"..
  ultimately show False by blast
qed

lemma infinite_ref [simp,intro]: "\<not>finite (UNIV::ref set)"
proof
  assume "finite (UNIV::ref set)"
  hence "finite (range Rep_ref)"
    by simp
  moreover
  have "range Rep_ref = ref"
  proof
    show "range Rep_ref \<subseteq> ref"
      by (simp add: ref_def)
  next
    show "ref \<subseteq> range Rep_ref"
    proof
      fix x
      assume x: "x \<in> ref"
      show "x \<in> range Rep_ref"
        by (rule Rep_ref_induct) (auto simp add: ref_def)
    qed
  qed
  ultimately have "finite ref"
    by simp
  thus False
    by (simp add: ref_def infinite_nat)
qed

consts Null :: ref

definition new :: "ref set \<Rightarrow> ref" where
  "new A = (SOME a. a \<notin> {Null} \<union> A)"

text \<open>
  Constant @{const "Null"} can be defined later on.  Conceptually
  @{const "Null"} and @{const "new"} are \<open>fixes\<close> of a locale
  with @{prop "finite A \<Longrightarrow> new A \<notin> A \<union> {Null}"}.  But since definitions
  relative to a locale do not yet work in Isabelle2005 we use this
  workaround to avoid lots of parameters in definitions.
\<close>

lemma new_notin [simp,intro]:
 "finite A \<Longrightarrow> new (A) \<notin> A"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
  done

lemma new_not_Null [simp,intro]:
  "finite A \<Longrightarrow> new (A) \<noteq> Null"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
done

end


(*  Title:      HOL/Datatype_Examples/Process.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Processes.
*)

section \<open>Processes\<close>

theory Process
imports "HOL-Library.Stream"
begin

codatatype 'a process =
  isAction: Action (prefOf: 'a) (contOf: "'a process") |
  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")

(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)

subsection \<open>Basic properties\<close>

(* Constructors versus discriminators *)
theorem isAction_isChoice:
"isAction p \<or> isChoice p"
by (rule process.exhaust_disc) auto

theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
by (cases rule: process.exhaust[of p]) auto

subsection\<open>Coinduction\<close>

theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
  assumes phi: "\<phi> p p'" and
  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
  shows "p = p'"
  using assms
  by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))

(* Stronger coinduction, up to equality: *)
theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
  assumes phi: "\<phi> p p'" and
  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
  shows "p = p'"
  using assms
  by (coinduct rule: process.coinduct_strong) (metis process.collapse(1,2) process.disc(3))

subsection \<open>Coiteration (unfold)\<close>

section\<open>Coinductive definition of the notion of trace\<close>
coinductive trace where
"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
|
"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"

section\<open>Examples of corecursive definitions:\<close>

subsection\<open>Single-guard fixpoint definition\<close>

primcorec BX where
  "isAction BX"
| "prefOf BX = ''a''"
| "contOf BX = BX"

subsection\<open>Multi-guard fixpoint definitions, simulated with auxiliary arguments\<close>

datatype x_y_ax = x | y | ax

primcorec F :: "x_y_ax \<Rightarrow> char list process" where
  "xyax = x \<Longrightarrow> isChoice (F xyax)"
| "ch1Of (F xyax) = F ax"
| "ch2Of (F xyax) = F y"
| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
| "contOf (F xyax) = F x"

definition "X = F x"  definition "Y = F y"  definition "AX = F ax"

lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
unfolding X_def Y_def AX_def by (subst F.code, simp)+

(* end product: *)
lemma X_AX:
"X = Choice AX (Action ''b'' X)"
"AX = Action ''a'' X"
using X_Y_AX by simp_all

section\<open>Case study: Multi-guard fixpoint definitions, without auxiliary arguments\<close>

hide_const x y ax X Y AX

(* Process terms *)
datatype ('a,'pvar) process_term =
 VAR 'pvar |
 PROC "'a process" |
 ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"

(* below, sys represents a system of equations *)
fun isACT where
"isACT sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
|
"isACT sys (PROC p) = isAction p"
|
"isACT sys (ACT a T) = True"
|
"isACT sys (CH T1 T2) = False"

fun PREF where
"PREF sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
|
"PREF sys (PROC p) = prefOf p"
|
"PREF sys (ACT a T) = a"

fun CONT where
"CONT sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
|
"CONT sys (PROC p) = PROC (contOf p)"
|
"CONT sys (ACT a T) = T"

fun CH1 where
"CH1 sys (VAR X) =
 (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
|
"CH1 sys (PROC p) = PROC (ch1Of p)"
|
"CH1 sys (CH T1 T2) = T1"

fun CH2 where
"CH2 sys (VAR X) =
 (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
|
"CH2 sys (PROC p) = PROC (ch2Of p)"
|
"CH2 sys (CH T1 T2) = T2"

definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"

primcorec solution where
  "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"

lemma isACT_VAR:
assumes g: "guarded sys"
shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
using g unfolding guarded_def by (cases "sys X") auto

lemma solution_VAR:
assumes g: "guarded sys"
shows "solution sys (VAR X) = solution sys (sys X)"
proof(cases "isACT sys (VAR X)")
  case True
  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  show ?thesis
  unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
  unfolding guarded_def by (cases "sys X", auto)
next
  case False note FFalse = False
  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  show ?thesis
  unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
  unfolding guarded_def by (cases "sys X", auto)
qed

lemma solution_PROC[simp]:
"solution sys (PROC p) = p"
proof-
  {fix q assume "q = solution sys (PROC p)"
   hence "p = q"
   proof (coinduct rule: process_coind)
     case (iss p p')
     from isAction_isChoice[of p] show ?case
     proof
       assume p: "isAction p"
       hence 0: "isACT sys (PROC p)" by simp
       thus ?thesis using iss not_isAction_isChoice by auto
     next
       assume "isChoice p"
       hence 0: "\<not> isACT sys (PROC p)"
       using not_isAction_isChoice by auto
       thus ?thesis using iss isAction_isChoice by auto
     qed
   next
     case (Action a a' p p')
     hence 0: "isACT sys (PROC (Action a p))" by simp
     show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
   next
     case (Choice p q p' q')
     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
     show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
   qed
  }
  thus ?thesis by metis
qed

lemma solution_ACT[simp]:
"solution sys (ACT a T) = Action a (solution sys T)"
by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))

lemma solution_CH[simp]:
"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))

(* Example: *)

fun sys where
"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
|
"sys (Suc 0) = ACT ''a'' (VAR 0)"
| (* dummy guarded term for variables outside the system: *)
"sys X = ACT ''a'' (VAR 0)"

lemma guarded_sys:
"guarded sys"
unfolding guarded_def proof (intro allI)
  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
qed

(* the actual processes: *)
definition "x \<equiv> solution sys (VAR 0)"
definition "ax \<equiv> solution sys (VAR (Suc 0))"

(* end product: *)
lemma x_ax:
"x = Choice ax (Action ''b'' x)"
"ax = Action ''a'' x"
unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+

(* Thanks to the inclusion of processes as process terms, one can
also consider parametrized systems of equations---here, x is a (semantic)
process parameter: *)

fun sys' where
"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
|
"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
| (* dummy guarded term : *)
"sys' X = ACT ''a'' (VAR 0)"

lemma guarded_sys':
"guarded sys'"
unfolding guarded_def proof (intro allI)
  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
qed

(* the actual processes: *)
definition "y \<equiv> solution sys' (VAR 0)"
definition "ay \<equiv> solution sys' (VAR (Suc 0))"

(* end product: *)
lemma y_ay:
"y = Choice x (Action ''b'' y)"
"ay = Choice (Action ''a'' y) x"
unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+

end


theory Datatype_Selectors
imports Main
begin

text\<open>
  Running Example: \<open>datatype_new iptrule_match = is_Src: Src (src_range: ipt_iprange)\<close>

  A discriminator \<open>disc\<close> tells whether a value is of a certain constructor.
    Example: \<open>is_Src\<close>

  A selector \<open>sel\<close> select the inner value.
    Example: \<open>src_range\<close>

  A constructor \<open>C\<close> constructs a value
    Example: \<open>Src\<close>

  The are well-formed if the belong together.
\<close>
fun wf_disc_sel :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "wf_disc_sel (disc, sel) C \<longleftrightarrow> (\<forall>a. disc a \<longrightarrow> C (sel a) = a) \<and> (\<forall>a. \<^cancel>\<open>disc (C a) \<longrightarrow>\<close> sel (C a) = a)"

(* should the following be added to the definition?
 the discriminator is true for all C independent of the a
 for example: is_Src_IP is true for all Src_IPs, independent of the numberic value of the ip.
lemma "wf_disc_sel (disc, sel) C \<Longrightarrow> (\<exists>a. disc (C a)) \<longrightarrow> (\<forall>a. disc (C a))"
*)

declare wf_disc_sel.simps[simp del]

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise Eps s) =
      (case s of
        nil2 => True
        | cons2 x y => False))"
  oops

end


theory sort_MSortBUPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun map2 :: "('t2 => 't) => 't2 list => 't list" where
"map2 f (Nil2) = Nil2"
| "map2 f (Cons2 y z) = Cons2 (f y) (map2 f z)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (Nil2) = Nil2"
| "pairwise (Cons2 xs (Nil2)) = Cons2 xs (Nil2)"
| "pairwise (Cons2 xs (Cons2 ys xss)) =
     Cons2 (lmerge xs ys) (pairwise xss)"

fun mergingbu :: "(int list) list => int list" where
"mergingbu (Nil2) = Nil2"
| "mergingbu (Cons2 xs (Nil2)) = xs"
| "mergingbu (Cons2 xs (Cons2 z x2)) =
     mergingbu (pairwise (Cons2 xs (Cons2 z x2)))"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun msortbu :: "int list => int list" where
"msortbu x =
   dot
     (% (y :: (int list) list) => mergingbu y)
     (% (z :: int list) => map2 (% (x2 :: int) => Cons2 x2 (Nil2)) z) x"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster or2
          null
          map2
          lmerge
          pairwise
          mergingbu
          elem
          dot
          msortbu
          delete
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (msortbu x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Poly_Ex
imports "Intervals"
        "Generic_Multivariate_Polynomials"
        "~~/src/HOL/Decision_Procs/Approximation"
begin

(* Theory "Generic_Multivariate_Polynomials" contains a, more or less, 1:1 generalization
   of theory "Multivariate_Polynomial". Any additions belong here. *)

(* Conversion map for poly. *)
fun poly_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a poly \<Rightarrow> 'b poly"
where "poly_map f (poly.C c)      = poly.C (f c)"
    | "poly_map _ (poly.Bound n)  = poly.Bound n"
    | "poly_map f (poly.Add a b)  = poly.Add (poly_map f a) (poly_map f b)"
    | "poly_map f (poly.Sub a b)  = poly.Sub (poly_map f a) (poly_map f b)"
    | "poly_map f (poly.Mul a b)  = poly.Mul (poly_map f a) (poly_map f b)"
    | "poly_map f (poly.Neg a)    = poly.Neg (poly_map f a)"
    | "poly_map f (poly.Pw a n)   = poly.Pw (poly_map f a) n"
    | "poly_map f (poly.CN a n b) = poly.CN (poly_map f a) n (poly_map f b)"

declare [[coercion_map poly_map]]

(* Apply float interval arguments to a float poly. *)
value "Ipoly [Ivl (Float 4 (-6)) (Float 10 6)] (poly.Add (poly.C (Float 3 5)) (poly.Bound 0))"

(* Coercing a "float poly" into a "real poly" is a homomorphism. *)
lemma poly_map_real_polyadd:
fixes p1 p2 :: "float poly"
shows "poly_map real_of_float (p1 +\<^sub>p p2) = poly_map real_of_float p1 +\<^sub>p poly_map real_of_float p2"
apply(induction p1 arbitrary: p2)
apply(simp_all)[7]
proof(goal_cases)
  case (1 x p2)
    show ?case
      by(induction p2, simp_all add: real_of_float_eq)
next
  case (2 p3 n1 p4 p2)
    show ?case
    apply(induction p2)
    using 2
    apply(simp_all add: real_of_float_eq)[7]
    proof(goal_cases a)
      case (a p5 n2 p6)
      show ?case
      unfolding polyadd.simps(4) poly_map.simps if_distrib[of "poly_map real_of_float"]
      apply(rule if_cong)
      apply(simp_all add: 2 a, safe)
      unfolding Let_def if_distrib[of "poly_map real_of_float"]
      apply(rule if_cong)
      apply(cases "p4 +\<^sub>p p6")
      by (simp_all add: real_of_float_eq 2[symmetric])
    qed
qed

lemma poly_map_real_polyneg:
fixes p :: "float poly"
shows "poly_map real_of_float (~\<^sub>pp) = ~\<^sub>p(poly_map real_of_float p)"
by (induction p) simp_all

lemma poly_map_real_polysub:
fixes p1 p2 :: "float poly"
shows "poly_map real_of_float (p1 -\<^sub>p p2) = poly_map real_of_float p1 -\<^sub>p poly_map real_of_float p2"
by (simp add: polysub_def poly_map_real_polyadd poly_map_real_polyneg)

lemma poly_map_real_polymul:
fixes p1 p2 :: "float poly"
shows "poly_map real_of_float (p1 *\<^sub>p p2) = poly_map real_of_float p1 *\<^sub>p poly_map real_of_float p2"
apply(induction p1 arbitrary: p2)
apply(simp_all)[7]
proof(goal_cases)
  case (1 x p2)
    show ?case
      by(induction p2, simp_all add: real_of_float_eq)
next
  case (2 p3 n1 p4 p2)
    show ?case
    apply(induction p2)
    using 2
    apply(simp_all add: real_of_float_eq)[7]
    proof(goal_cases a)
      case (a p5 n2 p6)
      show ?case
      unfolding polymul.simps(4) poly_map.simps if_distrib[of "poly_map real_of_float"]
      apply(rule if_cong)
      apply(simp)
      apply(simp add: 2)
      apply(rule if_cong)
      apply(simp)
      apply(simp add: a)
      using a
      by (simp add: poly_map_real_polyadd)
    qed
qed

lemma poly_map_real_polypow:
fixes p :: "float poly"
shows "poly_map real_of_float (p^\<^sub>pn) = (poly_map real_of_float p)^\<^sub>pn"
proof(induction n rule: nat_less_induct)
  fix n assume assm: "\<forall>m<n. poly_map real_of_float (p ^\<^sub>p m) = (poly_map real_of_float) p ^\<^sub>p m"
  thus "poly_map real_of_float (p ^\<^sub>p n) = poly_map real_of_float p ^\<^sub>p n"
    apply(cases n)
    apply(simp_all)
    by (smt Suc_less_eq div2_less_self even_Suc odd_Suc_div_two poly_map_real_polymul)
qed

lemmas poly_map_real_polyarith = poly_map_real_polyadd poly_map_real_polyneg poly_map_real_polysub poly_map_real_polymul poly_map_real_polypow

(* Count the number of parameters of a polynomial. *)
fun num_params :: "'a poly \<Rightarrow> nat"
where "num_params (poly.C c) = 0"
    | "num_params (poly.Bound n)  = Suc n"
    | "num_params (poly.Add a b)  = max (num_params a) (num_params b)"
    | "num_params (poly.Sub a b)  = max (num_params a) (num_params b)"
    | "num_params (poly.Mul a b)  = max (num_params a) (num_params b)"
    | "num_params (poly.Neg a)    = num_params a"
    | "num_params (poly.Pw a n)   = num_params a"
    | "num_params (poly.CN a n b) = max (max (num_params a) (num_params b)) (Suc n)"

lemma num_params_poly_map[simp]:
shows "num_params (poly_map f p) = num_params p"
by (induction p, simp_all)

lemma num_params_polyadd:
shows "num_params (p1 +\<^sub>p p2) \<le> max (num_params p1) (num_params p2)"
apply(induction p1 p2 rule: polyadd.induct)
apply(auto)[3]
proof-
  case (4 c n p c' n' p')
  show ?case
    apply(cases "n' < n")
    apply(simp)
    using 4
    apply(simp)
    apply(smt max.cobounded2 max.coboundedI2 max.commute max_def)
    apply(cases "n' = n")
    apply(simp add: Let_def)
    apply(smt "4.IH"(3) "4.IH"(4) le_max_iff_disj max.cobounded1)
    apply(simp)
    apply(safe)
    apply(simp_all)
    using 4(1) by auto
qed simp_all

lemma num_params_polyneg:
shows "num_params (~\<^sub>p p) = num_params p"
by (induction p rule: polyneg.induct) simp_all

lemma num_params_polymul:
shows "num_params (p1 *\<^sub>p p2) \<le> max (num_params p1) (num_params p2)"
apply(induction p1 p2 rule: polymul.induct)
apply(auto)[3]
proof-
  case (4 c n p c' n' p')
  show ?case
    apply(cases "n' < n")
    apply(simp)
    using 4
    apply(simp)
    apply(smt max.cobounded2 max.coboundedI2 max.commute max_def)
    apply(cases "n' > n")
    apply(simp add: Let_def)
    apply(safe)
    apply(simp_all)
    using 4(1)
    apply auto[1]
    using 4(2)
    apply(smt le_SucI le_neq_implies_less le_refl le_trans less_Suc_eq_le less_eq_Suc_le less_max_iff_disj less_not_refl linorder_neqE_nat max.absorb1 max.absorb2 max.assoc max.bounded_iff max.cobounded2 max.coboundedI1 max.coboundedI2 max.commute max.left_commute max.strict_order_iff max_less_iff_conj nat_le_linear not_less_eq_eq num_params.simps(8))
    using 4(3,4) num_params_polyadd[of "CN c n p *\<^sub>p c'" "CN 0\<^sub>p n (CN c n p *\<^sub>p p')"]
    apply(simp)
    by (smt max.commute max.left_commute max_def)
qed simp_all

lemma num_params_polypow:
shows "num_params (p ^\<^sub>p n) \<le> num_params p"
using assms
apply(induction n rule: polypow.induct)
apply(simp)
proof-
  fix v assume "(\<And>x. num_params (p ^\<^sub>p Suc v div 2) \<le> num_params p)"
  thus "num_params (p ^\<^sub>p Suc v) \<le> num_params p"
    unfolding polypow.simps
    apply(simp add: Let_def del: polypow.simps)
    apply(safe)
    apply(smt Suc_eq_plus1 add_self_div_2 dvd.order.trans evenE even_Suc even_Suc_div_two even_numeral max_def mult.commute mult_2 num_params_polymul oddE odd_Suc_div_two order.trans order_refl)
    by (smt even_Suc_div_two le_max_iff_disj max_def num_params_polymul)
qed

find_theorems "linorder_class.Max (_ \<union> _)"
find_theorems "0::nat" name: "induct"

lemma num_params_polynate:
shows "num_params (polynate p) \<le> num_params p"
proof(induction p rule: polynate.induct)
  case (2 l r)
  thus ?case
    using num_params_polyadd[of "polynate l" "polynate r"]
    by simp
next
  case (3 l r)
  thus ?case
    apply(simp add: polysub_def)
    using num_params_polyadd[of "polynate l" "~\<^sub>p (polynate r)"]
    by (simp add: num_params_polyneg)
next
  case (4 l r)
  thus ?case
    using num_params_polymul[of "polynate l" "polynate r"]
    by simp
next
  case (5 p)
  thus ?case
    by (simp add: num_params_polyneg)
next
  case (6 p n)
  thus ?case
    using num_params_polypow[of n "polynate p"]
    by simp
qed simp_all

lemma polynate_poly_map_real[simp]:
fixes p :: "float poly"
shows "poly_map real_of_float (polynate p) = polynate (poly_map real_of_float p)"
by (induction p) (simp_all add: poly_map_real_polyarith)

(* Evaluating a float poly is equivalent to evaluating the corresponding
   real poly with the float parameters converted to reals. *)
lemma Ipoly_real_float_eqiv:
fixes p::"float poly" and xs::"float list"
assumes "num_params p \<le> length xs"
shows "Ipoly xs (p::real poly) = Ipoly xs p"
using assms by (induction p, simp_all)

(* Evaluating an "'a poly" with "'a interval" arguments is monotone. *)
lemma Ipoly_interval_args_mono:
fixes p::"'a::linordered_idom poly"
and   x::"'a list"
and   xs::"'a interval list"
assumes "x all_in xs"
assumes "num_params p \<le> length xs"
shows "Ipoly x p \<in> set_of (Ipoly xs (poly_map interval_of p))"
using assms
apply(induction p)
by (simp_all add: set_of_add_mono set_of_minus_mono set_of_mult_mono set_of_uminus_mono set_of_power_mono)

lemma Ipoly_interval_args_inc_mono:
fixes p::"'a::linordered_idom poly"
and   I::"'a interval list" and J::"'a interval list"
assumes "num_params p \<le> length I"
assumes "I all_subset J"
shows "set_of (Ipoly I (poly_map interval_of p)) \<subseteq> set_of (Ipoly J (poly_map interval_of p))"
using assms(1)
apply(induction p)
using assms(2)
by (simp_all add: set_of_add_inc set_of_sub_inc set_of_mul_inc set_of_neg_inc set_of_pow_inc)

section \<open>Splitting polynomials to reduce floating point precision\<close>

(* TODO: Move this! Definitions regarding floating point numbers should not be in a theory about polynomials. *)
fun float_prec :: "float \<Rightarrow> int"
where "float_prec f = (let p=exponent f in if p \<ge> 0 then 0 else -p)"

fun float_round :: "nat \<Rightarrow> float \<Rightarrow> float"
where "float_round prec f = (
         let d = float_down prec f; u = float_up prec f
         in if f - d < u - f then d else u)"

lemma float_round_correct:
shows "float_prec (float_round prec f) \<le> prec"
apply(cases f)
apply(simp add: Let_def, safe)
thm float_down_correct
oops

(* Splits any polynomial p into two polynomials l, r, such that for all x::real. p(x) = l(x) + r(x)
   and all floating point coefficients in p are rounded to precision prec.
   Not all cases need to be give good results. Polynomials normalized with polynate
   only contain poly.C and poly.CN constructors. *)
fun split_by_prec :: "nat \<Rightarrow> float poly \<Rightarrow> float poly * float poly"
where "split_by_prec prec (poly.C f) = (let r = float_round prec f in (poly.C r, poly.C (f - r)))"
    | "split_by_prec prec (poly.Bound n) = (poly.Bound n, poly.C 0)"
    | "split_by_prec prec (poly.Add l r) = (let (ll, lr) = split_by_prec prec l;
                                                (rl, rr) = split_by_prec prec r
                                            in (poly.Add ll rl, poly.Add lr rr))"
    | "split_by_prec prec (poly.Sub l r) = (let (ll, lr) = split_by_prec prec l;
                                             (rl, rr) = split_by_prec prec r
                                         in (poly.Sub ll rl, poly.Sub lr rr))"
    | "split_by_prec prec (poly.Mul l r) = (let (ll, lr) = split_by_prec prec l;
                                                (rl, rr) = split_by_prec prec r
                                            in (poly.Mul ll rl, poly.Add (poly.Add (poly.Mul lr rl) (poly.Mul ll rr)) (poly.Mul lr rr)))"
    | "split_by_prec prec (poly.Neg p) = (let (l, r) = split_by_prec prec p in (poly.Neg l, poly.Neg r))"
    | "split_by_prec prec (poly.Pw p 0) = (poly.C 1, poly.C 0)"
    | "split_by_prec prec (poly.Pw p (Suc n)) = (let (l, r) = split_by_prec prec p in (poly.Pw l n, poly.Sub (poly.Pw p (Suc n)) (poly.Pw l n)))"
    | "split_by_prec prec (poly.CN c n p) = (let (cl, cr) = split_by_prec prec c;
                                                 (pl, pr) = split_by_prec prec p
                                             in (poly.CN cl n pl, poly.CN cr n pr))"

(* TODO: Prove precision constraint on l. *)
lemma split_by_prec_correct:
fixes args :: "real list"
assumes "(l, r) = split_by_prec prec p"
shows "Ipoly args p = Ipoly args l + Ipoly args r" (is ?P1)
and   "num_params l \<le> num_params p" (is ?P2)
and   "num_params r \<le> num_params p" (is ?P3)
unfolding atomize_conj
using assms
proof(induction p arbitrary: l r)
  case (Add p1 p2 l r)
  thus ?case
    apply(simp add: Add(1,2)[OF prod.collapse] split_beta)
    using max.coboundedI1 max.coboundedI2 prod.collapse
    by blast
next
  case (Sub p1 p2 l r)
  thus ?case
  apply(simp add: Sub(1,2)[OF prod.collapse] split_beta)
  using max.coboundedI1 max.coboundedI2 prod.collapse
  by blast
next
  case (Mul p1 p2 l r)
  thus ?case
  apply(simp add: Mul(1,2)[OF prod.collapse] split_beta algebra_simps)
  using max.coboundedI1 max.coboundedI2 prod.collapse
  by blast
next
  case (Neg p l r)
  thus ?case by (simp add: Neg(1)[OF prod.collapse] split_beta)
next
  case (Pw p n l r)
  thus ?case by (cases n) (simp_all add: Pw(1)[OF prod.collapse] split_beta)
next
  case (CN c n p2)
  thus ?case
  apply(simp add: CN(1,2)[OF prod.collapse] split_beta algebra_simps)
  by (meson le_max_iff_disj prod.collapse)
qed (simp_all add: Let_def)

section \<open>Splitting polynomials by degree\<close>

fun maxdegree :: "('a::zero) poly \<Rightarrow> nat"
where "maxdegree (poly.C c) = 0"
    | "maxdegree (poly.Bound n) = 1"
    | "maxdegree (poly.Add l r) = max (maxdegree l) (maxdegree r)"
    | "maxdegree (poly.Sub l r) = max (maxdegree l) (maxdegree r)"
    | "maxdegree (poly.Mul l r) = maxdegree l + maxdegree r"
    | "maxdegree (poly.Neg p) = maxdegree p"
    | "maxdegree (poly.Pw p n) = n * maxdegree p"
    | "maxdegree (poly.CN c n p) = max (maxdegree c) (1 + maxdegree p)"

fun split_by_degree :: "nat \<Rightarrow> 'a::zero poly \<Rightarrow> 'a poly * 'a poly"
where "split_by_degree n (poly.C c) = (poly.C c, poly.C 0)"
    | "split_by_degree 0 p = (poly.C 0, p)"
    | "split_by_degree (Suc n) (poly.CN c v p) = (
         let (cl, cr) = split_by_degree (Suc n) c;
             (pl, pr) = split_by_degree n p
         in (poly.CN cl v pl, poly.CN cr v pr))"
    (* This function is only intended for use on polynomials in normal form.
       Hence most cases never get executed. *)
    | "split_by_degree n p = (poly.C 0, p)"

lemma split_by_degree_correct:
fixes x :: "real list" and p :: "float poly"
assumes "(l, r) = split_by_degree ord p"
shows "maxdegree l \<le> ord" (is ?P1)
and   "Ipoly x p = Ipoly x l + Ipoly x r" (is ?P2)
and   "num_params l \<le> num_params p" (is ?P3)
and   "num_params r \<le> num_params p" (is ?P4)
unfolding atomize_conj
using assms
proof(induction p arbitrary: l r ord)
  case (C c l r ord)
  thus ?case by simp
next
  case (Bound v l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Add p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Sub p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Mul p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Neg p l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Pw p k l r ord)
  thus ?case by (cases ord) simp_all
next
  case (CN c v p l r ord)
  show ?case
  proof(cases ord)
    case 0
    thus ?thesis using CN by simp
  next
    case (Suc m)
    obtain cl cr where cl_cr_def: "(cl, cr) = split_by_degree (Suc m) c"
      by (cases "split_by_degree (Suc m) c", simp)
    obtain pl pr where pl_pr_def: "(pl, pr) = split_by_degree m p"
      by (cases "split_by_degree m p", simp)
    have [simp]: "Ipoly x p = Ipoly x pl + Ipoly x pr"
      using CN(2)[OF pl_pr_def]
      by (cases ord) simp_all
    from CN(3)
    have l_decomp: "l = CN cl v pl" and r_decomp: "r = CN cr v pr"
      by (simp_all add: Suc cl_cr_def[symmetric] pl_pr_def[symmetric])
    show ?thesis
      apply(simp add: l_decomp, safe)
      using CN(1)[OF cl_cr_def]
      apply(simp add: Suc)
      using CN(2)[OF pl_pr_def]
      apply(simp add: Suc)
      using pl_pr_def
      apply(cases p)
      apply(simp_all)
      apply(simp_all add: l_decomp r_decomp CN(1)[OF cl_cr_def] algebra_simps)
      apply(safe)
      prefer 3
      using CN(1)[OF cl_cr_def]
      apply(simp_all add: max.coboundedI1)[2]
      using CN(2)[OF pl_pr_def]
      by auto
  qed
qed

(* Operations on lists. *)
fun list_op :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where "list_op f [] _ = []"
    | "list_op f _ [] = []"
    | "list_op f (l#ls) (r#rs) = (f l r) # list_op f ls rs"

lemma list_op_length[simp]:
shows "length (list_op f a b) = min (length a) (length b)"
using assms
proof(induction "list_op f a b" arbitrary: a b)
  case (Nil a b)
  hence "a = [] | b = []"
    by(cases a, simp, cases b, simp_all)
  thus ?case
    by (safe, simp_all, cases a, simp_all)
next
  case (Cons x c a b)
  have "0 < length a \<and> 0 < length b"
    using Cons(2)
    by (cases a, simp, cases b, simp_all)
  then obtain xa ar xb br
  where a_decomp[simp]: "a = xa # ar"
  and   b_decomp[simp]: "b = xb # br"
    by (cases a, simp_all, cases b, simp_all)

  show ?case
    using Cons
    by simp
qed

lemma list_op_nth[simp]:
assumes "n < min (length a) (length b)"
assumes "n < length b"
shows "(list_op f a b)!n = f (a!n) (b!n)"
using assms
proof(induction n arbitrary: a b)
  case (0 a b)
  have "0 < length a" and "0 < length b"
    using 0
    by simp_all
  thus ?case
    using 0
    by (simp, smt list.exhaust list_op.simps(3) nth_Cons_0)
next
  case (Suc n a b)
  have "0 < length a" and "0 < length b"
    using Suc(2, 3)
    by auto
  thus ?case
    using Suc
    apply(simp, safe)
    (* TODO: Clean this up. *)
    proof -
      assume a1: "\<And>a b. \<lbrakk>n < length a; n < length b\<rbrakk> \<Longrightarrow> list_op f a b ! n = f (a ! n) (b ! n)"
      assume a2: "Suc n < length b"
      assume a3: "Suc n < length a"
      have f4: "b = b ! 0 # drop (Suc 0) b"
        by (metis (no_types) \<open>0 < length b\<close> append.simps(1) id_take_nth_drop take_0)
      hence f5: "Suc (length (drop (Suc 0) b) + 0) = length b"
        by (metis (no_types) add_Suc_right list.size(4))
      have f6: "a = a ! 0 # drop (Suc 0) a"
        by (metis (no_types) \<open>0 < length a\<close> append.simps(1) id_take_nth_drop take_0)
      hence f7: "Suc (length (drop (Suc 0) a) + 0) = length a"
        by (metis (no_types) add_Suc_right list.size(4))
      have f8: "n < length (drop (Suc 0) b)"
        using f5 a2 by linarith
      have "n < length (drop (Suc 0) a)"
        using f7 a3 by linarith
      thus ?thesis
        using f8 f6 f4 a1 by (metis (no_types) list_op.simps(3) nth_Cons_Suc)
    qed
qed

(* Translating a polynomial by a vector. *)
fun poly_translate :: "'a list \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
where "poly_translate vs (poly.C c)  = poly.C c"
    | "poly_translate vs (poly.Bound n) = poly.Add (poly.Bound n) (poly.C (vs ! n))"
    | "poly_translate vs (poly.Add l r) = poly.Add (poly_translate vs l) (poly_translate vs r)"
    | "poly_translate vs (poly.Sub l r) = poly.Sub (poly_translate vs l) (poly_translate vs r)"
    | "poly_translate vs (poly.Mul l r) = poly.Mul (poly_translate vs l) (poly_translate vs r)"
    | "poly_translate vs (poly.Neg p) = poly.Neg (poly_translate vs p)"
    | "poly_translate vs (poly.Pw p n) = poly.Pw (poly_translate vs p) n"
    | "poly_translate vs (poly.CN c n p) = poly.Add (poly_translate vs c) (poly.Mul (poly.Add (poly.Bound n) (poly.C (vs ! n))) (poly_translate vs p))"

(* Translating a polynomial is equivalent to translating its argument. *)
lemma poly_translate_correct:
assumes "num_params p \<le> length x"
assumes "length x = length v"
shows "Ipoly x (poly_translate v p) = Ipoly (list_op op+ x v) p"
using assms
by (induction p, simp_all)

lemma real_poly_translate:
assumes "num_params p \<le> length v"
shows "Ipoly x (poly_map real_of_float (poly_translate v p)) = Ipoly x (poly_translate v (poly_map real_of_float p))"
using assms
by (induction p, simp_all)

lemma num_params_poly_translate[simp]:
shows "num_params (poly_translate v p) = num_params p"
by (induction p, simp_all)

end


theory prop_18
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster append rev *)

lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes append.simps rev.simps)

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes append.simps rev.simps)

lemma lemma_ab [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes append.simps rev.simps)

lemma lemma_ac [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes append.simps rev.simps)

  theorem x0 :
    "(rev (append (rev x) y)) = (append (rev y) x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p (Plus q r)) s) =
      (recognise (Plus (Plus p q) r) s))"
  oops

end