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

declare [[syntax_ambiguity_warning = false]]

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

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

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

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

declare subst_Var [simp del]

subsection {* Beta-reduction *}

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

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

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

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

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

subsection {* Congruence rules *}

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

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

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

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

subsection {* Substitution-lemmas *}

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

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

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

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

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

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

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

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

subsection {* Preservation theorems *}

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

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

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

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

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

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

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

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

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

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

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

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

subsection {* Environments *}

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

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

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

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

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

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

subsection {* Types and typing rules *}

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

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

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

lemma typing_elim_app: assumes "e \<turnstile> t \<degree> u : T" shows "(\<And>T' U'. e \<turnstile> t : T' \<Rightarrow> U' \<Longrightarrow> e \<turnstile> u : T' \<Longrightarrow> P) \<Longrightarrow> P"
  using assms apply cases close auto
  apply (erule typing_elims(2)) by auto

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

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

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

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

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

subsection {* Lists of types *}

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

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

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

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

subsection {* n-ary function types *}

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

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

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

subsection {* Lifting preserves well-typedness *}

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

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

subsection {* Substitution lemmas *}

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

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

subsection {* Subject reduction *}

lemma reduce_below_lift:
  assumes "lift s' k \<rightarrow>\<^sub>\<beta> t"
  shows "\<exists>t'. t = lift t' k \<and> s' \<rightarrow>\<^sub>\<beta> t'"
proof -
def s == "lift s' k"
from assms have st: "s \<rightarrow>\<^sub>\<beta> t" unfolding s_def by simp
have "\<And>s' k. s=lift s' k \<Longrightarrow> \<exists>t'. t = lift t' k \<and> s' \<rightarrow>\<^sub>\<beta> t'"
  using st proof (induction)
  case (abs s t)
    obtain s0 where "s'=Abs s0" and "s = lift s0 (Suc k)"
      apply (atomize_elim)
      apply (cases s')
      using `Abs s = lift s' k` apply auto
      by (metis dB.distinct(3))
    with abs.IH obtain t' where "t = lift t' (Suc k)" and "s0 \<rightarrow>\<^sub>\<beta> t'" by auto
    show ?case apply (rule exI[of _ "Abs t'"], auto)
      apply (metis `t = lift t' (Suc k)`)
      by (metis `s' = Abs s0` `s0 \<rightarrow>\<^sub>\<beta> t'` beta.abs)
  next case (appL s t u)
    obtain s0 u0 where s':"s'=s0 \<degree> u0"
          and s:"s = lift s0 k" and u:"u = lift u0 k"
      by (metis appL.prems dB.distinct(1) dB.distinct(5) dB.exhaust dB.inject(2) lift.simps(2) subst_App subst_lift)
    with appL.IH obtain t' where t:"t = lift t' k" and s0: "s0 \<rightarrow>\<^sub>\<beta> t'" by auto
    show ?case apply (rule exI[of _ "t' \<degree> u0"], auto)
      close (fact t) close (fact u)
      by (metis (full_types) s' s0 beta.appL)
  next case (appR s t u)
    obtain s0 u0 where s':"s'=u0 \<degree> s0"
          and s:"s = lift s0 k" and u:"u = lift u0 k"
      by (metis appR.prems dB.distinct(1) dB.distinct(6) dB.exhaust dB.inject(2) lift.simps(2) subst_App subst_lift)
    with appR.IH obtain t' where t:"t = lift t' k" and s0: "s0 \<rightarrow>\<^sub>\<beta> t'" by auto
    show ?case apply (rule exI[of _ "u0 \<degree> t'"], auto)
      close (fact u) close (fact t)
      by (metis (full_types) s' s0 beta.appR)
  next case (beta s t)
    then obtain s0 t0 where s':"s'=Abs s0 \<degree> t0"
        and s:"s=lift s0 (Suc k)" and t:"t=lift t0 k"
      apply (atomize_elim)
      apply (cases s')
      close (metis beta.beta beta_cases(1) subst_lift subst_preserves_beta)
      defer close auto
      apply (rename_tac s0' t0', case_tac s0')
      defer close auto close auto
      by (metis dB.distinct(3) dB.inject(2) lift.simps(2) subst_Abs subst_lift)
    show "\<exists>t'. s[t/0] = lift t' k \<and> s' \<rightarrow>\<^sub>\<beta> t'"
      apply (rule exI[of _ "s0[t0/0]"])
      by (auto simp: s t s')
  qed
  with s_def show ?thesis by auto
qed

lemma remove_product_type:
  assumes "e \<turnstile> Abs r : T'"
  shows "\<exists>A B. e \<turnstile> Abs r : A \<Rightarrow> B"
using assms apply (cases, auto)
  apply (rename_tac x X y Y)
  apply (rule_tac x="X \<Rightarrow> Y \<Rightarrow> Atom 0" in  exI)
  by (rule_tac x="Atom 0" in  exI, auto)

lemma remove_product_type_fst:
  assumes "e \<turnstile> r : Prod A B"
  shows "e \<turnstile> r : (A \<Rightarrow> B \<Rightarrow> A) \<Rightarrow> A"
using assms apply (cases, auto)
(* Wrong if e is a variable! ! ! *)
by auto

lemma subject_reduction: "e \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> e \<turnstile> t' : T"
proof (induct arbitrary: t' set: typing)
case Var thus ?case by blast
next case Abs thus ?case by blast
next case Pair thus ?case apply auto
  apply (frule reduce_below_lift, auto)
  by (frule reduce_below_lift, auto)
next case Fst thus ?case  by auto
next case (App env s T U t) show ?case
  using App.prems proof (cases)
  case (beta s0) show ?thesis
    using `env \<turnstile> s : T \<Rightarrow> U` proof (cases)
    case Var thus ?thesis by (metis dB.distinct(3) local.beta(1))
    next case App thus ?thesis by (metis dB.distinct(6) local.beta(1))
    next case Abs thus ?thesis by (metis App.hyps(3) dB.inject(3) local.beta(1) local.beta(2) subst_lemma)
    next case Pair fix V assume s:"s = Abs (Var 0 \<degree> Abs (Abs (Var (Suc 0))))" and T:"T = Prod U V"
print_facts
      with App.hyps have "env \<turnstile> t : Prod U V" by auto
      hence t_typ:"env \<turnstile> t : (U\<Rightarrow>V\<Rightarrow>U) \<Rightarrow> U" by (rule remove_product_type_fst)
      from `s=Abs s0` and s have "s0 = Var 0 \<degree> Abs (Abs (Var (Suc 0)))" by simp
      with beta have t':"t' = t \<degree> Abs (Abs (Var (Suc 0)))" by auto
      show "env \<turnstile> t' : U"
        unfolding t' apply (rule typing.intros)
        close (rule t_typ) by auto
    qed
  next case appL with App show ?thesis by auto
  next case appR with App show ?thesis by auto
  qed
qed

subsection {* Alternative induction rule for types *}

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

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

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

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

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

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

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

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

subsection {* Terminating lambda terms *}

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection {* Well-typed substitution preserves termination *}

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

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

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

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

end


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

Koenig's lemma.
*)

section \<open>Koenig's Lemma\<close>

theory Koenig
imports TreeFI "~~/src/HOL/Library/Stream"
begin

(* infinite trees: *)
coinductive infiniteTr where
"\<lbrakk>tr' \<in> set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"

lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
assumes *: "phi tr" and
**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr' \<or> infiniteTr tr'"
shows "infiniteTr tr"
using assms by (elim infiniteTr.coinduct) blast

lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
assumes *: "phi tr" and
**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr'"
shows "infiniteTr tr"
using assms by (elim infiniteTr.coinduct) blast

lemma infiniteTr_sub[simp]:
"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set (sub tr). infiniteTr tr')"
by (erule infiniteTr.cases) blast

primcorec konigPath where
  "shd (konigPath t) = lab t"
| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set (sub t) \<and> infiniteTr tr)"

(* proper paths in trees: *)
coinductive properPath where
"\<lbrakk>shd as = lab tr; tr' \<in> set (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
 properPath as tr"

lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
assumes *: "phi as tr" and
**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
***: "\<And> as tr.
         phi as tr \<Longrightarrow>
         \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
shows "properPath as tr"
using assms by (elim properPath.coinduct) blast

lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
assumes *: "phi as tr" and
**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
***: "\<And> as tr.
         phi as tr \<Longrightarrow>
         \<exists> tr' \<in> set (sub tr). phi (stl as) tr'"
shows "properPath as tr"
using properPath_strong_coind[of phi, OF * **] *** by blast

lemma properPath_shd_lab:
"properPath as tr \<Longrightarrow> shd as = lab tr"
by (erule properPath.cases) blast

lemma properPath_sub:
"properPath as tr \<Longrightarrow>
 \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
by (erule properPath.cases) blast

(* prove the following by coinduction *)
theorem Konig:
  assumes "infiniteTr tr"
  shows "properPath (konigPath tr) tr"
proof-
  {fix as
   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
   proof (coinduction arbitrary: tr as rule: properPath_coind)
     case (sub tr as)
     let ?t = "SOME t'. t' \<in> set (sub tr) \<and> infiniteTr t'"
     from sub have "\<exists>t' \<in> set (sub tr). infiniteTr t'" by simp
     then have "\<exists>t'. t' \<in> set (sub tr) \<and> infiniteTr t'" by blast
     then have "?t \<in> set (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
     moreover have "stl (konigPath tr) = konigPath ?t" by simp
     ultimately show ?case using sub by blast
   qed simp
  }
  thus ?thesis using assms by blast
qed

(* some more stream theorems *)

primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
  "shd (plus xs ys) = shd xs + shd ys"
| "stl (plus xs ys) = plus (stl xs) (stl ys)"

definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  [simp]: "scalar n = smap (\<lambda>x. n * x)"

primcorec ones :: "nat stream" where "ones = 1 ## ones"
primcorec twos :: "nat stream" where "twos = 2 ## twos"
definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"

lemma "ones \<oplus> ones = twos"
  by coinduction simp

lemma "n \<cdot> twos = ns (2 * n)"
  by coinduction simp

lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  by (coinduction arbitrary: xs) auto

lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)

lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  by (coinduction arbitrary: xs ys) auto

lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  by (coinduction arbitrary: xs ys zs) auto

end


theory inductive_predicates_pg
imports Main
begin

datatype tau =
C0 |
C1 tau |
C2 tau tau |
C3 tau tau tau
thm tau.induct

value "C0"
value "C1 C0"
value "C2 (C0) (C1 C0)"

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"
thm ev.cases ev.induct

inductive IP :: "tau \<Rightarrow> bool"  where
rule0: "IP C0" |
rule1: "IP x" |
rule2: "Q (x::tau) \<Longrightarrow> IP x" |
rule3: "Q (x::tau) \<Longrightarrow> IP x'"
thm IP.cases IP.induct

(* *)

inductive bar2 :: "'a \<Rightarrow> bool" where
bar0: "bar2 x" |
bar1: "bar2 x \<Longrightarrow> bar2 x" |
bar2: "bar2 x \<Longrightarrow> bar2 y"

(* *)

inductive I :: "tau \<Rightarrow> bool"  where
rule0: "I C0" |
rule1: "I x" |
rule2: "Q x \<Longrightarrow> I (x::tau)" |
rule3: "Q (x::tau) \<Longrightarrow> I x'" |
rule4: "Q x \<Longrightarrow> I (C1 x)" |
rule5: "Q (C1 x) \<Longrightarrow> I x" |
rule6: "Q (C1 x) \<Longrightarrow> I x'" |
rule7: "Q (x::tau) \<Longrightarrow> I (C2 x' x'')" |
rule8: "I (C2 x' x'')" |
rule9: "Q (x::tau) \<Longrightarrow> I C0 \<Longrightarrow> I (C3 x x' x'') \<Longrightarrow> I (C2 x x')" |
rule10: "Q (x::tau) \<Longrightarrow> I C0 \<Longrightarrow> I x \<Longrightarrow> I (C3 x x' x'') \<Longrightarrow> I (C2 x x')"
thm I.cases I.induct
thm nat.induct
thm I.induct
(*
I ?x \<Longrightarrow>
?P C0 \<Longrightarrow>
(\<And>x. ?P x) \<Longrightarrow>
(\<And>Q x. Q x \<Longrightarrow> ?P x) \<Longrightarrow>
(\<And>Q x x'. Q x \<Longrightarrow> ?P x') \<Longrightarrow>
(\<And>Q x. Q x \<Longrightarrow> ?P (C1 x)) \<Longrightarrow>
(\<And>Q x. Q (C1 x) \<Longrightarrow> ?P x) \<Longrightarrow>
(\<And>Q x x'. Q (C1 x) \<Longrightarrow> ?P x') \<Longrightarrow>
(\<And>Q x x' x''. Q x \<Longrightarrow> ?P (C2 x' x'')) \<Longrightarrow>
(\<And>x' x''. ?P (C2 x' x'')) \<Longrightarrow>
(\<And>Q x x' x''. Q x \<Longrightarrow> I C0 \<Longrightarrow> ?P C0 \<Longrightarrow> I (C3 x x' x'') \<Longrightarrow> ?P (C3 x x' x'') \<Longrightarrow> ?P (C2 x x')) \<Longrightarrow>
(\<And>Q x x' x''. Q x \<Longrightarrow> I C0 \<Longrightarrow> ?P C0 \<Longrightarrow> I x \<Longrightarrow> ?P x \<Longrightarrow> I (C3 x x' x'') \<Longrightarrow> ?P (C3 x x' x'') \<Longrightarrow> ?P (C2 x x')) \<Longrightarrow> ?P ?x
*)

theorem "I x \<Longrightarrow> P x"
  apply (induction rule: I.induct)
  sorry

theorem "I x \<Longrightarrow> P x"
  apply (rule I.induct)
  sorry

theorem "I x \<Longrightarrow> P x"
  apply (cases rule: I.cases)
  apply simp (* explicitly unifies! *)
  sorry

(*
Exercise 4.4. Analogous to star, give an inductive definition of the n-fold iteration of a relation r:
iter r n x y should hold if there are x0, ..., xn s.t. x = x0, xn = y and r xi xi+1 for all i < n
Correct and prove the following claim: star r x y =\<Rightarrow> iter r n x y.

iter r n x y \<equiv> \<exists> x1 ... xn . x=x0 \<and> y=xn \<and> \<forall> i < n. r xi x(i+1)
*)

(*
iter r n x y = there should be a path from x to y using r to get from x to y.
iter0: iter must be reflexive. i.e. there is a path of length 0 from x to y and y is simply itself x.
iterSS: is inductively defined. If we already know there is a path of length n from y to z and we
simply include the extra step x\<rightarrow>y using r, then of course there is a path from x to z using r.
Simply use the old path from the inductively defined  iter r n y z the "old path" and then add the
new path x\<rightarrow>y using r. Thus there is a path of length n+1 (i.e. we can conclude the left most
predicate in the meta-implication chain.
*)
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x" |
iterSS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl: "star r x x"|
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
thm star.induct

lemma "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
  apply (induction rule: star.induct)
(* apply (rule_tac ?n2="0" in exI) *)
(* apply (rule_tac r="\<lambda>x. 0" in exI) *)
   apply (meson iter0)
(*
proof:
1) r x y & r* y z let's us conclude r* x z via start.step
2) Then using the assumptions r* x z and for any n. iter r n y z
we can use iter.iterSS to get iter r (Suc n) x z for any n (from previous selection).
Which gives us iter r ?n x z for the n above as required (need to show existential so there is the
witness).
*)
  by (meson iterSS)

lemma "iter r n x y \<Longrightarrow> star r x y"
  apply (induction rule: iter.induct)
   apply (rule star.refl)
  by (simp add: star.step)

lemma
  shows "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (iter0 x)
  then show ?case by (rule star.refl)
next
  case (iterSS x y n z)
  then show ?case by (meson star.step)
qed

end


theory BasicDef
  imports Main HOL.Real
begin

subsection \<open>Bool\<close>

value "True \<and> False"

value "True \<longrightarrow> False"

value "False \<longrightarrow> True"

definition "TRUE \<equiv> True"

definition "FALSE \<equiv> False"

definition "A \<equiv> TRUE \<and> FALSE"
value A

consts boolconst :: bool
specification (boolconst)
   "boolconst = False"
  by auto

definition AND :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "AND a b \<equiv> \<not>a \<and> \<not>b"

definition "lAND \<equiv> \<lambda>a b. \<not>a \<and> \<not>b"

value "AND True False"
value "lAND True False"
value "True \<and> False"

lemma "\<forall>a b. (AND a b) = (\<not>(a \<or> b))"
  by (simp add:AND_def)

lemma "\<forall>a b. (AND a b) = (lAND a b)"
  by (simp add:AND_def lAND_def)

subsection \<open>Nat number\<close>

value "3::nat"

value "(1::nat) + 2"

value "(3::nat) - 2"

value "(2::nat) * 2"

value "(2::nat)^3"

value "(8::nat) div 3"

value "(6::nat) mod 4"

value "(2::nat) dvd 6"

value "(2::nat) < 4"

value "(2::nat) \<le> 4"

value "min (2::nat) 4"

value "max (2::nat) 4"

value "Min {1::nat, 3, 4}"

value "Max {1::nat, 3, 4}"

(* value "of_nat (5::nat)" *)

(* value "op ^^ (\<lambda>x::nat. x + 2) 3 4" *)

definition next_nat :: "nat \<Rightarrow> nat"
  where "next_nat n \<equiv> Suc n"

definition next_nat2 :: "nat \<Rightarrow> nat"
  where "next_nat2 n \<equiv> n + 1"

lemma "next_nat n = next_nat2 n"
  by (simp add: next_nat_def next_nat2_def)

definition times5 :: "nat \<Rightarrow> nat"
  where "times5 n \<equiv> 5 * n"

definition greater :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  where "greater m n \<equiv> (m > n)"

definition greater2 :: "(nat \<times> nat) \<Rightarrow> bool"
  where "greater2 mn \<equiv> (fst mn > snd mn)"

definition greater3 :: "(nat \<times> nat) \<Rightarrow> bool"
  where "greater3 \<equiv> \<lambda>(m,n). (m > n)"

definition greater4 :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  where "greater4 \<equiv> \<lambda>m n. (m > n)"

lemma "\<forall>m n. greater2 (m,n) = greater3 (m,n)"
   by (simp add: greater2_def greater3_def)

lemma "\<forall>m n. greater3 (m,n) = greater4 m n"
  by (simp add: greater3_def greater4_def)

value "greater4 10"

(* value "greater3 10" *)

subsection \<open>integer\<close>

value "- (4::int)"

value "(5::int) div 3"

value "sgn (- (15::int))"

definition test :: "int \<rightharpoonup> int"
  where "test n \<equiv> (if n > 0 then Some n else None)"

subsection \<open>function type\<close>

definition f :: "nat \<Rightarrow> nat"
  where "f x \<equiv> 2 * x + 1"

definition g :: "nat \<Rightarrow> nat"
  where "g x \<equiv> 3 * x + 1"

term f
term g

term "True"

definition h :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "h x y \<equiv> x + y"

term h

definition h2 :: "(nat \<times> nat) \<Rightarrow> nat"
  where "h2 \<equiv> \<lambda>(x,y). x + y"

value "h 3 5"
value "h 3"
value "h2 (3,5)"

(* value "h2 3" *)

subsection \<open>term, expression, formula\<close>

consts cst1 :: int
specification(cst1)
  "cst1 = 1" by simp

consts cst2 :: int
specification(cst2)
  "cst2 > 1"
  using gt_ex by auto

definition "cst3 = (3::int)"
term cst3

thm cst3_def

consts fun1 :: "nat \<Rightarrow> nat"
specification(fun1)
  fun1def: "fun1 n = Suc n"
  by auto

lemma "fun1 2 = 3"
  using fun1def by simp

axiomatization fun2 :: "nat \<Rightarrow> nat" where fun2_def: "fun2 n = n + 2"

lemma "fun2 5 = 7"
  using fun2_def by simp

definition fun2' :: "nat \<Rightarrow> nat"
  where "fun2' n \<equiv> n + 2"

lemma "fun2 = fun2'"
  using fun2_def fun2'_def by auto

term "cst1"

term "''a string''"

term "\<lambda>x. y"
value "(\<lambda>x. y) a"

term "\<lambda>x. True"
value "(\<lambda>x. True) 2"
value "(\<lambda>x. True) ''abc''"
value "(\<lambda>x. True) 2.0"

term "\<lambda>x. Suc x"
value "(\<lambda>x. Suc x) 5"

term "\<lambda>x. (x::int) + 10"

term "\<lambda>x. \<lambda>y. x * y"
term "\<lambda>x y. x * y"
value "(\<lambda>x y. x * y) (5::int) (6::int)"
value "(\<lambda>x y. x * y) (5.0::real) (6::int)"
value "(\<lambda>x y. x * y) (5.0::real) (6.5::real)"

term "\<lambda>x y. (x::int) * y"
value "(\<lambda>x y. (x::int) * y) 5 6"

term "\<lambda>x. (x::int) + a"
value "(\<lambda>x. (x::int) + a) 1"

lemma "(\<lambda>x y. x * y) = (\<lambda>x. \<lambda>y. x * y)"
  by simp

definition "lam1 \<equiv> \<lambda>x y z. (if x \<ge> y then
                               if x \<ge> z then x else z
                             else
                               if y \<ge> z then y else z)"
term "lam1"
value "lam1 (2::int) 3 1"

definition "lam2 \<equiv> \<lambda>f x. f x"
term "lam2"
value "lam2 Suc 1"

term "(\<lambda>f x. f x)"
value "(\<lambda>f x. f x) Suc 1"

definition "lam3 \<equiv> \<lambda>f g x y. f (g x y)"
value "lam3 Suc plus 10 20"
term "(\<lambda>f g x y. f (g x y))"
value "(\<lambda>f g x y. f (g x y)) Suc plus 10 20"

definition f1 :: "nat \<Rightarrow> nat"
  where "f1 \<equiv> \<lambda>x. 2 * x + 1"

definition g1 :: "nat \<Rightarrow> nat"
  where "g1 \<equiv> \<lambda>x. 3 * x + 1"

lemma "f1 = f"
  unfolding f_def f1_def by auto

lemma "g1 = g"
  unfolding g_def g1_def by auto

definition addint :: "int \<Rightarrow> int"
  where "addint i \<equiv> i + 1"

definition addint2 :: "int \<Rightarrow> int"
  where "addint2 \<equiv> \<lambda>i. (i + 1)"

thm addint_def

lemma "addint = addint2"
  unfolding addint_def addint2_def by simp

lemma "addint = (\<lambda>i. (i + 1))"
  unfolding addint_def by simp

definition if1 :: "bool \<Rightarrow> string"
  where "if1 b \<equiv> if b then
                    ''its true''
                 else ''its false''"
value "if1 True"
value "(\<lambda>b. if b then
              ''its true''
            else ''its false'') True"

term "if b then e1 else e2"

term "let x = i; y = i + 1 in (x + y) * 2"

definition let1 :: "nat \<Rightarrow> nat"
  where "let1 i = (let x = i; y = i + 1 in (x + y) * 2)"

value "let1 3"

lemma "(let x = i; y = i + 1 in (x + y) * 2) = (i + (i + 1)) * 2"
  by simp

definition let2 :: "nat \<Rightarrow> nat"
  where "let2 i = (let x = i; y = i + 1 in
                    (\<lambda>x. (Suc x) + y) x + (\<lambda>y. (Suc y) + x) y)"

lemma "let x = i; y = i + 1
       in (\<lambda>x. (Suc x) + y) x + (\<lambda>y. (Suc y) + x) y = ((\<lambda>x. (Suc x) + (i + 1)) i + (\<lambda>y. (Suc y) + i) (i + 1))"
  by simp

value "let2 3"

term "let x = (5::nat) in x * 2"

definition case1 :: "nat \<Rightarrow> string"
  where "case1 n \<equiv> case n of 0 \<Rightarrow> ''zero'' |
                             (Suc m) \<Rightarrow> ''not zero''"

primrec case2 :: "nat \<Rightarrow> string"
  where "case2 0 = ''zero''" |
        "case2 (Suc m) = ''not zero''"

lemma "case1 x = case2 x"
  apply(simp add:case1_def) apply(induct x) apply(cases x) by simp+

value "case1 0"
value "case1 1"

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Models of Relation Algebra\<close>

theory Relation_Algebra_Models
  imports Relation_Algebra Kleene_Algebra.Inf_Matrix
begin

text \<open>We formalise two models. First we show the obvious: binary relations
form a relation algebra. Then we show that infinite matrices (which we
formalised originally for Kleene algebras) form models of relation algebra if
we restrict their element type to @{typ bool}.\<close>

subsection \<open>Binary Relations\<close>

text \<open>Since Isabelle's libraries for binary relations are very well
developed, the proof for this model is entirely trivial.\<close>

interpretation rel_relation_algebra: relation_algebra "(-)" uminus "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV "(O)" Relation.converse Id
by unfold_locales auto

subsection \<open>Infinite Boolean Matrices\<close>

text \<open>Next we consider infinite Boolean matrices. We define the maximal
Boolean matrix (all of its entries are @{const True}), the converse or
transpose of a matrix, the intersection of two Boolean matrices and the
complement of a Boolean matrix.\<close>

definition mat_top :: "('a, 'b, bool) matrix" ("\<tau>")
  where "\<tau> i j \<equiv> True"

definition mat_transpose :: "('a, 'b, 'c) matrix \<Rightarrow> ('b, 'a, 'c) matrix" ("_\<^sup>\<dagger>" [101] 100)
  where "f\<^sup>\<dagger> \<equiv> (\<lambda>i j. f j i)"

definition mat_inter :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" (infixl "\<sqinter>" 70)
  where "f \<sqinter> g \<equiv> (\<lambda>i j. f i j \<cdot> g i j)"

definition mat_complement :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" ("_\<^sup>c" [101] 100)
  where "f\<^sup>c = (\<lambda>i j. - f i j)"

text \<open>Next we show that the Booleans form a dioid. We state this as an
\emph{instantiation} result. The Kleene algebra files contain an
\emph{interpretation} proof, which is not sufficient for our purposes.\<close>

instantiation bool :: dioid_one_zero
begin

  definition zero_bool_def:
    "zero_bool \<equiv> False"

  definition one_bool_def:
    "one_bool \<equiv> True"

  definition times_bool_def:
    "times_bool \<equiv> (\<and>)"

  definition plus_bool_def:
    "plus_bool \<equiv> (\<or>)"

  instance
  by standard (auto simp: plus_bool_def times_bool_def one_bool_def zero_bool_def)

end

text \<open>We now show that infinite Boolean matrices form a Boolean algebra.\<close>

lemma le_funI2: "(\<And>i j. f i j \<le> g i j) \<Longrightarrow> f \<le> g"
by (metis le_funI)

interpretation matrix_ba: boolean_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" mat_add mat_zero mat_top
by standard (force intro!: le_funI simp: mat_inter_def plus_bool_def mat_add_def mat_zero_def zero_bool_def mat_top_def mat_complement_def)+

text \<open>We continue working towards the main result of this section, that
infinite Boolean matrices form a relation algebra.\<close>

lemma mat_mult_var: "(f \<otimes> g) = (\<lambda>i j. \<Sum> {(f i k) * (g k j) | k. k \<in> UNIV})"
by (rule ext)+ (simp add: mat_mult_def)

text \<open>The following fact is related to proving the last relation algebra
axiom in the matrix model. It is more complicated than necessary since finite
infima are not well developed in Isabelle. Instead we translate properties of
finite infima into properties of finite suprema by using Boolean algebra. For
finite suprema we have developed special-purpose theorems in the Kleene algebra
files.\<close>

lemma mat_res_pointwise:
  fixes i j :: "'a::finite"
    and x :: "('a, 'a, bool) matrix"
  shows "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j \<le> (y\<^sup>c) i j"
proof -
  have "\<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV} \<le> (y\<^sup>c) i j \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j) \<le> (y\<^sup>c) i j)"
    by (subst sum_sup) auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> - (x \<otimes> y) k j) \<le> (y\<^sup>c) i j)"
    by (simp only: mat_complement_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> ((y\<^sup>c) i j \<or> (x \<otimes> y) k j))"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> (- y i j \<or> (x \<otimes> y) k j))"
    by (simp only: mat_complement_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> y i j) \<le> (x \<otimes> y) k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> (x \<otimes> y) k j)"
    by (simp add: mat_transpose_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
    by (simp add: mat_mult_def times_bool_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. \<Sum>{x k i \<and> y i j} \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
    by simp
  also have "\<dots> \<longleftrightarrow> True"
    by (intro iffI TrueI allI sum_intro[rule_format]) auto
  moreover have "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j = \<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV}"
    by (subst mat_mult_def) (simp add: times_bool_def)
  ultimately show ?thesis
    by auto
qed

text \<open>Finally the main result of this section.\<close>

interpretation matrix_ra: relation_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "(\<sqinter>)" "(\<le>)" "(<)" "(\<oplus>)" "\<lambda>i j. False" \<tau> "(\<otimes>)" mat_transpose \<epsilon>
proof
  fix x y z :: "'a::finite \<Rightarrow> 'a \<Rightarrow> bool"
  show "(\<lambda>(i::'a) j::'a. False) \<le> x"
    by (metis predicate2I)
  show "x \<sqinter> x\<^sup>c = (\<lambda>i j. False)"
    by (metis matrix_ba.bot.extremum matrix_ba.inf_compl_bot rev_predicate2D)
  show "x \<oplus> x\<^sup>c = \<tau>"
    by (fact matrix_ba.sup_compl_top)
  show "x \<sqinter> y\<^sup>c = x \<sqinter> y\<^sup>c"
    by (fact refl)
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)"
    by (metis mat_mult_assoc)
  show "x \<otimes> \<epsilon> = x"
    by (fact mat_oner)
  show "x \<oplus> y \<otimes> z = (x \<otimes> z) \<oplus> (y \<otimes> z)"
    by (fact mat_distr)
  show "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x"
    by (simp add: mat_transpose_def)
  show "(x \<oplus> y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<oplus> y\<^sup>\<dagger>"
    by (simp add: mat_transpose_def mat_add_def)
  show "(x \<otimes> y)\<^sup>\<dagger> = y\<^sup>\<dagger> \<otimes> x\<^sup>\<dagger>"
    by (simp add: mat_transpose_def mat_mult_var times_bool_def conj_commute)
  show "x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c \<le> y\<^sup>c"
    by (metis le_funI2 mat_res_pointwise)
qed

end


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
chapter \<open>Examples\<close>
theory OCL_Examples
  imports OCL_Normalization
begin

(*** Classes ****************************************************************)

section \<open>Classes\<close>

datatype classes1 =
  Object | Person | Employee | Customer | Project | Task | Sprint

inductive subclass1 where
  "c \<noteq> Object \<Longrightarrow>
   subclass1 c Object"
| "subclass1 Employee Person"
| "subclass1 Customer Person"

instantiation classes1 :: semilattice_sup
begin

definition "(<) \<equiv> subclass1"
definition "(\<le>) \<equiv> subclass1\<^sup>=\<^sup>="

fun sup_classes1 where
  "Object \<squnion> _ = Object"
| "Person \<squnion> c = (if c = Person \<or> c = Employee \<or> c = Customer
    then Person else Object)"
| "Employee \<squnion> c = (if c = Employee then Employee else
    if c = Person \<or> c = Customer then Person else Object)"
| "Customer \<squnion> c = (if c = Customer then Customer else
    if c = Person \<or> c = Employee then Person else Object)"
| "Project \<squnion> c = (if c = Project then Project else Object)"
| "Task \<squnion> c = (if c = Task then Task else Object)"
| "Sprint \<squnion> c = (if c = Sprint then Sprint else Object)"

lemma less_le_not_le_classes1:
  "c < d \<longleftrightarrow> c \<le> d \<and> \<not> d \<le> c"
  for c d :: classes1
  unfolding less_classes1_def less_eq_classes1_def
  using subclass1.simps by auto

lemma order_refl_classes1:
  "c \<le> c"
  for c :: classes1
  unfolding less_eq_classes1_def by simp

lemma order_trans_classes1:
  "c \<le> d \<Longrightarrow> d \<le> e \<Longrightarrow> c \<le> e"
  for c d e :: classes1
  unfolding less_eq_classes1_def
  using subclass1.simps by auto

lemma antisym_classes1:
  "c \<le> d \<Longrightarrow> d \<le> c \<Longrightarrow> c = d"
  for c d :: classes1
  unfolding less_eq_classes1_def
  using subclass1.simps by auto

lemma sup_ge1_classes1:
  "c \<le> c \<squnion> d"
  for c d :: classes1
  by (induct c; auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

lemma sup_ge2_classes1:
  "d \<le> c \<squnion> d"
  for c d :: classes1
  by (induct c; auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

lemma sup_least_classes1:
  "c \<le> e \<Longrightarrow> d \<le> e \<Longrightarrow> c \<squnion> d \<le> e"
  for c d e :: classes1
  by (induct c; induct d;
      auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

instance
  apply intro_classes
  apply (simp add: less_le_not_le_classes1)
  apply (simp add: order_refl_classes1)
  apply (rule order_trans_classes1; auto)
  apply (simp add: antisym_classes1)
  apply (simp add: sup_ge1_classes1)
  apply (simp add: sup_ge2_classes1)
  by (simp add: sup_least_classes1)

end

code_pred subclass1 .

fun subclass1_fun where
  "subclass1_fun Object \<C> = False"
| "subclass1_fun Person \<C> = (\<C> = Object)"
| "subclass1_fun Employee \<C> = (\<C> = Object \<or> \<C> = Person)"
| "subclass1_fun Customer \<C> = (\<C> = Object \<or> \<C> = Person)"
| "subclass1_fun Project \<C> = (\<C> = Object)"
| "subclass1_fun Task \<C> = (\<C> = Object)"
| "subclass1_fun Sprint \<C> = (\<C> = Object)"

lemma less_classes1_code [code]:
  "(<) = subclass1_fun"
proof (intro ext iffI)
  fix \<C> \<D> :: "classes1"
  show "\<C> < \<D> \<Longrightarrow> subclass1_fun \<C> \<D>"
    unfolding less_classes1_def
    apply (erule subclass1.cases, auto)
    using subclass1_fun.elims(3) by blast
  show "subclass1_fun \<C> \<D> \<Longrightarrow> \<C> < \<D>"
    by (erule subclass1_fun.elims, auto simp add: less_classes1_def subclass1.intros)
qed

lemma less_eq_classes1_code [code]:
  "(\<le>) = (\<lambda>x y. subclass1_fun x y \<or> x = y)"
  unfolding dual_order.order_iff_strict less_classes1_code
  by auto

(*** Object Model ***********************************************************)

section \<open>Object Model\<close>

abbreviation "\<Gamma>\<^sub>0 \<equiv> fmempty :: classes1 type env"
declare [[coercion "ObjectType :: classes1 \<Rightarrow> classes1 basic_type"]]
declare [[coercion "phantom :: String.literal \<Rightarrow> classes1 enum"]]

instantiation classes1 :: ocl_object_model
begin

definition "classes_classes1 \<equiv>
  {|Object, Person, Employee, Customer, Project, Task, Sprint|}"

definition "attributes_classes1 \<equiv> fmap_of_list [
  (Person, fmap_of_list [
    (STR ''name'', String[1] :: classes1 type)]),
  (Employee, fmap_of_list [
    (STR ''name'', String[1]),
    (STR ''position'', String[1])]),
  (Customer, fmap_of_list [
    (STR ''vip'', Boolean[1])]),
  (Project, fmap_of_list [
    (STR ''name'', String[1]),
    (STR ''cost'', Real[?])]),
  (Task, fmap_of_list [
    (STR ''description'', String[1])])]"

abbreviation "assocs \<equiv> [
  STR ''ProjectManager'' \<mapsto>\<^sub>f [
    STR ''projects'' \<mapsto>\<^sub>f (Project, 0::nat, \<infinity>::enat, False, True),
    STR ''manager'' \<mapsto>\<^sub>f (Employee, 1, 1, False, False)],
  STR ''ProjectMember'' \<mapsto>\<^sub>f [
    STR ''member_of'' \<mapsto>\<^sub>f (Project, 0, \<infinity>, False, False),
    STR ''members'' \<mapsto>\<^sub>f (Employee, 1, 20, True, True)],
  STR ''ManagerEmployee'' \<mapsto>\<^sub>f [
    STR ''line_manager'' \<mapsto>\<^sub>f (Employee, 0, 1, False, False),
    STR ''project_manager'' \<mapsto>\<^sub>f (Employee, 0, \<infinity>, False, False),
    STR ''employees'' \<mapsto>\<^sub>f (Employee, 3, 7, False, False)],
  STR ''ProjectCustomer'' \<mapsto>\<^sub>f [
    STR ''projects'' \<mapsto>\<^sub>f (Project, 0, \<infinity>, False, True),
    STR ''customer'' \<mapsto>\<^sub>f (Customer, 1, 1, False, False)],
  STR ''ProjectTask'' \<mapsto>\<^sub>f [
    STR ''project'' \<mapsto>\<^sub>f (Project, 1, 1, False, False),
    STR ''tasks'' \<mapsto>\<^sub>f (Task, 0, \<infinity>, True, True)],
  STR ''SprintTaskAssignee'' \<mapsto>\<^sub>f [
    STR ''sprint'' \<mapsto>\<^sub>f (Sprint, 0, 10, False, True),
    STR ''tasks'' \<mapsto>\<^sub>f (Task, 0, 5, False, True),
    STR ''assignee'' \<mapsto>\<^sub>f (Employee, 0, 1, False, False)]]"

definition "associations_classes1 \<equiv> assocs"

definition "association_classes_classes1 \<equiv> fmempty :: classes1 \<rightharpoonup>\<^sub>f assoc"

text \<open>
\begin{verbatim}
context Project
def: membersCount() : Integer[1] = members->size()
def: membersByName(mn : String[1]) : Set(Employee[1]) =
       members->select(member | member.name = mn)
static def: allProjects() : Set(Project[1]) =
              Project[1].allInstances()
\end{verbatim}\<close>

definition "operations_classes1 \<equiv> [
  (STR ''membersCount'', Project[1], [], Integer[1], False,
   Some (OperationCall
    (AssociationEndCall (Var STR ''self'') DotCall None STR ''members'')
    ArrowCall CollectionSizeOp [])),
  (STR ''membersByName'', Project[1], [(STR ''mn'', String[1], In)],
    Set Employee[1], False,
   Some (SelectIteratorCall
    (AssociationEndCall (Var STR ''self'') DotCall None STR ''members'')
    ArrowCall [STR ''member''] None
    (OperationCall
      (AttributeCall (Var STR ''member'') DotCall STR ''name'')
      DotCall EqualOp [Var STR ''mn'']))),
  (STR ''allProjects'', Project[1], [], Set Project[1], True,
   Some (MetaOperationCall Project[1] AllInstancesOp))
  ] :: (classes1 type, classes1 expr) oper_spec list"

definition "literals_classes1 \<equiv> fmap_of_list [
  (STR ''E1'' :: classes1 enum, {|STR ''A'', STR ''B''|}),
  (STR ''E2'', {|STR ''C'', STR ''D'', STR ''E''|})]"

lemma assoc_end_min_less_eq_max:
  "assoc |\<in>| fmdom assocs \<Longrightarrow>
   fmlookup assocs assoc = Some ends \<Longrightarrow>
   role |\<in>| fmdom ends  \<Longrightarrow>
   fmlookup ends role = Some end \<Longrightarrow>
   assoc_end_min end \<le> assoc_end_max end"
  unfolding assoc_end_min_def assoc_end_max_def
  using zero_enat_def one_enat_def numeral_eq_enat by auto

lemma association_ends_unique:
  assumes "association_ends' classes assocs \<C> from role end\<^sub>1"
      and "association_ends' classes assocs \<C> from role end\<^sub>2"
    shows "end\<^sub>1 = end\<^sub>2"
proof -
  have "\<not> association_ends_not_unique' classes assocs" by eval
  with assms show ?thesis
    using association_ends_not_unique'.simps by blast
qed

instance
  apply standard
  unfolding associations_classes1_def
  using assoc_end_min_less_eq_max apply blast
  using association_ends_unique by blast

end

(*** Simplification Rules ***************************************************)

section \<open>Simplification Rules\<close>

lemma ex_alt_simps [simp]:
  "\<exists>a. a"
  "\<exists>a. \<not> a"
  "(\<exists>a. (a \<longrightarrow> P) \<and> a) = P"
  "(\<exists>a. \<not> a \<and> (\<not> a \<longrightarrow> P)) = P"
  by auto

declare numeral_eq_enat [simp]

lemmas basic_type_le_less [simp] = Orderings.order_class.le_less
  for x y :: "'a basic_type"

declare element_type_alt_simps [simp]
declare update_element_type.simps [simp]
declare to_unique_collection.simps [simp]
declare to_nonunique_collection.simps [simp]
declare to_ordered_collection.simps [simp]

declare assoc_end_class_def [simp]
declare assoc_end_min_def [simp]
declare assoc_end_max_def [simp]
declare assoc_end_ordered_def [simp]
declare assoc_end_unique_def [simp]

declare oper_name_def [simp]
declare oper_context_def [simp]
declare oper_params_def [simp]
declare oper_result_def [simp]
declare oper_static_def [simp]
declare oper_body_def [simp]

declare oper_in_params_def [simp]
declare oper_out_params_def [simp]

declare assoc_end_type_def [simp]
declare oper_type_def [simp]

declare op_type_alt_simps [simp]
declare typing_alt_simps [simp]
declare normalize_alt_simps [simp]
declare nf_typing.simps [simp]

declare subclass1.intros [intro]
declare less_classes1_def [simp]

declare literals_classes1_def [simp]

lemma attribute_Employee_name [simp]:
  "attribute Employee STR ''name'' \<D> \<tau> =
   (\<D> = Employee \<and> \<tau> = String[1])"
proof -
  have "attribute Employee STR ''name'' Employee String[1]"
    by eval
  thus ?thesis
    using attribute_det by blast
qed

lemma association_end_Project_members [simp]:
  "association_end Project None STR ''members'' \<D> \<tau> =
   (\<D> = Project \<and> \<tau> = (Employee, 1, 20, True, True))"
proof -
  have "association_end Project None STR ''members''
          Project (Employee, 1, 20, True, True)"
    by eval
  thus ?thesis
    using association_end_det by blast
qed

lemma association_end_Employee_projects_simp [simp]:
  "association_end Employee None STR ''projects'' \<D> \<tau> =
   (\<D> = Employee \<and> \<tau> = (Project, 0, \<infinity>, False, True))"
proof -
  have "association_end Employee None STR ''projects''
          Employee (Project, 0, \<infinity>, False, True)"
    by eval
  thus ?thesis
    using association_end_det by blast
qed

lemma static_operation_Project_allProjects [simp]:
  "static_operation \<langle>Project\<rangle>\<^sub>\<T>[1] STR ''allProjects'' [] oper =
   (oper = (STR ''allProjects'', \<langle>Project\<rangle>\<^sub>\<T>[1], [], Set \<langle>Project\<rangle>\<^sub>\<T>[1], True,
     Some (MetaOperationCall \<langle>Project\<rangle>\<^sub>\<T>[1] AllInstancesOp)))"
proof -
  have "static_operation \<langle>Project\<rangle>\<^sub>\<T>[1] STR ''allProjects'' []
    (STR ''allProjects'', \<langle>Project\<rangle>\<^sub>\<T>[1], [], Set \<langle>Project\<rangle>\<^sub>\<T>[1], True,
     Some (MetaOperationCall \<langle>Project\<rangle>\<^sub>\<T>[1] AllInstancesOp))"
    by eval
  thus ?thesis
    using static_operation_det by blast
qed

(*** Basic Types ************************************************************)

section \<open>Basic Types\<close>

subsection \<open>Positive Cases\<close>

lemma "UnlimitedNatural < (Real :: classes1 basic_type)" by simp
lemma "\<langle>Employee\<rangle>\<^sub>\<T> < \<langle>Person\<rangle>\<^sub>\<T>" by auto
lemma "\<langle>Person\<rangle>\<^sub>\<T> \<le> OclAny" by simp

subsection \<open>Negative Cases\<close>

lemma "\<not> String \<le> (Boolean :: classes1 basic_type)" by simp

(*** Types ******************************************************************)

section \<open>Types\<close>

subsection \<open>Positive Cases\<close>

lemma "Integer[?] < (OclSuper :: classes1 type)" by simp
lemma "Collection Real[?] < (OclSuper :: classes1 type)" by simp
lemma "Set (Collection Boolean[1]) < (OclSuper :: classes1 type)" by simp
lemma "Set (Bag Boolean[1]) < Set (Collection Boolean[?] :: classes1 type)"
  by simp
lemma "Tuple (fmap_of_list [(STR ''a'', Boolean[1]), (STR ''b'', Integer[1])]) <
       Tuple (fmap_of_list [(STR ''a'', Boolean[?] :: classes1 type)])" by eval

lemma "Integer[1] \<squnion> (Real[?] :: classes1 type) = Real[?]" by simp
lemma "Set Integer[1] \<squnion> Set (Real[1] :: classes1 type) = Set Real[1]" by simp
lemma "Set Integer[1] \<squnion> Bag (Boolean[?] :: classes1 type) = Collection OclAny[?]"
  by simp
lemma "Set Integer[1] \<squnion> (Real[1] :: classes1 type) = OclSuper" by simp

subsection \<open>Negative Cases\<close>

lemma "\<not> OrderedSet Boolean[1] < Set (Boolean[1] :: classes1 type)" by simp

(*** Typing *****************************************************************)

section \<open>Typing\<close>

subsection \<open>Positive Cases\<close>

text \<open>
\<^verbatim>\<open>E1::A : E1[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> EnumLiteral STR ''E1'' STR ''A'' : (Enum STR ''E1'')[1]"
  by simp

text \<open>
\<^verbatim>\<open>true or false : Boolean[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (BooleanLiteral True) DotCall OrOp
    [BooleanLiteral False] : Boolean[1]"
  by simp

text \<open>
\<^verbatim>\<open>null and true : Boolean[?]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (NullLiteral) DotCall AndOp
    [BooleanLiteral True] : Boolean[?]"
  by simp

text \<open>
\<^verbatim>\<open>let x : Real[1] = 5 in x + 7 : Real[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> Let (STR ''x'') (Some Real[1]) (IntegerLiteral 5)
    (OperationCall (Var STR ''x'') DotCall PlusOp [IntegerLiteral 7]) : Real[1]"
  by simp

text \<open>
\<^verbatim>\<open>null.oclIsUndefined() : Boolean[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (NullLiteral) DotCall OclIsUndefinedOp [] : Boolean[1]"
  by simp

text \<open>
\<^verbatim>\<open>Sequence{1..5, null}.oclIsUndefined() : Sequence(Boolean[1])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5),
     CollectionItem NullLiteral])
    DotCall OclIsUndefinedOp [] : Sequence Boolean[1]"
  by simp

text \<open>
\<^verbatim>\<open>Sequence{1..5}->product(Set{'a', 'b'})
  : Set(Tuple(first: Integer[1], second: String[1]))\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5)])
    ArrowCall ProductOp
    [CollectionLiteral SetKind
      [CollectionItem (StringLiteral ''a''),
       CollectionItem (StringLiteral ''b'')]] :
    Set (Tuple (fmap_of_list [
      (STR ''first'', Integer[1]), (STR ''second'', String[1])]))"
  by simp

text \<open>
\<^verbatim>\<open>Sequence{1..5, null}?->iterate(x, acc : Real[1] = 0 | acc + x)
  : Real[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> IterateCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5),
     CollectionItem NullLiteral]) SafeArrowCall
    [STR ''x''] None
    (STR ''acc'') (Some Real[1]) (IntegerLiteral 0)
    (OperationCall (Var STR ''acc'') DotCall PlusOp [Var STR ''x'']) : Real[1]"
  by simp

text \<open>
\<^verbatim>\<open>Sequence{1..5, null}?->max() : Integer[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> OperationCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5),
     CollectionItem NullLiteral])
    SafeArrowCall CollectionMaxOp [] : Integer[1]"
  by simp

text \<open>
\<^verbatim>\<open>let x : Sequence(String[?]) = Sequence{'abc', 'zxc'} in
x->any(it | it = 'test') : String[?]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> Let (STR ''x'') (Some (Sequence String[?]))
    (CollectionLiteral SequenceKind
      [CollectionItem (StringLiteral ''abc''),
       CollectionItem (StringLiteral ''zxc'')])
    (AnyIteratorCall (Var STR ''x'') ArrowCall
      [STR ''it''] None
      (OperationCall (Var STR ''it'') DotCall EqualOp
        [StringLiteral ''test''])) : String[?]"
  by simp

text \<open>
\<^verbatim>\<open>let x : Sequence(String[?]) = Sequence{'abc', 'zxc'} in
x?->closure(it | it) : OrderedSet(String[1])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> Let STR ''x'' (Some (Sequence String[?]))
    (CollectionLiteral SequenceKind
      [CollectionItem (StringLiteral ''abc''),
       CollectionItem (StringLiteral ''zxc'')])
    (ClosureIteratorCall (Var STR ''x'') SafeArrowCall
      [STR ''it''] None
      (Var STR ''it'')) : OrderedSet String[1]"
  by simp

text \<open>
\<^verbatim>\<open>context Employee:
name : String[1]\<close>\<close>
lemma
  "\<Gamma>\<^sub>0(STR ''self'' \<mapsto>\<^sub>f Employee[1]) \<turnstile>
    AttributeCall (Var STR ''self'') DotCall STR ''name'' : String[1]"
  by simp

text \<open>
\<^verbatim>\<open>context Employee:
projects : Set(Project[1])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0(STR ''self'' \<mapsto>\<^sub>f Employee[1]) \<turnstile>
    AssociationEndCall (Var STR ''self'') DotCall None
      STR ''projects'' : Set Project[1]"
  by simp

text \<open>
\<^verbatim>\<open>context Employee:
projects.members : Bag(Employee[1])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0(STR ''self'' \<mapsto>\<^sub>f Employee[1]) \<turnstile>
    AssociationEndCall (AssociationEndCall (Var STR ''self'')
        DotCall None STR ''projects'')
      DotCall None STR ''members'' : Bag Employee[1]"
  by simp

text \<open>
\<^verbatim>\<open>Project[?].allInstances() : Set(Project[?])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> MetaOperationCall Project[?] AllInstancesOp : Set Project[?]"
  by simp

text \<open>
\<^verbatim>\<open>Project[1]::allProjects() : Set(Project[1])\<close>\<close>
lemma
  "\<Gamma>\<^sub>0 \<turnstile> StaticOperationCall Project[1] STR ''allProjects'' [] : Set Project[1]"
  by simp

subsection \<open>Negative Cases\<close>

text \<open>
\<^verbatim>\<open>true = null\<close>\<close>
lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> OperationCall (BooleanLiteral True) DotCall EqualOp
    [NullLiteral] : \<tau>"
  by simp

text \<open>
\<^verbatim>\<open>let x : Boolean[1] = 5 in x and true\<close>\<close>
lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> Let STR ''x'' (Some Boolean[1]) (IntegerLiteral 5)
    (OperationCall (Var STR ''x'') DotCall AndOp [BooleanLiteral True]) : \<tau>"
  by simp

text \<open>
\<^verbatim>\<open>let x : Sequence(String[?]) = Sequence{'abc', 'zxc'} in
x->closure(it | 1)\<close>\<close>
lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> Let STR ''x'' (Some (Sequence String[?]))
    (CollectionLiteral SequenceKind
      [CollectionItem (StringLiteral ''abc''),
       CollectionItem (StringLiteral ''zxc'')])
    (ClosureIteratorCall (Var STR ''x'') ArrowCall [STR ''it''] None
      (IntegerLiteral 1)) : \<tau>"
  by simp

text \<open>
\<^verbatim>\<open>Sequence{1..5, null}->max()\<close>\<close>
lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> OperationCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5),
     CollectionItem NullLiteral])
    ArrowCall CollectionMaxOp [] : \<tau>"
proof -
  have "\<not> operation_defined (Integer[?] :: classes1 type) STR ''max'' [Integer[?]]"
    by eval
  thus ?thesis by simp
qed

(*** Code *******************************************************************)

section \<open>Code\<close>

subsection \<open>Positive Cases\<close>

values "{(\<D>, \<tau>). attribute Employee STR ''name'' \<D> \<tau>}"
values "{(\<D>, end). association_end Employee None STR ''employees'' \<D> end}"
values "{(\<D>, end). association_end Employee (Some STR ''project_manager'') STR ''employees'' \<D> end}"
values "{op. operation Project[1] STR ''membersCount'' [] op}"
values "{op. operation Project[1] STR ''membersByName'' [String[1]] op}"
value "has_literal STR ''E1'' STR ''A''"

text \<open>
\<^verbatim>\<open>context Employee:
projects.members : Bag(Employee[1])\<close>\<close>
values
  "{\<tau>. \<Gamma>\<^sub>0(STR ''self'' \<mapsto>\<^sub>f Employee[1]) \<turnstile>
    AssociationEndCall (AssociationEndCall (Var STR ''self'')
        DotCall None STR ''projects'')
      DotCall None STR ''members'' : \<tau>}"

subsection \<open>Negative Cases\<close>

values "{(\<D>, \<tau>). attribute Employee STR ''name2'' \<D> \<tau>}"
value "has_literal STR ''E1'' STR ''C''"

text \<open>
\<^verbatim>\<open>Sequence{1..5, null}->max()\<close>\<close>
values
  "{\<tau>. \<Gamma>\<^sub>0 \<turnstile> OperationCall (CollectionLiteral SequenceKind
    [CollectionRange (IntegerLiteral 1) (IntegerLiteral 5),
      CollectionItem NullLiteral])
    ArrowCall CollectionMaxOp [] : \<tau>}"

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section \<open>A Generic Work-List Algorithm\<close>

theory Transitive_Closure_Impl
imports Main
begin

text \<open>
  Let @{term R} be some finite relation. We start to present a standard work-list algorithm to
  compute all elements that are reachable from some initial set by at most @{term n} @{term
  R}-steps. Then, we obtain algorithms for the (reflexive) transitive closure from a given starting
  set by exploiting the fact that for finite relations we have to iterate at most @{term "card R"}
  times. The presented algorithms are generic in the sense that the underlying data structure can
  freely be chosen, you just have to provide certain operations like union, membership, etc.
\<close>

subsection \<open>Bounded Reachability\<close>

text \<open>
  We provide an algorithm @{text relpow_impl} that computes all states that are reachable from an
  initial set of states @{term new} by at most @{term n} steps. The algorithm also stores a set of
  states that have already been visited @{term have}, and then show, do not have to be expanded a
  second time. The algorithm is parametric in the underlying data structure, it just requires
  operations for union and membership as well as a function to compute the successors of a list.
\<close>
fun
  relpow_impl ::
    "('a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> 'b"
where
  "relpow_impl succ un memb new have 0 = un new have" |
  "relpow_impl succ un memb new have (Suc m) =
    (if new = [] then have
    else
      let
        maybe = succ new;
        have' = un new have;
        new' = filter (\<lambda> n. \<not> memb n have') maybe
      in relpow_impl succ un memb new' have' m)"

text \<open>
  We need to know that the provided operations behave correctly.
\<close>

locale set_access =
  fixes un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b"
    and set_of :: "'b \<Rightarrow> 'a set"
    and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
    and empty :: 'b
  assumes un: "set_of (un as bs) = set as \<union> set_of bs"
    and memb: "memb a bs \<longleftrightarrow> (a \<in> set_of bs)"
    and empty: "set_of empty = {}"

locale set_access_succ = set_access un
  for un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b" +
  fixes succ :: "'a list \<Rightarrow> 'a list"
   and  rel :: "('a \<times> 'a) set"
  assumes succ: "set (succ as) = {b. \<exists> a \<in> set as. (a, b) \<in> rel}"
begin

abbreviation "relpow_i \<equiv> relpow_impl succ un memb"

text \<open>
  What follows is the main technical result of the @{const relpow_impl} algorithm: what it computes
  for arbitrary values of @{term new} and @{term have}.
\<close>

lemma relpow_impl_main:
  "set_of (relpow_i new have n) =
    {b | a b m. a \<in> set new \<and> m \<le> n \<and> (a, b) \<in> (rel \<inter> {(a, b). b \<notin> set_of have}) ^^ m} \<union>
    set_of have"
  (is "?l new have n = ?r new have n")
proof (induction n arbitrary: "have" new)
  case (Suc n hhave nnew)
  show ?case
  proof (cases "nnew = []")
    case True
    then show ?thesis by auto
  next
    case False
    let ?have = "set_of hhave"
    let ?new = "set nnew"
    obtain "have" new where hav: "have = ?have" and new: "new = ?new" by auto
    let ?reln = "\<lambda> m. (rel \<inter> {(a, b). b \<notin> new \<and> b \<notin> have}) ^^  m"
    let ?rel = "\<lambda> m. (rel \<inter> {(a, b). b \<notin> have}) ^^  m"
    have idl: "?l nnew hhave (Suc n) =
      {uu. \<exists>a. (\<exists>aa\<in> new. (aa,a) \<in> rel) \<and> a \<notin> new \<and> a \<notin> have \<and> (\<exists>m \<le> n. (a, uu) \<in> ?reln m)} \<union>
      (new \<union> have)"
      (is "_ = ?l1 \<union> (?l2 \<union> ?l3)")
      by (simp add: hav new False Let_def Suc, simp add: memb un succ)
    let ?l = "?l1 \<union> (?l2 \<union> ?l3)"
    have idr: "?r nnew hhave (Suc n) = {b. \<exists> a m. a \<in> new \<and> m \<le> Suc n \<and> (a, b) \<in> ?rel m} \<union> have"
      (is "_ = (?r1 \<union> ?r2)") by (simp add: hav new)
    let ?r = "?r1 \<union> ?r2"
    {
      fix b
      assume b: "b \<in> ?l"
      have "b \<in> ?r"
      proof (cases "b \<in> new \<or> b \<in> have")
        case True then show ?thesis
        proof
          assume "b \<in> have" then show ?thesis by auto
        next
          assume b: "b \<in> new"
          have "b \<in> ?r1"
            by (intro CollectI, rule exI, rule exI [of _ 0], intro conjI, rule b, auto)
          then show ?thesis by auto
        qed
      next
        case False
        with b have "b \<in> ?l1" by auto
        then obtain a2 a1 m where a2n: "a2 \<notin> new" and a2h: "a2 \<notin> have" and a1: "a1 \<in> new"
          and a1a2: "(a1,a2) \<in> rel" and m: "m \<le> n" and a2b: "(a2,b) \<in> ?reln m" by auto
        have "b \<in> ?r1"
          by (rule CollectI, rule exI, rule exI [of _ "Suc m"], intro conjI, rule a1, simp add: m, rule relpow_Suc_I2, rule, rule a1a2, simp add: a2h, insert a2b, induct m arbitrary: a2 b, auto)
        then show ?thesis by auto
      qed
    }
    moreover
    {
      fix b
      assume b: "b \<in> ?r"
      then have "b \<in> ?l"
      proof (cases "b \<in> have")
        case True then show ?thesis by auto
      next
        case False
        with b have "b \<in> ?r1" by auto
        then obtain a m where a: "a \<in> new" and m: "m \<le> Suc n" and ab: "(a, b) \<in> ?rel m" by auto
        have seq: "\<exists> a \<in> new. (a, b) \<in> ?rel m"
          using a  ab by auto
        obtain l where l: "l = (LEAST m. (\<exists> a \<in> new. (a, b) \<in> ?rel m))" by auto
        have least: "(\<exists> a \<in> new. (a, b) \<in> ?rel l)"
          by (unfold l, rule LeastI, rule seq)
        have lm: "l \<le> m" unfolding l
          by (rule Least_le, rule seq)
        with m have ln: "l \<le> Suc n" by auto
        from least obtain a where a: "a \<in> new"
          and ab: "(a, b) \<in> ?rel l" by auto
        from ab [unfolded relpow_fun_conv]
        obtain f where fa: "f 0 = a" and fb: "b = f l"
          and steps: "\<And> i. i < l \<Longrightarrow> (f i, f (Suc i)) \<in> ?rel 1" by auto
        {
          fix i
          assume i: "i < l"
          have main: "f (Suc i) \<notin> new"
          proof
            assume new: "f (Suc i) \<in> new"
            let ?f = "\<lambda> j. f (Suc i + j)"
            have seq: "(f (Suc i), b) \<in> ?rel (l - Suc i)"
              unfolding relpow_fun_conv
            proof (rule exI[of _ ?f], intro conjI allI impI)
              from i show "f (Suc i + (l - Suc i)) = b"
                unfolding fb by auto
            next
              fix j
              assume "j < l - Suc i"
              then have small: "Suc i + j < l" by auto
              show "(?f j, ?f (Suc j)) \<in> rel \<inter> {(a, b). b \<notin> have}" using steps [OF small] by auto
            qed simp
            from i have small: "l - Suc i < l" by auto
            from seq new have "\<exists> a \<in> new. (a, b) \<in> ?rel (l - Suc i)"  by auto
            with not_less_Least [OF small [unfolded l]]
            show False unfolding l by auto
          qed
          then have "(f i, f (Suc i)) \<in> ?reln 1"
            using steps [OF i] by auto
        } note steps = this
        have ab: "(a, b) \<in> ?reln l" unfolding relpow_fun_conv
          by (intro exI conjI, insert fa fb steps, auto)
        have "b \<in> ?l1 \<union> ?l2"
        proof (cases l)
          case 0
          with ab a show ?thesis by auto
        next
          case (Suc ll)
          from relpow_Suc_D2 [OF ab [unfolded Suc]] a ln Suc
          show ?thesis by auto
        qed
        then show ?thesis by auto
      qed
    }
    ultimately show ?thesis
      unfolding idl idr by blast
  qed
qed (simp add: un)

text \<open>
  From the previous lemma we can directly derive that @{const relpow_impl} works correctly if @{term
  have} is initially set to @{text empty}
\<close>
lemma relpow_impl:
  "set_of (relpow_i new empty n) = {b | a b m. a \<in> set new \<and> m \<le> n \<and> (a, b) \<in> rel ^^ m}"
proof -
  have id: "rel \<inter> {(a ,b). True} = rel" by auto
  show ?thesis unfolding relpow_impl_main empty by (simp add: id)
qed

end

subsection \<open>Reflexive Transitive Closure and Transitive closure\<close>

text \<open>
  Using @{const relpow_impl} it is now easy to obtain algorithms for the reflexive transitive
  closure and the transitive closure by restricting the number of steps to the size of the finite
  relation. Note that @{const relpow_impl} will abort the computation as soon as no new states are
  detected. Hence, there is no penalty in using this large bound.
\<close>

definition
  rtrancl_impl ::
    "(('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'b"
where
  "rtrancl_impl gen_succ un memb emp rel =
    (let
      succ = gen_succ rel;
      n = length rel
    in (\<lambda> as. relpow_impl succ un memb as emp n))"

definition
  trancl_impl ::
    "(('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'b"
where
  "trancl_impl gen_succ un memb emp rel =
    (let
      succ = gen_succ rel;
      n = length rel
    in (\<lambda> as. relpow_impl succ un memb (succ as) emp n))"

text {*
  The soundness of both @{const rtrancl_impl} and @{const trancl_impl} follows from the soundness of
  @{const relpow_impl} and the fact that for finite relations, we can limit the number of steps to
  explore all elements in the reflexive transitive closure.
*}

lemma rtrancl_finite_relpow:
  "(a, b) \<in> (set rel)\<^sup>* \<longleftrightarrow> (\<exists> n \<le> length rel. (a, b) \<in> set rel ^^ n)" (is "?l = ?r")
proof
  assume ?r
  then show ?l
    unfolding rtrancl_power by auto
next
  assume ?l
  from this [unfolded rtrancl_power]
    obtain n where ab: "(a,b) \<in> set rel ^^ n" ..
  obtain l where l: "l = (LEAST n. (a,b) \<in> set rel ^^ n)" by auto
  have ab: "(a, b) \<in> set rel ^^ l" unfolding l
    by (intro LeastI, rule ab)
  from this [unfolded relpow_fun_conv]
  obtain f where a: "f 0 = a" and b: "f l = b"
    and steps: "\<And> i. i < l \<Longrightarrow> (f i, f (Suc i)) \<in> set rel" by auto
  let ?hits = "map (\<lambda> i. f (Suc i)) [0 ..< l]"
  from steps have subset: "set ?hits \<subseteq> snd ` set rel" by force
  have "l \<le> length rel"
  proof (cases "distinct ?hits")
    case True
    have "l = length ?hits" by simp
    also have "... = card (set ?hits)" unfolding distinct_card [OF True] ..
    also have "... \<le> card (snd ` set rel)" by (rule card_mono [OF _ subset], auto)
    also have "... = card (set (map snd rel))" by auto
    also have "... \<le> length (map snd rel)" by (rule card_length)
    finally  show ?thesis by simp
  next
    case False
    from this [unfolded distinct_conv_nth]
    obtain i j where i: "i < l" and j: "j < l" and ij: "i \<noteq> j" and fij: "f (Suc i) = f (Suc j)" by auto
    let ?i = "min i j"
    let ?j = "max i j"
    have i: "?i < l" and j: "?j < l" and fij: "f (Suc ?i) = f (Suc ?j)"
      and ij: "?i < ?j"
      using i j ij fij unfolding min_def max_def by (cases "i \<le> j", auto)
    from i j fij ij obtain i j where i: "i < l" and j: "j < l" and ij: "i < j" and fij: "f (Suc i) = f (Suc j)" by blast
    let ?g = "\<lambda> n. if n \<le> i then f n else f (n + (j - i))"
    let ?l = "l - (j - i)"
    have abl: "(a,b) \<in> set rel ^^ ?l"
      unfolding relpow_fun_conv
    proof (rule exI [of _ ?g], intro conjI impI allI)
      show "?g ?l = b" unfolding b [symmetric] using j ij by auto
    next
      fix k
      assume k: "k < ?l"
      show "(?g k, ?g (Suc k)) \<in> set rel"
      proof (cases "k < i")
        case True
        with i have "k < l" by auto
        from steps [OF this] show ?thesis using True by simp
      next
        case False
        then have ik: "i \<le> k" by auto
        show ?thesis
        proof (cases "k = i")
          case True
          then show ?thesis using ij fij steps [OF i] by simp
        next
          case False
          with ik have ik: "i < k" by auto
          then have small: "k + (j - i) < l" using k by auto
          show ?thesis using steps[OF small] ik by auto
        qed
      qed
    qed (simp add: a)
    from ij i have ll: "?l < l" by auto
    have "l \<le> ?l" unfolding l
      by (rule Least_le, rule abl [unfolded l])
    with ll have False by simp
    then show ?thesis by simp
  qed
  with ab show ?r by auto
qed

locale set_access_gen = set_access un
  for un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b" +
  fixes gen_succ :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  assumes gen_succ: "set (gen_succ rel as) = {b. \<exists> a \<in> set as. (a, b) \<in> set rel}"
begin

abbreviation "rtrancl_i \<equiv> rtrancl_impl gen_succ un memb empty"
abbreviation "trancl_i \<equiv> trancl_impl gen_succ un memb empty"

lemma rtrancl_impl:
  "set_of (rtrancl_i rel as) = {b. (\<exists> a \<in> set as. (a, b) \<in> (set rel)\<^sup>*)}"
proof -
  interpret set_access_succ set_of memb empty un "gen_succ rel" "set rel"
    by (unfold_locales, insert gen_succ, auto)
  show ?thesis unfolding rtrancl_impl_def Let_def relpow_impl
    by (auto simp: rtrancl_finite_relpow)
qed

lemma trancl_impl:
  "set_of (trancl_i rel as) = {b. (\<exists> a \<in> set as. (a, b) \<in> (set rel)\<^sup>+)}"
proof -
  interpret set_access_succ set_of memb empty un "gen_succ rel" "set rel"
    by (unfold_locales, insert gen_succ, auto)
  show ?thesis
    unfolding trancl_impl_def Let_def relpow_impl trancl_unfold_left relcomp_unfold rtrancl_finite_relpow succ by auto
qed

end

end