(*  Title:      CCL/ex/List.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Programs defined over lists *}

theory List
imports Nat
begin

definition map :: "[i\<Rightarrow>i,i]\<Rightarrow>i"
  where "map(f,l) == lrec(l, [], \<lambda>x xs g. f(x)$g)"

definition comp :: "[i\<Rightarrow>i,i\<Rightarrow>i]\<Rightarrow>i\<Rightarrow>i"  (infixr "\<circ>" 55)
  where "f \<circ> g == (\<lambda>x. f(g(x)))"

definition append :: "[i,i]\<Rightarrow>i"  (infixr "@" 55)
  where "l @ m == lrec(l, m, \<lambda>x xs g. x$g)"

axiomatization member :: "[i,i]\<Rightarrow>i"  (infixr "mem" 55)  (* FIXME dangling eq *)
  where member_ax: "a mem l == lrec(l, false, \<lambda>h t g. if eq(a,h) then true else g)"

definition filter :: "[i,i]\<Rightarrow>i"
  where "filter(f,l) == lrec(l, [], \<lambda>x xs g. if f`x then x$g else g)"

definition flat :: "i\<Rightarrow>i"
  where "flat(l) == lrec(l, [], \<lambda>h t g. h @ g)"

definition partition :: "[i,i]\<Rightarrow>i" where
  "partition(f,l) == letrec part l a b be lcase(l, <a,b>, \<lambda>x xs.
                            if f`x then part(xs,x$a,b) else part(xs,a,x$b))
                    in part(l,[],[])"

definition insert :: "[i,i,i]\<Rightarrow>i"
  where "insert(f,a,l) == lrec(l, a$[], \<lambda>h t g. if f`a`h then a$h$t else h$g)"

definition isort :: "i\<Rightarrow>i"
  where "isort(f) == lam l. lrec(l, [], \<lambda>h t g. insert(f,h,g))"

definition qsort :: "i\<Rightarrow>i" where
  "qsort(f) == lam l. letrec qsortx l be lcase(l, [], \<lambda>h t.
                                   let p be partition(f`h,t)
                                   in split(p, \<lambda>x y. qsortx(x) @ h$qsortx(y)))
                          in qsortx(l)"

lemmas list_defs = map_def comp_def append_def filter_def flat_def
  insert_def isort_def partition_def qsort_def

lemma listBs [simp]:
  "\<And>f g. (f \<circ> g) = (\<lambda>a. f(g(a)))"
  "\<And>a f g. (f \<circ> g)(a) = f(g(a))"
  "\<And>f. map(f,[]) = []"
  "\<And>f x xs. map(f,x$xs) = f(x)$map(f,xs)"
  "\<And>m. [] @ m = m"
  "\<And>x xs m. x$xs @ m = x$(xs @ m)"
  "\<And>f. filter(f,[]) = []"
  "\<And>f x xs. filter(f,x$xs) = if f`x then x$filter(f,xs) else filter(f,xs)"
  "flat([]) = []"
  "\<And>x xs. flat(x$xs) = x @ flat(xs)"
  "\<And>a f. insert(f,a,[]) = a$[]"
  "\<And>a f xs. insert(f,a,x$xs) = if f`a`x then a$x$xs else x$insert(f,a,xs)"
  by (simp_all add: list_defs)

lemma nmapBnil: "n:Nat \<Longrightarrow> map(f) ^ n ` [] = []"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma nmapBcons: "n:Nat \<Longrightarrow> map(f)^n`(x$xs) = (f^n`x)$(map(f)^n`xs)"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma mapT: "\<lbrakk>\<And>x. x:A \<Longrightarrow> f(x):B; l : List(A)\<rbrakk> \<Longrightarrow> map(f,l) : List(B)"
  apply (unfold map_def)
  apply typechk
  apply blast
  done

lemma appendT: "\<lbrakk>l : List(A); m : List(A)\<rbrakk> \<Longrightarrow> l @ m : List(A)"
  apply (unfold append_def)
  apply typechk
  done

lemma appendTS:
  "\<lbrakk>l : {l:List(A). m : {m:List(A).P(l @ m)}}\<rbrakk> \<Longrightarrow> l @ m : {x:List(A). P(x)}"
  by (blast intro!: appendT)

lemma filterT: "\<lbrakk>f:A->Bool; l : List(A)\<rbrakk> \<Longrightarrow> filter(f,l) : List(A)"
  apply (unfold filter_def)
  apply typechk
  done

lemma flatT: "l : List(List(A)) \<Longrightarrow> flat(l) : List(A)"
  apply (unfold flat_def)
  apply (typechk appendT)
  done

lemma insertT: "\<lbrakk>f : A->A->Bool; a:A; l : List(A)\<rbrakk> \<Longrightarrow> insert(f,a,l) : List(A)"
  apply (unfold insert_def)
  apply typechk
  done

lemma insertTS:
  "\<lbrakk>f : {f:A->A->Bool. a : {a:A. l : {l:List(A).P(insert(f,a,l))}}} \<rbrakk> \<Longrightarrow>
   insert(f,a,l)  : {x:List(A). P(x)}"
  by (blast intro!: insertT)

lemma partitionT: "\<lbrakk>f:A->Bool; l : List(A)\<rbrakk> \<Longrightarrow> partition(f,l) : List(A)*List(A)"
  apply (unfold partition_def)
  apply typechk
  apply clean_ccs
  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
    apply assumption+
  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
   apply assumption+
  done

end


(*
    Author:   Salomon Sickert
    License:  BSD
*)

section \<open>A Normal Form for Linear Temporal Logic\<close>

theory Normal_Form imports
  LTL_Master_Theorem.Master_Theorem
begin

subsection \<open>LTL Equivalences\<close>

text \<open>Several valid laws of LTL relating strong and weak operators that are useful later.\<close>

lemma ltln_strong_weak_2:
  "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> and\<^sub>n F\<^sub>n \<psi>) W\<^sub>n \<psi>" (is "?thesis1")
  "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> R\<^sub>n (\<psi> and\<^sub>n F\<^sub>n \<phi>)" (is "?thesis2")
proof -
  have "\<exists>j. suffix (i + j) w \<Turnstile>\<^sub>n \<psi>"
    if "suffix j w \<Turnstile>\<^sub>n \<psi>" and "\<forall>j\<le>i. \<not> suffix j w \<Turnstile>\<^sub>n \<psi>" for i j
  proof
    from that have "j > i"
      by (cases "j > i") auto
    thus "suffix (i + (j - i)) w \<Turnstile>\<^sub>n \<psi>"
      using that by auto
  qed
  thus ?thesis1
    unfolding ltln_strong_weak by auto
next
  have "\<exists>j. suffix (i + j) w \<Turnstile>\<^sub>n \<phi>"
    if "suffix j w \<Turnstile>\<^sub>n \<phi>" and "\<forall>j<i. \<not> suffix j w \<Turnstile>\<^sub>n \<phi>" for i j
  proof
    from that have "j \<ge> i"
      by (cases "j \<ge> i") auto
    thus "suffix (i + (j - i)) w \<Turnstile>\<^sub>n \<phi>"
      using that by auto
  qed
  thus ?thesis2
    unfolding ltln_strong_weak by auto
qed

lemma ltln_weak_strong_2:
  "w \<Turnstile>\<^sub>n \<phi> W\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> U\<^sub>n (\<psi> or\<^sub>n G\<^sub>n \<phi>)" (is "?thesis1")
  "w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> or\<^sub>n G\<^sub>n \<psi>) M\<^sub>n \<psi>" (is "?thesis2")
proof -
  have "suffix j w \<Turnstile>\<^sub>n \<phi>"
    if "\<And>j. j < i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<phi>" and "\<And>j. suffix (i + j) w \<Turnstile>\<^sub>n \<phi>" for i j
    using that(1)[of j] that(2)[of "j - i"] by (cases "j < i") simp_all
  thus ?thesis1
    unfolding ltln_weak_strong unfolding semantics_ltln.simps suffix_suffix by blast
next
  have "suffix j w \<Turnstile>\<^sub>n \<psi>"
    if "\<And>j. j \<le> i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<psi>" and "\<And>j. suffix (i + j) w \<Turnstile>\<^sub>n \<psi>" for i j
    using that(1)[of j] that(2)[of "j - i"] by (cases "j \<le> i") simp_all
  thus ?thesis2
    unfolding ltln_weak_strong unfolding semantics_ltln.simps suffix_suffix by blast
qed

subsection \<open>$\evalnu{\psi}{M}$, $\evalmu{\psi}{N}$, $\flatten{\psi}{M}$, and $\flattentwo{\psi}{N}$\<close>

text \<open>The following four functions use "promise sets", named $M$ or $N$, to rewrite arbitrary
  formulas into formulas from the class $\Sigma_1$-, $\Sigma_2$-, $\Pi_1$-, and $\Pi_2$,
  respectively. In general the obtained formulas are not  equivalent, but under some conditions
  (as outlined below) they are.\<close>

no_notation FG_advice ("_[_]\<^sub>\<mu>" [90,60] 89)
no_notation GF_advice ("_[_]\<^sub>\<nu>" [90,60] 89)

notation FG_advice ("_[_]\<^sub>\<Sigma>\<^sub>1" [90,60] 89)
notation GF_advice ("_[_]\<^sub>\<Pi>\<^sub>1" [90,60] 89)

fun flatten_sigma_2:: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln" ("_[_]\<^sub>\<Sigma>\<^sub>2")
where
  "(\<phi> U\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = (\<phi>[M]\<^sub>\<Sigma>\<^sub>2) U\<^sub>n (\<psi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "(\<phi> W\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = (\<phi>[M]\<^sub>\<Sigma>\<^sub>2) U\<^sub>n ((\<psi>[M]\<^sub>\<Sigma>\<^sub>2) or\<^sub>n (G\<^sub>n \<phi>[M]\<^sub>\<Pi>\<^sub>1))"
| "(\<phi> M\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = (\<phi>[M]\<^sub>\<Sigma>\<^sub>2) M\<^sub>n (\<psi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "(\<phi> R\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = ((\<phi>[M]\<^sub>\<Sigma>\<^sub>2) or\<^sub>n (G\<^sub>n \<psi>[M]\<^sub>\<Pi>\<^sub>1)) M\<^sub>n (\<psi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "(\<phi> and\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = (\<phi>[M]\<^sub>\<Sigma>\<^sub>2) and\<^sub>n (\<psi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "(\<phi> or\<^sub>n \<psi>)[M]\<^sub>\<Sigma>\<^sub>2 = (\<phi>[M]\<^sub>\<Sigma>\<^sub>2) or\<^sub>n (\<psi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "(X\<^sub>n \<phi>)[M]\<^sub>\<Sigma>\<^sub>2 = X\<^sub>n (\<phi>[M]\<^sub>\<Sigma>\<^sub>2)"
| "\<phi>[M]\<^sub>\<Sigma>\<^sub>2 = \<phi>"

fun flatten_pi_2 :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln" ("_[_]\<^sub>\<Pi>\<^sub>2")
where
  "(\<phi> W\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2) W\<^sub>n (\<psi>[N]\<^sub>\<Pi>\<^sub>2)"
| "(\<phi> U\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2 and\<^sub>n (F\<^sub>n \<psi>[N]\<^sub>\<Sigma>\<^sub>1)) W\<^sub>n (\<psi>[N]\<^sub>\<Pi>\<^sub>2)"
| "(\<phi> R\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2) R\<^sub>n (\<psi>[N]\<^sub>\<Pi>\<^sub>2)"
| "(\<phi> M\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2) R\<^sub>n ((\<psi>[N]\<^sub>\<Pi>\<^sub>2) and\<^sub>n (F\<^sub>n \<phi>[N]\<^sub>\<Sigma>\<^sub>1))"
| "(\<phi> and\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2) and\<^sub>n (\<psi>[N]\<^sub>\<Pi>\<^sub>2)"
| "(\<phi> or\<^sub>n \<psi>)[N]\<^sub>\<Pi>\<^sub>2 = (\<phi>[N]\<^sub>\<Pi>\<^sub>2) or\<^sub>n (\<psi>[N]\<^sub>\<Pi>\<^sub>2)"
| "(X\<^sub>n \<phi>)[N]\<^sub>\<Pi>\<^sub>2 = X\<^sub>n (\<phi>[N]\<^sub>\<Pi>\<^sub>2)"
| "\<phi>[N]\<^sub>\<Pi>\<^sub>2 = \<phi>"

lemma GF_advice_restriction:
  "\<phi>[\<G>\<F> (\<phi> W\<^sub>n \<psi>) w]\<^sub>\<Pi>\<^sub>1 = \<phi>[\<G>\<F> \<phi> w]\<^sub>\<Pi>\<^sub>1"
  "\<psi>[\<G>\<F> (\<phi> R\<^sub>n \<psi>) w]\<^sub>\<Pi>\<^sub>1 = \<psi>[\<G>\<F> \<psi> w]\<^sub>\<Pi>\<^sub>1"
  by (metis (no_types, lifting) \<G>\<F>_semantics' inf_commute inf_left_commute inf_sup_absorb subformulas\<^sub>\<mu>.simps(6) GF_advice_inter_subformulas)
     (metis (no_types, lifting) GF_advice_inter \<G>\<F>.simps(5) \<G>\<F>_semantics' \<G>\<F>_subformulas\<^sub>\<mu> inf.commute sup.boundedE)

lemma FG_advice_restriction:
  "\<psi>[\<F>\<G> (\<phi> U\<^sub>n \<psi>) w]\<^sub>\<Sigma>\<^sub>1 = \<psi>[\<F>\<G> \<psi> w]\<^sub>\<Sigma>\<^sub>1"
  "\<phi>[\<F>\<G> (\<phi> M\<^sub>n \<psi>) w]\<^sub>\<Sigma>\<^sub>1 = \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Sigma>\<^sub>1"
  by (metis (no_types, lifting) FG_advice_inter \<F>\<G>.simps(4) \<F>\<G>_semantics' \<F>\<G>_subformulas\<^sub>\<nu> inf.commute sup.boundedE)
     (metis (no_types, lifting) FG_advice_inter \<F>\<G>.simps(7) \<F>\<G>_semantics' \<F>\<G>_subformulas\<^sub>\<nu> inf.right_idem inf_commute sup.cobounded1)

lemma flatten_sigma_2_intersection:
  "M \<inter> subformulas\<^sub>\<mu> \<phi> \<subseteq> S \<Longrightarrow> \<phi>[M \<inter> S]\<^sub>\<Sigma>\<^sub>2 = \<phi>[M]\<^sub>\<Sigma>\<^sub>2"
  by (induction \<phi>) (simp; blast intro: GF_advice_inter)+

lemma flatten_sigma_2_intersection_eq:
  "M \<inter> subformulas\<^sub>\<mu> \<phi> = M' \<Longrightarrow> \<phi>[M']\<^sub>\<Sigma>\<^sub>2 = \<phi>[M]\<^sub>\<Sigma>\<^sub>2"
  using flatten_sigma_2_intersection by auto

lemma flatten_sigma_2_monotone:
  "w \<Turnstile>\<^sub>n \<phi>[M]\<^sub>\<Sigma>\<^sub>2 \<Longrightarrow> M \<subseteq> M' \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[M']\<^sub>\<Sigma>\<^sub>2"
  by (induction \<phi> arbitrary: w)
     (simp; blast dest: GF_advice_monotone)+

lemma flatten_pi_2_intersection_eq:
  "N \<inter> subformulas\<^sub>\<nu> \<phi> = N' \<Longrightarrow> \<phi>[N']\<^sub>\<Pi>\<^sub>2 = \<phi>[N]\<^sub>\<Pi>\<^sub>2"
  using flatten_pi_2_intersection by auto

lemma flatten_pi_2_monotone:
  "w \<Turnstile>\<^sub>n \<phi>[N]\<^sub>\<Pi>\<^sub>2 \<Longrightarrow> N \<subseteq> N' \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[N']\<^sub>\<Pi>\<^sub>2"
  by (induction \<phi> arbitrary: w)
     (simp; blast dest: FG_advice_monotone)+

lemma ltln_weak_strong_stable_words_1:
  "w \<Turnstile>\<^sub>n (\<phi> W\<^sub>n \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> U\<^sub>n (\<psi> or\<^sub>n (G\<^sub>n \<phi>[\<G>\<F> \<phi> w]\<^sub>\<Pi>\<^sub>1))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs

  moreover

  {
    assume assm: "w \<Turnstile>\<^sub>n G\<^sub>n \<phi>"
    moreover
    obtain i where "\<And>j. \<F> \<phi> (suffix i w) \<subseteq> \<G>\<F> \<phi> w"
      by (metis MOST_nat_le \<G>\<F>_suffix \<mu>_stable_def order_refl suffix_\<mu>_stable)
    hence "\<And>j. \<F> \<phi> (suffix i (suffix j w)) \<subseteq> \<G>\<F> \<phi> w"
      by (metis \<F>_suffix \<G>\<F>_\<F>_subset \<G>\<F>_suffix semiring_normalization_rules(24) subset_Un_eq suffix_suffix sup.orderE)
    ultimately
    have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<phi>[\<G>\<F> \<phi> w]\<^sub>\<Pi>\<^sub>1)"
      using GF_advice_a1[OF \<open>\<And>j. \<F> \<phi> (suffix i (suffix j w)) \<subseteq> \<G>\<F> \<phi> w\<close>]
      by (simp add: add.commute)
    hence "?rhs"
      using assm by auto
  }

  moreover

  have "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<Longrightarrow> ?rhs"
    by auto

  ultimately

  show ?rhs
    using ltln_weak_to_strong(1) by blast
next
  assume ?rhs
  thus ?lhs
    unfolding ltln_weak_strong_2 unfolding semantics_ltln.simps
    by (metis \<G>\<F>_suffix order_refl GF_advice_a2)
qed

lemma ltln_weak_strong_stable_words_2:
  "w \<Turnstile>\<^sub>n (\<phi> R\<^sub>n \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> or\<^sub>n (G\<^sub>n \<psi>[\<G>\<F> \<psi> w]\<^sub>\<Pi>\<^sub>1)) M\<^sub>n \<psi>" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs

  moreover

  {
    assume assm: "w \<Turnstile>\<^sub>n G\<^sub>n \<psi>"
    moreover
    obtain i where "\<And>j. \<F> \<psi> (suffix i w) \<subseteq> \<G>\<F> \<psi> w"
      by (metis MOST_nat_le \<G>\<F>_suffix \<mu>_stable_def order_refl suffix_\<mu>_stable)
    hence "\<And>j. \<F> \<psi> (suffix i (suffix j w)) \<subseteq> \<G>\<F> \<psi> w"
      by (metis \<F>_suffix \<G>\<F>_\<F>_subset \<G>\<F>_suffix semiring_normalization_rules(24) subset_Un_eq suffix_suffix sup.orderE)
    ultimately
    have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>[\<G>\<F> \<psi> w]\<^sub>\<Pi>\<^sub>1)"
      using GF_advice_a1[OF \<open>\<And>j. \<F> \<psi> (suffix i (suffix j w)) \<subseteq> \<G>\<F> \<psi> w\<close>]
      by (simp add: add.commute)
    hence "?rhs"
      using assm by auto
  }

  moreover

  have "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<Longrightarrow> ?rhs"
    by auto

  ultimately

  show ?rhs
    using ltln_weak_to_strong by blast
next
  assume ?rhs
  thus ?lhs
    unfolding ltln_weak_strong_2 unfolding semantics_ltln.simps
    by (metis GF_advice_a2 \<G>\<F>_suffix order_refl)
qed

lemma ltln_weak_strong_stable_words:
  "w \<Turnstile>\<^sub>n (\<phi> W\<^sub>n \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> U\<^sub>n (\<psi> or\<^sub>n (G\<^sub>n \<phi>[\<G>\<F> (\<phi> W\<^sub>n \<psi>) w]\<^sub>\<Pi>\<^sub>1))"
  "w \<Turnstile>\<^sub>n (\<phi> R\<^sub>n \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> or\<^sub>n (G\<^sub>n \<psi>[\<G>\<F> (\<phi> R\<^sub>n \<psi>) w]\<^sub>\<Pi>\<^sub>1)) M\<^sub>n \<psi>"
  unfolding ltln_weak_strong_stable_words_1 ltln_weak_strong_stable_words_2 GF_advice_restriction by simp+

lemma flatten_sigma_2_IH_lifting:
  assumes "\<psi> \<in> subfrmlsn \<phi>"
  assumes "suffix i w \<Turnstile>\<^sub>n \<psi>[\<G>\<F> \<psi> (suffix i w)]\<^sub>\<Sigma>\<^sub>2 = suffix i w \<Turnstile>\<^sub>n \<psi>"
  shows "suffix i w \<Turnstile>\<^sub>n \<psi>[\<G>\<F> \<phi> w]\<^sub>\<Sigma>\<^sub>2 = suffix i w \<Turnstile>\<^sub>n \<psi>"
  by (metis (no_types, lifting) inf.absorb_iff2 inf_assoc inf_commute assms(2) \<G>\<F>_suffix flatten_sigma_2_intersection_eq[of "\<G>\<F> \<phi> w" \<psi> "\<G>\<F> \<psi> w"] \<G>\<F>_semantics' subformulas\<^sub>\<mu>_subset[OF assms(1)])

lemma flatten_sigma_2_correct:
  "w \<Turnstile>\<^sub>n \<phi>[\<G>\<F> \<phi> w]\<^sub>\<Sigma>\<^sub>2 \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 and\<^sub>n \<phi>2" 0] by simp
next
  case (Or_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 or\<^sub>n \<phi>2" 0] by simp
next
  case (Next_ltln \<phi>)
  then show ?case
    using flatten_sigma_2_IH_lifting[of _ "X\<^sub>n \<phi>" 1] by fastforce
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 U\<^sub>n \<phi>2"] by fastforce
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding ltln_weak_strong_stable_words
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 R\<^sub>n \<phi>2"] by fastforce
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding ltln_weak_strong_stable_words
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 W\<^sub>n \<phi>2"] by fastforce
next
case (StrongRelease_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_sigma_2_IH_lifting[of _ "\<phi>1 M\<^sub>n \<phi>2"] by fastforce
qed auto

lemma ltln_strong_weak_stable_words_1:
  "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> and\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> \<psi> w]\<^sub>\<Sigma>\<^sub>1)) W\<^sub>n \<psi>" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs

  moreover

  obtain i where "\<nu>_stable \<psi> (suffix i w)"
    by (metis MOST_nat less_Suc_eq suffix_\<nu>_stable)
  hence "\<forall>\<psi> \<in> \<F>\<G> \<psi> w. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>"
    using \<F>\<G>_suffix \<G>_elim \<nu>_stable_def by blast

  {
    assume assm: "w \<Turnstile>\<^sub>n G\<^sub>n (\<phi> and\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> \<psi> w]\<^sub>\<Sigma>\<^sub>1))"
    hence "suffix i w \<Turnstile>\<^sub>n (F\<^sub>n \<psi>)[\<F>\<G> \<psi> w]\<^sub>\<Sigma>\<^sub>1"
      by simp
    hence "suffix i w \<Turnstile>\<^sub>n F\<^sub>n \<psi>"
      by (blast dest: FG_advice_b2_helper[OF \<open>\<forall>\<psi> \<in> \<F>\<G> \<psi> w. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<close>])
    hence "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi>"
      using assm by auto
  }

  ultimately

  show ?lhs
    by (meson ltln_weak_to_strong(1) semantics_ltln.simps(5) until_and_left_distrib)
next
  assume ?lhs

  moreover

  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<psi> w]\<^sub>\<Sigma>\<^sub>1"
    using \<F>\<G>_suffix by (blast intro: FG_advice_b1)

  ultimately

  show "?rhs"
    unfolding ltln_strong_weak_2 by fastforce
qed

lemma ltln_strong_weak_stable_words_2:
  "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> R\<^sub>n (\<psi> and\<^sub>n (F\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Sigma>\<^sub>1))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs

  moreover

  obtain i where "\<nu>_stable \<phi> (suffix i w)"
    by (metis MOST_nat less_Suc_eq suffix_\<nu>_stable)
  hence "\<forall>\<psi> \<in> \<F>\<G> \<phi> w. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>"
    using \<F>\<G>_suffix \<G>_elim \<nu>_stable_def by blast

  {
    assume assm: "w \<Turnstile>\<^sub>n G\<^sub>n (\<psi> and\<^sub>n (F\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Sigma>\<^sub>1))"
    hence "suffix i w \<Turnstile>\<^sub>n (F\<^sub>n \<phi>)[\<F>\<G> \<phi> w]\<^sub>\<Sigma>\<^sub>1"
      by simp
    hence "suffix i w \<Turnstile>\<^sub>n F\<^sub>n \<phi>"
      by (blast dest: FG_advice_b2_helper[OF \<open>\<forall>\<psi> \<in> \<F>\<G> \<phi> w. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<close>])
    hence "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi>"
      using assm by auto
  }

  ultimately

  show ?lhs
    using ltln_weak_to_strong(3) semantics_ltln.simps(5) strong_release_and_right_distrib by blast
next
  assume ?lhs

  moreover

  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Sigma>\<^sub>1"
    using \<F>\<G>_suffix by (blast intro: FG_advice_b1)

  ultimately

  show "?rhs"
    unfolding ltln_strong_weak_2 by fastforce
qed

lemma ltln_strong_weak_stable_words:
  "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n (\<phi> and\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> (\<phi> U\<^sub>n \<psi>) w]\<^sub>\<Sigma>\<^sub>1)) W\<^sub>n \<psi>"
  "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> R\<^sub>n (\<psi> and\<^sub>n (F\<^sub>n \<phi>[\<F>\<G> (\<phi> M\<^sub>n \<psi>) w]\<^sub>\<Sigma>\<^sub>1))"
  unfolding ltln_strong_weak_stable_words_1 ltln_strong_weak_stable_words_2 FG_advice_restriction by simp+

lemma flatten_pi_2_IH_lifting:
  assumes "\<psi> \<in> subfrmlsn \<phi>"
  assumes "suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<psi> (suffix i w)]\<^sub>\<Pi>\<^sub>2 = suffix i w \<Turnstile>\<^sub>n \<psi>"
  shows "suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<Pi>\<^sub>2 = suffix i w \<Turnstile>\<^sub>n \<psi>"
  by (metis (no_types, lifting) inf.absorb_iff2 inf_assoc inf_commute assms(2) \<F>\<G>_suffix flatten_pi_2_intersection_eq[of "\<F>\<G> \<phi> w" \<psi> "\<F>\<G> \<psi> w"] \<F>\<G>_semantics' subformulas\<^sub>\<nu>_subset[OF assms(1)])

lemma flatten_pi_2_correct:
  "w \<Turnstile>\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Pi>\<^sub>2 \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 and\<^sub>n \<phi>2" 0] by simp
next
  case (Or_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 or\<^sub>n \<phi>2" 0] by simp
next
  case (Next_ltln \<phi>)
  then show ?case
    using flatten_pi_2_IH_lifting[of _ "X\<^sub>n \<phi>" 1] by fastforce
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding ltln_strong_weak_stable_words
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 U\<^sub>n \<phi>2"] by fastforce
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 R\<^sub>n \<phi>2"] by fastforce
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 W\<^sub>n \<phi>2"] by fastforce
next
case (StrongRelease_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding ltln_strong_weak_stable_words
    using flatten_pi_2_IH_lifting[of _ "\<phi>1 M\<^sub>n \<phi>2"] by fastforce
qed auto

subsection \<open>Main Theorem\<close>

text \<open>Using the four previously defined functions we obtain our normal form.\<close>

theorem normal_form_with_flatten_sigma_2:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>M \<subseteq> subformulas\<^sub>\<mu> \<phi>. \<exists>N \<subseteq> subformulas\<^sub>\<nu> \<phi>.
      w \<Turnstile>\<^sub>n \<phi>[M]\<^sub>\<Sigma>\<^sub>2 \<and> (\<forall>\<psi> \<in> M. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[N]\<^sub>\<Sigma>\<^sub>1)) \<and> (\<forall>\<psi> \<in> N. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[M]\<^sub>\<Pi>\<^sub>1)))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have "w \<Turnstile>\<^sub>n \<phi>[\<G>\<F> \<phi> w]\<^sub>\<Sigma>\<^sub>2"
    using flatten_sigma_2_correct by blast
  then show ?rhs
    using \<G>\<F>_subformulas\<^sub>\<mu> \<F>\<G>_subformulas\<^sub>\<nu> \<G>\<F>_implies_GF \<F>\<G>_implies_FG by metis
next
  assume ?rhs
  then obtain M N where "w \<Turnstile>\<^sub>n \<phi>[M]\<^sub>\<Sigma>\<^sub>2" and "M \<subseteq> \<G>\<F> \<phi> w" and "N \<subseteq> \<F>\<G> \<phi> w"
    using X_\<G>\<F>_Y_\<F>\<G> by blast
  then have "w \<Turnstile>\<^sub>n \<phi>[\<G>\<F> \<phi> w]\<^sub>\<Sigma>\<^sub>2"
    using flatten_sigma_2_monotone by blast
  then show ?lhs
    using flatten_sigma_2_correct by blast
qed

theorem normal_form_with_flatten_pi_2:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>M \<subseteq> subformulas\<^sub>\<mu> \<phi>. \<exists>N \<subseteq> subformulas\<^sub>\<nu> \<phi>.
      w \<Turnstile>\<^sub>n \<phi>[N]\<^sub>\<Pi>\<^sub>2 \<and> (\<forall>\<psi> \<in> M. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[N]\<^sub>\<Sigma>\<^sub>1)) \<and> (\<forall>\<psi> \<in> N. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[M]\<^sub>\<Pi>\<^sub>1)))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have "w \<Turnstile>\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Pi>\<^sub>2"
    using flatten_pi_2_correct by blast
  then show ?rhs
    using \<G>\<F>_subformulas\<^sub>\<mu> \<F>\<G>_subformulas\<^sub>\<nu> \<G>\<F>_implies_GF \<F>\<G>_implies_FG by metis
next
  assume ?rhs
  then obtain M N where "w \<Turnstile>\<^sub>n \<phi>[N]\<^sub>\<Pi>\<^sub>2" and "M \<subseteq> \<G>\<F> \<phi> w" and "N \<subseteq> \<F>\<G> \<phi> w"
    using X_\<G>\<F>_Y_\<F>\<G> by metis
  then have "w \<Turnstile>\<^sub>n \<phi>[\<F>\<G> \<phi> w]\<^sub>\<Pi>\<^sub>2"
    using flatten_pi_2_monotone by metis
  then show ?lhs
    using flatten_pi_2_correct by blast
qed

end


subsection \<open>Precedence\<close>

text
  \<open>A precedence consists of two compatible relations (strict and non-strict) on symbols such that
the strict relation is strongly normalizing. In the formalization we model this via a
function "prc" (precedence-compare) which returns two Booleans, indicating whether the one symbol is
strictly or weakly bigger than the other symbol. Moreover, there also is a function "prl"
(precedence-least) which gives quick access to whether a symbol is least in precedence, i.e.,
without comparing it to all other symbols explicitly.\<close>

theory Precedence
  imports
    "Abstract-Rewriting.Abstract_Rewriting"
begin

locale precedence =
  fixes prc :: "'f \<Rightarrow> 'f \<Rightarrow> bool \<times> bool"
    and prl :: "'f \<Rightarrow> bool"
  assumes prc_refl: "prc f f = (False, True)"
    and prc_SN: "SN {(f, g). fst (prc f g)}"
    and prl: "prl g \<Longrightarrow> snd (prc f g) = True"
    and prl3: "prl f \<Longrightarrow> snd (prc f g) \<Longrightarrow> prl g"
    and prc_compat: "prc f g = (s1, ns1) \<Longrightarrow> prc g h = (s2, ns2) \<Longrightarrow> prc f h = (s, ns) \<Longrightarrow>
   (ns1 \<and> ns2 \<longrightarrow> ns) \<and> (ns1 \<and> s2 \<longrightarrow> s) \<and> (s1 \<and> ns2 \<longrightarrow> s)"
    and prc_stri_imp_nstri: "fst (prc f g) \<Longrightarrow> snd (prc f g)"
begin

lemma prl2:
  assumes g: "prl g" shows "fst (prc g f) = False"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain b where gf: "prc g f = (True, b)" by (cases "prc g f", auto)
  obtain b1 b2 where gg: "prc g g = (b1, b2)" by force
  obtain b' where fg: "prc f g = (b', True)" using prl[OF g, of f] by (cases "prc f g", auto)
  from prc_compat[OF gf fg gg] gg have gg: "fst (prc g g)" by auto
  with SN_on_irrefl[OF prc_SN] show False by blast
qed

abbreviation "pr \<equiv> (prc, prl)"

end

end


theory Executable_Relation
imports Main
begin

subsection \<open>A dedicated type for relations\<close>

subsubsection \<open>Definition of the dedicated type for relations\<close>

typedef 'a rel = "UNIV :: (('a * 'a) set) set"
morphisms set_of_rel rel_of_set by simp

setup_lifting type_definition_rel

lift_definition Rel :: "'a set => ('a * 'a) set => 'a rel" is "\<lambda> X R. Id_on X Un R" .

subsubsection \<open>Constant definitions on relations\<close>

hide_const (open) converse relcomp rtrancl Image

lift_definition member :: "'a * 'a => 'a rel => bool" is "Set.member" .

lift_definition converse :: "'a rel => 'a rel" is "Relation.converse" .

lift_definition union :: "'a rel => 'a rel => 'a rel" is "Set.union" .

lift_definition relcomp :: "'a rel => 'a rel => 'a rel" is "Relation.relcomp" .

lift_definition rtrancl :: "'a rel => 'a rel" is "Transitive_Closure.rtrancl" .

lift_definition Image :: "'a rel => 'a set => 'a set" is "Relation.Image" .

subsubsection \<open>Code generation\<close>

code_datatype Rel

lemma [code]:
  "converse (Rel X R) = Rel X (R^-1)"
by transfer auto

lemma [code]:
  "union (Rel X R) (Rel Y S) = Rel (X Un Y) (R Un S)"
by transfer auto

lemma [code]:
   "relcomp (Rel X R) (Rel Y S) = Rel (X Int Y) (Set.filter (%(x, y). y : Y) R Un (Set.filter (%(x, y). x : X) S Un R O S))"
by transfer (auto simp add: Id_on_eqI relcomp.simps)

lemma [code]:
  "rtrancl (Rel X R) = Rel UNIV (R^+)"
apply transfer
apply auto
apply (metis Id_on_iff Un_commute UNIV_I rtrancl_Un_separatorE rtrancl_eq_or_trancl)
by (metis in_rtrancl_UnI trancl_into_rtrancl)

lemma [code]:
  "Image (Rel X R) S = (X Int S) Un (R `` S)"
by transfer auto

quickcheck_generator rel constructors: Rel

lemma
  "member (x, (y :: nat)) (rtrancl (union R S)) \<Longrightarrow> member (x, y) (union (rtrancl R) (rtrancl S))"
quickcheck[exhaustive, expect = counterexample]
oops

end


section \<open>Galois Connections and Fusion Theorems \label{S:galois}\<close>

theory Galois_Connections
imports Refinement_Lattice
begin

text \<open>
  The concept of Galois connections is introduced here to prove the fixed-point fusion lemmas.
  The definition of Galois connections used is quite simple but encodes a lot of
  information.
  The material in this section is largely based on the work of the Eindhoven
  Mathematics of Program Construction Group \cite{fixedpointcalculus1995}
  and the reader is referred to their work for a full explanation of this section.
\<close>

subsection \<open>Lower Galois connections\<close>

(* auxiliary lemma to prefer 2-element sets rather than disjunction *)
lemma Collect_2set [simp]:  "{F x |x. x = a \<or> x = b} = {F a, F b}"
  by auto

locale lower_galois_connections
begin

definition
  l_adjoint :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" ("_\<^sup>\<flat>" [201] 200)
where
  "(F\<^sup>\<flat>) x \<equiv> \<Sqinter>{y. x \<sqsubseteq> F y}"

lemma l_cancellation: "dist_over_inf F \<Longrightarrow> x \<sqsubseteq> (F \<circ> F\<^sup>\<flat>) x"
proof -
  assume dist: "dist_over_inf F"

  define Y where "Y = {F y | y. x \<sqsubseteq> F y}"
  define X where "X = {x}"

  have "(\<forall> y \<in> Y. (\<exists> x \<in> X. x \<sqsubseteq> y))" using X_def Y_def CollectD singletonI by auto
  then have "\<Sqinter> X \<sqsubseteq> \<Sqinter> Y" by (simp add: Inf_mono)
  then have "x \<sqsubseteq> \<Sqinter>{F y | y. x \<sqsubseteq> F y}" by (simp add: X_def Y_def)
  then have "x \<sqsubseteq> F (\<Sqinter>{y. x \<sqsubseteq> F y})" by (simp add: dist le_INF_iff)
  thus ?thesis by (metis comp_def l_adjoint_def)
qed

lemma l_galois_connection: "dist_over_inf F \<Longrightarrow> ((F\<^sup>\<flat>) x \<sqsubseteq> y) \<longleftrightarrow> (x \<sqsubseteq> F y)"
proof
  assume "x \<sqsubseteq> F y"
  then have "\<Sqinter>{y. x \<sqsubseteq> F y} \<sqsubseteq> y" by (simp add: Inf_lower)
  thus "(F\<^sup>\<flat>) x \<sqsubseteq> y" by (metis l_adjoint_def)
next
  assume dist: "dist_over_inf F" then have monoF: "mono F" by (simp add: dist_inf_mono)
  assume "(F\<^sup>\<flat>) x \<sqsubseteq> y" then have a: "F ((F\<^sup>\<flat>) x) \<sqsubseteq> F y" by (simp add: monoD monoF)
  have "x \<sqsubseteq> F ((F\<^sup>\<flat>) x)" using dist l_cancellation by simp
  thus "x \<sqsubseteq> F y" using a by auto
qed

lemma v_simple_fusion: "mono G \<Longrightarrow> \<forall>x. ((F \<circ> G) x \<sqsubseteq> (H \<circ> F) x) \<Longrightarrow> F (gfp G) \<sqsubseteq> gfp H"
  by (metis comp_eq_dest_lhs gfp_unfold gfp_upperbound)

subsection \<open>Greatest fixpoint fusion theorems\<close>

text \<open>
  Combining lower Galois connections and greatest fixed points allows
  elegant proofs of the weak fusion lemmas.
\<close>

theorem fusion_gfp_geq:
  assumes monoH: "mono H"
  and distribF: "dist_over_inf F"
  and comp_geq: "\<And>x. ((H \<circ> F) x \<sqsubseteq> (F \<circ> G) x)"
  shows "gfp H \<sqsubseteq> F (gfp G)"
proof -
  have "(gfp H) \<sqsubseteq> (F \<circ> F\<^sup>\<flat>) (gfp H)" using distribF l_cancellation by simp
  then have "H (gfp H) \<sqsubseteq> H ((F \<circ> F\<^sup>\<flat>) (gfp H))" by (simp add: monoD monoH)
  then have "H (gfp H) \<sqsubseteq> F ((G \<circ> F\<^sup>\<flat>) (gfp H))" using comp_geq by (metis comp_def refine_trans)
  then have "(F\<^sup>\<flat>) (H (gfp H)) \<sqsubseteq> (G \<circ> F\<^sup>\<flat>) (gfp H)" using distribF by (metis (mono_tags) l_galois_connection)
  then have "(F\<^sup>\<flat>) (gfp H) \<sqsubseteq> (gfp G)" by (metis comp_apply gfp_unfold gfp_upperbound monoH)
  thus "gfp H \<sqsubseteq> F (gfp G)" using distribF by (metis (mono_tags) l_galois_connection)
qed

theorem fusion_gfp_eq:
  assumes monoH: "mono H" and monoG: "mono G"
  and distF: "dist_over_inf F"
  and fgh_comp: "\<And>x. ((F \<circ> G) x = (H \<circ> F) x)"
  shows "F (gfp G) = gfp H"
proof (rule antisym)
  show "F (gfp G) \<sqsubseteq> (gfp H)" by (metis fgh_comp le_less v_simple_fusion monoG)
next
  have "\<And>x. ((H \<circ> F) x \<sqsubseteq> (F \<circ> G) x)" using fgh_comp by auto
  then show "gfp H \<sqsubseteq> F (gfp G)" using monoH distF fusion_gfp_geq by blast
qed

end

subsection \<open>Upper Galois connections\<close>

locale upper_galois_connections
begin

definition
  u_adjoint :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" ("_\<^sup>#" [201] 200)
where
  "(F\<^sup>#) x \<equiv> \<Squnion>{y. F y \<sqsubseteq> x}"

lemma dist_sup_mono:
  assumes distF: "dist_over_sup F"
  shows "mono F"
proof
  fix x :: 'a and y :: 'a
  assume "x \<sqsubseteq> y"
  then have "F y = F (x \<squnion> y)" by (simp add: le_iff_sup)
  also have "... = F x \<squnion> F y"
  proof -
    from distF
    have "F (\<Squnion>{x, y}) = \<Squnion>{F x, F y}" by (drule_tac x = "{x, y}" in spec, simp)
    then show "F (x \<squnion> y) = F x \<squnion> F y" by simp
  qed
  finally show "F x \<sqsubseteq> F y" by (metis le_iff_sup)
qed

lemma u_cancellation: "dist_over_sup F \<Longrightarrow> (F \<circ> F\<^sup>#) x \<sqsubseteq> x"
proof -
  assume dist: "dist_over_sup F"
  define Y where "Y = {F y | y. F y \<sqsubseteq> x}"
  define X where "X = {x}"

  have "(\<forall> y \<in> Y. (\<exists> x \<in> X. y \<sqsubseteq> x))" using X_def Y_def CollectD singletonI by auto
  then have "\<Squnion> Y \<sqsubseteq> \<Squnion> X" by (simp add: Sup_mono)
  then have "\<Squnion>{F y | y. F y \<sqsubseteq> x} \<sqsubseteq> x" by (simp add: X_def Y_def)
  then have "F (\<Squnion>{y. F y \<sqsubseteq> x}) \<sqsubseteq> x" using SUP_le_iff dist by fastforce
  thus ?thesis by (metis comp_def u_adjoint_def)
qed

lemma u_galois_connection: "dist_over_sup F \<Longrightarrow> (F x \<sqsubseteq> y) \<longleftrightarrow> (x \<sqsubseteq> (F\<^sup>#) y)"
proof
  assume dist: "dist_over_sup F" then have monoF: "mono F" by (simp add: dist_sup_mono)
  assume "x \<sqsubseteq> (F\<^sup>#) y" then have a: "F x \<sqsubseteq> F ((F\<^sup>#) y)" by (simp add: monoD monoF)
  have "F ((F\<^sup>#) y) \<sqsubseteq> y" using dist u_cancellation by simp
  thus "F x \<sqsubseteq> y" using a by auto
next
  assume "F x \<sqsubseteq> y"
  then have "x \<sqsubseteq> \<Squnion>{x. F x \<sqsubseteq> y}" by (simp add: Sup_upper)
  thus "x \<sqsubseteq> (F\<^sup>#) y" by (metis u_adjoint_def)
qed

lemma u_simple_fusion: "mono H \<Longrightarrow> \<forall>x. ((F \<circ> G) x \<sqsubseteq> (G \<circ> H) x) \<Longrightarrow> lfp F \<sqsubseteq> G (lfp H)"
  by (metis comp_def lfp_lowerbound lfp_unfold)

subsection \<open>Least fixpoint fusion theorems\<close>

text \<open>
  Combining upper Galois connections and least fixed points allows elegant proofs
  of the strong fusion lemmas.
\<close>

theorem fusion_lfp_leq:
  assumes monoH: "mono H"
  and distribF: "dist_over_sup F"
  and comp_leq: "\<And>x. ((F \<circ> G) x \<sqsubseteq> (H \<circ> F) x)"
  shows "F (lfp G) \<sqsubseteq> (lfp H)"
proof -
  have "((F \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> lfp H"  using distribF u_cancellation by simp
  then have "H ((F \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> H (lfp H)" by (simp add: monoD monoH)
  then have "F ((G \<circ> F\<^sup>#) (lfp H)) \<sqsubseteq> H (lfp H)" using comp_leq by (metis comp_def refine_trans)
  then have "(G \<circ> F\<^sup>#) (lfp H) \<sqsubseteq> (F\<^sup>#) (H (lfp H))" using distribF by (metis (mono_tags) u_galois_connection)
  then have "(lfp G) \<sqsubseteq> (F\<^sup>#) (lfp H)" by (metis comp_def def_lfp_unfold lfp_lowerbound monoH)
  thus "F (lfp G) \<sqsubseteq> (lfp H)" using distribF by (metis (mono_tags) u_galois_connection)
qed

theorem fusion_lfp_eq:
  assumes monoH: "mono H" and monoG: "mono G"
  and distF: "dist_over_sup F"
  and fgh_comp: "\<And>x. ((F \<circ> G) x = (H \<circ> F) x)"
  shows "F (lfp G) = (lfp H)"
proof (rule antisym)
  show "lfp H \<sqsubseteq> F (lfp G)" by (metis monoG fgh_comp eq_iff upper_galois_connections.u_simple_fusion)
next
  have "\<And>x. (F \<circ> G) x \<sqsubseteq> (H \<circ> F) x" using fgh_comp by auto
  then show "F (lfp G) \<sqsubseteq> (lfp H)" using monoH distF fusion_lfp_leq by blast
qed

end
end


theory mMem
  imports mSet
begin

context GZF_Model begin

thm mMem_def

lemma mmemI :
  assumes
    x' : "<set,x'> : mSet" and a : "a \<in> x'"
  shows "a m <set, x'>"
  unfolding
    mMem_def mset_snd_eq[OF x']
  using
    assms
  by auto

lemma mmemI_eq :
  assumes x : "x : mSet" "x = <set, x'>"
      and a : "a \<in> x'"
    shows "a m x"
  using mmemI[OF _ a] x by auto

lemma mmem_mset :
  "a m x \<Longrightarrow> x : mSet"
  unfolding mMem_def by auto

lemma mmemD :
  assumes a : "a m <set, x'>"
    shows "a \<in> x'"
  using
    a mset_snd_eq
  unfolding
    mMem_def
  by auto

lemma mmemD_eq :
  assumes x : "x = <set, x'>"
      and a : "a m x"
    shows "a \<in> x'"
  using a mset_snd_eq
  unfolding mMem_def x by auto

lemma mmemE :
  assumes a : "a m x"
  obtains x' where "x = <set,x'>" "a \<in> x'"
  by (rule msetE[OF mmem_mset[OF a]],
      use mmemD a in auto)

lemma mmem_iff :
  assumes x : "<set,x'> : mSet"
  shows "a m <set,x'> \<longleftrightarrow> a \<in> x'"
  using
    mmemI[OF x] mmemD
  by auto

lemma mmem_iff_eq :
  assumes x: "x : mSet" "x = <set, x'>"
  shows "a m x \<longleftrightarrow> a \<in> x'"
  using mmem_iff x by auto

lemma mmem_tier :
  assumes j : "j : Ord" and x : "<set,x'> \<in> Tier (succ j)"
      and a : "a m <set,x'>"
    shows "a \<in> Tier j \<ominus> set"
 using
  tierD_mset[OF j x] mmemD[OF a]
 by auto

lemma mmem_m :
  assumes b : "b m x"
    shows "b : M"
proof (rule msetE[OF mmem_mset[OF b]], rule mE[OF mset_m[OF mmem_mset[OF b]]])
  fix x' i assume x:"x = <set,x'>" "x' : Set" "i : Ord" "x \<in> Tier i"
  hence "<set,x'> \<in> Tier (succ i)" using tier_succI1 by auto
  thus "b : M" using mI[OF _ exsetD1[OF tier_set mmem_tier]] b x by auto
qed

lemma msetofI :
  assumes "x : mSet" "\<And>b. b m x \<Longrightarrow> b : P"
  shows "x : mSetOf P"
  using assms
  unfolding mSetOf_def has_ty_def
  by auto

lemma msetof_mset :
  assumes "x : mSetOf P"
  shows "x : mSet"
  using assms
  unfolding mSetOf_def has_ty_def by auto

lemma msetof_mmem :
  assumes "x : mSetOf P" "b m x"
  shows "b : P"
  using assms mmem_m
  unfolding mSetOf_def mall_def tall_def has_ty_def by auto

lemma msetof_iff :
  "x : mSetOf P \<longleftrightarrow> x : mSet \<and> (\<forall>b. b m x \<longrightarrow> b : P)"
  using mmem_m
  unfolding mSetOf_def mall_def tall_def has_ty_def by auto

lemma msetof_cong : "\<And>fun1 fun2. (\<And>x. x : M \<Longrightarrow> fun1 x = fun2 x)
    \<Longrightarrow> (\<And>x. x : M \<Longrightarrow> mSetOf fun1 x = mSetOf fun2 x)"
 unfolding mSetOf_def mall_def tall_def has_ty_def
          by auto

lemma msetmemI :
  assumes "b m x"
  shows "b : mSetMem"
  using assms mset_m mmem_mset
  unfolding mSetMem_def has_ty_def mtex_def mex_def tex_def by auto

lemma msetmem_iff :
  "b : mSetMem \<longleftrightarrow> (\<exists>x. b m x)"
  using msetmemI
  unfolding mSetMem_def has_ty_def mtex_def mex_def tex_def by auto

lemma mset_pair_setof :
  assumes x : "<set, x'> : mSetOf P"
  shows "x' : SetOf P"
proof (rule setofI)
 from msetof_mset[OF x] have x_mset:"<set,x'> : mSet" by auto
 thus "x' : Set" using mset_pair_set[OF mset_m] by auto
 fix b assume "b \<in> x'"
 hence "b m <set,x'>" using mmemI[OF x_mset] by auto
 thus "b : P" using msetof_mmem[OF x] by auto
qed

lemma setof_msetof :
  assumes x : "<set,x'> : mSet"
      and x' : "x' : SetOf P"
    shows "<set, x'> : mSetOf P"
proof (rule msetofI[OF x])
  fix b
  assume "b m <set,x'>" thus "b : P"
    unfolding mmem_iff[OF x]
    using setof_mem[OF x'] by auto
qed

lemma msetofE :
  assumes x : "x : mSetOf P"
  obtains x' where "x = <set,x'>" "x' : SetOf P"
  by (rule msetE[OF msetof_mset[OF x]],
      metis mset_pair_setof x)

text \<open>Axiom of Extensionality\<close>
lemma mset_eq_iff :
  assumes x : "x : mSet" and y : "y : mSet"
      and iff : "\<forall>a. a m x \<longleftrightarrow> a m y"
    shows "x = y"
proof -
  obtain x' y'
   where x': "x = <set,x'>" "x' : Set"
     and y': "y = <set,y'>" "y' : Set"
    by (metis msetE x y)
  hence "x' = y'"
    using equality_iffI iff mmem_iff x y
    by auto
  thus "x = y"
    unfolding x'(1) y'(1) by auto
qed

theorem mext_ax :
  "m\<forall>x : mSet. m\<forall>y : mSet.
    (m\<forall>a. a m x \<longleftrightarrow> a m y) \<longrightarrow> x = y"
  unfolding mall_def mtall_def tall_def
  using mset_eq_iff mmem_m by meson

lemma msmem_smem :
  assumes b : "b : mSetMem"
  shows "b : SetMem"
proof -
  from b mmem_mset obtain x where
    x : "x : mSet" and b : "b m x"
    unfolding msetmem_iff[of b] tex_def by auto
  then obtain x' where x' : "x = <set, x'>" "x' : Set"
    using msetE by auto
  hence bx:"b \<in> x'" using mmemD b by auto
  thus "b : SetMem" using setmemI[OF x'(2)] by auto
qed

lemma msmem_m :
  assumes b:"b : mSetMem"
  shows "b : M"
proof -
  from b mmem_mset obtain x where
    x:"x : mSet" and bx:"b m x"
    unfolding msetmem_iff tex_def by auto
  thus "b : M"
    using mmem_m by auto
qed

lemma msmem_not_excluded :
  assumes b:"b : mSetMem"
  shows "\<not> Excluded set b"
proof -
  from b obtain x where
    x:"x : mSet" and bx:"b m x"
    using msetmem_iff mmem_mset unfolding tex_def by auto
  obtain x' where "x = <set,x'>" "b \<in> x'"
    by (rule msetE[OF x], metis mmemD bx)
  then obtain j where "j : Ord" and "<set,x'> \<in> Tier (succ j)"
    using tier_succI1 mE[OF mset_m[OF x]] by metis
  hence "x' \<subseteq> Tier j \<ominus> set"
    using tierD_mset by auto
  thus "\<not> Excluded set b"
    using exsetD2[OF tier_set[OF \<open>j : Ord\<close>]] \<open>b \<in> x'\<close> by auto
qed

lemma not_excluded_msmem :
  assumes b : "b : M" and b_ex  : "\<not> Excluded set b"
  shows "b : mSetMem"
proof (rule msetmemI[of _ \<open><set, {b}>\<close>], rule mmemI)
  from b obtain j where
    j:"j : Ord" and bx:"b \<in> Tier j"
    using mE by auto
  moreover hence "b : SetMem"
    using setmemI[OF tier_set[OF j] bx] by auto
  moreover thus "b \<in> {b}"
    using sng_iff by auto
  ultimately have "{b} \<subseteq> Tier j \<ominus> set"
    using sng_iff exsetI[OF tier_set[OF j] _ b_ex] by auto
  hence "<set, {b}> \<in> Tier (succ j)"
    using tierI_mset[OF j sng_set[OF \<open>b : SetMem\<close>]] by auto
  thus "<set, {b}> : mSet"
    using msetI[OF mI[OF succ_ord[OF j]]] by auto
qed

end
end


(* Author: Fabian Hellauer
           Fabian Immler
*)
theory Conversion_IEEE_Float
  imports
    "HOL-Library.Float"
    IEEE_Properties
    "HOL-Library.Code_Target_Numeral"
begin

definition "of_finite (x::('e, 'f)float) =
  (if is_normal x then (Float (normal_mantissa x) (normal_exponent x))
    else if is_denormal x then (Float (denormal_mantissa x) (denormal_exponent TYPE(('e, 'f)float)))
    else 0)"

lemma float_val_of_finite: "is_finite x \<Longrightarrow> of_finite x = valof x"
  by (induction x) (auto simp: normal_imp_not_denormal of_finite_def)

definition is_normal_Float::"('e, 'f)float itself \<Rightarrow> Float.float \<Rightarrow> bool" where
  "is_normal_Float x f \<longleftrightarrow>
    mantissa f \<noteq> 0 \<and>
    bitlen \<bar>mantissa f\<bar> \<le> fracwidth x + 1 \<and>
    - int (bias x) - bitlen \<bar>mantissa f\<bar> + 1 < Float.exponent f \<and>
    Float.exponent f < 2^(LENGTH('e)) - bitlen \<bar>mantissa f\<bar> - bias x"

definition is_denormal_Float::"('e, 'f)float itself \<Rightarrow> Float.float \<Rightarrow> bool" where
  "is_denormal_Float x f \<longleftrightarrow>
    mantissa f \<noteq> 0 \<and>
    bitlen \<bar>mantissa f\<bar> \<le> 1 - Float.exponent f - int (bias x) \<and>
    1 - 2^(LENGTH('e) - 1) - int LENGTH('f) < Float.exponent f"

lemmas is_denormal_FloatD =
  is_denormal_Float_def[THEN iffD1, THEN conjunct1]
  is_denormal_Float_def[THEN iffD1, THEN conjunct2]

definition is_finite_Float::"('e, 'f)float itself \<Rightarrow> Float.float \<Rightarrow> bool" where
  "is_finite_Float x f \<longleftrightarrow> is_normal_Float x f \<or> is_denormal_Float x f \<or> f = 0"

lemma is_finite_Float_eq:
  "is_finite_Float TYPE(('e, 'f)float) f \<longleftrightarrow>
    (let e = Float.exponent f; bm = bitlen (abs (mantissa f))
    in bm \<le> Suc LENGTH('f) \<and>
     bm \<le> 2 ^ (LENGTH('e) - 1) - e \<and>
     1 - 2 ^ (LENGTH('e) - 1) - int LENGTH('f) < e)"
proof -
  have *: "(2::int) ^ (LENGTH('e) - Suc 0) - 1 < 2 ^ LENGTH('e)"
    by (metis Suc_1 diff_le_self lessI linorder_not_less one_less_numeral_iff
        power_strict_increasing_iff zle_diff1_eq)
  have **: "1 - 2 ^ (LENGTH('e) - Suc 0) < int LENGTH('f)"
    by (smt len_gt_0 of_nat_0_less_iff zero_less_power)
  have ***: "2 ^ (LENGTH('e) - 1) + 1 =
    2 ^ LENGTH('e) - int (bias TYPE(('e, 'f) IEEE.float))"
    by (simp add: bias_def power_Suc[symmetric])
  have rewr: "x \<le> 2 ^ n - e \<longleftrightarrow> x + e < 2 ^ n + 1" for x::int and n e
    by auto
  show ?thesis
    unfolding *** rewr
    using * **
    unfolding is_finite_Float_def is_normal_Float_def is_denormal_Float_def
    by (auto simp: Let_def bias_def mantissa_eq_zero_iff
        intro: le_less_trans[OF add_right_mono])
qed

lift_definition normal_of_Float :: "Float.float \<Rightarrow> ('e, 'f)float"
  is "\<lambda>x. let m = mantissa x; e = Float.exponent x in
    (if m > 0 then 0 else 1,
      word_of_int (e + int (bias TYPE(('e, 'f)float)) + bitlen \<bar>m\<bar> - 1),
      word_of_int (\<bar>m\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>m\<bar>)) - 2 ^ (LENGTH('f))))"
  .

lemma sign_normal_of_Float:"sign (normal_of_Float x) = (if x > 0 then 0 else 1)"
  by transfer (auto simp: Let_def mantissa_pos_iff)

lemma uints_bitlen_eq: "uints n = {i. 0 \<le> i \<and> bitlen i \<le> n}"
  by (auto simp: uints_num bitlen_le_iff_power)

lemma uint_word_of_int_bitlen_eq:
  "uint (word_of_int x::'a::len0 word) = x" if "bitlen x \<le> LENGTH('a)" "x \<ge> 0"
  by (subst word_uint.Abs_inverse) (simp_all add: uints_bitlen_eq that)

lemma fraction_normal_of_Float:"fraction (normal_of_Float x::('e, 'f)float) =
  (nat \<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>)) - 2 ^ LENGTH('f))"
  if "is_normal_Float TYPE(('e, 'f)float) x"
proof -
  from that have bmp: "bitlen \<bar>mantissa x\<bar> > 0"
    by (metis abs_of_nonneg bitlen_bounds bitlen_def is_normal_Float_def nat_code(2) of_nat_0_le_iff
        power.simps(1) zabs_less_one_iff zero_less_abs_iff)
  have mless: "\<bar>mantissa x\<bar> < 2 ^ nat (bitlen \<bar>mantissa x\<bar>)"
    using bitlen_bounds by force
  have lem: "2 ^ nat (bitlen \<bar>mantissa x\<bar> - 1) \<le> \<bar>mantissa x\<bar>"
    using bitlen_bounds is_normal_Float_def that zero_less_abs_iff by blast
  from that have nble: "nat (bitlen \<bar>mantissa x\<bar>) \<le> Suc LENGTH('f)"
    using bitlen_bounds by (auto simp: is_normal_Float_def)
  have nn: "0 \<le> \<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>)) - 2 ^ LENGTH('f)"
    apply (rule add_le_imp_le_diff)
    apply (rule order_trans[rotated])
     apply (rule mult_right_mono)
      apply (rule lem, force)
    unfolding power_add[symmetric]
    using nble bmp
    by (auto)
  have "\<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>)) < 2 * 2 ^ LENGTH('f)"
    apply (rule less_le_trans)
     apply (rule mult_strict_right_mono)
      apply (rule mless)
     apply force
    unfolding power_add[symmetric] power_Suc[symmetric]
    apply (rule power_increasing)
    using nble
    by auto
  then have "bitlen (\<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>)) - 2 ^ LENGTH('f))
    \<le> int LENGTH('f)"
    unfolding bitlen_le_iff_power
    by simp
  then show ?thesis
    apply (transfer fixing: x)
    unfolding Let_def split_beta' fst_conv snd_conv uint_nat[symmetric] unat_def
    using nn
    by (subst uint_word_of_int_bitlen_eq)
      (auto simp: nat_mult_distrib nat_diff_distrib nat_power_eq)
qed

lemma exponent_normal_of_Float:"exponent (normal_of_Float x::('e, 'f)float) =
  nat (Float.exponent x + (bias TYPE(('e, 'f)float)) + bitlen \<bar>mantissa x\<bar> - 1)"
  if "is_normal_Float TYPE(('e, 'f)float) x"
  using that
  by (transfer fixing: x)
    (auto simp: is_normal_Float_def bitlen_le_iff_power uint_word_of_int_bitlen_eq Let_def
      uint_nat[symmetric] unat_def)

lift_definition denormal_of_Float :: "Float.float \<Rightarrow> ('e, 'f)float"
  is "\<lambda>x. let m = mantissa x; e = Float.exponent x in
  (if m \<ge> 0 then 0 else 1, 0,
    word_of_int (\<bar>m\<bar> * 2 ^ nat (e + bias TYPE(('e, 'f)float) + fracwidth TYPE(('e, 'f)float) - 1)))"
  .

lemma sign_denormal_of_Float:"sign (denormal_of_Float x) = (if x \<ge> 0 then 0 else 1)"
  by transfer (auto simp: Let_def mantissa_nonneg_iff)

lemma exponent_denormal_of_Float:"exponent (denormal_of_Float x::('e, 'f)float) = 0"
  by (transfer fixing: x) (auto simp: Let_def)

lemma fraction_denormal_of_Float:"fraction (denormal_of_Float x::('e, 'f)float) =
  (nat \<bar>mantissa x\<bar> * 2 ^ nat (Float.exponent x + bias TYPE(('e, 'f)float) + LENGTH('f) - 1))"
  if "is_denormal_Float TYPE(('e, 'f)float) x"
proof -
  have mless: "\<bar>mantissa x\<bar> < 2 ^ nat (bitlen \<bar>mantissa x\<bar>)"
    using bitlen_bounds by force
  have *: "nat (bitlen \<bar>mantissa x\<bar>) +
    nat (Float.exponent x + (2 ^ (LENGTH('e) - Suc 0) + int LENGTH('f)) - 2)
    \<le> LENGTH('f)"
    using that
    by (auto simp: is_denormal_Float_def nat_diff_distrib' le_diff_conv
        bitlen_nonneg nat_le_iff bias_def nat_add_distrib[symmetric])
  have "\<bar>mantissa x\<bar> *  2 ^ nat (Float.exponent x + int (bias TYPE(('e, 'f)float)) +
    LENGTH('f) - 1) < 2 ^ LENGTH('f)"
    apply (rule less_le_trans)
     apply (rule mult_strict_right_mono)
      apply (rule mless, force)
    unfolding power_add[symmetric] power_Suc[symmetric]
    apply (rule power_increasing)
     apply (auto simp: bias_def)
    using that *
    by (auto simp: is_denormal_Float_def algebra_simps)
  then show ?thesis
    apply (transfer fixing: x)
    unfolding Let_def split_beta' fst_conv snd_conv uint_nat[symmetric] unat_def
    apply (subst uint_word_of_int_bitlen_eq)
    unfolding bitlen_le_iff_power
    by (auto simp: nat_mult_distrib)
qed

definition of_finite_Float :: "Float.float \<Rightarrow> ('e, 'f) float" where
  "of_finite_Float x = (if is_normal_Float TYPE(('e, 'f)float) x then normal_of_Float x
    else if is_denormal_Float TYPE(('e, 'f)float) x then denormal_of_Float x
    else 0)"

lemma valof_normal_of_Float: "valof (normal_of_Float x::('e, 'f)float) = x"
  if "is_normal_Float TYPE(('e, 'f)float) x"
proof -
  have "valof (normal_of_Float x::('e, 'f)float) =
    (- 1) ^ sign (normal_of_Float x::('e, 'f)float) *
    ((1 + real (nat \<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>)) - 2 ^ LENGTH('f)) / 2 ^ LENGTH('f)) *
      2 powr (bitlen \<bar>mantissa x\<bar> - 1)) *
    2 powr Float.exponent x"
    (is "_ = ?s * ?m * ?e")
    using that
    by (auto simp: is_normal_Float_def valof_eq fraction_normal_of_Float
        powr_realpow[symmetric] exponent_normal_of_Float powr_diff powr_add)
  also
  have "\<bar>mantissa x\<bar> > 0"
    using that
    by (auto simp: is_normal_Float_def)
  have bound: "2 ^ LENGTH('f) \<le> nat \<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>))"
  proof -
    have "(2::nat) ^ LENGTH('f) \<le> 2 ^ nat (bitlen \<bar>mantissa x\<bar> - 1) * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>))"
      by (simp add: power_add[symmetric])
    also have "\<dots> \<le> nat \<bar>mantissa x\<bar> * 2 ^ (Suc LENGTH('f) - nat (bitlen \<bar>mantissa x\<bar>))"
      using bitlen_bounds[of "\<bar>mantissa x\<bar>"] that
      by (auto simp: is_normal_Float_def)
    finally show ?thesis .
  qed
  have "?m = abs (mantissa x)"
    apply (subst of_nat_diff)
    subgoal using bound by auto
    subgoal
      using that
      by (auto simp: powr_realpow[symmetric] powr_add[symmetric]
          is_normal_Float_def bitlen_nonneg of_nat_diff divide_simps)
    done
  finally show ?thesis
    by (auto simp: mantissa_exponent sign_normal_of_Float abs_real_def zero_less_mult_iff)
qed

lemma valof_denormal_of_Float: "valof (denormal_of_Float x::('e, 'f)float) = x"
  if "is_denormal_Float TYPE(('e, 'f)float) x"
proof -
  have less: "0 < Float.exponent x + (int (bias TYPE(('e, 'f) IEEE.float)) + int LENGTH('f))"
    using that
    by (auto simp: is_denormal_Float_def bias_def)
  have "valof (denormal_of_Float x::('e, 'f)float) =
    ((- 1) ^ sign (denormal_of_Float x::('e, 'f)float) * \<bar>real_of_int (mantissa x)\<bar>) *
    (2 powr real (nat (Float.exponent x + int (bias TYPE(('e, 'f) IEEE.float)) + int LENGTH('f) - 1)) /
      (2 powr real (bias TYPE(('e, 'f) IEEE.float)) * 2 powr LENGTH('f)) * 2)"
    (is "_ = ?m * ?e")
    by (auto simp: valof_eq exponent_denormal_of_Float fraction_denormal_of_Float that
        mantissa_exponent powr_realpow[symmetric])
  also have "?m = mantissa x"
    by (auto simp: sign_denormal_of_Float abs_real_def mantissa_neg_iff)
  also have "?e = 2 powr Float.exponent x"
    by (auto simp: powr_add[symmetric] divide_simps powr_mult_base less ac_simps)
  finally show ?thesis by (simp add: mantissa_exponent)
qed

lemma valof_of_finite_Float:
  "is_finite_Float (TYPE(('e, 'f) IEEE.float)) x \<Longrightarrow> valof (of_finite_Float x::('e, 'f)float) = x"
  by (auto simp: of_finite_Float_def is_finite_Float_def valof_denormal_of_Float valof_normal_of_Float)

lemma is_normal_normal_of_Float:
  "is_normal (normal_of_Float x::('e, 'f)float)" if "is_normal_Float TYPE(('e, 'f)float) x"
  using that
  by (auto simp: is_normal_def exponent_normal_of_Float that is_normal_Float_def
      emax_eq nat_less_iff)

lemma is_denormal_denormal_of_Float: "is_denormal (denormal_of_Float x::('e, 'f)float)"
  if "is_denormal_Float TYPE(('e, 'f)float) x"
  using that
  by (auto simp: is_denormal_def exponent_denormal_of_Float that is_denormal_Float_def
      emax_eq fraction_denormal_of_Float le_nat_iff bias_def)

lemma is_finite_of_finite_Float: "is_finite (of_finite_Float x)"
  by (auto simp: is_finite_def of_finite_Float_def is_normal_normal_of_Float
      is_denormal_denormal_of_Float)

lemma Float_eq_zero_iff: "Float m e = 0 \<longleftrightarrow> m = 0"
  by (metis Float.compute_is_float_zero Float_0_eq_0)

lemma bitlen_mantissa_Float:
  shows "bitlen \<bar>mantissa (Float m e)\<bar> = (if m = 0 then 0 else bitlen \<bar>m\<bar> + e) - Float.exponent (Float m e)"
  using bitlen_Float[of m e] by auto

lemma exponent_Float:
  shows "Float.exponent (Float m e) = (if m = 0 then 0 else bitlen \<bar>m\<bar> + e) - bitlen \<bar>mantissa (Float m e)\<bar> "
  using bitlen_Float[of m e] by auto

lemma is_normal_Float_normal:
  "is_normal_Float TYPE(('e, 'f)float) (Float (normal_mantissa x) (normal_exponent x))"
  if "is_normal x" for x::"('e, 'f)float"
proof -
  define f where "f = Float (normal_mantissa x) (normal_exponent x)"
  from that have "f \<noteq> 0"
    by (auto simp: f_def is_normal_def zero_float_def[symmetric]
        Float_eq_zero_iff normal_mantissa_def add_nonneg_eq_0_iff)
  from denormalize_shift[OF f_def this] obtain i where
    i: "normal_mantissa x = mantissa f * 2 ^ i" "normal_exponent x = Float.exponent f - int i"
    by auto
  have "mantissa f \<noteq> 0"
    by (auto simp: \<open>f \<noteq> 0\<close> i mantissa_eq_zero_iff Float_eq_zero_iff)
  moreover
  have "normal_exponent x \<le> Float.exponent f" unfolding i by simp
  then have " bitlen \<bar>mantissa f\<bar> \<le> 1 + int LENGTH('f)"
    unfolding bitlen_mantissa_Float bitlen_normal_mantissa f_def
    by auto
  moreover
  have "- int (bias TYPE(('e, 'f)float)) - bitlen \<bar>mantissa f\<bar> + 1 < Float.exponent f"
    unfolding bitlen_mantissa_Float bitlen_normal_mantissa f_def
    using that
    by (auto simp: mantissa_eq_zero_iff abs_mult bias_def normal_mantissa_def normal_exponent_def
        is_normal_def emax_eq less_diff_conv add_nonneg_eq_0_iff)
  moreover
  have "2 ^ (LENGTH('e) - Suc 0) + - (1::int) * 2 ^ LENGTH('e) \<le> 0"
    by simp
  then have "(2::int) ^ (LENGTH('e) - Suc 0) < 1 + 2 ^ LENGTH('e)" by arith
  then have "Float.exponent f <
      2 ^ LENGTH('e) - bitlen \<bar>mantissa f\<bar> - int (bias TYPE(('e, 'f)float))"
    using normal_exponent_bounds_int[OF that]
    unfolding bitlen_mantissa_Float bitlen_normal_mantissa f_def
    by (auto simp: bias_def algebra_simps power_Suc[symmetric]
        intro: le_less_trans[OF add_right_mono] normal_exponent_bounds_int[OF that])
  ultimately
  show ?thesis
    by (auto simp: is_normal_Float_def f_def)
qed

lemma is_denormal_Float_denormal:
  "is_denormal_Float TYPE(('e, 'f)float)
    (Float (denormal_mantissa x) (denormal_exponent TYPE(('e, 'f)float)))"
  if "is_denormal x" for x::"('e, 'f)float"
proof -
  define f where "f = Float (denormal_mantissa x) (denormal_exponent TYPE(('e, 'f)float))"
  from that have "f \<noteq> 0"
    by (auto simp: f_def is_denormal_def zero_float_def[symmetric]
        Float_eq_zero_iff denormal_mantissa_def add_nonneg_eq_0_iff)
  from denormalize_shift[OF f_def this] obtain i where
    i: "denormal_mantissa x = mantissa f * 2 ^ i" "denormal_exponent TYPE(('e, 'f)float) = Float.exponent f - int i"
    by auto
  have "mantissa f \<noteq> 0"
    by (auto simp: \<open>f \<noteq> 0\<close> i mantissa_eq_zero_iff Float_eq_zero_iff)
  moreover
  have "bitlen \<bar>mantissa f\<bar> \<le> 1 - Float.exponent f - int (bias TYPE(('e, 'f) IEEE.float))"
    using \<open>mantissa f \<noteq> 0\<close>
    unfolding f_def bitlen_mantissa_Float
    using bitlen_denormal_mantissa[of x]
    by (auto simp: denormal_exponent_def)
  moreover
  have "2 - 2 ^ (LENGTH('e) - Suc 0) - int LENGTH('f) \<le> Float.exponent f"
    (is "?l \<le> _")
  proof -
    have "?l \<le> denormal_exponent TYPE(('e, 'f)float) + i"
      using that
      by (auto simp: is_denormal_def bias_def denormal_exponent_def)
    also have "\<dots> = Float.exponent f" unfolding i by auto
    finally show ?thesis .
  qed
  ultimately
  show ?thesis
    unfolding is_denormal_Float_def exponent_Float f_def[symmetric]
    by auto
qed

lemma is_finite_Float_of_finite: "is_finite_Float TYPE(('e, 'f)float) (of_finite x)" for x::"('e, 'f)float"
  by (auto simp: is_finite_Float_def of_finite_def is_normal_Float_normal
      is_denormal_Float_denormal)

end


(*  Title:      Code_Target_Word_Base.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Common base for target language implementations of word types\<close>

theory Code_Target_Word_Base imports
  "HOL-Word.Word"
  Bits_Integer
begin

text \<open>More lemmas\<close>

lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> n \<ge> m \<and> n < 2 * m"
  apply (auto simp add: sdl)
  using not_less apply fastforce
  apply (metis One_nat_def Suc_1 div_eq_0_iff lessI neq0_conv td_gal_lt)
  done

lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ LENGTH('a :: len)"
  by (metis One_nat_def len_gt_0 lessI numeral_2_eq_2 one_less_power)

lemma div_half_nat:
  fixes x y :: nat
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  let ?q = "2 * (x div 2 div y)"
  have q: "?q = x div y - x div y mod 2"
    by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
  let ?r = "x - ?q * y"
  have r: "?r = x mod y + x div y mod 2 * y"
    by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

  show ?thesis
  proof(cases "y \<le> x - ?q * y")
    case True
    with assms q have "x div y mod 2 \<noteq> 0" unfolding r
      by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1))
    hence "x div y = ?q + 1" unfolding q
      by simp
    moreover hence "x mod y = ?r - y"
      by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
    ultimately show ?thesis using True by(simp add: Let_def)
  next
    case False
    hence "x div y mod 2 = 0" unfolding r
      by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
    hence "x div y = ?q" unfolding q by simp
    moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
    ultimately show ?thesis using False by(simp add: Let_def)
  qed
qed

lemma unat_p2: "n < LENGTH('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  then obtain n' where "LENGTH('a) = Suc n'" by(cases "LENGTH('a)") simp_all
  with Suc show ?case by (simp add: unat_word_ariths bintrunc_mod2p)
qed

lemma word_div_lt_eq_0:
  "x < y \<Longrightarrow> x div y = 0" for x :: "'a :: len word"
  by (simp add: word_eq_iff word_less_def word_test_bit_def uint_div)

lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
apply(simp only: word_arith_nat_defs word_le_nat_alt nat_div_eq_Suc_0_iff[symmetric])
apply(rule word_unat.Abs_inject)
 apply(simp only: unat_div[symmetric] word_unat.Rep)
apply(simp add: unats_def Suc_0_lt_2p_len_of)
done

lemma div_half_word:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)" by (cases x)
  obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)" by(cases y)
  let ?q = "(x >> 1) div y << 1"
  let ?q' = "2 * (n div 2 div m)"
  have "n div 2 div m < 2 ^ LENGTH('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
  hence q: "?q = of_nat ?q'" using n m
    apply(simp add: shiftr_def shiftr1_def bin_rest_def uint_nat unat_of_nat shiftl_def shiftl1_def Bit_def word_div_def word_of_nat)
    by (metis of_nat_inverse of_nat_numeral uno_simps(2) word_of_nat zdiv_int)
  from assms have "m \<noteq> 0" using m by -(rule notI, simp)

  from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
    by(metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
  moreover
  have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
    by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
  moreover have "2 * (n div 2 div m) * m \<le> n"
    by(metis div_mult2_eq div_mult_le mult.assoc mult.commute)
  ultimately
  have r: "x - ?q * y = of_nat (n - ?q' * m)"
    and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
    using n m unfolding q
    by (simp_all add: word_sub_wi word_mult_def uint_nat unat_of_nat of_nat_mult [symmetric] word_of_nat[symmetric] of_nat_diff word_le_nat_alt del: of_nat_mult)
      (metis diff_diff_left less_imp_diff_less of_nat_diff of_nat_inverse word_of_nat)
  thus ?thesis using n m div_half_nat[OF \<open>m \<noteq> 0\<close>, of n] unfolding q
    by(simp add: word_le_nat_alt word_div_def word_mod_def uint_nat unat_of_nat zmod_int[symmetric] zdiv_int[symmetric] word_of_nat[symmetric])(simp add: Let_def split del: if_split split: if_split_asm)
qed

lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len0 word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> f n"
by(auto simp add: word_set_bits_def test_bit_bl word_bl.Abs_inverse word_size)

lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
by(rule word_eqI)(simp add: word_test_bit_set_bits)

lemma word_and_mask_or_conv_and_mask:
  "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)

lemma uint_and_mask_or_full:
  fixes n :: "'a :: len word"
  assumes "n !! (LENGTH('a) - 1)"
  and "mask1 = mask (LENGTH('a) - 1)"
  and "mask2 = 1 << LENGTH('a) - 1"
  shows "uint (n AND mask1) OR mask2 = uint n"
proof -
  have "mask2 = uint (1 << LENGTH('a) - 1 :: 'a word)" using assms
    by(simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)(metis One_nat_def Suc_diff_Suc bintrunc_minus bintrunc_shiftl diff_self_eq_0 len_gt_0 len_num1 lessI uint_1 uint_word_arith_bintrs(8))
  hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << LENGTH('a) - 1 :: 'a word))"
    by(simp add: uint_or)
  also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
    using assms by(simp only: word_and_mask_or_conv_and_mask)
  also have "\<dots> = uint n" by simp
  finally show ?thesis .
qed

text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>

definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  note [simp] = word_sdiv_def word_smod_def
  have F5: "\<forall>u::'a word. - (- u) = u" by (metis minus_minus)
  have F7: "\<forall>v u::'a word. u + v = v + u" by(metis add.left_commute add_0_right)
  have F8: "\<forall>(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by (metis word_sint.Rep_inverse wi_hom_syms(1) wi_hom_syms(3))
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by (metis minus_minus word_sint.Rep_inverse' mult_minus_left add.commute mult_div_mod_eq [symmetric])
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a" by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by(metis mult.commute mult_minus_left)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a" using F7 by metis

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by simp (metis wi_hom_add wi_hom_mult add.commute mult.commute word_sint.Rep_inverse add.commute mult_div_mod_eq [symmetric])
    qed
  qed
qed

text \<open>
  This algorithm implements unsigned division in terms of signed division.
  Taken from Hacker's Delight.
\<close>

lemma divmod_via_sdivmod:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows
  "(x div y, x mod y) =
  (if 1 << (LENGTH('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
   else let q = ((x >> 1) sdiv y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof(cases "1 << (LENGTH('a) - 1) \<le> y")
  case True
  note y = this
  show ?thesis
  proof(cases "x < y")
    case True
    then have "x mod y = x"
      by (cases x, cases y) (simp add: word_less_def word_mod_def)
    thus ?thesis using True y by(simp add: word_div_lt_eq_0)
  next
    case False
    obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)" by(cases y)
    have "unat x < 2 ^ LENGTH('a)" by(rule unat_lt2p)
    also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
      by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
    also have "\<dots> \<le> 2 * n" using y n
      by(simp add: word_le_nat_alt unat_of_nat unat_p2)
    finally have div: "x div of_nat n = 1" using False n
      by(simp add: word_div_eq_1_iff not_less word_le_nat_alt unat_of_nat)
    moreover have "x mod y = x - x div y * y"
      by (metis add_diff_cancel2 word_mod_div_equality)
    with div n have "x mod y = x - y" by simp
    ultimately show ?thesis using False y n by simp
  qed
next
  case False
  note y = this
  obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)" by(cases x)
  hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
    by (cases "LENGTH('a)")
      (simp_all, simp only: of_nat_numeral [where ?'a = int, symmetric]
      zdiv_int [symmetric] of_nat_power [symmetric])
  with y n have "sint (x >> 1) = uint (x >> 1)"
    by (simp add: sint_uint sbintrunc_mod2p shiftr_div_2n) (simp add: uint_nat unat_of_nat)
  moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
    using y by (cases "LENGTH('a)")
      (simp_all add: not_le word_2p_lem word_size)
  then have "sint y = uint y"
    by (simp add: sint_uint sbintrunc_mod2p)
  ultimately show ?thesis using y
    by(subst div_half_word[OF assms])(simp add: word_sdiv_def uint_div[symmetric])
qed

text \<open>More implementations tailored towards target-language implementations\<close>

context
includes integer.lifting
begin
lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len0 word" is word_of_int .

lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
by(simp add: word_of_integer.rep_eq)
end

lemma word_of_int_code [code abstract]:
  "uint (word_of_int x :: 'a word) = x AND bin_mask (LENGTH('a :: len0))"
by(simp add: uint_word_of_int and_bin_mask_conv_mod)

context fixes f :: "nat \<Rightarrow> bool" begin

fun set_bits_aux :: "'a word \<Rightarrow> nat \<Rightarrow> 'a :: len0 word"
where
  "set_bits_aux w 0 = w"
| "set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n"

lemma set_bits_aux_conv: "set_bits_aux w n = (w << n) OR (set_bits f AND mask n)"
apply(induct w n rule: set_bits_aux.induct)
apply(auto 4 3 intro: word_eqI simp add: word_ao_nth nth_shiftl test_bit.eq_norm word_size not_less less_Suc_eq)
done

corollary set_bits_conv_set_bits_aux:
  "set_bits f = (set_bits_aux 0 (LENGTH('a)) :: 'a :: len word)"
by(simp add: set_bits_aux_conv)

end

lemma word_of_int_via_signed:
  fixes mask
  assumes mask_def: "mask = bin_mask (LENGTH('a))"
  and shift_def: "shift = 1 << LENGTH('a)"
  and index_def: "index = LENGTH('a) - 1"
  and overflow_def:"overflow = 1 << (LENGTH('a) - 1)"
  and least_def: "least = - overflow"
  shows
  "(word_of_int i :: 'a :: len word) =
   (let i' = i AND mask
    in if i' !! index then
         if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
       else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
proof -
  define i' where "i' = i AND mask"
  have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
  hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
  show ?thesis
  proof(cases "i' !! index")
    case True
    hence unf: "i' = overflow OR i'" unfolding assms i'_def
      by(auto intro!: bin_eqI simp add: bin_nth_ops)
    have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
    hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
      by(cases "LENGTH('a)")(simp_all add: not_less Bit_def)
    moreover
    have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
      by(cases "LENGTH('a)")(auto simp add: not_le Bit_def elim: less_le_trans)
    moreover
    have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
      by(auto intro!: word_eqI simp add: i'_def shift_def mask_def bin_nth_ops bin_nth_minus_p2 bin_sign_and)
    ultimately show ?thesis using True by(simp add: Let_def i'_def)
  next
    case False
    hence "i' = i AND bin_mask (LENGTH('a) - 1)" unfolding assms i'_def
      by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "LENGTH('a)", auto simp add: less_Suc_eq)
    also have "\<dots> \<le> bin_mask (LENGTH('a) - 1)" by(rule int_and_le) simp
    also have "\<dots> < overflow" unfolding overflow_def
      by(simp add: bin_mask_p1_conv_shift[symmetric])
    also
    have "least \<le> 0" unfolding least_def overflow_def by simp
    have "0 \<le> i'" by(simp add: i'_def mask_def bin_mask_ge0)
    hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
    moreover
    have "word_of_int i' = (word_of_int i :: 'a word)"
      by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
    ultimately show ?thesis using False by(simp add: Let_def i'_def)
  qed
qed

text \<open>Quickcheck conversion functions\<close>

notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_random_cnv ::
  "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
    \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
  where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
       let n = a_of_natural k
       in (n, \<lambda>_. Code_Evaluation.term_of n)))"

no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_exhaustive_cnv a_of_natural f d =
   Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

definition qc_full_exhaustive_cnv ::
  "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
  (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
where
  "qc_narrowing_drawn_from xs =
   foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

locale quickcheck_narrowing_samples =
  fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
  and zero :: "'a"
  and tr :: "typerep"
begin

function narrowing_samples :: "integer \<Rightarrow> 'a list"
where
  "narrowing_samples i =
   (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
by pat_completeness auto
termination including integer.lifting
proof(relation "measure nat_of_integer")
  fix i :: integer
  assume "0 < i"
  thus "(i - 1, i) \<in> measure nat_of_integer"
    by simp(transfer, simp)
qed simp

definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
where
  "partial_term_of_sample i =
  (if i < 0 then undefined
   else if i = 0 then zero
   else if i mod 2 = 0 then snd (a_of_integer (i div 2))
   else fst (a_of_integer (i div 2 + 1)))"

lemma partial_term_of_code:
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
    Code_Evaluation.Free (STR ''_'') tr"
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
   Code_Evaluation.term_of (partial_term_of_sample i)"
by (rule partial_term_of_anything)+

end

lemmas [code] =
  quickcheck_narrowing_samples.narrowing_samples.simps
  quickcheck_narrowing_samples.partial_term_of_sample_def

text \<open>
  The separate code target \<open>SML_word\<close> collects setups for the
  code generator that PolyML does not provide.
\<close>

setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>

code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
  (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

export_code sbintrunc bin_mask in SML

end


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

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

datatype Tree = TNode "Tree" "int" "Tree" | TNil

fun flatten :: "Tree => int list => int list" where
"flatten (TNode p z q) y = flatten p (cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun add :: "int => Tree => Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "int list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "isPermutation (tsort xs) xs"
  oops

end


section \<open>Bouncing ball example\<close>

theory BouncingBall
  imports BigStep
begin

text \<open>From Derivs in AFP/Green.\<close>
lemma has_vector_derivative_divide[derivative_intros]:
  fixes a :: "'a::real_normed_field"
  shows "(f has_vector_derivative x) F \<Longrightarrow> ((\<lambda>x. f x / a) has_vector_derivative (x / a)) F"
  unfolding divide_inverse by (fact has_vector_derivative_mult_left)

locale bouncing_ball =
  fixes g :: real and
    c :: real and
    H :: real
  assumes pos_g: "g > 0" and
    pos_c: "c > 0" and
    le1_c: "c \<le> 1"
begin

definition V :: char where "V = CHR ''v''"

lemma vars_distinct: "X \<noteq> V" "V \<noteq> X"
  unfolding X_def V_def by auto

subsection \<open>Single run\<close>

lemma bouncingBallOne:
  assumes "v0 > 0"
  shows "Valid
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0)) [])
    (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0))
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0))
        [ODEBlock (2 * v0/g) (restrict (\<lambda>t. (\<lambda>_. 0)(X := v0*t-g*t^2/2, V := v0-g*t)) {0..2 * v0/g})])"
proof -
  have 1: "ODEsol (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g))) (\<lambda>t. (\<lambda>_. 0)(X := v0 * t - g * t\<^sup>2 / 2, V := v0 - g * t)) (2 * v0 / g)"
    unfolding ODEsol_def solves_ode_def has_vderiv_on_def
    apply auto using assms pos_g apply simp
    apply (rule has_vector_derivative_projI)
    apply (auto simp add: vars_distinct state2vec_def)
     apply (rule has_vector_derivative_eq_rhs)
    unfolding power2_eq_square apply (fast intro!: derivative_intros) apply simp
    apply (rule has_vector_derivative_eq_rhs)
     apply (fast intro!: derivative_intros) apply simp
    done
  have 2: "local_lipschitz {- (1::real)<..} UNIV (\<lambda>t v. ODE2Vec (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g))) (vec2state v))"
  proof -
    have bounded: "bounded_linear (\<lambda>(y::vec). \<chi> a. if a = X then y $ V else 0)"
      apply (rule bounded_linearI')
      using vec_lambda_unique by fastforce+
    show ?thesis
      unfolding state2vec_def vec2state_def fun_upd_def
      apply (rule c1_implies_local_lipschitz[where f'="(\<lambda>(t,y). Blinfun(\<lambda>y. \<chi> a. if a = X then y $ V else 0))"])
      apply (auto simp add: bounded_linear_Blinfun_apply[OF bounded])
      subgoal premises pre for t x
        unfolding has_derivative_def apply (auto simp add: bounded)
        apply (rule vec_tendstoI)
        by (auto simp add: vars_distinct state2vec_def)
      done
  qed
  have 3: "g * t\<^sup>2 < v0 * t * 2" if "t < 2 * v0 / g" "\<not> g * t < v0" "0 \<le> t" for t
  proof -
    have "t \<noteq> 0"
      using that(2) assms by auto
    then have "t > 0"
      using that(3) by auto
    have "2 * v0 / g > t" using that by arith
    then have "2 * v0 > t * g" using pos_g
      using pos_less_divide_eq by auto
    moreover have "t * g \<ge> 0" using pos_g that(3) by auto
    ultimately have "2 * v0 * t > t * g * t" using \<open>t > 0\<close> by simp
    then show ?thesis
      unfolding power2_eq_square by (auto simp add: algebra_simps)
  qed
  have 4: "g * (2 * v0 / g)\<^sup>2 < 4 * (v0 * v0) / g \<Longrightarrow> False"
    apply (auto simp add: power2_eq_square)
    using pos_g by auto
  show ?thesis
    apply (rule Valid_ode_unique_solution[of "2 * v0/g" _ "\<lambda>t. (\<lambda>_. 0)(X := v0*t-g*t^2/2, V := v0-g*t)"])
    using assms vars_distinct pos_g 1 2 3 4 by auto
qed

definition Inv :: "state \<Rightarrow> real" where
  "Inv = (\<lambda>s. (s V) ^ 2 + 2 * g * s X)"

lemma bouncingBallInv:
  assumes "v0 > 0"
  shows "Valid
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0)) [])
    (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0))
    (\<lambda>t. \<exists>d p. t = extend_trace (Trace ((\<lambda>_. 0)(V := v0)) []) (ODEBlock d (restrict p {0..d})) \<and>
               d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) []) \<and>
               (\<forall>t. 0\<le>t \<and> t\<le>d \<longrightarrow> Inv (p t) = Inv (p 0)))"
proof -
  show ?thesis
    apply (rule Valid_ode_invariant)
    unfolding Inv_def
     apply (auto simp add: vec2state_def)[1]
     apply (auto intro!: derivative_intros)[1]
    apply (auto simp add: vec2state_def state2vec_def)
    using vars_distinct by auto
qed

inductive valid_blocks :: "real \<Rightarrow> trace_block list \<Rightarrow> bool" where
  "v0 > 0 \<Longrightarrow> valid_blocks v0 []"
| "valid_blocks v0 blks \<Longrightarrow>
   d \<ge> 0 \<Longrightarrow>
   p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<Longrightarrow>
   (\<forall>t. 0\<le>t \<and> t\<le>d \<longrightarrow> Inv (p t) = Inv (p 0)) \<Longrightarrow>
   valid_blocks v0 (blks @ [ODEBlock d (restrict p {0..d}), TauBlock ((p d)(V := - c * p d V))])"

lemma bouncingBall:
  assumes "v0 > 0"
  shows "Valid
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0)) [])
    (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0);
          Assign V (\<lambda>s. - c * s V)))
    (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks v0 blks)"
proof -
  have 1: "Valid
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks v0 blks)
     (Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g))) (\<lambda>s. 0 < s X \<or> 0 < s V))
     (\<lambda>t. \<exists>blks d p.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d})]) \<and>
             valid_blocks v0 blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks
      apply (rule Valid_post)
      prefer 2
       apply (rule Valid_ode_invariant[where inv=Inv])
        prefer 3 apply clarify
      subgoal for blks2 d p
        apply (rule exI[where x=blks]) apply (rule exI[where x=d]) apply (rule exI[where x=p])
        using pre by fastforce
      apply (auto simp add: vec2state_def Inv_def)[1]
      apply (auto intro!: derivative_intros)[1]
      by (auto simp add: state2vec_def vars_distinct)
    done
  have 2: "Valid
     (\<lambda>t. \<exists>blks d p.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d})]) \<and>
             valid_blocks v0 blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))
     (V ::= (\<lambda>s. - (c * s V)))
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks v0 blks)"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks d p
      apply (rule Valid_assign2)
      using valid_blocks.intros(2)[of v0 blks d p, OF pre]
      by (auto simp add: pre(2) end_of_blocks_append)
    done
  have 3: "Valid
      (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks v0 blks)
      (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g))) (\<lambda>s. 0 < s X \<or> 0 < s V); V ::= (\<lambda>s. - c * s V)))
      (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks v0 blks)"
    apply (auto intro!: Valid_rep Valid_seq)
    using 1 2 by auto
  show ?thesis
    apply (rule Valid_pre)
    using 3 valid_blocks.intros(1) assms by auto
qed

lemma valid_blocks_prop:
  "valid_blocks v0 blks \<Longrightarrow>
   s = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<Longrightarrow>
   Inv s \<le> v0 ^ 2"
proof (induction arbitrary: s rule: valid_blocks.induct)
  case (1 v0)
  then show ?case
    by (auto simp add: Inv_def vars_distinct)
next
  case (2 v0 blks d p)
  have s1: "s = (\<lambda>a. if a = V then - (c * p d V) else p d a)"
    using 2(6) by (auto simp add: end_of_blocks_append)
  have s2: "Inv (p 0) \<le> v0 ^ 2"
    using 2(3) 2(5) unfolding end_of_trace.simps by blast
  have s3: "Inv (p 0) = Inv (p d)"
    using 2(4) 2(2) by (metis order_refl)
  have s4: "Inv s \<le> Inv (p d)"
  proof -
    have "p d V * p d V \<ge> 0" by auto
    then have s2: "c * (p d V * p d V) \<le> p d V * p d V"
      using pos_c le1_c by (metis mult.commute mult_left_le)
    then have s3: "c * (c * (p d V * p d V)) \<le> c * (p d V * p d V)"
      using pos_c le1_c by simp
    have s4: "(c * p d V)^2 \<le> (p d V)^2"
      using s2 s3 unfolding power2_eq_square by (auto simp add: algebra_simps)
    then show ?thesis
      by (auto simp add: Inv_def s1 vars_distinct)
  qed
  show ?case
    using s2 s3 s4 by auto
qed

lemma bouncingBallFinal:
  assumes "v0 > 0"
  shows "Valid
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0)) [])
    (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0);
          Assign V (\<lambda>s. - c * s V)))
    (\<lambda>t. Inv (end_of_trace t) \<le> v0 ^ 2)"
  apply (rule Valid_post[OF _ bouncingBall])
  using valid_blocks_prop assms by auto

end  (* locale bouncing_ball *)

end