header {* Section 6 Material and Gödel's First Incompleteness Theorem*}

theory Goedel_I
imports Pf_Predicates Functions
begin

section{*The Function W and Lemma 6.1*}

subsection{*Predicate form, defined on sequences*}

definition SeqWR :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqWR s k y \<equiv> LstSeq s k y \<and> app s 0 = 0 \<and>
                        (\<forall>l \<^bold>\<in> k. app s (succ l) = q_Eats (app s l) (app s l))"

nominal_function SeqWRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl); atom sl \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqWRP s k y = LstSeqP s k y AND
          HPair Zero Zero IN s AND
          All2 l k (Ex sl (HPair (Var l) (Var sl) IN s AND
                           HPair (SUCC (Var l)) (Q_Succ (Var sl)) IN s))"
  by (auto simp: eqvt_def SeqWRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqWRP_fresh_iff [simp]: "a \<sharp> SeqWRP s k y \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> y" (is ?thesis1)
    and eval_fm_SeqWRP [simp]:   "eval_fm e (SeqWRP s k y) \<longleftrightarrow> SeqWR \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
    and SeqWRP_sf [iff]:         "Sigma_fm (SeqWRP s k y)"  (is ?thsf)
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
      by (auto simp: SeqWR_def q_defs LstSeq_imp_Ord
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma SeqWRP_subst [simp]:
      "(SeqWRP s k y)(i::=t) = SeqWRP (subst i t s) (subst i t k) (subst i t y)"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl,t,i)" "atom sl \<sharp> (s,k,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP.simps [where l=l and sl=sl])
qed

lemma SeqWRP_cong:
  assumes "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'" and  "H \<turnstile> y EQ y'"
  shows "H \<turnstile> SeqWRP s k y IFF SeqWRP s' k' y'"
  by (rule P3_cong [OF _ assms], auto)

declare SeqWRP.simps [simp del]

subsection{*Predicate form of W*}

definition WR :: "hf \<Rightarrow> hf \<Rightarrow> bool"
  where "WR x y \<equiv> (\<exists>s. SeqWR s x y)"

nominal_function WRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,y)\<rbrakk> \<Longrightarrow>
    WRP x y = Ex s (SeqWRP (Var s) x y)"
  by (auto simp: eqvt_def WRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows WRP_fresh_iff [simp]: "a \<sharp> WRP x y \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y" (is ?thesis1)
    and eval_fm_WRP [simp]:   "eval_fm e (WRP x y) \<longleftrightarrow> WR \<lbrakk>x\<rbrakk>e \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
    and sigma_fm_WRP [simp]:  "Sigma_fm (WRP x y)"  (is ?thsf)
proof -
  obtain s::name where "atom s \<sharp> (x,y)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: WR_def)
qed

lemma WRP_subst [simp]: "(WRP x y)(i::=t) = WRP (subst i t x) (subst i t y)"
proof -
  obtain s::name where "atom s \<sharp> (x,y,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: WRP.simps [of s])
qed

lemma WRP_cong: "H \<turnstile> t EQ t' \<Longrightarrow> H \<turnstile> u EQ u' \<Longrightarrow> H \<turnstile> WRP t u IFF WRP t' u'"
  by (rule P2_cong) auto

declare WRP.simps [simp del]

lemma WR0_iff: "WR 0 y \<longleftrightarrow> y=0"
  by (simp add: WR_def SeqWR_def) (metis LstSeq_1 LstSeq_app)

lemma WR0: "WR 0 0"
  by (simp add: WR0_iff)

lemma WR_succ_iff: assumes i: "Ord i" shows "WR (succ i) z = (\<exists>y. z = q_Eats y y \<and> WR i y)"
proof
  assume "WR (succ i) z"
  then obtain s where s: "SeqWR s (succ i) z"
    by (auto simp: WR_def i)
  moreover then have "app s (succ i) = z"
    by (auto simp: SeqWR_def)
  ultimately show "\<exists>y. z = q_Eats y y \<and> WR i y" using i
    by (auto simp: WR_def SeqWR_def) (metis LstSeq_trunc hmem_succ_self)
next
  assume "\<exists>y. z = q_Eats y y \<and> WR i y"
  then obtain y where z: "z = q_Eats y y" and y: "WR i y"
    by blast
  thus "WR (succ i) z" using i
    apply (auto simp: WR_def SeqWR_def)
    apply (rule_tac x="insf s (succ i) (q_Eats y y)" in exI)
    apply (auto simp: LstSeq_imp_Seq_succ app_insf_Seq_if LstSeq_insf succ_notin_self)
    done
qed

lemma WR_succ: "Ord i \<Longrightarrow> WR (succ i) (q_Eats y y) = WR i y"
  by (metis WR_succ_iff q_Eats_iff)

lemma WR_ord_of: "WR (ord_of i) \<lbrakk>\<lceil>ORD_OF i\<rceil>\<rbrakk>e"
  by (induct i) (auto simp: WR0_iff WR_succ_iff quot_Succ q_defs)

text{*Lemma 6.1*}
lemma WR_quot_Var: "WR \<lbrakk>\<lceil>Var x\<rceil>\<rbrakk>e \<lbrakk>\<lceil>\<lceil>Var x\<rceil>\<rceil>\<rbrakk>e"
  by (auto simp: quot_Var quot_Succ)
     (metis One_nat_def Ord_ord_of WR_ord_of WR_succ htuple.simps q_Eats_def)

lemma ground_WRP [simp]: "ground_fm (WRP x y) \<longleftrightarrow> ground x \<and> ground y"
  by (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh)

lemma prove_WRP:  "{} \<turnstile> WRP \<lceil>Var x\<rceil> \<lceil>\<lceil>Var x\<rceil>\<rceil>"
  by (auto simp: WR_quot_Var ground_aux_def supp_conv_fresh intro: Sigma_fm_imp_thm)

subsection{*Proving that these relations are functions*}

lemma SeqWRP_Zero_E:
  assumes "insert (y EQ Zero) H \<turnstile> A"  "H \<turnstile> k EQ Zero"
  shows "insert (SeqWRP s k y) H \<turnstile> A"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule cut_same [where A = "LstSeqP s Zero y"])
    apply (blast intro: thin1 assms  LstSeqP_cong [OF Refl _ Refl, THEN Iff_MP_same])
    apply (rule cut_same [where A = "y EQ Zero"])
    apply (blast intro: LstSeqP_EQ)
    apply (metis rotate2 assms(1) thin1)
    done
qed

lemma SeqWRP_SUCC_lemma:
  assumes y': "atom y' \<sharp> (s,k,y)"
  shows "{SeqWRP s (SUCC k) y} \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
proof -
  obtain l::name and sl::name
    where atoms: "atom l \<sharp> (s,k,y,y',sl)" "atom sl \<sharp> (s,k,y,y')"
    by (metis obtain_fresh)
  thus ?thesis using y'
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], auto)
    apply (rule Ex_I [where x = "Var sl"], auto)
    apply (blast intro: LstSeqP_SUCC) --{*showing @{term"SeqWRP s k (Var sl)"}*}
    apply (blast intro: ContraProve LstSeqP_EQ)
    done
qed

lemma SeqWRP_SUCC_E:
  assumes y': "atom y' \<sharp> (s,k,y)" and k': "H \<turnstile> k' EQ (SUCC k)"
  shows "insert (SeqWRP s k' y) H  \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
  using SeqWRP_cong [OF Refl k' Refl] cut1 [OF SeqWRP_SUCC_lemma [of y' s k y]]
  by (metis Assume Iff_MP_left Iff_sym y')

lemma SeqWRP_unique: "{OrdP x, SeqWRP s x y, SeqWRP s' x y'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and sl::name and sl'::name and l::name and pi::name
    where  i: "atom i \<sharp> (s,s',y,y')" and j: "atom j \<sharp> (s,s',i,x,y,y')" and j': "atom j' \<sharp> (s,s',i,j,x,y,y')"
      and atoms: "atom k \<sharp> (s,s',i,j,j')" "atom sl \<sharp> (s,s',i,j,j',k)" "atom sl' \<sharp> (s,s',i,j,j',k,sl)"
                 "atom pi \<sharp> (s,s',i,j,j',k,sl,sl')"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> All j (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))"
    apply (rule OrdIndH [where j=k])
    using i j j' atoms apply auto
    apply (rule rotate4)
    apply (rule OrdP_cases_E [where k=pi], simp_all)
    --{*Zero case*}
    apply (rule SeqWRP_Zero_E [THEN rotate3])
    prefer 2 apply blast
    apply (rule SeqWRP_Zero_E [THEN rotate4])
    prefer 2 apply blast
    apply (blast intro: ContraProve [THEN rotate4] Sym Trans)
    --{*SUCC case*}
    apply (rule Ex_I [where x = "Var pi"], auto)
    apply (metis ContraProve EQ_imp_SUBS2 Mem_SUCC_I2 Refl Subset_D)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl' s' "Var pi", THEN rotate4], auto)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl s "Var pi", THEN rotate7], auto)
    apply (rule All_E [where x = "Var sl", THEN rotate5], simp)
    apply (rule All_E [where x = "Var sl'"], simp)
    apply (rule Imp_E, blast)+
    apply (rule cut_same [OF Q_Succ_cong [OF Assume]])
    apply (blast intro: Trans [OF Hyp Sym] HPair_cong)
    done
  hence "{OrdP (Var i)} \<turnstile> (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))(j::=y)"
    by (metis All_D)
  hence "{OrdP (Var i)} \<turnstile> (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ y))(j'::=y')"
    using j j'
    by simp (drule All_D [where x=y'], simp)
  hence "{} \<turnstile> OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y))"
    using j j'
    by simp (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y)))(i::=x)"
    by (metis Subst emptyE)
  thus ?thesis using i
    by simp (metis anti_deduction insert_commute)
qed

theorem WRP_unique: "{OrdP x, WRP x y, WRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name
    where "atom s \<sharp> (x,y,y')"  "atom s' \<sharp> (x,y,y',s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP_unique [THEN rotate3] WRP.simps [of s _ y]  WRP.simps [of s' _ y'])
qed

subsection{*The equivalent function*}

definition W :: "hf \<Rightarrow> tm"
  where "W \<equiv> hmemrec (\<lambda>f z. if z=0 then Zero else Q_Eats (f (pred z)) (f (pred z)))"

lemma W0 [simp]: "W 0 = Zero"
  by (rule trans [OF def_hmemrec [OF W_def]]) auto

lemma W_succ [simp]: "Ord i \<Longrightarrow> W (succ i) = Q_Eats (W i) (W i)"
  by (rule trans [OF def_hmemrec [OF W_def]]) (auto simp: ecut_apply SUCC_def W_def)

lemma W_ord_of [simp]: "W (ord_of i) = \<lceil>ORD_OF i\<rceil>"
  by (induct i, auto simp: SUCC_def quot_simps)

lemma WR_iff_eq_W: "Ord x \<Longrightarrow> WR x y \<longleftrightarrow> y = \<lbrakk>W x\<rbrakk>e"
proof (induct x arbitrary: y rule: Ord_induct2)
  case 0 thus ?case
    by (metis W0 WR0_iff eval_tm.simps(1))
next
  case (succ k) thus ?case
    by (auto simp: WR_succ_iff q_Eats_def)
qed

section{*The Function HF and Lemma 6.2*}

definition SeqHR :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "SeqHR x x' s k \<equiv>
       BuildSeq2 (\<lambda>y y'. Ord y \<and> WR y y')
                 (\<lambda>u u' v v' w w'. u = \<langle>v,w\<rangle> \<and> u' = q_HPair v' w') s k x x'"

subsection {*Defining the syntax: quantified body*}

nominal_function SeqHRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn');
          atom sl' \<sharp> (s,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn');
          atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn');
          atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn');
          atom sn' \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqHRP x x' s k =
      LstSeqP s k (HPair x x') AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                ((OrdP (Var sl) AND WRP (Var sl) (Var sl')) OR
                 Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       Var sl EQ HPair (Var sm) (Var sn) AND
                       Var sl' EQ Q_HPair (Var sm') (Var sn')))))))))))"
by (auto simp: eqvt_def SeqHRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SeqHRP_fresh_iff [simp]:
      "a \<sharp> SeqHRP x x' s k \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
   and eval_fm_SeqHRP [simp]:
      "eval_fm e (SeqHRP x x' s k) \<longleftrightarrow> SeqHR \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e"  (is ?thesis2)
  and SeqHRP_sf [iff]:  "Sigma_fm (SeqHRP x x' s k)"  (is ?thsf)
  and SeqHRP_imp_OrdP: "{ SeqHRP x y s k } \<turnstile> OrdP k"  (is ?thord)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (s,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
         "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thord
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by (fastforce simp: LstSeq_imp_Ord SeqHR_def
             BuildSeq2_def BuildSeq_def Builds_def
             HBall_def q_HPair_def q_Eats_def
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"]
             cong: conj_cong)
qed

lemma SeqHRP_subst [simp]:
      "(SeqHRP x x' s k)(i::=t) = SeqHRP (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (s,k,t,i,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (s,t,i,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (s,t,i,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (s,t,i,n,sm,sm',sn,sn')" "atom n \<sharp> (s,t,i,sm,sm',sn,sn')"
          "atom sm \<sharp> (s,t,i,sm',sn,sn')" "atom sm' \<sharp> (s,t,i,sn,sn')"
          "atom sn \<sharp> (s,t,i,sn')" "atom sn' \<sharp> (s,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqHRP_cong:
  assumes "H \<turnstile> x EQ x'" and "H \<turnstile> y EQ y'" "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'"
  shows "H \<turnstile> SeqHRP x y s k IFF SeqHRP x' y' s' k'"
  by (rule P4_cong [OF _ assms], auto)

subsection {*Defining the syntax: main predicate*}

definition HR :: "hf \<Rightarrow> hf \<Rightarrow> bool"
  where "HR x x' \<equiv> \<exists>s k. SeqHR x x' s k"

nominal_function HRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,x',k); atom k \<sharp> (x,x')\<rbrakk> \<Longrightarrow>
         HRP x x' = Ex s (Ex k (SeqHRP x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def HRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows HRP_fresh_iff [simp]: "a \<sharp> HRP x x' \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x'"  (is ?thesis1)
   and eval_fm_HRP [simp]:   "eval_fm e (HRP x x') \<longleftrightarrow> HR \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e"  (is ?thesis2)
   and HRP_sf [iff]:         "Sigma_fm (HRP x x')"  (is ?thsf)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (x,x',k)"  "atom k \<sharp> (x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: HR_def q_defs)
qed

lemma HRP_subst [simp]: "(HRP x x')(i::=t) = HRP (subst i t x) (subst i t x')"
proof -
  obtain s::name and k::name where "atom s \<sharp> (x,x',t,i,k)"  "atom k \<sharp> (x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: HRP.simps [of s _ _ k])
qed

subsection{*Proving that these relations are functions*}

lemma SeqHRP_lemma:
  assumes "atom m \<sharp> (x,x',s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (x,x',s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (x,x',s,k,sm',sn,sn')" "atom sm' \<sharp> (x,x',s,k,sn,sn')"
          "atom sn \<sharp> (x,x',s,k,sn')" "atom sn' \<sharp> (x,x',s,k)"
    shows "{ SeqHRP x x' s k }
         \<turnstile> (OrdP x AND WRP x x') OR
             Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqHRP (Var sm) (Var sm') s (Var m) AND
                       SeqHRP (Var sn) (Var sn') s (Var n) AND
                       x EQ HPair (Var sm) (Var sn) AND
                       x' EQ Q_HPair (Var sm') (Var sn')))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where atoms:
          "atom l \<sharp> (x,x',s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (x,x',s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (x,x',s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using atoms assms
    apply (simp add: SeqHRP.simps [of l s k sl sl' m n sm sm' sn sn'])
    apply (rule Conj_E)
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], simp_all)
    apply (rule rotate2)
    apply (rule Ex_E Conj_E)+
    apply (rule cut_same [where A = "HPair x x' EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume LstSeqP_EQ rotate4, simp_all, clarify)
    apply (rule Disj_E [THEN rotate4])
    apply (rule Disj_I1)
    apply (metis Assume AssumeH(3) Sym thin1  Iff_MP_same [OF Conj_cong [OF OrdP_cong WRP_cong] Assume])
    --{*auto could be used but is VERY SLOW*}
    apply (rule Disj_I2)
    apply (rule Ex_E Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp add: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
    apply (rule Conj_I, blast)+
    --{*first SeqHRP subgoal*}
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    --{*next SeqHRP subgoal*}
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (auto intro!: SUCC_Subset_Ord LstSeqP_OrdP)
    --{*finally, the equality pair*}
    apply (blast intro: Trans)+
    done
qed

lemma SeqHRP_unique: "{SeqHRP x y s u, SeqHRP x y' s' u'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',y,y')"   "atom j \<sharp> (s,s',i,x,y,y')"  "atom j' \<sharp> (s,s',i,j,x,y,y')"
                  "atom k \<sharp> (s,s',x,y,y',u',i,j,j')" "atom k' \<sharp> (s,s',x,y,y',k,i,j,j')" "atom l \<sharp> (s,s',i,j,j',k,k')"
                  "atom m \<sharp> (s,s',i,j,j',k,k',l)"   "atom n \<sharp> (s,s',i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{OrdP (Var k)}
       \<turnstile> All i (All j (All j' (All k' (SeqHRP (Var i) (Var j) s (Var k) IMP (SeqHRP (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m2 "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    --{*case 1, both are ordinals*}
    apply (blast intro: cut3 [OF WRP_unique])
    --{*case 2, @{term "OrdP (Var i)"} but also a pair*}
    apply (rule Conj_EH Ex_EH)+
    apply simp_all
    apply (rule cut_same [where A = "OrdP (HPair (Var sm) (Var sn))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    --{*towards second two cases*}
    apply (rule Ex_E Disj_EH Conj_EH)+
    --{*case 3, @{term "OrdP (Var i)"} but also a pair*}
    apply (rule cut_same [where A = "OrdP (HPair (Var sm2) (Var sn2))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    --{*case 4, two pairs*}
    apply (rule Ex_E Disj_EH Conj_EH)+
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp_all)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule cut_same [where A = "HPair (Var sm) (Var sn) EQ HPair (Var sm2) (Var sn2)"])
    apply (blast intro: Sym Trans)
    apply (rule cut_same [where A = "SeqHRP (Var sn) (Var sn2') s' (Var n2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule cut_same [where A = "SeqHRP (Var sm) (Var sm2') s' (Var m2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (blast intro: Trans [OF Hyp Sym] intro!: HPair_cong)
    done
  hence "{OrdP (Var k)}
         \<turnstile> All j (All j' (All k' (SeqHRP x (Var j) s (Var k)
               IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ Var j))))"
    apply (rule All_D [where x = x, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
         \<turnstile> All j' (All k' (SeqHRP x y s (Var k) IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ y)))"
    apply (rule All_D [where x = y, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
          \<turnstile> All k' (SeqHRP x y s (Var k) IMP (SeqHRP x y' s' (Var k') IMP y' EQ y))"
    apply (rule All_D [where x = y', THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    apply (rule All_D [where x = u', THEN cut_same])
    using atoms by auto
  hence "{SeqHRP x y s (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    by (metis SeqHRP_imp_OrdP cut1)
  hence "{} \<turnstile> ((SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)))(k::=u)"
    by (metis Subst emptyE Assume MP_same Imp_I)
  hence "{} \<turnstile> SeqHRP x y s u IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    using atoms by simp
  thus ?thesis
    by (metis anti_deduction insert_commute)
qed

theorem HRP_unique: "{HRP x y, HRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (x,y,y')" "atom s' \<sharp> (x,y,y',s)"
          "atom k \<sharp> (x,y,y',s,s')" "atom k' \<sharp> (x,y,y',s,s',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP_unique HRP.simps [of s x y k]  HRP.simps [of s' x y' k'])
qed

subsection {*Finally The Function HF Itself*}

definition HF :: "hf \<Rightarrow> tm"
  where "HF \<equiv> hmemrec (\<lambda>f z. if Ord z then W z else Q_HPair (f (hfst z)) (f (hsnd z)))"

lemma HF_Ord [simp]: "Ord i \<Longrightarrow> HF i = W i"
  by (rule trans [OF def_hmemrec [OF HF_def]]) auto

lemma HF_pair [simp]: "HF (hpair x y) = Q_HPair (HF x) (HF y)"
  by (rule trans [OF def_hmemrec [OF HF_def]]) (auto simp: ecut_apply HF_def)

lemma SeqHR_hpair: "SeqHR x1 x3 s1 k1 \<Longrightarrow> SeqHR x2 x4 s2 k2 \<Longrightarrow> \<exists>s k. SeqHR \<langle>x1,x2\<rangle> (q_HPair x3 x4) s k"
  by (auto simp: SeqHR_def intro: BuildSeq2_combine)

lemma HR_H:  "coding_hf x \<Longrightarrow> HR x \<lbrakk>HF x\<rbrakk>e"
proof (induct x rule: hmem_rel_induct)
  case (step x) show ?case
  proof (cases "Ord x")
    case True thus ?thesis
      by (auto simp: HR_def SeqHR_def Ord_not_hpair WR_iff_eq_W [where e=e] intro!: BuildSeq2_exI)
  next
    case False
    then obtain x1 x2 where x: "x = \<langle>x1,x2\<rangle>"
      by (metis Ord_ord_of coding_hf.simps step.prems)
    then have x12: "(x1, x) \<in> hmem_rel" "(x2, x) \<in> hmem_rel"
      by (auto simp: hmem_rel_iff_hmem_eclose)
    have co12: "coding_hf x1"  "coding_hf x2" using False step x
      by (metis Ord_ord_of coding_hf_hpair)+
    hence "HR x1 \<lbrakk>HF x1\<rbrakk>e"  "HR x2 \<lbrakk>HF x2\<rbrakk>e"
      by (auto simp: x12 step)
    thus ?thesis using x SeqHR_hpair
      by (auto simp: HR_def q_defs)
  qed
qed

text{*Lemma 6.2*}
lemma HF_quot_coding_tm: "coding_tm t \<Longrightarrow> HF \<lbrakk>t\<rbrakk>e = \<lceil>t\<rceil>"
  by (induct t rule: coding_tm.induct) (auto, simp add: HPair_def quot_Eats)

lemma HR_quot_fm: fixes A::fm shows "HR \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<lbrakk>\<lceil>\<lceil>A\<rceil>\<rceil>\<rbrakk>e"
  by (metis HR_H HF_quot_coding_tm coding_tm_hf quot_fm_coding)

lemma prove_HRP: fixes A::fm shows "{} \<turnstile> HRP \<lceil>A\<rceil> \<lceil>\<lceil>A\<rceil>\<rceil>"
  by (auto simp: supp_conv_fresh Sigma_fm_imp_thm ground_aux_def ground_fm_aux_def HR_quot_fm)

section{*The Function K and Lemma 6.3*}

nominal_function KRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "atom y \<sharp> (v,x,x') \<Longrightarrow>
         KRP v x x' = Ex y (HRP x (Var y) AND SubstFormP v (Var y) x x')"
  by (auto simp: eqvt_def KRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma KRP_fresh_iff [simp]: "a \<sharp> KRP v x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> x \<and> a \<sharp> x'"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x')"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma KRP_subst [simp]: "(KRP v x x')(i::=t) = KRP (subst i t v) (subst i t x) (subst i t x')"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of y])
qed

declare KRP.simps [simp del]

lemma prove_SubstFormP: "{} \<turnstile> SubstFormP \<lceil>Var i\<rceil> \<lceil>\<lceil>A\<rceil>\<rceil> \<lceil>A\<rceil> \<lceil>A(i::=\<lceil>A\<rceil>)\<rceil>"
  by (auto simp: supp_conv_fresh Sigma_fm_imp_thm ground_aux_def SubstForm_quot)

lemma prove_KRP: "{} \<turnstile> KRP \<lceil>Var i\<rceil> \<lceil>A\<rceil> \<lceil>A(i::=\<lceil>A\<rceil>)\<rceil>"
  by (auto simp: KRP.simps [of y]
           intro!: Ex_I [where x="\<lceil>\<lceil>A\<rceil>\<rceil>"] prove_HRP prove_SubstFormP)

lemma KRP_unique: "{KRP v x y, KRP v x y'} \<turnstile> y' EQ y"
proof -
  obtain u::name and u'::name where "atom u \<sharp> (v,x,y,y')" "atom u' \<sharp> (v,x,y,y',u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of u v x y] KRP.simps [of u' v x y']
             intro: SubstFormP_cong [THEN Iff_MP2_same]
                    SubstFormP_unique [THEN cut2] HRP_unique [THEN cut2])
qed

lemma KRP_subst_fm: "{KRP \<lceil>Var i\<rceil> \<lceil>\<beta>\<rceil> (Var j)} \<turnstile> Var j EQ \<lceil>\<beta>(i::=\<lceil>\<beta>\<rceil>)\<rceil>"
  by (metis KRP_unique cut0 prove_KRP)

section{*The Diagonal Lemma and Gödel's Theorem*}

lemma diagonal:
  obtains \<delta> where "{} \<turnstile> \<delta> IFF \<alpha>(i::=\<lceil>\<delta>\<rceil>)"  "supp \<delta> = supp \<alpha> - {atom i}"
proof -
  obtain k::name and j::name
    where atoms: "atom k \<sharp> (i,j,\<alpha>)" "atom j \<sharp> (i,\<alpha>)"
    by (metis obtain_fresh)
  def \<beta> \<equiv> "Ex j (KRP \<lceil>Var i\<rceil> (Var i) (Var j) AND \<alpha>(i ::= Var j))"
  hence 1: "{} \<turnstile> \<beta>(i ::= \<lceil>\<beta>\<rceil>) IFF (Ex j (KRP \<lceil>Var i\<rceil> (Var i) (Var j) AND \<alpha>(i ::= Var j)))(i ::= \<lceil>\<beta>\<rceil>)"
    by (metis Iff_refl)
  have 2: "{} \<turnstile> (Ex j (KRP \<lceil>Var i\<rceil> (Var i) (Var j) AND \<alpha>(i ::= Var j)))(i ::= \<lceil>\<beta>\<rceil>) IFF
                Ex j (Var j EQ \<lceil>\<beta>(i::=\<lceil>\<beta>\<rceil>)\<rceil> AND \<alpha>(i::=Var j))"
    using atoms
    apply (auto intro!: Ex_cong Conj_cong KRP_subst_fm)
    apply (rule Iff_MP_same [OF Var_Eq_subst_Iff])
    apply (auto intro: prove_KRP thin0)
    done
  have 3: "{} \<turnstile> Ex j (Var j EQ \<lceil>\<beta>(i::=\<lceil>\<beta>\<rceil>)\<rceil> AND \<alpha>(i::=Var j)) IFF \<alpha>(i::=\<lceil>\<beta>(i::=\<lceil>\<beta>\<rceil>)\<rceil>)"
    using atoms
    apply auto
    apply (rule cut_same [OF Iff_MP2_same [OF Var_Eq_subst_Iff AssumeH(2)]])
    apply (auto intro: Ex_I [where x="\<lceil>\<beta>(i::=\<lceil>\<beta>\<rceil>)\<rceil>"])
    done
  have "supp (\<beta>(i ::= \<lceil>\<beta>\<rceil>)) = supp \<alpha> - {atom i}" using atoms
    by (auto simp: fresh_at_base ground_fm_aux_def \<beta>_def supp_conv_fresh)
  thus ?thesis using atoms
    by (metis that 1 2 3 Iff_trans)
qed

text{*Gödel's first incompleteness theorem: If consistent, our theory is incomplete.*}
theorem Goedel_I:
  assumes "\<not> {} \<turnstile> Fls"
  obtains \<delta> where "{} \<turnstile> \<delta> IFF Neg (PfP \<lceil>\<delta>\<rceil>)"  "\<not> {} \<turnstile> \<delta>"  "\<not> {} \<turnstile> Neg \<delta>"
                  "eval_fm e \<delta>"  "ground_fm \<delta>"
proof -
  fix i::name
  obtain \<delta> where        "{} \<turnstile> \<delta> IFF Neg ((PfP (Var i))(i::=\<lceil>\<delta>\<rceil>))"
             and suppd: "supp \<delta> = supp (Neg (PfP (Var i))) - {atom i}"
    by (metis SyntaxN.Neg diagonal)
  hence diag: "{} \<turnstile> \<delta> IFF Neg (PfP \<lceil>\<delta>\<rceil>)"
    by simp
  hence np: "\<not> {} \<turnstile> \<delta>"
    by (metis assms Iff_MP_same Neg_D proved_iff_proved_PfP)
  hence npn: "\<not> {} \<turnstile> Neg \<delta>" using diag
    by (metis Iff_MP_same NegNeg_D Neg_cong proved_iff_proved_PfP)
  moreover have "eval_fm e \<delta>" using hfthm_sound [where e=e, OF diag]
    by simp (metis Pf_quot_imp_is_proved np)
  moreover have "ground_fm \<delta>" using suppd
    by (simp add: supp_conv_fresh ground_fm_aux_def subset_eq) (metis fresh_ineq_at_base)
  ultimately show ?thesis
    by (metis diag np npn that)
qed

end


theory Pals

imports Main
        "../Listing"
        "../Sorting"
begin

datatype 'a openL = Stop | Sing 'a | FrontBack 'a "'a openL" 'a
(*
fun is_pal :: "'a openL \<Rightarrow> bool" where
  "is_pal Nil = True"
| "is_pal (Sing x) = True"
| "is_pal (FrontBack t xs r) = (t = r \<and> is_pal xs)"*)

fun lenD :: "'a openL \<Rightarrow> Nat" where
  "lenD Stop = Z"
| "lenD (Sing x) = S Z"
| "lenD (FrontBack _ xs _) = S (S (lenD xs))"

fun revD :: "'a openL \<Rightarrow> 'a openL" where
  "revD Stop = Stop"
| "revD (Sing x) = Sing x"
| "revD (FrontBack t xs r) = FrontBack r (revD xs) t"

fun lastD :: "'a openL \<Rightarrow> 'a" where
  "lastD (Sing t) = t"
| "lastD (FrontBack x ts y) = y"

fun headD :: "'a openL \<Rightarrow> 'a" where
  "headD (Sing t) = t"
| "headD (FrontBack x ts y) = x"

thm sorted.induct
thm List.induct
thm drop.induct
thm take.induct
thm app.induct
thm zip.induct

prf zip.induct
prf List.induct
prf last.induct
prf drop.induct

thm headD.induct
thm openL.induct
thm lastD.induct
thm List.induct
thm last.induct
thm head.induct

ML \<open>
  val t = Induct.find_inductT @{context} @{typ "Nat \<Rightarrow> 'a List \<Rightarrow> 'a List"}
\<close>

lemma lemma_ac2 []: "leq x2 Z = lez x2" (* NB: used to be problematic *)
(*by (metis leq.elims(2) leq.simps(1) leq.simps(2) lez.simps)*)
by (hipster_induct_simp_metis)

lemma leqLeqEq : "\<lbrakk> leq r t ; leq t r \<rbrakk> \<Longrightarrow> r = t"  (* schemes ... *)
by (hipster_induct_schemes leq.simps Nat.exhaust)

lemma dropTake : "ts = app (take n ts) (drop n ts)"
by hipster_induct_schemes (*
apply(induction ts rule: take.induct)
apply(case_tac n)
apply(simp_all)
done*)

(*lemma q1 : "sorted' (qsort xs)"
*)

lemma isortIds : "sorted ts \<Longrightarrow> isort ts = ts"
by hipster_induct_schemes (* sorted.induct *)

lemma insSortInvar : "sorted ts \<Longrightarrow> sorted (insert t ts)"
apply(induction ts arbitrary: t rule: sorted.induct)
apply(simp_all)
apply(metis (full_types) sorted.simps insert.simps)
by (hipster_induct_schemes sorted.simps insert.simps  ) (* sorted.induct *)

lemma isortSorts : "sorted (isort ts)"
by (hipster_induct_simp_metis insSortInvar)

lemma isortIdsP : "sorted ts \<Longrightarrow> sorted (isort ts)"
by (metis isortSorts)

lemma isortFixes : "isort (isort ts) = isort ts"
by (metis isortSorts isortIds)

lemma insSomeInsorted : "sorted ts \<Longrightarrow> isort (insert t ts) = insert t ts"
by (hipster_induct_simp_metis isortIds insSortInvar)

lemma lastElemIsLast: "last (app ts (Cons t Nil)) = t"
apply(induction ts)
apply(simp_all)
by (metis List.exhaust Listing.last.simps(2) app.simps)

lemma lastElemIsLastR: "last (app ts (Cons t Nil)) = t"
(* apply(induction ts rule: last.induct)  apply(simp_all) *)
by (hipster_induct_schemes)

lemma firstLast: "ts \<noteq> Nil \<Longrightarrow> head ts = last (rev ts)"
(* apply(induction ts)  by (simp_all add: lastElemIsLast) *)
by (metis Listing.rev.simps(2) head.cases head.simps lastElemIsLast)

lemma firstLastD: "ts \<noteq> Stop \<Longrightarrow> headD ts = lastD (revD ts)"
by (hipster_induct_simp_metis )

(* by (metis openL.exhaust headD.simps lastD.simps revD.simps) *)

(*
by (tactic {*ALLGOALS( Hipster_Tacs.timed_metis_tac @{context} @{thms
      headD.simps is_pal.elims(2) is_pal.elims(3) lastD.simps revD.simps}) *})
*)

(*
lemma lenApp: "len (app xs ts) = add (len xs) (len ts)" by hipster_induct_simp_metis
lemma addId: "add n Z = n"                              by hipster_induct_simp_metis
lemma addS2: "add n (S m) = S (add n m)"                by hipster_induct_simp_metis

lemma revLen : "len (rev xs) = len xs"
by (hipster_induct_schemes lenApp addId addS2)

lemma revDLen : "lenD (revD ts) = lenD ts"
by hipster_induct_simp_metis
lemma lastCons: "ts \<noteq> Nil \<Longrightarrow> last (Cons t ts) = last ts"
by (metis List.exhaust Listing.last.simps(2))
*)

(*
fun dropD :: "Nat \<Rightarrow> 'a openL \<Rightarrow> 'a openL" where
  "dropD _ Nil = Nil"
| "dropD Z ts  = ts"
| "dropD (S n) (Sing _) = Nil"
| "dropD (S n) (FrontBack x Nil y) = dropD n (Sing y)"
| "dropD (S n) (FrontBack x ts y)  = *)
(*
fun appD :: "'a openL \<Rightarrow> 'a openL \<Rightarrow> 'a openL" where
  "appD Nil ts = ts"
| "appD ts Nil = ts"
| "appD (Sing x) (Sing y) = FrontBack x Nil y"
| "appD (Sing x) (FrontBack t ys r) = FrontBack x (appD (Sing t) ys) r"
| "appD (FrontBack t ys r) (Sing x) = FrontBack t (appD ys (Sing r)) x"
| "appD (FrontBack t ys r) (FrontBack a xs b) = FrontBack t (appD (appD ys (Sing r)) (appD (Sing a) xs)) b"*)

(*| "appD (FrontBack t ys r) (Sing x) = FrontBack t (appD ys (Sing r)) x"
(appD (Sing t) ys
*)
end


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

declare [[values_timeout = 480.0]]

subsection {* Basic predicates *}

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 .

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 {* We expect the user to expand the tuples in the values command.
The following values command is not supported. *}
(*values "{x. zerozero x}" *)
text {* Instead, the user must type *}
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 {* Alternative Rules *}

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 {* Compilation of is_FGH requires elimination rule for is_F_or_G *}

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 {* Named alternative rules *}

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 {* With code_pred_intro, we can give fact names to the alternative rules,
  which are used for the code_pred command. *}

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 alt_nil nil show thesis by auto
  next
    case cons
    from 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 even_0 show thesis by simp
  next
    case even_plus1
    from even_plus1 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 odd_Suc show thesis by simp
  qed
qed

subsection {* Preprocessor Inlining  *}

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 {* if preprocessing fails, zerozero'' will not have all modes. *}

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

subsection {* Sets *}
(*
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 {* Numerals *}

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 {* even predicate *}

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 {* append predicate *}

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 {* tricky case with alternative rules *}

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 {* map_ofP predicate *}

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 {* filter predicate *}

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 {* reverse predicate *}

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 {* partition predicate *}

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 {* transitive predicate *}

text {* Also look at the tabled transitive closure in the Library *}

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 {* values command needs mode annotation of the parameter succ
to disambiguate which mode is to be chosen. *}

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 {* rtrancl compilation is strange! *}
(*
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 {* Free function variable *}

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

code_pred FF .

subsection {* IMP *}

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 {* CCS *}

text{* This example formalizes finite CCS processes without communication or
recursion. For simplicity, labels are natural numbers. *}

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 {* divmod *}

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 {* Transforming predicate logic into logic programs *}

subsection {* Transforming functions into logic programs *}
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 {* Minimum *}

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 {* Lexicographic order *}
text {* 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. *}

(*
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 {* AVL Tree *}

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 {* Definitions about Relations *}
(*
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 {* Inverting list functions *}

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 {* Function predicate replacement *}

text {*
If the mode analysis uses the functional mode, we
replace predicates that resulted from functions again by their functions.
*}

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 {* If append is not turned into a predicate, then the mode
  o => o => i => bool could not be inferred. *}

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

text {* If appendP is not reverted back to a function, then mode i => i => o => bool
  fails after deleting the predicate equation. *}

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 {* Redeclaring append.equation as code equation *}

declare appendP.equation[code]

subsection {* Function with tuples *}

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 {* Arithmetic examples *}

subsection {* Examples on nat *}

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 {* Examples on int *}

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 {* minus on bool *}

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 {* Functions *}

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 {* Locales *}

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 {* The global introduction rules must be redeclared as introduction rules and then
  one could invoke code_pred. *}

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 {* A locally compliant solution with a trivial interpretation fails, because
the predicate compiler has very strict assumptions about the terms and their structure. *}

(*code_pred hd_predicate_in_locale .*)

section {* Integer example *}

definition three :: int
where "three = 3"

inductive is_three
where
  "is_three three"

code_pred is_three .

thm is_three.equation

section {* String.literal example *}

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 {* Another function example *}

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 {* Examples for detecting switches *}

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 {* The higher-order predicate r is in an output term *}

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 {*
  We want that the argument r is not treated as a higher-order relation, but simply as input.
*}

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 {* Proof procedure cannot handle this situation yet. *}

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

thm test_uninterpreted_relation2.equation

text {* Trivial predicate *}

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

code_pred implies_itself .

text {* Case expressions *}

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

code_pred [inductify] map_prods .

end


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

Processes.
*)

section \<open>Processes\<close>

theory Process
imports "~~/src/HOL/Library/Stream"
begin

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

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

subsection \<open>Basic properties\<close>

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

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

subsection\<open>Coinduction\<close>

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

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

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

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

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

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

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

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

datatype x_y_ax = x | y | ax

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

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

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

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

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

hide_const x y ax X Y AX

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

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

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

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

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

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

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

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

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

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

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

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

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

(* Example: *)

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

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

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

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

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

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

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

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

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

end