(*  Title:      ZF/Constructible/WF_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness of Well-Founded Recursion\<close>

theory WF_absolute imports WFrec begin

subsection\<open>Transitive closure without fixedpoints\<close>

definition
  rtrancl_alt :: "[i,i]=>i" where
    "rtrancl_alt(A,r) ==
       {p \<in> A*A. \<exists>n\<in>nat. \<exists>f \<in> succ(n) -> A.
                 (\<exists>x y. p = <x,y> &  f`0 = x & f`n = y) &
                       (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)}"

lemma alt_rtrancl_lemma1 [rule_format]:
    "n \<in> nat
     ==> \<forall>f \<in> succ(n) -> field(r).
         (\<forall>i\<in>n. \<langle>f`i, f ` succ(i)\<rangle> \<in> r) \<longrightarrow> \<langle>f`0, f`n\<rangle> \<in> r^*"
apply (induct_tac n)
apply (simp_all add: apply_funtype rtrancl_refl, clarify)
apply (rename_tac n f)
apply (rule rtrancl_into_rtrancl)
 prefer 2 apply assumption
apply (drule_tac x="restrict(f,succ(n))" in bspec)
 apply (blast intro: restrict_type2)
apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
done

lemma rtrancl_alt_subset_rtrancl: "rtrancl_alt(field(r),r) \<subseteq> r^*"
apply (simp add: rtrancl_alt_def)
apply (blast intro: alt_rtrancl_lemma1)
done

lemma rtrancl_subset_rtrancl_alt: "r^* \<subseteq> rtrancl_alt(field(r),r)"
apply (simp add: rtrancl_alt_def, clarify)
apply (frule rtrancl_type [THEN subsetD], clarify, simp)
apply (erule rtrancl_induct)
 txt\<open>Base case, trivial\<close>
 apply (rule_tac x=0 in bexI)
  apply (rule_tac x="\<lambda>x\<in>1. xa" in bexI)
   apply simp_all
txt\<open>Inductive step\<close>
apply clarify
apply (rename_tac n f)
apply (rule_tac x="succ(n)" in bexI)
 apply (rule_tac x="\<lambda>i\<in>succ(succ(n)). if i=succ(n) then z else f`i" in bexI)
  apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
  apply (blast intro: mem_asym)
 apply typecheck
 apply auto
done

lemma rtrancl_alt_eq_rtrancl: "rtrancl_alt(field(r),r) = r^*"
by (blast del: subsetI
          intro: rtrancl_alt_subset_rtrancl rtrancl_subset_rtrancl_alt)

definition
  rtran_closure_mem :: "[i=>o,i,i,i] => o" where
    \<comment>\<open>The property of belonging to \<open>rtran_closure(r)\<close>\<close>
    "rtran_closure_mem(M,A,r,p) ==
              \<exists>nnat[M]. \<exists>n[M]. \<exists>n'[M].
               omega(M,nnat) & n\<in>nnat & successor(M,n,n') &
               (\<exists>f[M]. typed_function(M,n',A,f) &
                (\<exists>x[M]. \<exists>y[M]. \<exists>zero[M]. pair(M,x,y,p) & empty(M,zero) &
                  fun_apply(M,f,zero,x) & fun_apply(M,f,n,y)) &
                  (\<forall>j[M]. j\<in>n \<longrightarrow>
                    (\<exists>fj[M]. \<exists>sj[M]. \<exists>fsj[M]. \<exists>ffp[M].
                      fun_apply(M,f,j,fj) & successor(M,j,sj) &
                      fun_apply(M,f,sj,fsj) & pair(M,fj,fsj,ffp) & ffp \<in> r)))"

definition
  rtran_closure :: "[i=>o,i,i] => o" where
    "rtran_closure(M,r,s) ==
        \<forall>A[M]. is_field(M,r,A) \<longrightarrow>
         (\<forall>p[M]. p \<in> s \<longleftrightarrow> rtran_closure_mem(M,A,r,p))"

definition
  tran_closure :: "[i=>o,i,i] => o" where
    "tran_closure(M,r,t) ==
         \<exists>s[M]. rtran_closure(M,r,s) & composition(M,r,s,t)"

lemma (in M_basic) rtran_closure_mem_iff:
     "[|M(A); M(r); M(p)|]
      ==> rtran_closure_mem(M,A,r,p) \<longleftrightarrow>
          (\<exists>n[M]. n\<in>nat &
           (\<exists>f[M]. f \<in> succ(n) -> A &
            (\<exists>x[M]. \<exists>y[M]. p = <x,y> & f`0 = x & f`n = y) &
                           (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)))"
by (simp add: rtran_closure_mem_def Ord_succ_mem_iff nat_0_le [THEN ltD])

locale M_trancl = M_basic +
  assumes rtrancl_separation:
         "[| M(r); M(A) |] ==> separation (M, rtran_closure_mem(M,A,r))"
      and wellfounded_trancl_separation:
         "[| M(r); M(Z) |] ==>
          separation (M, \<lambda>x.
              \<exists>w[M]. \<exists>wx[M]. \<exists>rp[M].
               w \<in> Z & pair(M,w,x,wx) & tran_closure(M,r,rp) & wx \<in> rp)"

lemma (in M_trancl) rtran_closure_rtrancl:
     "M(r) ==> rtran_closure(M,r,rtrancl(r))"
apply (simp add: rtran_closure_def rtran_closure_mem_iff
                 rtrancl_alt_eq_rtrancl [symmetric] rtrancl_alt_def)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) rtrancl_closed [intro,simp]:
     "M(r) ==> M(rtrancl(r))"
apply (insert rtrancl_separation [of r "field(r)"])
apply (simp add: rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
done

lemma (in M_trancl) rtrancl_abs [simp]:
     "[| M(r); M(z) |] ==> rtran_closure(M,r,z) \<longleftrightarrow> z = rtrancl(r)"
apply (rule iffI)
 txt\<open>Proving the right-to-left implication\<close>
 prefer 2 apply (blast intro: rtran_closure_rtrancl)
apply (rule M_equalityI)
apply (simp add: rtran_closure_def rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) trancl_closed [intro,simp]:
     "M(r) ==> M(trancl(r))"
by (simp add: trancl_def comp_closed rtrancl_closed)

lemma (in M_trancl) trancl_abs [simp]:
     "[| M(r); M(z) |] ==> tran_closure(M,r,z) \<longleftrightarrow> z = trancl(r)"
by (simp add: tran_closure_def trancl_def)

lemma (in M_trancl) wellfounded_trancl_separation':
     "[| M(r); M(Z) |] ==> separation (M, \<lambda>x. \<exists>w[M]. w \<in> Z & <w,x> \<in> r^+)"
by (insert wellfounded_trancl_separation [of r Z], simp)

text\<open>Alternative proof of \<open>wf_on_trancl\<close>; inspiration for the
      relativized version.  Original version is on theory WF.\<close>
lemma "[| wf[A](r);  r-``A \<subseteq> A |] ==> wf[A](r^+)"
apply (simp add: wf_on_def wf_def)
apply (safe intro!: equalityI)
apply (drule_tac x = "{x\<in>A. \<exists>w. \<langle>w,x\<rangle> \<in> r^+ & w \<in> Z}" in spec)
apply (blast elim: tranclE)
done

lemma (in M_trancl) wellfounded_on_trancl:
     "[| wellfounded_on(M,A,r);  r-``A \<subseteq> A; M(r); M(A) |]
      ==> wellfounded_on(M,A,r^+)"
apply (simp add: wellfounded_on_def)
apply (safe intro!: equalityI)
apply (rename_tac Z x)
apply (subgoal_tac "M({x\<in>A. \<exists>w[M]. w \<in> Z & \<langle>w,x\<rangle> \<in> r^+})")
 prefer 2
 apply (blast intro: wellfounded_trancl_separation')
apply (drule_tac x = "{x\<in>A. \<exists>w[M]. w \<in> Z & \<langle>w,x\<rangle> \<in> r^+}" in rspec, safe)
apply (blast dest: transM, simp)
apply (rename_tac y w)
apply (drule_tac x=w in bspec, assumption, clarify)
apply (erule tranclE)
  apply (blast dest: transM)   (*transM is needed to prove M(xa)*)
 apply blast
done

lemma (in M_trancl) wellfounded_trancl:
     "[|wellfounded(M,r); M(r)|] ==> wellfounded(M,r^+)"
apply (simp add: wellfounded_iff_wellfounded_on_field)
apply (rule wellfounded_on_subset_A, erule wellfounded_on_trancl)
   apply blast
  apply (simp_all add: trancl_type [THEN field_rel_subset])
done

text\<open>Absoluteness for wfrec-defined functions.\<close>

(*first use is_recfun, then M_is_recfun*)

lemma (in M_trancl) wfrec_relativize:
  "[|wf(r); M(a); M(r);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) &
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) &
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> wfrec(r,a,H) = z \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, a, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) &
            z = H(a,restrict(f,r-``{a})))"
apply (frule wf_trancl)
apply (simp add: wftrec_def wfrec_def, safe)
 apply (frule wf_exists_is_recfun
              [of concl: "r^+" a "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
      apply (simp_all add: trans_trancl function_restrictI trancl_subset_times)
 apply (clarify, rule_tac x=x in rexI)
 apply (simp_all add: the_recfun_eq trans_trancl trancl_subset_times)
done

text\<open>Assuming @{term r} is transitive simplifies the occurrences of \<open>H\<close>.
      The premise @{term "relation(r)"} is necessary
      before we can replace @{term "r^+"} by @{term r}.\<close>
theorem (in M_trancl) trans_wfrec_relativize:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> wfrec(r,a,H) = z \<longleftrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f) & z = H(a,f))"
apply (frule wfrec_replacement', assumption+)
apply (simp cong: is_recfun_cong
           add: wfrec_relativize trancl_eq_r
                is_recfun_restrict_idem domain_restrict_idem)
done

theorem (in M_trancl) trans_wfrec_abs:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);  M(z);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> is_wfrec(M,MH,r,a,z) \<longleftrightarrow> z=wfrec(r,a,H)"
by (simp add: trans_wfrec_relativize [THEN iff_sym] is_wfrec_abs, blast)

lemma (in M_trancl) trans_eq_pair_wfrec_iff:
  "[|wf(r);  trans(r); relation(r); M(r);  M(y);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r,x,H,f) & y = <x, H(x,f)>)"
apply safe
 apply (simp add: trans_wfrec_relativize [THEN iff_sym, of concl: _ x])
txt\<open>converse direction\<close>
apply (rule sym)
apply (simp add: trans_wfrec_relativize, blast)
done

subsection\<open>M is closed under well-founded recursion\<close>

text\<open>Lemma with the awkward premise mentioning \<open>wfrec\<close>.\<close>
lemma (in M_trancl) wfrec_closed_lemma [rule_format]:
     "[|wf(r); M(r);
        strong_replacement(M, \<lambda>x y. y = \<langle>x, wfrec(r, x, H)\<rangle>);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(a) \<longrightarrow> M(wfrec(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption+)
apply (subst wfrec, assumption, clarify)
apply (drule_tac x1=x and x="\<lambda>x\<in>r -`` {x}. wfrec(r, x, H)"
       in rspec [THEN rspec])
apply (simp_all add: function_lam)
apply (blast intro: lam_closed dest: pair_components_in_M)
done

text\<open>Eliminates one instance of replacement.\<close>
lemma (in M_trancl) wfrec_replacement_iff:
     "strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. pair(M,x,y,z) & (\<exists>g[M]. is_recfun(r,x,H,g) & y = H(x,g))) \<longleftrightarrow>
      strong_replacement(M,
           \<lambda>x y. \<exists>f[M]. is_recfun(r,x,H,f) & y = <x, H(x,f)>)"
apply simp
apply (rule strong_replacement_cong, blast)
done

text\<open>Useful version for transitive relations\<close>
theorem (in M_trancl) trans_wfrec_closed:
     "[|wf(r); trans(r); relation(r); M(r); M(a);
       wfrec_replacement(M,MH,r);  relation2(M,MH,H);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(wfrec(r,a,H))"
apply (frule wfrec_replacement', assumption+)
apply (frule wfrec_replacement_iff [THEN iffD1])
apply (rule wfrec_closed_lemma, assumption+)
apply (simp_all add: wfrec_replacement_iff trans_eq_pair_wfrec_iff)
done

subsection\<open>Absoluteness without assuming transitivity\<close>
lemma (in M_trancl) eq_pair_wfrec_iff:
  "[|wf(r);  M(r);  M(y);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) &
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) &
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) &
            y = <x, H(x,restrict(f,r-``{x}))>)"
apply safe
 apply (simp add: wfrec_relativize [THEN iff_sym, of concl: _ x])
txt\<open>converse direction\<close>
apply (rule sym)
apply (simp add: wfrec_relativize, blast)
done

text\<open>Full version not assuming transitivity, but maybe not very useful.\<close>
theorem (in M_trancl) wfrec_closed:
     "[|wf(r); M(r); M(a);
        wfrec_replacement(M,MH,r^+);
        relation2(M,MH, \<lambda>x f. H(x, restrict(f, r -`` {x})));
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(wfrec(r,a,H))"
apply (frule wfrec_replacement'
               [of MH "r^+" "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
   prefer 4
   apply (frule wfrec_replacement_iff [THEN iffD1])
   apply (rule wfrec_closed_lemma, assumption+)
     apply (simp_all add: eq_pair_wfrec_iff func.function_restrictI)
done

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Chain
  imports Agent
begin

definition tauChain :: "ccs \<Rightarrow> ccs \<Rightarrow> bool" ("_ \<Longrightarrow>\<^sub>\<tau> _" [80, 80] 80)
  where "P \<Longrightarrow>\<^sub>\<tau> P' \<equiv> (P, P') \<in> {(P, P') | P P'. P \<longmapsto>\<tau> \<prec> P'}^*"

lemma tauChainInduct[consumes 1, case_names Base Step]:
  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "Prop P"
  and     "\<And>P' P''. \<lbrakk>P \<Longrightarrow>\<^sub>\<tau> P'; P' \<longmapsto>\<tau> \<prec> P''; Prop P'\<rbrakk> \<Longrightarrow> Prop P''"

  shows "Prop P'"
using assms
by(auto simp add: tauChain_def elim: rtrancl_induct)

lemma tauChainRefl[simp]:
  fixes P :: ccs

  shows "P \<Longrightarrow>\<^sub>\<tau> P"
by(auto simp add: tauChain_def)

lemma tauChainCons[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<longmapsto>\<tau> \<prec> P''"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using assms
by(auto simp add: tauChain_def) (blast dest: rtrancl_trans)

lemma tauChainCons2[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P' \<longmapsto>\<tau> \<prec> P''"
  and     "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using assms
by(auto simp add: tauChain_def) (blast dest: rtrancl_trans)

lemma tauChainAppend[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<Longrightarrow>\<^sub>\<tau> P''"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using \<open>P' \<Longrightarrow>\<^sub>\<tau> P''\<close> \<open>P \<Longrightarrow>\<^sub>\<tau> P'\<close>
by(induct rule: tauChainInduct) auto

lemma tauChainSum1:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P \<noteq> P'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'"
using assms
proof(induct rule: tauChainInduct)
  case Base
  thus ?case by simp
next
  case(Step P' P'')
  thus ?case
    by(case_tac "P=P'") (auto intro: Sum1 simp add: tauChain_def)
qed

lemma tauChainSum2:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     "Q \<noteq> Q'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'"
using assms
proof(induct rule: tauChainInduct)
  case Base
  thus ?case by simp
next
  case(Step Q' Q'')
  thus ?case
    by(case_tac "Q=Q'") (auto intro: Sum2 simp add: tauChain_def)
qed

lemma tauChainPar1:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q"
using assms
by(induct rule: tauChainInduct) (auto intro: Par1)

lemma tauChainPar2:
  fixes Q  :: ccs
  and   Q' :: ccs
  and   P  :: ccs

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'"
using assms
by(induct rule: tauChainInduct) (auto intro: Par2)

lemma tauChainRes:
  fixes P  :: ccs
  and   P' :: ccs
  and   x  :: name

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "\<lparr>\<nu>x\<rparr>P \<Longrightarrow>\<^sub>\<tau> \<lparr>\<nu>x\<rparr>P'"
using assms
by(induct rule: tauChainInduct) (auto dest: Res)

lemma tauChainRepl:
  fixes P :: ccs

  assumes "P \<parallel> !P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<noteq> P \<parallel> !P"

  shows "!P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
apply(induct rule: tauChainInduct)
apply auto
apply(case_tac "P' \<noteq> P \<parallel> !P")
apply auto
apply(drule Bang)
apply(simp add: tauChain_def)
by auto

end


theory Compiler_Manual
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))" |
  "[] !! i = undefined"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
proof (induct xs arbitrary: i)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof (cases "i = 0")
    case True
    then show ?thesis by auto
  next
    case False
    with Cons(2) have Hle: "0 \<le> i - 1" by simp
    have "i - 1 - int (length xs) = i - (int (length xs) + 1)" by simp
    also have "\<dots> = i - int (length xs + 1)" by simp
    also have "\<dots> = i - int (length (a # xs))" by simp
    finally have 0: "i - 1 - int (length xs) = i - int (length (a # xs))" .
    have "((a # xs) @ ys) !! i = (a # xs @ ys) !! i" by simp
    also from False have "\<dots> = (xs @ ys) !! (i - 1)" by simp
    also from Cons(1) Hle have "\<dots> = (if i - 1 < int (length xs) then xs !! (i - 1) else ys !! (i - 1 - int (length xs)))" by simp
    also have "\<dots> = (if i < int (length xs) + 1 then xs !! (i - 1) else ys !! (i - int (length (a # xs))))" by (simp add: 0)
    also have "\<dots> = (if i < int (length (a # xs)) then xs !! (i - 1) else ys !! (i - int (length (a # xs))))" by simp
    also from Hle have "\<dots> = (if i < int (length (a # xs)) then (a # xs) !! i else ys !! (i - int (length (a # xs))))" by simp
    finally show ?thesis .
  qed
qed

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

datatype instr =
  LOADI int | LOAD vname |
  ADD |
  STORE vname |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

(* note: by using hd / tl functions rather than pattern matching, we limit
  reliance on the structure of stk in the behavior of iexec, allowing us
  to simplify preconditions on lemmas that don't rely on the structure of
  the stack
*)
fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := hd stk), tl stk)" |
  "iexec (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
  "iexec (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
  "iexec (JMPGE n) (i, s, stk) = (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk)"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

(* an introduction rule that expects the LHS config parameters to already be known *)
lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P !! i) (i, s, stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i, s, stk) \<rightarrow> c'"
  by (simp add: exec1_def)
code_pred exec1
proof -
  assume "x \<turnstile> (xa, xb, xc) \<rightarrow> (xd, xe, xf)"
  with exec1_def have "\<exists>i s stk. (xa, xb, xc) = (i, s, stk) \<and> (xd, xe, xf) = iexec (x !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size x" by simp
  then obtain xa' xb' xc' where "(xa, xb, xc) = (xa', xb', xc')" and "(xd, xe, xf) = iexec (x !! xa') (xa', xb', xc')" and "0 \<le> xa'" and "xa' < size x" by blast+
  then have 0: "(xd, xe, xf) = iexec (x !! xa) (xa, xb, xc)" and 1: "0 \<le> xa" and 2: "xa < size x" by auto
  assume "\<And>P i s stk c'. \<lbrakk>x = P; (xa, xb, xc) = (i, s, stk); (xd, xe, xf) = c'; c' = iexec (P !! i) (i, s, stk); 0 \<le> i; i < size P\<rbrakk> \<Longrightarrow> thesis"
  with refl [of "x"] refl [of "(xa, xb, xc)"] refl [of "(xd, xe, xf)"] 0 1 2 show thesis by simp
qed

abbreviation exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

(* proof by case analysis on instructions, and that each case changes the PC relative to its
  initial value
*)
lemma iexec_shift [simp]:
  "(n + i', s', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
  (i', s', stk') = iexec x (i, s, stk)"
  by (cases x, auto)

(* trivial: iexec (P !! i) depends only on first i elements of P, and 0 \<le> i < size P *)
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow> c'" unfolding exec1_def
proof -
  assume "\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P"
  then obtain i s stk where "c = (i, s, stk)" and "c' = iexec (P !! i) (i, s, stk)" and "0 \<le> i" and "i < size P" by blast+
  then have "c = (i, s, stk) \<and> c' = iexec ((P @ P') !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size (P @ P')" by auto+
  then show "\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec ((P @ P') !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size (P @ P')" by blast
qed

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
proof (induct rule: star.induct)
  case (refl x)
  then show ?case by (rule star.refl)
next
  case (step x y z)
  from step(1) exec1_appendR have "P @ P' \<turnstile> x \<rightarrow> y" by simp
  with step(3) show ?case by (simp add: star.step)
qed

lemma exec1_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow> (i', s', stk') \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow> (size P' + i', s', stk')"
  by (auto simp add: exec1_def)

lemma exec_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')  \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow>* (size P' + i', s', stk')"
proof (induct rule: exec_induct)
  case (refl a aa b)
  then show ?case by (rule star.refl)
next
  case (step aa ab ac ba bb bc ca cb cc)
  from step(1) exec1_appendL have "P' @ P \<turnstile> (size P' + aa, ab, ac) \<rightarrow> (size P' + ba, bb, bc)" by simp
  with step(3) show ?case by (simp add: star.step)
qed

(* specialize append lemmas to discuss execution through concrete instructions
  while assuming the execution of preceding and following code.
*)
lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0, s, stk) \<rightarrow>* (j, t, stk') \<Longrightarrow>
  instr # P \<turnstile> (1, s, stk) \<rightarrow>* (1 + j, t, stk')"
proof (drule exec_appendL [where P'="[instr]"]) qed simp

(* as exec_appendL, with (i := i - size P'), precondition necessary to satisfy exec1 precondition *)
lemma exec_appendL_if [intro]:
  fixes i i' j :: int
  shows "size P' <= i \<Longrightarrow>
    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk') \<Longrightarrow>
    i' = size P' + j \<Longrightarrow>
    P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
proof (drule exec_appendL [where P'=P']) qed simp

(* extend exec_appendL_if with an execution on the LHS. Note the premises here that are needed
  to satisfy the preconditions for exec_appendL
*)
lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk') \<Longrightarrow>
    size P \<le> i' \<Longrightarrow>
    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'') \<Longrightarrow>
    j'' = size P + i'' \<Longrightarrow>
    P @ P' \<turnstile> (0, s, stk) \<rightarrow>* (j'', s'', stk'')"
proof (rule star_trans [OF exec_appendR exec_appendL_if])
  assume 0: "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk')"
    and 1: "size P \<le> i'"
    and 2: "P' \<turnstile> (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'')"
    and 3: "j'' = size P + i''"
  from 0 show "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk')" .
  from 1 show "size P \<le> i'" .
  from 2 show "P' \<turnstile> (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'')" .
  from 3 show "j'' = size P + i''" .
qed

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
  "acomp (N n) = [LOADI n]" |
  "acomp (V x) = [LOAD x]" |
  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
  by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
  "bcomp (And b1 b2) f n = (let
    cb2 = bcomp b2 f n;
    m = if f
      then size cb2
      else size cb2 + n;
    cb1 = bcomp b1 False m in
    cb1 @ cb2)" |
  "bcomp (Less a1 a2) f n =
    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)
    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
    And(2) [of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
  "ccomp SKIP = []" |
  "ccomp (x ::= a) = acomp a @ [STORE x]" |
  "ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
    cc\<^sub>1 = ccomp c\<^sub>1;
    cc\<^sub>2 = ccomp c\<^sub>2;
    cb = bcomp b False (size cc\<^sub>1 + 1) in
    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
  "ccomp (WHILE b DO c) = (let
    cc = ccomp c;
    cb = bcomp b False (size cc + 1) in
    cb @ cc @ [JMP (-(size cb + size cc + 1))])"

lemma ccomp_bigstep:
  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  and ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)"
    using \<open>bval b s1\<close> by fastforce
  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
    using WhileTrue.IH(1) by fastforce
  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)"
    by fastforce
  moreover have "?cw \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cw, s3, stk)" by (rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


theory Predicate_Compile_Tests
imports "~~/src/HOL/Library/Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 480.0]]

subsection \<open>Basic predicates\<close>

inductive False' :: "bool"

code_pred (expected_modes: bool) False' .
code_pred [dseq] False' .
code_pred [random_dseq] False' .

values [expected "{}" pred] "{x. False'}"
values [expected "{}" dseq 1] "{x. False'}"
values [expected "{}" random_dseq 1, 1, 1] "{x. False'}"

value "False'"

inductive True' :: "bool"
where
  "True ==> True'"

code_pred True' .
code_pred [dseq] True' .
code_pred [random_dseq] True' .

thm True'.equation
thm True'.dseq_equation
thm True'.random_dseq_equation
values [expected "{()}"] "{x. True'}"
values [expected "{}" dseq 0] "{x. True'}"
values [expected "{()}" dseq 1] "{x. True'}"
values [expected "{()}" dseq 2] "{x. True'}"
values [expected "{}" random_dseq 1, 1, 0] "{x. True'}"
values [expected "{}" random_dseq 1, 1, 1] "{x. True'}"
values [expected "{()}" random_dseq 1, 1, 2] "{x. True'}"
values [expected "{()}" random_dseq 1, 1, 3] "{x. True'}"

inductive EmptyPred :: "'a \<Rightarrow> bool"

code_pred (expected_modes: o => bool, i => bool) EmptyPred .

definition EmptyPred' :: "'a \<Rightarrow> bool"
where "EmptyPred' = (\<lambda> x. False)"

code_pred (expected_modes: o => bool, i => bool) [inductify] EmptyPred' .

inductive EmptyRel :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

code_pred (expected_modes: o => o => bool, i => o => bool, o => i => bool, i => i => bool) EmptyRel .

inductive EmptyClosure :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

code_pred
  (expected_modes: (o => o => bool) => o => o => bool, (o => o => bool) => i => o => bool,
         (o => o => bool) => o => i => bool, (o => o => bool) => i => i => bool,
         (i => o => bool) => o => o => bool, (i => o => bool) => i => o => bool,
         (i => o => bool) => o => i => bool, (i => o => bool) => i => i => bool,
         (o => i => bool) => o => o => bool, (o => i => bool) => i => o => bool,
         (o => i => bool) => o => i => bool, (o => i => bool) => i => i => bool,
         (i => i => bool) => o => o => bool, (i => i => bool) => i => o => bool,
         (i => i => bool) => o => i => bool, (i => i => bool) => i => i => bool)
  EmptyClosure .

thm EmptyClosure.equation

(* TODO: inductive package is broken!
inductive False'' :: "bool"
where
  "False \<Longrightarrow> False''"

code_pred (expected_modes: bool) False'' .

inductive EmptySet'' :: "'a \<Rightarrow> bool"
where
  "False \<Longrightarrow> EmptySet'' x"

code_pred (expected_modes: i => bool, o => bool) [inductify] EmptySet'' .
*)

consts a' :: 'a

inductive Fact :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "Fact a' a'"

code_pred (expected_modes: o => o => bool, i => o => bool, o => i => bool, i => i => bool) Fact .

text \<open>
  The following example was derived from an predicate in the CakeML formalisation provided by Lars Hupel.
\<close>
inductive predicate_where_argument_is_condition :: "bool \<Rightarrow> bool"
where
  "ck \<Longrightarrow> predicate_where_argument_is_condition ck"

code_pred predicate_where_argument_is_condition .

text \<open>Other similar examples of this kind:\<close>

inductive predicate_where_argument_is_in_equation :: "bool \<Rightarrow> bool"
where
  "ck = True \<Longrightarrow> predicate_where_argument_is_in_equation ck"

code_pred predicate_where_argument_is_in_equation .

inductive predicate_where_argument_is_condition_and_value :: "bool \<Rightarrow> bool"
where
  "predicate_where_argument_is_condition_and_value ck \<Longrightarrow> ck
     \<Longrightarrow> predicate_where_argument_is_condition_and_value ck"

code_pred predicate_where_argument_is_condition_and_value .

inductive predicate_where_argument_is_neg_condition :: "bool \<Rightarrow> bool"
where
  "\<not> ck \<Longrightarrow> predicate_where_argument_is_neg_condition ck"

code_pred predicate_where_argument_is_neg_condition .

inductive predicate_where_argument_is_neg_condition_and_in_equation :: "bool \<Rightarrow> bool"
where
  "\<not> ck \<Longrightarrow> ck = False \<Longrightarrow> predicate_where_argument_is_neg_condition_and_in_equation ck"

code_pred predicate_where_argument_is_neg_condition_and_in_equation .

inductive zerozero :: "nat * nat => bool"
where
  "zerozero (0, 0)"

code_pred (expected_modes: i => bool, i * o => bool, o * i => bool, o => bool) zerozero .
code_pred [dseq] zerozero .
code_pred [random_dseq] zerozero .

thm zerozero.equation
thm zerozero.dseq_equation
thm zerozero.random_dseq_equation

text \<open>We expect the user to expand the tuples in the values command.
The following values command is not supported.\<close>
(*values "{x. zerozero x}" *)
text \<open>Instead, the user must type\<close>
values "{(x, y). zerozero (x, y)}"

values [expected "{}" dseq 0] "{(x, y). zerozero (x, y)}"
values [expected "{(0::nat, 0::nat)}" dseq 1] "{(x, y). zerozero (x, y)}"
values [expected "{(0::nat, 0::nat)}" dseq 2] "{(x, y). zerozero (x, y)}"
values [expected "{}" random_dseq 1, 1, 2] "{(x, y). zerozero (x, y)}"
values [expected "{(0::nat, 0:: nat)}" random_dseq 1, 1, 3] "{(x, y). zerozero (x, y)}"

inductive nested_tuples :: "((int * int) * int * int) => bool"
where
  "nested_tuples ((0, 1), 2, 3)"

code_pred nested_tuples .

inductive JamesBond :: "nat => int => natural => bool"
where
  "JamesBond 0 0 7"

code_pred JamesBond .

values [expected "{(0::nat, 0::int , 7::natural)}"] "{(a, b, c). JamesBond a b c}"
values [expected "{(0::nat, 7::natural, 0:: int)}"] "{(a, c, b). JamesBond a b c}"
values [expected "{(0::int, 0::nat, 7::natural)}"] "{(b, a, c). JamesBond a b c}"
values [expected "{(0::int, 7::natural, 0::nat)}"] "{(b, c, a). JamesBond a b c}"
values [expected "{(7::natural, 0::nat, 0::int)}"] "{(c, a, b). JamesBond a b c}"
values [expected "{(7::natural, 0::int, 0::nat)}"] "{(c, b, a). JamesBond a b c}"

values [expected "{(7::natural, 0::int)}"] "{(a, b). JamesBond 0 b a}"
values [expected "{(7::natural, 0::nat)}"] "{(c, a). JamesBond a 0 c}"
values [expected "{(0::nat, 7::natural)}"] "{(a, c). JamesBond a 0 c}"

subsection \<open>Alternative Rules\<close>

datatype char = C | D | E | F | G | H

inductive is_C_or_D
where
  "(x = C) \<or> (x = D) ==> is_C_or_D x"

code_pred (expected_modes: i => bool) is_C_or_D .
thm is_C_or_D.equation

inductive is_D_or_E
where
  "(x = D) \<or> (x = E) ==> is_D_or_E x"

lemma [code_pred_intro]:
  "is_D_or_E D"
by (auto intro: is_D_or_E.intros)

lemma [code_pred_intro]:
  "is_D_or_E E"
by (auto intro: is_D_or_E.intros)

code_pred (expected_modes: o => bool, i => bool) is_D_or_E
proof -
  case is_D_or_E
  from is_D_or_E.prems show thesis
  proof
    fix xa
    assume x: "x = xa"
    assume "xa = D \<or> xa = E"
    from this show thesis
    proof
      assume "xa = D" from this x is_D_or_E(1) show thesis by simp
    next
      assume "xa = E" from this x is_D_or_E(2) show thesis by simp
    qed
  qed
qed

thm is_D_or_E.equation

inductive is_F_or_G
where
  "x = F \<or> x = G ==> is_F_or_G x"

lemma [code_pred_intro]:
  "is_F_or_G F"
by (auto intro: is_F_or_G.intros)

lemma [code_pred_intro]:
  "is_F_or_G G"
by (auto intro: is_F_or_G.intros)

inductive is_FGH
where
  "is_F_or_G x ==> is_FGH x"
| "is_FGH H"

text \<open>Compilation of is_FGH requires elimination rule for is_F_or_G\<close>

code_pred (expected_modes: o => bool, i => bool) is_FGH
proof -
  case is_F_or_G
  from is_F_or_G.prems show thesis
  proof
    fix xa
    assume x: "x = xa"
    assume "xa = F \<or> xa = G"
    from this show thesis
    proof
      assume "xa = F"
      from this x is_F_or_G(1) show thesis by simp
    next
      assume "xa = G"
      from this x is_F_or_G(2) show thesis by simp
    qed
  qed
qed

subsection \<open>Named alternative rules\<close>

inductive appending
where
  nil: "appending [] ys ys"
| cons: "appending xs ys zs \<Longrightarrow> appending (x#xs) ys (x#zs)"

lemma appending_alt_nil: "ys = zs \<Longrightarrow> appending [] ys zs"
by (auto intro: appending.intros)

lemma appending_alt_cons: "xs' = x # xs \<Longrightarrow> appending xs ys zs \<Longrightarrow> zs' = x # zs \<Longrightarrow> appending xs' ys zs'"
by (auto intro: appending.intros)

text \<open>With code_pred_intro, we can give fact names to the alternative rules,
  which are used for the code_pred command.\<close>

declare appending_alt_nil[code_pred_intro alt_nil] appending_alt_cons[code_pred_intro alt_cons]

code_pred appending
proof -
  case appending
  from appending.prems show thesis
  proof(cases)
    case nil
    from appending.alt_nil nil show thesis by auto
  next
    case cons
    from appending.alt_cons cons show thesis by fastforce
  qed
qed

inductive ya_even and ya_odd :: "nat => bool"
where
  even_zero: "ya_even 0"
| odd_plus1: "ya_even x ==> ya_odd (x + 1)"
| even_plus1: "ya_odd x ==> ya_even (x + 1)"

declare even_zero[code_pred_intro even_0]

lemma [code_pred_intro odd_Suc]: "ya_even x ==> ya_odd (Suc x)"
by (auto simp only: Suc_eq_plus1 intro: ya_even_ya_odd.intros)

lemma [code_pred_intro even_Suc]:"ya_odd x ==> ya_even (Suc x)"
by (auto simp only: Suc_eq_plus1 intro: ya_even_ya_odd.intros)

code_pred ya_even
proof -
  case ya_even
  from ya_even.prems show thesis
  proof (cases)
    case even_zero
    from even_zero ya_even.even_0 show thesis by simp
  next
    case even_plus1
    from even_plus1 ya_even.even_Suc show thesis by simp
  qed
next
  case ya_odd
  from ya_odd.prems show thesis
  proof (cases)
    case odd_plus1
    from odd_plus1 ya_odd.odd_Suc show thesis by simp
  qed
qed

subsection \<open>Preprocessor Inlining\<close>

definition "equals == (op =)"

inductive zerozero' :: "nat * nat => bool" where
  "equals (x, y) (0, 0) ==> zerozero' (x, y)"

code_pred (expected_modes: i => bool) zerozero' .

lemma zerozero'_eq: "zerozero' x == zerozero x"
proof -
  have "zerozero' = zerozero"
    apply (auto simp add: fun_eq_iff)
    apply (cases rule: zerozero'.cases)
    apply (auto simp add: equals_def intro: zerozero.intros)
    apply (cases rule: zerozero.cases)
    apply (auto simp add: equals_def intro: zerozero'.intros)
    done
  from this show "zerozero' x == zerozero x" by auto
qed

declare zerozero'_eq [code_pred_inline]

definition "zerozero'' x == zerozero' x"

text \<open>if preprocessing fails, zerozero'' will not have all modes.\<close>

code_pred (expected_modes: i * i => bool, i * o => bool, o * i => bool, o => bool) [inductify] zerozero'' .

subsection \<open>Sets\<close>
(*
inductive_set EmptySet :: "'a set"

code_pred (expected_modes: o => bool, i => bool) EmptySet .

definition EmptySet' :: "'a set"
where "EmptySet' = {}"

code_pred (expected_modes: o => bool, i => bool) [inductify] EmptySet' .
*)
subsection \<open>Numerals\<close>

definition
  "one_or_two = (%x. x = Suc 0 \<or> ( x = Suc (Suc 0)))"

code_pred [inductify] one_or_two .

code_pred [dseq] one_or_two .
code_pred [random_dseq] one_or_two .
thm one_or_two.dseq_equation
values [expected "{Suc 0, Suc (Suc 0)}"] "{x. one_or_two x}"
values [random_dseq 0,0,10] 3 "{x. one_or_two x}"

inductive one_or_two' :: "nat => bool"
where
  "one_or_two' 1"
| "one_or_two' 2"

code_pred one_or_two' .
thm one_or_two'.equation

values "{x. one_or_two' x}"

definition one_or_two'':
  "one_or_two'' == (%x. x = 1 \<or> x = (2::nat))"

code_pred [inductify] one_or_two'' .
thm one_or_two''.equation

values "{x. one_or_two'' x}"

subsection \<open>even predicate\<close>

inductive even :: "nat \<Rightarrow> bool" and odd :: "nat \<Rightarrow> bool" where
    "even 0"
  | "even n \<Longrightarrow> odd (Suc n)"
  | "odd n \<Longrightarrow> even (Suc n)"

code_pred (expected_modes: i => bool, o => bool) even .
code_pred [dseq] even .
code_pred [random_dseq] even .

thm odd.equation
thm even.equation
thm odd.dseq_equation
thm even.dseq_equation
thm odd.random_dseq_equation
thm even.random_dseq_equation

values "{x. even 2}"
values "{x. odd 2}"
values 10 "{n. even n}"
values 10 "{n. odd n}"
values [expected "{}" dseq 2] "{x. even 6}"
values [expected "{}" dseq 6] "{x. even 6}"
values [expected "{()}" dseq 7] "{x. even 6}"
values [dseq 2] "{x. odd 7}"
values [dseq 6] "{x. odd 7}"
values [dseq 7] "{x. odd 7}"
values [expected "{()}" dseq 8] "{x. odd 7}"

values [expected "{}" dseq 0] 8 "{x. even x}"
values [expected "{0::nat}" dseq 1] 8 "{x. even x}"
values [expected "{0, Suc (Suc 0)}" dseq 3] 8 "{x. even x}"
values [expected "{0, Suc (Suc 0)}" dseq 4] 8 "{x. even x}"
values [expected "{0, Suc (Suc 0), Suc (Suc (Suc (Suc 0)))}" dseq 6] 8 "{x. even x}"

values [random_dseq 1, 1, 0] 8 "{x. even x}"
values [random_dseq 1, 1, 1] 8 "{x. even x}"
values [random_dseq 1, 1, 2] 8 "{x. even x}"
values [random_dseq 1, 1, 3] 8 "{x. even x}"
values [random_dseq 1, 1, 6] 8 "{x. even x}"

values [expected "{}" random_dseq 1, 1, 7] "{x. odd 7}"
values [random_dseq 1, 1, 8] "{x. odd 7}"
values [random_dseq 1, 1, 9] "{x. odd 7}"

definition odd' where "odd' x == \<not> even x"

code_pred (expected_modes: i => bool) [inductify] odd' .
code_pred [dseq inductify] odd' .
code_pred [random_dseq inductify] odd' .

values [expected "{}" dseq 2] "{x. odd' 7}"
values [expected "{()}" dseq 9] "{x. odd' 7}"
values [expected "{}" dseq 2] "{x. odd' 8}"
values [expected "{}" dseq 10] "{x. odd' 8}"

inductive is_even :: "nat \<Rightarrow> bool"
where
  "n mod 2 = 0 \<Longrightarrow> is_even n"

code_pred (expected_modes: i => bool) is_even .

subsection \<open>append predicate\<close>

inductive append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
    "append [] xs xs"
  | "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"

code_pred (modes: i => i => o => bool as "concat", o => o => i => bool as "slice", o => i => i => bool as prefix,
  i => o => i => bool as suffix, i => i => i => bool) append .
code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as "concat", o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as "slice", o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool as prefix,
  i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as suffix, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool) append .

code_pred [dseq] append .
code_pred [random_dseq] append .

thm append.equation
thm append.dseq_equation
thm append.random_dseq_equation

values "{(ys, xs). append xs ys [0, Suc 0, 2]}"
values "{zs. append [0, Suc 0, 2] [17, 8] zs}"
values "{ys. append [0, Suc 0, 2] ys [0, Suc 0, 2, 17, 0, 5]}"

values [expected "{}" dseq 0] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
values [expected "{(([]::nat list), [Suc 0, Suc (Suc 0), Suc (Suc (Suc 0)), Suc (Suc (Suc (Suc 0))), Suc (Suc (Suc (Suc (Suc 0))))])}" dseq 1] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
values [dseq 4] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
values [dseq 6] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
values [random_dseq 1, 1, 4] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
values [random_dseq 1, 1, 1] 10 "{(xs, ys, zs::int list). append xs ys zs}"
values [random_dseq 1, 1, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
values [random_dseq 3, 1, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
values [random_dseq 1, 3, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
values [random_dseq 1, 1, 4] 10 "{(xs, ys, zs::int list). append xs ys zs}"

value "Predicate.the (concat [0::int, 1, 2] [3, 4, 5])"
value "Predicate.the (slice ([]::int list))"

text \<open>tricky case with alternative rules\<close>

inductive append2
where
  "append2 [] xs xs"
| "append2 xs ys zs \<Longrightarrow> append2 (x # xs) ys (x # zs)"

lemma append2_Nil: "append2 [] (xs::'b list) xs"
  by (simp add: append2.intros(1))

lemmas [code_pred_intro] = append2_Nil append2.intros(2)

code_pred (expected_modes: i => i => o => bool, o => o => i => bool, o => i => i => bool,
  i => o => i => bool, i => i => i => bool) append2
proof -
  case append2
  from append2.prems show thesis
  proof
    fix xs
    assume "xa = []" "xb = xs" "xc = xs"
    from this append2(1) show thesis by simp
  next
    fix xs ys zs x
    assume "xa = x # xs" "xb = ys" "xc = x # zs" "append2 xs ys zs"
    from this append2(2) show thesis by fastforce
  qed
qed

inductive tupled_append :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
where
  "tupled_append ([], xs, xs)"
| "tupled_append (xs, ys, zs) \<Longrightarrow> tupled_append (x # xs, ys, x # zs)"

code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
  i * o * i => bool, i * i * i => bool) tupled_append .

code_pred (expected_modes: i \<times> i \<times> o \<Rightarrow> bool, o \<times> o \<times> i \<Rightarrow> bool, o \<times> i \<times> i \<Rightarrow> bool,
  i \<times> o \<times> i \<Rightarrow> bool, i \<times> i \<times> i \<Rightarrow> bool) tupled_append .

code_pred [random_dseq] tupled_append .
thm tupled_append.equation

values "{xs. tupled_append ([(1::nat), 2, 3], [4, 5], xs)}"

inductive tupled_append'
where
"tupled_append' ([], xs, xs)"
| "[| ys = fst (xa, y); x # zs = snd (xa, y);
 tupled_append' (xs, ys, zs) |] ==> tupled_append' (x # xs, xa, y)"

code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
  i * o * i => bool, i * i * i => bool) tupled_append' .
thm tupled_append'.equation

inductive tupled_append'' :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
where
  "tupled_append'' ([], xs, xs)"
| "ys = fst yszs ==> x # zs = snd yszs ==> tupled_append'' (xs, ys, zs) \<Longrightarrow> tupled_append'' (x # xs, yszs)"

code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
  i * o * i => bool, i * i * i => bool) tupled_append'' .
thm tupled_append''.equation

inductive tupled_append''' :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
where
  "tupled_append''' ([], xs, xs)"
| "yszs = (ys, zs) ==> tupled_append''' (xs, yszs) \<Longrightarrow> tupled_append''' (x # xs, ys, x # zs)"

code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
  i * o * i => bool, i * i * i => bool) tupled_append''' .
thm tupled_append'''.equation

subsection \<open>map_ofP predicate\<close>

inductive map_ofP :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "map_ofP ((a, b)#xs) a b"
| "map_ofP xs a b \<Longrightarrow> map_ofP (x#xs) a b"

code_pred (expected_modes: i => o => o => bool, i => i => o => bool, i => o => i => bool, i => i => i => bool) map_ofP .
thm map_ofP.equation

subsection \<open>filter predicate\<close>

inductive filter1
for P
where
  "filter1 P [] []"
| "P x ==> filter1 P xs ys ==> filter1 P (x#xs) (x#ys)"
| "\<not> P x ==> filter1 P xs ys ==> filter1 P (x#xs) ys"

code_pred (expected_modes: (i => bool) => i => o => bool, (i => bool) => i => i => bool) filter1 .
code_pred [dseq] filter1 .
code_pred [random_dseq] filter1 .

thm filter1.equation

values [expected "{[0, Suc (Suc 0), Suc (Suc (Suc (Suc 0)))]}"] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"
values [expected "{}" dseq 9] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"
values [expected "{[0, Suc (Suc 0), Suc (Suc (Suc (Suc 0)))]}" dseq 10] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"

inductive filter2
where
  "filter2 P [] []"
| "P x ==> filter2 P xs ys ==> filter2 P (x#xs) (x#ys)"
| "\<not> P x ==> filter2 P xs ys ==> filter2 P (x#xs) ys"

code_pred (expected_modes: (i => bool) => i => i => bool, (i => bool) => i => o => bool) filter2 .
code_pred [dseq] filter2 .
code_pred [random_dseq] filter2 .

thm filter2.equation
thm filter2.random_dseq_equation

inductive filter3
for P
where
  "List.filter P xs = ys ==> filter3 P xs ys"

code_pred (expected_modes: (o => bool) => i => o => bool, (o => bool) => i => i => bool , (i => bool) => i => o => bool, (i => bool) => i => i => bool) [skip_proof] filter3 .

code_pred filter3 .
thm filter3.equation

(*
inductive filter4
where
  "List.filter P xs = ys ==> filter4 P xs ys"

code_pred (expected_modes: i => i => o => bool, i => i => i => bool) filter4 .
(*code_pred [depth_limited] filter4 .*)
(*code_pred [random] filter4 .*)
*)
subsection \<open>reverse predicate\<close>

inductive rev where
    "rev [] []"
  | "rev xs xs' ==> append xs' [x] ys ==> rev (x#xs) ys"

code_pred (expected_modes: i => o => bool, o => i => bool, i => i => bool) rev .

thm rev.equation

values "{xs. rev [0, 1, 2, 3::nat] xs}"

inductive tupled_rev where
  "tupled_rev ([], [])"
| "tupled_rev (xs, xs') \<Longrightarrow> tupled_append (xs', [x], ys) \<Longrightarrow> tupled_rev (x#xs, ys)"

code_pred (expected_modes: i * o => bool, o * i => bool, i * i => bool) tupled_rev .
thm tupled_rev.equation

subsection \<open>partition predicate\<close>

inductive partition :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  for f where
    "partition f [] [] []"
  | "f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) (x # ys) zs"
  | "\<not> f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) ys (x # zs)"

code_pred (expected_modes: (i => bool) => i => o => o => bool, (i => bool) => o => i => i => bool,
  (i => bool) => i => i => o => bool, (i => bool) => i => o => i => bool, (i => bool) => i => i => i => bool)
  partition .
code_pred [dseq] partition .
code_pred [random_dseq] partition .

values 10 "{(ys, zs). partition is_even
  [0, Suc 0, 2, 3, 4, 5, 6, 7] ys zs}"
values 10 "{zs. partition is_even zs [0, 2] [3, 5]}"
values 10 "{zs. partition is_even zs [0, 7] [3, 5]}"

inductive tupled_partition :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'a list \<times> 'a list) \<Rightarrow> bool"
  for f where
   "tupled_partition f ([], [], [])"
  | "f x \<Longrightarrow> tupled_partition f (xs, ys, zs) \<Longrightarrow> tupled_partition f (x # xs, x # ys, zs)"
  | "\<not> f x \<Longrightarrow> tupled_partition f (xs, ys, zs) \<Longrightarrow> tupled_partition f (x # xs, ys, x # zs)"

code_pred (expected_modes: (i => bool) => i => bool, (i => bool) => (i * i * o) => bool, (i => bool) => (i * o * i) => bool,
  (i => bool) => (o * i * i) => bool, (i => bool) => (i * o * o) => bool) tupled_partition .

thm tupled_partition.equation

lemma [code_pred_intro]:
  "r a b \<Longrightarrow> tranclp r a b"
  "r a b \<Longrightarrow> tranclp r b c \<Longrightarrow> tranclp r a c"
  by auto

subsection \<open>transitive predicate\<close>

text \<open>Also look at the tabled transitive closure in the Library\<close>

code_pred (modes: (i => o => bool) => i => i => bool, (i => o => bool) => i => o => bool as forwards_trancl,
  (o => i => bool) => i => i => bool, (o => i => bool) => o => i => bool as backwards_trancl, (o => o => bool) => i => i => bool, (o => o => bool) => i => o => bool,
  (o => o => bool) => o => i => bool, (o => o => bool) => o => o => bool) tranclp
proof -
  case tranclp
  from this converse_tranclpE[OF tranclp.prems] show thesis by metis
qed

code_pred [dseq] tranclp .
code_pred [random_dseq] tranclp .
thm tranclp.equation
thm tranclp.random_dseq_equation

inductive rtrancl' :: "'a => 'a => ('a => 'a => bool) => bool"
where
  "rtrancl' x x r"
| "r x y ==> rtrancl' y z r ==> rtrancl' x z r"

code_pred [random_dseq] rtrancl' .

thm rtrancl'.random_dseq_equation

inductive rtrancl'' :: "('a * 'a * ('a \<Rightarrow> 'a \<Rightarrow> bool)) \<Rightarrow> bool"
where
  "rtrancl'' (x, x, r)"
| "r x y \<Longrightarrow> rtrancl'' (y, z, r) \<Longrightarrow> rtrancl'' (x, z, r)"

code_pred rtrancl'' .

inductive rtrancl''' :: "('a * ('a * 'a) * ('a * 'a => bool)) => bool"
where
  "rtrancl''' (x, (x, x), r)"
| "r (x, y) ==> rtrancl''' (y, (z, z), r) ==> rtrancl''' (x, (z, z), r)"

code_pred rtrancl''' .

inductive succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
    "succ 0 1"
  | "succ m n \<Longrightarrow> succ (Suc m) (Suc n)"

code_pred (modes: i => i => bool, i => o => bool, o => i => bool, o => o => bool) succ .
code_pred [random_dseq] succ .
thm succ.equation
thm succ.random_dseq_equation

values 10 "{(m, n). succ n m}"
values "{m. succ 0 m}"
values "{m. succ m 0}"

text \<open>values command needs mode annotation of the parameter succ
to disambiguate which mode is to be chosen.\<close>

values [mode: i => o => bool] 20 "{n. tranclp succ 10 n}"
values [mode: o => i => bool] 10 "{n. tranclp succ n 10}"
values 20 "{(n, m). tranclp succ n m}"

inductive example_graph :: "int => int => bool"
where
  "example_graph 0 1"
| "example_graph 1 2"
| "example_graph 1 3"
| "example_graph 4 7"
| "example_graph 4 5"
| "example_graph 5 6"
| "example_graph 7 6"
| "example_graph 7 8"

inductive not_reachable_in_example_graph :: "int => int => bool"
where "\<not> (tranclp example_graph x y) ==> not_reachable_in_example_graph x y"

code_pred (expected_modes: i => i => bool) not_reachable_in_example_graph .

thm not_reachable_in_example_graph.equation
thm tranclp.equation
value "not_reachable_in_example_graph 0 3"
value "not_reachable_in_example_graph 4 8"
value "not_reachable_in_example_graph 5 6"
text \<open>rtrancl compilation is strange!\<close>
(*
value "not_reachable_in_example_graph 0 4"
value "not_reachable_in_example_graph 1 6"
value "not_reachable_in_example_graph 8 4"*)

code_pred [dseq] not_reachable_in_example_graph .

values [dseq 6] "{x. tranclp example_graph 0 3}"

values [dseq 0] "{x. not_reachable_in_example_graph 0 3}"
values [dseq 0] "{x. not_reachable_in_example_graph 0 4}"
values [dseq 20] "{x. not_reachable_in_example_graph 0 4}"
values [dseq 6] "{x. not_reachable_in_example_graph 0 3}"
values [dseq 3] "{x. not_reachable_in_example_graph 4 2}"
values [dseq 6] "{x. not_reachable_in_example_graph 4 2}"

inductive not_reachable_in_example_graph' :: "int => int => bool"
where "\<not> (rtranclp example_graph x y) ==> not_reachable_in_example_graph' x y"

code_pred not_reachable_in_example_graph' .

value "not_reachable_in_example_graph' 0 3"
(* value "not_reachable_in_example_graph' 0 5" would not terminate *)

(*values [depth_limited 0] "{x. not_reachable_in_example_graph' 0 3}"*)
(*values [depth_limited 3] "{x. not_reachable_in_example_graph' 0 3}"*) (* fails with undefined *)
(*values [depth_limited 5] "{x. not_reachable_in_example_graph' 0 3}"*)
(*values [depth_limited 1] "{x. not_reachable_in_example_graph' 0 4}"*)
(*values [depth_limit = 4] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
(*values [depth_limit = 20] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)

code_pred [dseq] not_reachable_in_example_graph' .

(*thm not_reachable_in_example_graph'.dseq_equation*)

(*values [dseq 0] "{x. not_reachable_in_example_graph' 0 3}"*)
(*values [depth_limited 3] "{x. not_reachable_in_example_graph' 0 3}"*) (* fails with undefined *)
(*values [depth_limited 5] "{x. not_reachable_in_example_graph' 0 3}"
values [depth_limited 1] "{x. not_reachable_in_example_graph' 0 4}"*)
(*values [depth_limit = 4] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
(*values [depth_limit = 20] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)

subsection \<open>Free function variable\<close>

inductive FF :: "nat => nat => bool"
where
  "f x = y ==> FF x y"

code_pred FF .

subsection \<open>IMP\<close>

type_synonym var = nat
type_synonym state = "int list"

datatype com =
  Skip |
  Ass var "state => int" |
  Seq com com |
  IF "state => bool" com com |
  While "state => bool" com

inductive tupled_exec :: "(com \<times> state \<times> state) \<Rightarrow> bool" where
"tupled_exec (Skip, s, s)" |
"tupled_exec (Ass x e, s, s[x := e(s)])" |
"tupled_exec (c1, s1, s2) ==> tupled_exec (c2, s2, s3) ==> tupled_exec (Seq c1 c2, s1, s3)" |
"b s ==> tupled_exec (c1, s, t) ==> tupled_exec (IF b c1 c2, s, t)" |
"~b s ==> tupled_exec (c2, s, t) ==> tupled_exec (IF b c1 c2, s, t)" |
"~b s ==> tupled_exec (While b c, s, s)" |
"b s1 ==> tupled_exec (c, s1, s2) ==> tupled_exec (While b c, s2, s3) ==> tupled_exec (While b c, s1, s3)"

code_pred tupled_exec .

values "{s. tupled_exec (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))), [3, 5], s)}"

subsection \<open>CCS\<close>

text\<open>This example formalizes finite CCS processes without communication or
recursion. For simplicity, labels are natural numbers.\<close>

datatype proc = nil | pre nat proc | or proc proc | par proc proc

inductive tupled_step :: "(proc \<times> nat \<times> proc) \<Rightarrow> bool"
where
"tupled_step (pre n p, n, p)" |
"tupled_step (p1, a, q) \<Longrightarrow> tupled_step (or p1 p2, a, q)" |
"tupled_step (p2, a, q) \<Longrightarrow> tupled_step (or p1 p2, a, q)" |
"tupled_step (p1, a, q) \<Longrightarrow> tupled_step (par p1 p2, a, par q p2)" |
"tupled_step (p2, a, q) \<Longrightarrow> tupled_step (par p1 p2, a, par p1 q)"

code_pred tupled_step .
thm tupled_step.equation

subsection \<open>divmod\<close>

inductive divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
    "k < l \<Longrightarrow> divmod_rel k l 0 k"
  | "k \<ge> l \<Longrightarrow> divmod_rel (k - l) l q r \<Longrightarrow> divmod_rel k l (Suc q) r"

code_pred divmod_rel .
thm divmod_rel.equation
value "Predicate.the (divmod_rel_i_i_o_o 1705 42)"

subsection \<open>Transforming predicate logic into logic programs\<close>

subsection \<open>Transforming functions into logic programs\<close>
definition
  "case_f xs ys = (case (xs @ ys) of [] => [] | (x # xs) => xs)"

code_pred [inductify, skip_proof] case_f .
thm case_fP.equation

fun fold_map_idx where
  "fold_map_idx f i y [] = (y, [])"
| "fold_map_idx f i y (x # xs) =
 (let (y', x') = f i y x; (y'', xs') = fold_map_idx f (Suc i) y' xs
 in (y'', x' # xs'))"

code_pred [inductify] fold_map_idx .

subsection \<open>Minimum\<close>

definition Min
where "Min s r x \<equiv> s x \<and> (\<forall>y. r x y \<longrightarrow> x = y)"

code_pred [inductify] Min .
thm Min.equation

subsection \<open>Lexicographic order\<close>
text \<open>This example requires to handle the differences of sets and predicates in the predicate compiler,
or to have a copy of all definitions on predicates due to the set-predicate distinction.\<close>

(*
declare lexord_def[code_pred_def]
code_pred [inductify] lexord .
code_pred [random_dseq inductify] lexord .

thm lexord.equation
thm lexord.random_dseq_equation

inductive less_than_nat :: "nat * nat => bool"
where
  "less_than_nat (0, x)"
| "less_than_nat (x, y) ==> less_than_nat (Suc x, Suc y)"

code_pred less_than_nat .

code_pred [dseq] less_than_nat .
code_pred [random_dseq] less_than_nat .

inductive test_lexord :: "nat list * nat list => bool"
where
  "lexord less_than_nat (xs, ys) ==> test_lexord (xs, ys)"

code_pred test_lexord .
code_pred [dseq] test_lexord .
code_pred [random_dseq] test_lexord .
thm test_lexord.dseq_equation
thm test_lexord.random_dseq_equation

values "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"
(*values [depth_limited 5] "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"*)

lemmas [code_pred_def] = lexn_conv lex_conv lenlex_conv
(*
code_pred [inductify] lexn .
thm lexn.equation
*)
(*
code_pred [random_dseq inductify] lexn .
thm lexn.random_dseq_equation

values [random_dseq 4, 4, 6] 100 "{(n, xs, ys::int list). lexn (%(x, y). x <= y) n (xs, ys)}"
*)

inductive has_length
where
  "has_length [] 0"
| "has_length xs i ==> has_length (x # xs) (Suc i)"

lemma has_length:
  "has_length xs n = (length xs = n)"
proof (rule iffI)
  assume "has_length xs n"
  from this show "length xs = n"
    by (rule has_length.induct) auto
next
  assume "length xs = n"
  from this show "has_length xs n"
    by (induct xs arbitrary: n) (auto intro: has_length.intros)
qed

lemma lexn_intros [code_pred_intro]:
  "has_length xs i ==> has_length ys i ==> r (x, y) ==> lexn r (Suc i) (x # xs, y # ys)"
  "lexn r i (xs, ys) ==> lexn r (Suc i) (x # xs, x # ys)"
proof -
  assume "has_length xs i" "has_length ys i" "r (x, y)"
  from this has_length show "lexn r (Suc i) (x # xs, y # ys)"
    unfolding lexn_conv Collect_def mem_def
    by fastforce
next
  assume "lexn r i (xs, ys)"
  thm lexn_conv
  from this show "lexn r (Suc i) (x#xs, x#ys)"
    unfolding Collect_def mem_def lexn_conv
    apply auto
    apply (rule_tac x="x # xys" in exI)
    by auto
qed

code_pred [random_dseq] lexn
proof -
  fix r n xs ys
  assume 1: "lexn r n (xs, ys)"
  assume 2: "\<And>r' i x xs' y ys'. r = r' ==> n = Suc i ==> (xs, ys) = (x # xs', y # ys') ==> has_length xs' i ==> has_length ys' i ==> r' (x, y) ==> thesis"
  assume 3: "\<And>r' i x xs' ys'. r = r' ==> n = Suc i ==> (xs, ys) = (x # xs', x # ys') ==> lexn r' i (xs', ys') ==> thesis"
  from 1 2 3 show thesis
    unfolding lexn_conv Collect_def mem_def
    apply (auto simp add: has_length)
    apply (case_tac xys)
    apply auto
    apply fastforce
    apply fastforce done
qed

values [random_dseq 1, 2, 5] 10 "{(n, xs, ys::int list). lexn (%(x, y). x <= y) n (xs, ys)}"

code_pred [inductify, skip_proof] lex .
thm lex.equation
thm lex_def
declare lenlex_conv[code_pred_def]
code_pred [inductify, skip_proof] lenlex .
thm lenlex.equation

code_pred [random_dseq inductify] lenlex .
thm lenlex.random_dseq_equation

values [random_dseq 4, 2, 4] 100 "{(xs, ys::int list). lenlex (%(x, y). x <= y) (xs, ys)}"

thm lists.intros
code_pred [inductify] lists .
thm lists.equation
*)
subsection \<open>AVL Tree\<close>

datatype 'a tree = ET | MKT 'a "'a tree" "'a tree" nat
fun height :: "'a tree => nat" where
"height ET = 0"
| "height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree => bool"
where
  "avl ET = True"
| "avl (MKT x l r h) = ((height l = height r \<or> height l = 1 + height r \<or> height r = 1+height l) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"
(*
code_pred [inductify] avl .
thm avl.equation*)

code_pred [new_random_dseq inductify] avl .
thm avl.new_random_dseq_equation
(* TODO: has highly non-deterministic execution time!

values [new_random_dseq 2, 1, 7] 5 "{t:: int tree. avl t}"
*)
fun set_of
where
"set_of ET = {}"
| "set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"

fun is_ord :: "nat tree => bool"
where
"is_ord ET = True"
| "is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

(*
code_pred (expected_modes: i => o => bool, i => i => bool) [inductify] set_of .
thm set_of.equation

code_pred (expected_modes: i => bool) [inductify] is_ord .
thm is_ord_aux.equation
thm is_ord.equation
*)
subsection \<open>Definitions about Relations\<close>
(*
code_pred (modes:
  (i * i => bool) => i * i => bool,
  (i * o => bool) => o * i => bool,
  (i * o => bool) => i * i => bool,
  (o * i => bool) => i * o => bool,
  (o * i => bool) => i * i => bool,
  (o * o => bool) => o * o => bool,
  (o * o => bool) => i * o => bool,
  (o * o => bool) => o * i => bool,
  (o * o => bool) => i * i => bool) [inductify] converse .

thm converse.equation
code_pred [inductify] relcomp .
thm relcomp.equation
code_pred [inductify] Image .
thm Image.equation
declare singleton_iff[code_pred_inline]
declare Id_on_def[unfolded Bex_def UNION_eq singleton_iff, code_pred_def]

code_pred (expected_modes:
  (o => bool) => o => bool,
  (o => bool) => i * o => bool,
  (o => bool) => o * i => bool,
  (o => bool) => i => bool,
  (i => bool) => i * o => bool,
  (i => bool) => o * i => bool,
  (i => bool) => i => bool) [inductify] Id_on .
thm Id_on.equation
thm Domain_unfold
code_pred (modes:
  (o * o => bool) => o => bool,
  (o * o => bool) => i => bool,
  (i * o => bool) => i => bool) [inductify] Domain .
thm Domain.equation

thm Domain_converse [symmetric]
code_pred (modes:
  (o * o => bool) => o => bool,
  (o * o => bool) => i => bool,
  (o * i => bool) => i => bool) [inductify] Range .
thm Range.equation

code_pred [inductify] Field .
thm Field.equation

thm refl_on_def
code_pred [inductify] refl_on .
thm refl_on.equation
code_pred [inductify] total_on .
thm total_on.equation
code_pred [inductify] antisym .
thm antisym.equation
code_pred [inductify] trans .
thm trans.equation
code_pred [inductify] single_valued .
thm single_valued.equation
thm inv_image_def
code_pred [inductify] inv_image .
thm inv_image.equation
*)
subsection \<open>Inverting list functions\<close>

code_pred [inductify, skip_proof] size_list' .
code_pred [new_random_dseq inductify] size_list' .
thm size_list'P.equation
thm size_list'P.new_random_dseq_equation

values [new_random_dseq 2,3,10] 3 "{xs. size_list'P (xs::nat list) (5::nat)}"

code_pred (expected_modes: i => o => bool, o => i => bool, i => i => bool) [inductify, skip_proof] List.concat .
thm concatP.equation

values "{ys. concatP [[1, 2], [3, (4::int)]] ys}"
values "{ys. concatP [[1, 2], [3]] [1, 2, (3::nat)]}"

code_pred [dseq inductify] List.concat .
thm concatP.dseq_equation

values [dseq 3] 3
  "{xs. concatP xs ([0] :: nat list)}"

values [dseq 5] 3
  "{xs. concatP xs ([1] :: int list)}"

values [dseq 5] 3
  "{xs. concatP xs ([1] :: nat list)}"

values [dseq 5] 3
  "{xs. concatP xs [(1::int), 2]}"

code_pred (expected_modes: i => o => bool, i => i => bool) [inductify] hd .
thm hdP.equation
values "{x. hdP [1, 2, (3::int)] x}"
values "{(xs, x). hdP [1, 2, (3::int)] 1}"

code_pred (expected_modes: i => o => bool, i => i => bool) [inductify] tl .
thm tlP.equation
values "{x. tlP [1, 2, (3::nat)] x}"
values "{x. tlP [1, 2, (3::int)] [3]}"

code_pred [inductify, skip_proof] last .
thm lastP.equation

code_pred [inductify, skip_proof] butlast .
thm butlastP.equation

code_pred [inductify, skip_proof] take .
thm takeP.equation

code_pred [inductify, skip_proof] drop .
thm dropP.equation
code_pred [inductify, skip_proof] zip .
thm zipP.equation

code_pred [inductify, skip_proof] upt .
(*
code_pred [inductify, skip_proof] remdups .
thm remdupsP.equation
code_pred [dseq inductify] remdups .
values [dseq 4] 5 "{xs. remdupsP xs [1, (2::int)]}"
*)
code_pred [inductify, skip_proof] remove1 .
thm remove1P.equation
values "{xs. remove1P 1 xs [2, (3::int)]}"

code_pred [inductify, skip_proof] removeAll .
thm removeAllP.equation
code_pred [dseq inductify] removeAll .

values [dseq 4] 10 "{xs. removeAllP 1 xs [(2::nat)]}"
(*
code_pred [inductify] distinct .
thm distinct.equation
*)
code_pred [inductify, skip_proof] replicate .
thm replicateP.equation
values 5 "{(n, xs). replicateP n (0::int) xs}"

code_pred [inductify, skip_proof] splice .
thm splice.simps
thm spliceP.equation

values "{xs. spliceP xs [1, 2, 3] [1, 1, 1, 2, 1, (3::nat)]}"

code_pred [inductify, skip_proof] List.rev .
code_pred [inductify] map .
code_pred [inductify] foldr .
code_pred [inductify] foldl .
code_pred [inductify] filter .
code_pred [random_dseq inductify] filter .

section \<open>Function predicate replacement\<close>

text \<open>
If the mode analysis uses the functional mode, we
replace predicates that resulted from functions again by their functions.
\<close>

inductive test_append
where
  "List.append xs ys = zs ==> test_append xs ys zs"

code_pred [inductify, skip_proof] test_append .
thm test_append.equation

text \<open>If append is not turned into a predicate, then the mode
  o => o => i => bool could not be inferred.\<close>

values 4 "{(xs::int list, ys). test_append xs ys [1, 2, 3, 4]}"

text \<open>If appendP is not reverted back to a function, then mode i => i => o => bool
  fails after deleting the predicate equation.\<close>

declare appendP.equation[code del]

values "{xs::int list. test_append [1,2] [3,4] xs}"
values "{xs::int list. test_append (replicate 1000 1) (replicate 1000 2) xs}"
values "{xs::int list. test_append (replicate 2000 1) (replicate 2000 2) xs}"

text \<open>Redeclaring append.equation as code equation\<close>

declare appendP.equation[code]

subsection \<open>Function with tuples\<close>

fun append'
where
  "append' ([], ys) = ys"
| "append' (x # xs, ys) = x # append' (xs, ys)"

inductive test_append'
where
  "append' (xs, ys) = zs ==> test_append' xs ys zs"

code_pred [inductify, skip_proof] test_append' .

thm test_append'.equation

values "{(xs::int list, ys). test_append' xs ys [1, 2, 3, 4]}"

declare append'P.equation[code del]

values "{zs :: int list. test_append' [1,2,3] [4,5] zs}"

section \<open>Arithmetic examples\<close>

subsection \<open>Examples on nat\<close>

inductive plus_nat_test :: "nat => nat => nat => bool"
where
  "x + y = z ==> plus_nat_test x y z"

code_pred [inductify, skip_proof] plus_nat_test .
code_pred [new_random_dseq inductify] plus_nat_test .

thm plus_nat_test.equation
thm plus_nat_test.new_random_dseq_equation

values [expected "{Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0))))))))}"] "{z. plus_nat_test 4 5 z}"
values [expected "{Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0))))))))}"] "{z. plus_nat_test 7 2 z}"
values [expected "{Suc (Suc (Suc (Suc 0)))}"] "{y. plus_nat_test 5 y 9}"
values [expected "{}"] "{y. plus_nat_test 9 y 8}"
values [expected "{Suc (Suc (Suc (Suc (Suc (Suc 0)))))}"] "{y. plus_nat_test 1 y 7}"
values [expected "{Suc (Suc 0)}"] "{x. plus_nat_test x 7 9}"
values [expected "{}"] "{x. plus_nat_test x 9 7}"
values [expected "{(0::nat, 0::nat)}"] "{(x, y). plus_nat_test x y 0}"
values [expected "{(0, Suc 0), (Suc 0, 0)}"] "{(x, y). plus_nat_test x y 1}"
values [expected "{(0, Suc (Suc (Suc (Suc (Suc 0))))),
                  (Suc 0, Suc (Suc (Suc (Suc 0)))),
                  (Suc (Suc 0), Suc (Suc (Suc 0))),
                  (Suc (Suc (Suc 0)), Suc (Suc 0)),
                  (Suc (Suc (Suc (Suc 0))), Suc 0),
                  (Suc (Suc (Suc (Suc (Suc 0)))), 0)}"]
  "{(x, y). plus_nat_test x y 5}"

inductive minus_nat_test :: "nat => nat => nat => bool"
where
  "x - y = z ==> minus_nat_test x y z"

code_pred [inductify, skip_proof] minus_nat_test .
code_pred [new_random_dseq inductify] minus_nat_test .

thm minus_nat_test.equation
thm minus_nat_test.new_random_dseq_equation

values [expected "{0::nat}"] "{z. minus_nat_test 4 5 z}"
values [expected "{Suc (Suc (Suc (Suc (Suc 0))))}"] "{z. minus_nat_test 7 2 z}"
values [expected "{Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))))))))))}"] "{x. minus_nat_test x 7 9}"
values [expected "{Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))))))))))}"] "{x. minus_nat_test x 9 7}"
values [expected "{0, Suc 0, Suc (Suc 0), Suc (Suc (Suc 0))}"] "{x. minus_nat_test x 3 0}"
values [expected "{0::nat}"] "{x. minus_nat_test x 0 0}"

subsection \<open>Examples on int\<close>

inductive plus_int_test :: "int => int => int => bool"
where
  "a + b = c ==> plus_int_test a b c"

code_pred [inductify, skip_proof] plus_int_test .
code_pred [new_random_dseq inductify] plus_int_test .

thm plus_int_test.equation
thm plus_int_test.new_random_dseq_equation

values [expected "{1::int}"] "{a. plus_int_test a 6 7}"
values [expected "{1::int}"] "{b. plus_int_test 6 b 7}"
values [expected "{11::int}"] "{c. plus_int_test 5 6 c}"

inductive minus_int_test :: "int => int => int => bool"
where
  "a - b = c ==> minus_int_test a b c"

code_pred [inductify, skip_proof] minus_int_test .
code_pred [new_random_dseq inductify] minus_int_test .

thm minus_int_test.equation
thm minus_int_test.new_random_dseq_equation

values [expected "{4::int}"] "{c. minus_int_test 9 5 c}"
values [expected "{9::int}"] "{a. minus_int_test a 4 5}"
values [expected "{-1::int}"] "{b. minus_int_test 4 b 5}"

subsection \<open>minus on bool\<close>

inductive All :: "nat => bool"
where
  "All x"

inductive None :: "nat => bool"

definition "test_minus_bool x = (None x - All x)"

code_pred [inductify] test_minus_bool .
thm test_minus_bool.equation

values "{x. test_minus_bool x}"

subsection \<open>Functions\<close>

fun partial_hd :: "'a list => 'a option"
where
  "partial_hd [] = Option.None"
| "partial_hd (x # xs) = Some x"

inductive hd_predicate
where
  "partial_hd xs = Some x ==> hd_predicate xs x"

code_pred (expected_modes: i => i => bool, i => o => bool) hd_predicate .

thm hd_predicate.equation

subsection \<open>Locales\<close>

inductive hd_predicate2 :: "('a list => 'a option) => 'a list => 'a => bool"
where
  "partial_hd' xs = Some x ==> hd_predicate2 partial_hd' xs x"

thm hd_predicate2.intros

code_pred (expected_modes: i => i => i => bool, i => i => o => bool) hd_predicate2 .
thm hd_predicate2.equation

locale A = fixes partial_hd :: "'a list => 'a option" begin

inductive hd_predicate_in_locale :: "'a list => 'a => bool"
where
  "partial_hd xs = Some x ==> hd_predicate_in_locale xs x"

end

text \<open>The global introduction rules must be redeclared as introduction rules and then
  one could invoke code_pred.\<close>

declare A.hd_predicate_in_locale.intros [code_pred_intro]

code_pred (expected_modes: i => i => i => bool, i => i => o => bool) A.hd_predicate_in_locale
by (auto elim: A.hd_predicate_in_locale.cases)

interpretation A partial_hd .
thm hd_predicate_in_locale.intros
text \<open>A locally compliant solution with a trivial interpretation fails, because
the predicate compiler has very strict assumptions about the terms and their structure.\<close>

(*code_pred hd_predicate_in_locale .*)

section \<open>Integer example\<close>

definition three :: int
where "three = 3"

inductive is_three
where
  "is_three three"

code_pred is_three .

thm is_three.equation

section \<open>String.literal example\<close>

definition Error_1
where
  "Error_1 = STR ''Error 1''"

definition Error_2
where
  "Error_2 = STR ''Error 2''"

inductive "is_error" :: "String.literal \<Rightarrow> bool"
where
  "is_error Error_1"
| "is_error Error_2"

code_pred is_error .

thm is_error.equation

inductive is_error' :: "String.literal \<Rightarrow> bool"
where
  "is_error' (STR ''Error1'')"
| "is_error' (STR ''Error2'')"

code_pred is_error' .

thm is_error'.equation

datatype ErrorObject = Error String.literal int

inductive is_error'' :: "ErrorObject \<Rightarrow> bool"
where
  "is_error'' (Error Error_1 3)"
| "is_error'' (Error Error_2 4)"

code_pred is_error'' .

thm is_error''.equation

section \<open>Another function example\<close>

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

inductive fun_upd :: "(('a * 'b) * ('a \<Rightarrow> 'b)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "fun_upd ((x, a), s) (s(x := f a))"

code_pred fun_upd .

thm fun_upd.equation

section \<open>Examples for detecting switches\<close>

inductive detect_switches1 where
  "detect_switches1 [] []"
| "detect_switches1 (x # xs) (y # ys)"

code_pred [detect_switches, skip_proof] detect_switches1 .

thm detect_switches1.equation

inductive detect_switches2 :: "('a => bool) => bool"
where
  "detect_switches2 P"

code_pred [detect_switches, skip_proof] detect_switches2 .
thm detect_switches2.equation

inductive detect_switches3 :: "('a => bool) => 'a list => bool"
where
  "detect_switches3 P []"
| "detect_switches3 P (x # xs)"

code_pred [detect_switches, skip_proof] detect_switches3 .

thm detect_switches3.equation

inductive detect_switches4 :: "('a => bool) => 'a list => 'a list => bool"
where
  "detect_switches4 P [] []"
| "detect_switches4 P (x # xs) (y # ys)"

code_pred [detect_switches, skip_proof] detect_switches4 .
thm detect_switches4.equation

inductive detect_switches5 :: "('a => 'a => bool) => 'a list => 'a list => bool"
where
  "detect_switches5 P [] []"
| "detect_switches5 P xs ys ==> P x y ==> detect_switches5 P (x # xs) (y # ys)"

code_pred [detect_switches, skip_proof] detect_switches5 .

thm detect_switches5.equation

inductive detect_switches6 :: "(('a => 'b => bool) * 'a list * 'b list) => bool"
where
  "detect_switches6 (P, [], [])"
| "detect_switches6 (P, xs, ys) ==> P x y ==> detect_switches6 (P, x # xs, y # ys)"

code_pred [detect_switches, skip_proof] detect_switches6 .

inductive detect_switches7 :: "('a => bool) => ('b => bool) => ('a * 'b list) => bool"
where
  "detect_switches7 P Q (a, [])"
| "P a ==> Q x ==> detect_switches7 P Q (a, x#xs)"

code_pred [skip_proof] detect_switches7 .

thm detect_switches7.equation

inductive detect_switches8 :: "nat => bool"
where
  "detect_switches8 0"
| "x mod 2 = 0 ==> detect_switches8 (Suc x)"

code_pred [detect_switches, skip_proof] detect_switches8 .

thm detect_switches8.equation

inductive detect_switches9 :: "nat => nat => bool"
where
  "detect_switches9 0 0"
| "detect_switches9 0 (Suc x)"
| "detect_switches9 (Suc x) 0"
| "x = y ==> detect_switches9 (Suc x) (Suc y)"
| "c1 = c2 ==> detect_switches9 c1 c2"

code_pred [detect_switches, skip_proof] detect_switches9 .

thm detect_switches9.equation

text \<open>The higher-order predicate r is in an output term\<close>

datatype result = Result bool

inductive fixed_relation :: "'a => bool"

inductive test_relation_in_output_terms :: "('a => bool) => 'a => result => bool"
where
  "test_relation_in_output_terms r x (Result (r x))"
| "test_relation_in_output_terms r x (Result (fixed_relation x))"

code_pred test_relation_in_output_terms .

thm test_relation_in_output_terms.equation

text \<open>
  We want that the argument r is not treated as a higher-order relation, but simply as input.
\<close>

inductive test_uninterpreted_relation :: "('a => bool) => 'a list => bool"
where
  "list_all r xs ==> test_uninterpreted_relation r xs"

code_pred (modes: i => i => bool) test_uninterpreted_relation .

thm test_uninterpreted_relation.equation

inductive list_ex'
where
  "P x ==> list_ex' P (x#xs)"
| "list_ex' P xs ==> list_ex' P (x#xs)"

code_pred list_ex' .

inductive test_uninterpreted_relation2 :: "('a => bool) => 'a list => bool"
where
  "list_ex r xs ==> test_uninterpreted_relation2 r xs"
| "list_ex' r xs ==> test_uninterpreted_relation2 r xs"

text \<open>Proof procedure cannot handle this situation yet.\<close>

code_pred (modes: i => i => bool) [skip_proof] test_uninterpreted_relation2 .

thm test_uninterpreted_relation2.equation

text \<open>Trivial predicate\<close>

inductive implies_itself :: "'a => bool"
where
  "implies_itself x ==> implies_itself x"

code_pred implies_itself .

text \<open>Case expressions\<close>

definition
  "map_prods xs ys = (map (%((a, b), c). (a, b, c)) xs = ys)"

code_pred [inductify] map_prods .

end


(*  Title:      HOL/HOLCF/ex/Domain_Proofs.thy
    Author:     Brian Huffman
*)

section \<open>Internal domain package proofs done manually\<close>

theory Domain_Proofs
imports HOLCF
begin

(*

The definitions and proofs below are for the following recursive
datatypes:

domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
   and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
   and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")

*)

(********************************************************************)

subsection \<open>Step 1: Define the new type combinators\<close>

text \<open>Start with the one-step non-recursive version\<close>

definition
  foo_bar_baz_deflF ::
    "udom defl \<rightarrow> udom defl \<times> udom defl \<times> udom defl \<rightarrow> udom defl \<times> udom defl \<times> udom defl"
where
  "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3).
    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>t2))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"

lemma foo_bar_baz_deflF_beta:
  "foo_bar_baz_deflF\<cdot>a\<cdot>t =
    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(fst (snd t))))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
unfolding foo_bar_baz_deflF_def
by (simp add: split_def)

text \<open>Individual type combinators are projected from the fixed point.\<close>

definition foo_defl :: "udom defl \<rightarrow> udom defl"
where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"

definition bar_defl :: "udom defl \<rightarrow> udom defl"
where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"

definition baz_defl :: "udom defl \<rightarrow> udom defl"
where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"

lemma defl_apply_thms:
  "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
  "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
  "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all

text \<open>Unfold rules for each combinator.\<close>

lemma foo_defl_unfold:
  "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

text "The automation for the previous steps will be quite similar to
how the fixrec package works."

(********************************************************************)

subsection \<open>Step 2: Define types, prove class instances\<close>

text \<open>Use \<open>pcpodef\<close> with the appropriate type combinator.\<close>

pcpodef 'a foo = "defl_set (foo_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

pcpodef 'a bar = "defl_set (bar_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

pcpodef 'a baz = "defl_set (baz_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

text \<open>Prove rep instance using lemma \<open>typedef_rep_class\<close>.\<close>

instantiation foo :: ("domain") "domain"
begin

definition emb_foo :: "'a foo \<rightarrow> udom"
where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"

definition prj_foo :: "udom \<rightarrow> 'a foo"
where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_foo :: "'a foo itself \<Rightarrow> udom defl"
where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a foo u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a foo itself). liftdefl_of\<cdot>DEFL('a foo)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_foo)
apply (rule below_foo_def)
apply (rule emb_foo_def)
apply (rule prj_foo_def)
apply (rule defl_foo_def)
apply (rule liftemb_foo_def)
apply (rule liftprj_foo_def)
apply (rule liftdefl_foo_def)
done

end

instantiation bar :: ("domain") "domain"
begin

definition emb_bar :: "'a bar \<rightarrow> udom"
where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"

definition prj_bar :: "udom \<rightarrow> 'a bar"
where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_bar :: "'a bar itself \<Rightarrow> udom defl"
where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a bar u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a bar itself). liftdefl_of\<cdot>DEFL('a bar)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_bar)
apply (rule below_bar_def)
apply (rule emb_bar_def)
apply (rule prj_bar_def)
apply (rule defl_bar_def)
apply (rule liftemb_bar_def)
apply (rule liftprj_bar_def)
apply (rule liftdefl_bar_def)
done

end

instantiation baz :: ("domain") "domain"
begin

definition emb_baz :: "'a baz \<rightarrow> udom"
where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"

definition prj_baz :: "udom \<rightarrow> 'a baz"
where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_baz :: "'a baz itself \<Rightarrow> udom defl"
where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a baz u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a baz itself). liftdefl_of\<cdot>DEFL('a baz)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_baz)
apply (rule below_baz_def)
apply (rule emb_baz_def)
apply (rule prj_baz_def)
apply (rule defl_baz_def)
apply (rule liftemb_baz_def)
apply (rule liftprj_baz_def)
apply (rule liftdefl_baz_def)
done

end

text \<open>Prove DEFL rules using lemma \<open>typedef_DEFL\<close>.\<close>

lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_foo_def)
done

lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_bar_def)
done

lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_baz_def)
done

text \<open>Prove DEFL equations using type combinator unfold lemmas.\<close>

lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule foo_defl_unfold)

lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule bar_defl_unfold)

lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule baz_defl_unfold)

(********************************************************************)

subsection \<open>Step 3: Define rep and abs functions\<close>

text \<open>Define them all using \<open>prj\<close> and \<open>emb\<close>!\<close>

definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
where "foo_rep \<equiv> prj oo emb"

definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
where "foo_abs \<equiv> prj oo emb"

definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
where "bar_rep \<equiv> prj oo emb"

definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
where "bar_abs \<equiv> prj oo emb"

definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
where "baz_rep \<equiv> prj oo emb"

definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
where "baz_abs \<equiv> prj oo emb"

text \<open>Prove isomorphism rules.\<close>

lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])

lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])

text \<open>Prove isodefl rules using \<open>isodefl_coerce\<close>.\<close>

lemma isodefl_foo_abs:
  "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma isodefl_bar_abs:
  "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma isodefl_baz_abs:
  "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])

(********************************************************************)

subsection \<open>Step 4: Define map functions, prove isodefl property\<close>

text \<open>Start with the one-step non-recursive version.\<close>

text \<open>Note that the type of the map function depends on which
variables are used in positive and negative positions.\<close>

definition
  foo_bar_baz_mapF ::
    "('a \<rightarrow> 'b) \<rightarrow>
     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
where
  "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
    (
      foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
          oo foo_rep
    ,
      bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
    ,
      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
    )))"

lemma foo_bar_baz_mapF_beta:
  "foo_bar_baz_mapF\<cdot>f\<cdot>d =
    (
      foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
          oo foo_rep
    ,
      bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
    ,
      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
    )"
unfolding foo_bar_baz_mapF_def
by (simp add: split_def)

text \<open>Individual map functions are projected from the fixed point.\<close>

definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"

definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"

definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"

lemma map_apply_thms:
  "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
  "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
  "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
unfolding foo_map_def bar_map_def baz_map_def by simp_all

text \<open>Prove isodefl rules for all map functions simultaneously.\<close>

lemma isodefl_foo_bar_baz:
  assumes isodefl_d: "isodefl d t"
  shows
  "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
  isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
  isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
unfolding map_apply_thms defl_apply_thms
 apply (rule parallel_fix_ind)
   apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
  apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
 apply (simp only: foo_bar_baz_mapF_beta
                   foo_bar_baz_deflF_beta
                   fst_conv snd_conv)
 apply (elim conjE)
 apply (intro
  conjI
  isodefl_foo_abs
  isodefl_bar_abs
  isodefl_baz_abs
  domain_isodefl
  isodefl_ID_DEFL isodefl_LIFTDEFL
  isodefl_d
 )
 apply assumption+
done

lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]

text \<open>Prove map ID lemmas, using isodefl_DEFL_imp_ID\<close>

lemma foo_map_ID: "foo_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_foo)
apply (rule isodefl_foo)
apply (rule isodefl_ID_DEFL)
done

lemma bar_map_ID: "bar_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_bar)
apply (rule isodefl_bar)
apply (rule isodefl_ID_DEFL)
done

lemma baz_map_ID: "baz_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_baz)
apply (rule isodefl_baz)
apply (rule isodefl_ID_DEFL)
done

(********************************************************************)

subsection \<open>Step 5: Define take functions, prove lub-take lemmas\<close>

definition
  foo_bar_baz_takeF ::
    "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
     ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
where
  "foo_bar_baz_takeF = (\<Lambda> p.
    ( foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
          oo foo_rep
    , bar_abs oo
        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
    , baz_abs oo
        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
    ))"

lemma foo_bar_baz_takeF_beta:
  "foo_bar_baz_takeF\<cdot>p =
    ( foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
          oo foo_rep
    , bar_abs oo
        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
    , baz_abs oo
        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
    )"
unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)

definition
  foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
where
  "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"

definition
  bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
where
  "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"

definition
  baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
where
  "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"

lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
unfolding foo_take_def bar_take_def baz_take_def
by (intro ch2ch_fst ch2ch_snd chain_iterate)+

lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_0 fst_strict snd_strict)+

lemma take_Suc_thms:
  "foo_take (Suc n) =
    foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
  "bar_take (Suc n) =
    bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
  "baz_take (Suc n) =
    baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+

lemma lub_take_lemma:
  "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
    = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
apply (simp only: map_apply_thms prod.collapse)
apply (simp only: fix_def2)
apply (rule lub_eq)
apply (rule nat.induct)
apply (simp only: iterate_0 Pair_strict take_0_thms)
apply (simp only: iterate_Suc prod_eq_iff fst_conv snd_conv
                  foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
done

lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
apply (rule trans [OF _ foo_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
apply (rule trans [OF _ bar_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
apply (rule trans [OF _ baz_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

end