header{*Formalizing Provability*}

theory Pf_Predicates
imports Coding_Predicates
begin

section {* Section 4 Predicates (Leading up to Pf)*}

subsection {*The predicate @{text SentP}, for the Sentiential (Boolean) Axioms*}

definition Sent_axioms :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool" where
 "Sent_axioms x y z w \<equiv>
             x = q_Imp y y \<or>
             x = q_Imp y (q_Disj y z) \<or>
             x = q_Imp (q_Disj y y) y \<or>
             x = q_Imp (q_Disj y (q_Disj z w)) (q_Disj (q_Disj y z) w) \<or>
             x = q_Imp (q_Disj y z) (q_Imp (q_Disj (q_Neg y) w) (q_Disj z w))"

definition Sent :: "hf set" where
 "Sent \<equiv> {x. \<exists>y z w. Form y \<and> Form z \<and> Form w \<and> Sent_axioms x y z w}"

nominal_function SentP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom y \<sharp> (z,w,x); atom z \<sharp> (w,x); atom w \<sharp> x\<rbrakk> \<Longrightarrow>
    SentP x = Ex y (Ex z (Ex w (FormP (Var y) AND FormP (Var z) AND FormP (Var w) AND
               ( (x EQ Q_Imp (Var y) (Var y)) OR
                 (x EQ Q_Imp (Var y) (Q_Disj (Var y) (Var z)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var y)) (Var y)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Q_Disj (Var z) (Var w)))
                             (Q_Disj (Q_Disj (Var y) (Var z)) (Var w))) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var z))
                             (Q_Imp (Q_Disj (Q_Neg (Var y)) (Var w)) (Q_Disj (Var z) (Var w)))))))))"
  by (auto simp: eqvt_def SentP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SentP_fresh_iff [simp]: "a \<sharp> SentP x \<longleftrightarrow> a \<sharp> x"                  (is ?thesis1)
   and eval_fm_SentP [simp]:   "eval_fm e (SentP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Sent"    (is ?thesis2)
   and SentP_sf [iff]:         "Sigma_fm (SentP x)"                     (is ?thsf)
proof -
  obtain y::name and z::name and w::name  where "atom y \<sharp> (z,w,x)" "atom z \<sharp> (w,x)" "atom w \<sharp> x"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Sent_def Sent_axioms_def q_defs)
qed

subsection {*The predicate @{text Equality_axP}, for the Equality Axioms*}

definition Equality_ax :: "hf set" where
 "Equality_ax \<equiv> { \<lbrakk>\<lceil>refl_ax\<rceil>\<rbrakk>e0, \<lbrakk>\<lceil>eq_cong_ax\<rceil>\<rbrakk>e0, \<lbrakk>\<lceil>mem_cong_ax\<rceil>\<rbrakk>e0, \<lbrakk>\<lceil>eats_cong_ax\<rceil>\<rbrakk>e0 }"

function Equality_axP :: "tm \<Rightarrow> fm"
  where "Equality_axP x =
    x EQ \<lceil>refl_ax\<rceil> OR x EQ \<lceil>eq_cong_ax\<rceil> OR x EQ \<lceil>mem_cong_ax\<rceil> OR x EQ \<lceil>eats_cong_ax\<rceil>"
by auto

termination
  by lexicographic_order

lemma eval_fm_Equality_axP [simp]: "eval_fm e (Equality_axP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Equality_ax"
  by (auto simp: Equality_ax_def intro: eval_quot_fm_ignore)

subsection {*The predicate @{text HF_axP}, for the HF Axioms*}

definition HF_ax :: "hf set" where
  "HF_ax \<equiv> {\<lbrakk>\<lceil>HF1\<rceil>\<rbrakk>e0, \<lbrakk>\<lceil>HF2\<rceil>\<rbrakk>e0}"

function HF_axP :: "tm \<Rightarrow> fm"
  where "HF_axP x = x EQ \<lceil>HF1\<rceil> OR x EQ \<lceil>HF2\<rceil>"
by auto

termination
  by lexicographic_order

lemma eval_fm_HF_axP [simp]: "eval_fm e (HF_axP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> HF_ax"
  by (auto simp: HF_ax_def intro: eval_quot_fm_ignore)

lemma HF_axP_sf [iff]: "Sigma_fm (HF_axP t)"
  by auto

subsection {*The specialisation axioms*}

inductive_set Special_ax :: "hf set" where
  I: "\<lbrakk>AbstForm v 0 x ax; SubstForm v y x sx; Form x; is_Var v; Term y\<rbrakk>
      \<Longrightarrow> q_Imp sx (q_Ex ax) \<in> Special_ax"

subsubsection {*Defining the syntax*}

nominal_function Special_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom v \<sharp> (p,sx,y,ax,x); atom x \<sharp> (p,sx,y,ax);
    atom ax \<sharp> (p,sx,y); atom y \<sharp> (p,sx); atom sx \<sharp> p\<rbrakk> \<Longrightarrow>
  Special_axP p = Ex v (Ex x (Ex ax (Ex y (Ex sx
                   (FormP (Var x) AND VarP (Var v) AND TermP (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var ax) AND
                    SubstFormP (Var v) (Var y) (Var x) (Var sx) AND
                    p EQ Q_Imp (Var sx) (Q_Ex (Var ax)))))))"
  by (auto simp: eqvt_def Special_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Special_axP_fresh_iff [simp]: "a \<sharp> Special_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and eval_fm_Special_axP [simp]: "eval_fm e (Special_axP p) \<longleftrightarrow> \<lbrakk>p\<rbrakk>e \<in> Special_ax" (is ?thesis2)
   and Special_axP_sf [iff]:       "Sigma_fm (Special_axP p)" (is ?thesis3)
proof -
  obtain v::name and x::name and ax::name and y::name and sx::name
    where "atom v \<sharp> (p,sx,y,ax,x)" "atom x \<sharp> (p,sx,y,ax)"
          "atom ax \<sharp> (p,sx,y)" "atom y \<sharp> (p,sx)" "atom sx \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    apply auto
    apply (metis q_Disj_def q_Ex_def q_Imp_def q_Neg_def Special_ax.intros)
    apply (metis q_Disj_def q_Ex_def q_Imp_def q_Neg_def Special_ax.cases)
    done
qed

subsubsection {*Correctness (or, correspondence) *}

lemma Special_ax_imp_special_axioms:
  assumes "x \<in> Special_ax" shows "\<exists>A. x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> A \<in> special_axioms"
using assms
proof (induction rule: Special_ax.induct)
  case (I v x ax y sx)
  obtain fm::fm and u::tm where fm: "x = \<lbrakk>\<lceil>fm\<rceil>\<rbrakk>e" and  u: "y = \<lbrakk>\<lceil>u\<rceil>\<rbrakk>e"
    using I  by (auto elim!: Form_imp_is_fm Term_imp_is_tm)
  obtain B where x: "x  = \<lbrakk>quot_dbfm B\<rbrakk>e"
            and ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 B)\<rbrakk>e"
    using I AbstForm_imp_abst_dbfm  by force
  obtain B' where x': "x = \<lbrakk>quot_dbfm B'\<rbrakk>e"
             and sx: "sx = \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] u) (decode_Var v) B')\<rbrakk>e"
    using I  by (metis u SubstForm_imp_subst_dbfm_lemma quot_tm_def)
  have eq: "B'=B"
    by (metis quot_dbfm_inject_lemma x x')
  have "fm(decode_Var v::=u) IMP SyntaxN.Ex (decode_Var v) fm \<in> special_axioms"
    by (metis special_axioms.intros)
  thus ?case using eq
    apply (auto simp: quot_simps q_defs
                intro!: exI [where x = "fm((decode_Var v)::=u) IMP (Ex (decode_Var v) fm)"])
    apply (metis fm quot_dbfm_inject_lemma quot_fm_def subst_fm_trans_commute sx x')
    apply (metis abst_trans_fm ax fm quot_dbfm_inject_lemma quot_fm_def x)
    done
qed

lemma special_axioms_into_Special_ax: "A \<in> special_axioms \<Longrightarrow> \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<in> Special_ax"
proof (induct rule: special_axioms.induct)
  case (I A i t)
  have "\<lbrakk>\<lceil>A(i::=t) IMP SyntaxN.Ex i A\<rceil>\<rbrakk>e =
        q_Imp \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] t) i (trans_fm [] A))\<rbrakk>e
              (q_Ex \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e)"
    by (simp add: quot_fm_def q_defs)
  also have "... \<in> Special_ax"
    apply (rule Special_ax.intros [OF AbstForm_trans_fm])
    apply (auto simp: quot_fm_def [symmetric] intro: SubstForm_quot [unfolded eval_Var_q])
    done
  finally show ?case .
qed

text{*We have precisely captured the codes of the specialisation axioms.*}
corollary Special_ax_eq_special_axioms: "Special_ax = (\<Union>A \<in> special_axioms. { \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e })"
  by (force dest: special_axioms_into_Special_ax Special_ax_imp_special_axioms)

subsection {*The induction axioms*}

inductive_set Induction_ax :: "hf set" where
  I: "\<lbrakk>SubstForm v 0 x x0;
       SubstForm v w x xw;
       SubstForm v (q_Eats v w) x xevw;
       AbstForm w 0 (q_Imp x (q_Imp xw xevw)) allw;
       AbstForm v 0 (q_All allw) allvw;
       AbstForm v 0 x ax;
       v \<noteq> w; VarNonOccForm w x\<rbrakk>
      \<Longrightarrow> q_Imp x0 (q_Imp (q_All allvw) (q_All ax)) \<in> Induction_ax"

subsubsection {*Defining the syntax*}

nominal_function Induction_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw);
    atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw); atom allw \<sharp> (p,v,w,x,x0,xw,xevw);
    atom xevw \<sharp> (p,v,w,x,x0,xw); atom xw \<sharp> (p,v,w,x,x0);
    atom x0 \<sharp> (p,v,w,x); atom x \<sharp> (p,v,w);
    atom w \<sharp> (p,v); atom v \<sharp> p\<rbrakk> \<Longrightarrow>
  Induction_axP p = Ex v (Ex w (Ex x (Ex x0 (Ex xw (Ex xevw (Ex allw (Ex allvw (Ex ax
               ((Var v NEQ Var w) AND VarNonOccFormP (Var w) (Var x) AND
                SubstFormP (Var v) Zero (Var x) (Var x0) AND
                SubstFormP (Var v) (Var w) (Var x) (Var xw) AND
                SubstFormP (Var v) (Q_Eats (Var v) (Var w)) (Var x) (Var xevw) AND
                AbstFormP (Var w) Zero (Q_Imp (Var x) (Q_Imp (Var xw) (Var xevw))) (Var allw) AND
                AbstFormP (Var v) Zero (Q_All (Var allw)) (Var allvw) AND
                AbstFormP (Var v) Zero (Var x) (Var ax) AND
                p EQ Q_Imp (Var x0) (Q_Imp (Q_All (Var allvw)) (Q_All (Var ax))))))))))))"
  by (auto simp: eqvt_def Induction_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Induction_axP_fresh_iff [simp]: "a \<sharp> Induction_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and eval_fm_Induction_axP [simp]:
      "eval_fm e (Induction_axP p) \<longleftrightarrow> \<lbrakk>p\<rbrakk>e \<in> Induction_ax"    (is ?thesis2)
   and Induction_axP_sf [iff]: "Sigma_fm (Induction_axP p)" (is ?thesis3)
proof -
  obtain v::name and w::name and x::name and x0::name and xw::name and xevw::name
                 and allw::name and allvw::name and ax::name
    where atoms: "atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw)"
                 "atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw)" "atom allw \<sharp> (p,v,w,x,x0,xw,xevw)"
                 "atom xevw \<sharp> (p,v,w,x,x0,xw)" "atom xw \<sharp> (p,v,w,x,x0)" "atom x0 \<sharp> (p,v,w,x)"
                 "atom x \<sharp> (p,v,w)" "atom w \<sharp> (p,v)" "atom v \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
  show ?thesis2
    proof
      assume "eval_fm e (Induction_axP p)"
      thus "\<lbrakk>p\<rbrakk>e \<in> Induction_ax" using atoms
        by (auto intro!: Induction_ax.I [unfolded q_defs])
    next
      assume "\<lbrakk>p\<rbrakk>e \<in> Induction_ax"
      thus "eval_fm e (Induction_axP p)"
        apply (rule Induction_ax.cases) using atoms
        apply (force simp: q_defs htuple_minus_1 intro!: AbstForm_imp_Ord)
        done
    qed
qed

subsubsection {*Correctness (or, correspondence) *}

lemma Induction_ax_imp_induction_axioms:
  assumes "x \<in> Induction_ax" shows "\<exists>A. x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> A \<in> induction_axioms"
using assms
proof (induction rule: Induction_ax.induct)
  case (I v x x0 w xw xevw allw allvw ax)
  then have v: "is_Var v" and w: "is_Var w"
        and dvw [simp]: "decode_Var v \<noteq> decode_Var w"  "atom (decode_Var w) \<sharp> [decode_Var v]"
    by (auto simp: AbstForm_def fresh_Cons)
  obtain A::fm where A: "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" and wfresh: "atom (decode_Var w) \<sharp> A"
    using I VarNonOccForm_imp_fresh  by blast
  then obtain A' A'' where A': "q_Imp (\<lbrakk>\<lceil>A\<rceil>\<rbrakk>e) (q_Imp xw xevw) = \<lbrakk>quot_dbfm A'\<rbrakk>e"
                       and A'': "q_All allw = \<lbrakk>quot_dbfm A''\<rbrakk>e"
    using I VarNonOccForm_imp_fresh by (auto dest!: AbstForm_imp_abst_dbfm)
  def Aw \<equiv> "A(decode_Var v::=Var (decode_Var w))"
  def Ae \<equiv> "A(decode_Var v::= Eats (Var (decode_Var v)) (Var (decode_Var w)))"
  have x0: "x0 = \<lbrakk>\<lceil>A(decode_Var v::=Zero)\<rceil>\<rbrakk>e"  using I SubstForm_imp_subst_fm
    by (metis A Form_quot_fm eval_fm_inject eval_tm.simps(1) quot_Zero)
  have xw: "xw = \<lbrakk>\<lceil>Aw\<rceil>\<rbrakk>e"  using I SubstForm_imp_subst_fm
    by (metis A Form_quot_fm eval_fm_inject is_Var_imp_decode_Var w Aw_def)
  have "SubstForm v (\<lbrakk>\<lceil>Eats (Var (decode_Var v)) (Var (decode_Var w))\<rceil>\<rbrakk>e) x xevw"
    using I  by (simp add: quot_simps q_defs) (metis is_Var_iff v w)
  hence xevw: "xevw = \<lbrakk>\<lceil>Ae\<rceil>\<rbrakk>e"
    by (metis A Ae_def Form_quot_fm SubstForm_imp_subst_fm eval_fm_inject)
  have ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 (trans_fm [] A))\<rbrakk>e"
    using I  by (metis A AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma quot_fm_def)
  have evw: "q_Imp x (q_Imp xw xevw) =
             \<lbrakk>quot_dbfm (trans_fm [] (A IMP (Aw IMP Ae)))\<rbrakk>e"
    using A xw xevw  by (auto simp: quot_simps q_defs quot_fm_def)
  hence allw: "allw = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var w) 0
                                    (trans_fm [] (A IMP (Aw IMP Ae))))\<rbrakk>e"
    using I  by (metis AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma)
  then have evw: "q_All allw = \<lbrakk>quot_dbfm (trans_fm [] (All (decode_Var w) (A IMP (Aw IMP Ae))))\<rbrakk>e"
    by (auto simp: q_defs abst_trans_fm)
  hence allvw: "allvw = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0
                                     (trans_fm [] (All (decode_Var w) (A IMP (Aw IMP Ae)))))\<rbrakk>e"
    using I  by (metis AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma)
  def ind_ax \<equiv>
       "A(decode_Var v::=Zero) IMP
        ((All (decode_Var v) (All (decode_Var w) (A IMP (Aw IMP Ae)))) IMP
        (All (decode_Var v) A))"
  have "atom (decode_Var w) \<sharp> (decode_Var v, A)" using I wfresh v w
    by (metis atom_eq_iff decode_Var_inject fresh_Pair fresh_ineq_at_base)
  hence "ind_ax \<in> induction_axioms"
    by (auto simp: ind_ax_def Aw_def Ae_def induction_axioms.intros)
  thus ?case
    by (force simp: quot_simps q_defs ind_ax_def allvw ax x0 abst_trans_fm2 abst_trans_fm)
qed

lemma induction_axioms_into_Induction_ax:
  "A \<in> induction_axioms \<Longrightarrow> \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<in> Induction_ax"
proof (induct rule: induction_axioms.induct)
  case (ind j i A)
  hence eq: "\<lbrakk>\<lceil>A(i::=Zero) IMP All i (All j (A IMP A(i::=Var j) IMP A(i::=Eats (Var i) (Var j)))) IMP All i A\<rceil>\<rbrakk>e =
            q_Imp \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] Zero) i (trans_fm [] A))\<rbrakk>e
            (q_Imp (q_All (q_All
                  (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] A)\<rbrakk>e
                    (q_Imp
                      \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Var j)))\<rbrakk>e
                      \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Eats (Var i) (Var j))))\<rbrakk>e))))
              (q_All \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e))"
    by (simp add: quot_simps q_defs quot_subst_eq fresh_Cons fresh_Pair)
  have [simp]: "atom j \<sharp> [i]" using ind
    by (metis fresh_Cons fresh_Nil fresh_Pair)
  show ?case
  proof (simp only: eq, rule Induction_ax.intros [where v = "q_Var i" and w = "q_Var j"])
    show "SubstForm (q_Var i) 0 \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e
           \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] Zero) i (trans_fm [] A))\<rbrakk>e"
     by (metis SubstForm_subst_dbfm_eq Term_quot_tm eval_tm.simps(1) quot_Zero quot_fm_def quot_tm_def)
  next
    show "SubstForm (q_Var i) (q_Var j) \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<lbrakk>quot_dbfm (subst_dbfm (DBVar j) i (trans_fm [] A))\<rbrakk>e"
      by (auto simp: quot_fm_def intro!: SubstForm_subst_dbfm_eq Term_Var)
         (metis q_Var_def)
  next
    show "SubstForm (q_Var i) (q_Eats (q_Var i) (q_Var j)) \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e
              \<lbrakk>quot_dbfm (subst_dbfm (DBEats (DBVar i) (DBVar j)) i (trans_fm [] A))\<rbrakk>e"
      unfolding quot_fm_def
        by (auto intro!: SubstForm_subst_dbfm_eq Term_Eats Term_Var) (simp add: q_defs)
  next
    show "AbstForm (q_Var j) 0
           (q_Imp \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e
              (q_Imp \<lbrakk>quot_dbfm (subst_dbfm (DBVar j) i (trans_fm [] A))\<rbrakk>e
                     \<lbrakk>quot_dbfm (subst_dbfm (DBEats (DBVar i) (DBVar j)) i (trans_fm [] A))\<rbrakk>e))
           \<lbrakk>quot_dbfm (trans_fm [j] (A IMP (A(i::= Var j) IMP A(i::= Eats(Var i)(Var j)))))\<rbrakk>e"
      by (rule AbstForm_trans_fm_eq [where A = "(A IMP A(i::= Var j) IMP A(i::= Eats(Var i)(Var j)))"])
         (auto simp: quot_simps q_defs quot_fm_def subst_fm_trans_commute_eq)
  next
    show "AbstForm (q_Var i) 0
     (q_All \<lbrakk>quot_dbfm (trans_fm [j] (A IMP A(i::=Var j) IMP A(i::=Eats (Var i) (Var j))))\<rbrakk>e)
     (q_All
       (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] A)\<rbrakk>e
         (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Var j)))\<rbrakk>e
                \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Eats (Var i) (Var j))))\<rbrakk>e)))"
      apply (rule AbstForm_trans_fm_eq
               [where A = "All j (A IMP (A(i::= Var j) IMP A(i::= Eats(Var i)(Var j))))"])
      apply (auto simp: q_defs quot_fm_def)
      done
  next
    show "AbstForm (q_Var i) 0 (\<lbrakk>\<lceil>A\<rceil>\<rbrakk>e) \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e"
      by (metis AbstForm_trans_fm)
  next
    show "q_Var i \<noteq> q_Var j" using ind
      by (simp add: q_Var_def)
  next
    show "VarNonOccForm (q_Var j) (\<lbrakk>\<lceil>A\<rceil>\<rbrakk>e)"
      by (metis fresh_Pair fresh_imp_VarNonOccForm ind)
  qed
qed

text{*We have captured the codes of the induction axioms.*}
corollary Induction_ax_eq_induction_axioms:
  "Induction_ax = (\<Union>A \<in> induction_axioms. {\<lbrakk>\<lceil>A\<rceil>\<rbrakk>e})"
  by (force dest: induction_axioms_into_Induction_ax Induction_ax_imp_induction_axioms)

subsection {*The predicate @{text AxiomP}, for any Axioms*}

definition Extra_ax :: "hf set" where
 "Extra_ax \<equiv> {\<lbrakk>\<lceil>extra_axiom\<rceil>\<rbrakk>e0}"

definition Axiom :: "hf set" where
  "Axiom \<equiv> Extra_ax \<union> Sent \<union> Equality_ax \<union> HF_ax \<union> Special_ax \<union> Induction_ax"

definition AxiomP :: "tm \<Rightarrow> fm"
  where "AxiomP x \<equiv> x EQ \<lceil>extra_axiom\<rceil> OR SentP x OR Equality_axP x OR
                    HF_axP x OR Special_axP x OR Induction_axP x"

lemma AxiomP_eqvt [eqvt]: "(p \<bullet> AxiomP x) = AxiomP (p \<bullet> x)"
  by (simp add: AxiomP_def)

lemma AxiomP_fresh_iff [simp]: "a \<sharp> AxiomP x \<longleftrightarrow> a \<sharp> x"
  by (auto simp: AxiomP_def)

lemma eval_fm_AxiomP [simp]: "eval_fm e (AxiomP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Axiom"
  unfolding AxiomP_def Axiom_def Extra_ax_def
  by (auto simp del: Equality_axP.simps HF_axP.simps intro: eval_quot_fm_ignore)

lemma AxiomP_sf [iff]: "Sigma_fm (AxiomP t)"
  by (auto simp: AxiomP_def)

subsection {*The predicate @{text ModPonP}, for the inference rule Modus Ponens*}

definition ModPon :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool" where
  "ModPon x y z \<equiv> (y = q_Imp x z)"

definition ModPonP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "ModPonP x y z = (y EQ Q_Imp x z)"

lemma ModPonP_eqvt [eqvt]: "(p \<bullet> ModPonP x y z) = ModPonP (p \<bullet> x) (p \<bullet> y) (p \<bullet> z)"
  by (simp add: ModPonP_def)

lemma ModPonP_fresh_iff [simp]: "a \<sharp> ModPonP x y z \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y \<and> a \<sharp> z"
  by (auto simp: ModPonP_def)

lemma eval_fm_ModPonP [simp]: "eval_fm e (ModPonP x y z) \<longleftrightarrow> ModPon \<lbrakk>x\<rbrakk>e \<lbrakk>y\<rbrakk>e \<lbrakk>z\<rbrakk>e"
  by (auto simp: ModPon_def ModPonP_def q_defs)

lemma ModPonP_sf [iff]: "Sigma_fm (ModPonP t u v)"
  by (auto simp: ModPonP_def)

lemma ModPonP_subst [simp]:
  "(ModPonP t u v)(i::=w) = ModPonP (subst i w t) (subst i w u) (subst i w v)"
  by (auto simp: ModPonP_def)

subsection {*The predicate @{text ExistsP}, for the existential rule *}
subsubsection {*Definition*}

(*  "\<turnstile> A IMP B \<Longrightarrow> atom i \<sharp> B \<Longrightarrow>  \<turnstile> (Ex i A) IMP B" *)
definition Exists :: "hf \<Rightarrow> hf \<Rightarrow> bool" where
 "Exists p q \<equiv> (\<exists>x x' y v. Form x \<and> VarNonOccForm v y \<and> AbstForm v 0 x x' \<and>
                p = q_Imp x y \<and> q = q_Imp (q_Ex x') y)"

nominal_function ExistsP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom x \<sharp> (p,q,v,y,x'); atom x' \<sharp> (p,q,v,y);
    atom y \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
  ExistsP p q = Ex x (Ex x' (Ex y (Ex v (FormP (Var x) AND
                    VarNonOccFormP (Var v) (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var x') AND
                    p EQ Q_Imp (Var x) (Var y) AND
                    q EQ Q_Imp (Q_Ex (Var x')) (Var y)))))"
  by (auto simp: eqvt_def ExistsP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows ExistsP_fresh_iff [simp]: "a \<sharp> ExistsP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"    (is ?thesis1)
   and eval_fm_ExistsP [simp]: "eval_fm e (ExistsP p q) \<longleftrightarrow> Exists \<lbrakk>p\<rbrakk>e \<lbrakk>q\<rbrakk>e"  (is ?thesis2)
   and ExistsP_sf [iff]:       "Sigma_fm (ExistsP p q)"   (is ?thesis3)
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (p,q,v,y,x')"  "atom x' \<sharp> (p,q,v,y)" "atom y \<sharp> (p,q,v)"  "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: Exists_def q_defs)
qed

lemma ExistsP_subst [simp]: "(ExistsP p q)(j::=w) = ExistsP (subst j w p) (subst j w q)"
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (j,w,p,q,v,y,x')"   "atom x' \<sharp> (j,w,p,q,v,y)"
          "atom y \<sharp> (j,w,p,q,v)"   "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: ExistsP.simps [of x _ _ x' y v])
qed

subsubsection {*Correctness*}

lemma Exists_imp_exists:
  assumes "Exists p q"
  shows "\<exists>A B i. p = \<lbrakk>\<lceil>A IMP B\<rceil>\<rbrakk>e \<and> q = \<lbrakk>\<lceil>(Ex i A) IMP B\<rceil>\<rbrakk>e \<and> atom i \<sharp> B"
proof -
  obtain x ax y v
    where x:    "Form x"
      and noc:  "VarNonOccForm v y"
      and abst: "AbstForm v 0 x ax"
      and p: "p = q_Imp x y"
      and q: "q = q_Imp (q_Ex ax) y"
    using assms  by (auto simp: Exists_def)
  then obtain B::fm where B: "y = \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e" and vfresh: "atom (decode_Var v) \<sharp> B"
   by (metis VarNonOccForm_imp_fresh)
  obtain A::fm where A: "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e"
    by (metis Form_imp_is_fm x)
  with AbstForm_imp_abst_dbfm [OF abst, of e]
  have ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 (trans_fm [] A))\<rbrakk>e"
           "p = \<lbrakk>\<lceil>A IMP B\<rceil>\<rbrakk>e" using p A B
    by (auto simp: quot_simps quot_fm_def q_defs)
  have "q = \<lbrakk>\<lceil>(Ex (decode_Var v) A) IMP B\<rceil>\<rbrakk>e" using q A B ax
    by (auto simp: abst_trans_fm quot_simps q_defs)
  then show ?thesis using vfresh ax
    by blast
qed

lemma Exists_intro: "atom i \<sharp> B \<Longrightarrow> Exists (\<lbrakk>\<lceil>A IMP B\<rceil>\<rbrakk>e) \<lbrakk>\<lceil>(Ex i A) IMP B\<rceil>\<rbrakk>e"
  by (simp add: Exists_def quot_simps q_defs)
     (metis AbstForm_trans_fm Form_quot_fm fresh_imp_VarNonOccForm)

text{*Thus, we have precisely captured the codes of the specialisation axioms.*}
corollary Exists_iff_exists:
  "Exists p q \<longleftrightarrow> (\<exists>A B i. p = \<lbrakk>\<lceil>A IMP B\<rceil>\<rbrakk>e \<and> q = \<lbrakk>\<lceil>(Ex i A) IMP B\<rceil>\<rbrakk>e \<and> atom i \<sharp> B)"
  by (force dest: Exists_imp_exists Exists_intro)

subsection {*The predicate @{text SubstP}, for the substitution rule *}

text{*Although the substitution rule is derivable in the calculus, the derivation is
too complicated to reproduce within the proof function. It is much easier to
provide it as an immediate inference step, justifying its soundness in terms
of other inference rules.*}

subsubsection {*Definition*}

text{*This is the inference @{text"H \<turnstile> A \<Longrightarrow> H \<turnstile> A (i::=x)"} *}
definition Subst :: "hf \<Rightarrow> hf \<Rightarrow> bool" where
  "Subst p q \<equiv> (\<exists>v u. SubstForm v u p q)"

nominal_function SubstP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom u \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
   SubstP p q = Ex v (Ex u (SubstFormP (Var v) (Var u) p q))"
  by (auto simp: eqvt_def SubstP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SubstP_fresh_iff [simp]: "a \<sharp> SubstP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"        (is ?thesis1)
   and eval_fm_SubstP [simp]: "eval_fm e (SubstP p q) \<longleftrightarrow> Subst \<lbrakk>p\<rbrakk>e \<lbrakk>q\<rbrakk>e" (is ?thesis2)
   and SubstP_sf [iff]: "Sigma_fm (SubstP p q)"                           (is ?thesis3)
proof -
  obtain u::name and v::name  where "atom u \<sharp> (p,q,v)" "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: Subst_def q_defs)
qed

lemma SubstP_subst [simp]: "(SubstP p q)(j::=w) = SubstP (subst j w p) (subst j w q)"
proof -
  obtain u::name and v::name  where "atom u \<sharp> (j,w,p,q,v)"  "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstP.simps [of u _ _ v])
qed

subsubsection {*Correctness*}

lemma Subst_imp_subst:
  assumes "Subst p q" "Form p"
  shows "\<exists>A::fm. \<exists>i t. p = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> q = \<lbrakk>\<lceil>A(i::=t)\<rceil>\<rbrakk>e"
proof -
  obtain v u where subst: "SubstForm v u p q" using assms
    by (auto simp: Subst_def)
  then obtain t::tm where substt: "SubstForm v \<lbrakk>\<lceil>t\<rceil>\<rbrakk>e p q"
    by (metis SubstForm_def Term_imp_is_tm)
  with SubstForm_imp_subst_fm [OF substt] assms
  obtain A where "p = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e"  "q = \<lbrakk>\<lceil>A(decode_Var v::=t)\<rceil>\<rbrakk>e"
    by auto
  thus ?thesis
    by blast
qed

subsection {*The predicate @{text PrfP}*}

(*Prf(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>n\<in>k)[Sent (s n) \<or> (\<exists>m,l\<in>n)[ModPon (s m) (s l) (s n)]]*)
definition Prf :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "Prf s k y \<equiv> BuildSeq (\<lambda>x. x \<in> Axiom) (\<lambda>u v w. ModPon v w u \<or> Exists v u \<or> Subst v u) s k y"

nominal_function PrfP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,sl,m,n,sm,sn); atom sl \<sharp> (s,m,n,sm,sn);
          atom m \<sharp> (s,n,sm,sn); atom n \<sharp> (s,k,sm,sn);
          atom sm \<sharp> (s,sn); atom sn \<sharp> (s)\<rbrakk> \<Longrightarrow>
    PrfP s k t =
      LstSeqP s k t AND
      All2 n (SUCC k) (Ex sn (HPair (Var n) (Var sn) IN s AND (AxiomP (Var sn) OR
                Ex m (Ex l (Ex sm (Ex sl (Var m IN Var n AND Var l IN Var n AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var l) (Var sl) IN s AND
                       (ModPonP (Var sm) (Var sl) (Var sn) OR
                        ExistsP (Var sm) (Var sn) OR
                        SubstP (Var sm) (Var sn)))))))))"
  by (auto simp: eqvt_def PrfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows PrfP_fresh_iff [simp]: "a \<sharp> PrfP s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t"      (is ?thesis1)
  and eval_fm_PrfP [simp]:     "eval_fm e (PrfP s k t) \<longleftrightarrow> Prf \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>t\<rbrakk>e"  (is ?thesis2)
  and PrfP_imp_OrdP [simp]:    "{PrfP s k t} \<turnstile> OrdP k"         (is ?thord)
  and PrfP_imp_LstSeqP [simp]: "{PrfP s k t} \<turnstile> LstSeqP s k t"  (is ?thlstseq)
  and PrfP_sf [iff]:           "Sigma_fm (PrfP s k t)"         (is ?thsf)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,m,n,sm,sn)"
        "atom m \<sharp> (s,n,sm,sn)"   "atom n \<sharp> (s,k,sm,sn)"
        "atom sm \<sharp> (s,sn)"   "atom sn \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thord ?thlstseq ?thsf
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by simp
       (simp cong: conj_cong add: LstSeq_imp_Ord Prf_def BuildSeq_def Builds_def
             ModPon_def Exists_def HBall_def HBex_def
             Seq_iff_app [OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma PrfP_subst [simp]:
     "(PrfP t u v)(j::=w) = PrfP (subst j w t) (subst j w u) (subst j w v)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (t,u,v,j,w,sl,m,n,sm,sn)"   "atom sl \<sharp> (t,u,v,j,w,m,n,sm,sn)"
          "atom m \<sharp> (t,u,v,j,w,n,sm,sn)"   "atom n \<sharp> (t,u,v,j,w,sm,sn)"
          "atom sm \<sharp> (t,u,v,j,w,sn)"   "atom sn \<sharp> (t,u,v,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: PrfP.simps [of l _ sl m n sm sn])
qed

subsection {*The predicate @{text PfP}*}

definition Pf :: "hf \<Rightarrow> bool"
  where "Pf y \<equiv> (\<exists>s k. Prf s k y)"

nominal_function PfP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,y); atom s \<sharp> y\<rbrakk> \<Longrightarrow>
    PfP y = Ex k (Ex s (PrfP (Var s) (Var k) y))"
  by (auto simp: eqvt_def PfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows PfP_fresh_iff [simp]: "a \<sharp> PfP y \<longleftrightarrow> a \<sharp> y"           (is ?thesis1)
   and eval_fm_PfP [simp]:  "eval_fm e (PfP y) \<longleftrightarrow> Pf \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
   and PfP_sf [iff]: "Sigma_fm (PfP y)"                      (is ?thsf)
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,y)" "atom s \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Pf_def)
qed

lemma PfP_subst [simp]: "(PfP t)(j::=w) = PfP (subst j w t)"
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,t,j,w)" "atom s \<sharp> (t,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: PfP.simps [of k s])
qed

lemma ground_PfP [simp]: "ground_fm (PfP y) = ground y"
  by (simp add: ground_aux_def ground_fm_aux_def supp_conv_fresh)

section{*Proposition 4.4*}

subsection{*Left-to-Right Proof*}

lemma extra_axiom_imp_Pf: "Pf \<lbrakk>\<lceil>extra_axiom\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>extra_axiom\<rceil>\<rbrakk>e \<in> Extra_ax"
    by (simp add: Extra_ax_def) (rule eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma boolean_axioms_imp_Pf:
  assumes "\<alpha> \<in> boolean_axioms" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<in> Sent" using assms
    by (rule boolean_axioms.cases)
       (auto simp: Sent_def Sent_axioms_def quot_Disj quot_Neg q_defs)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma equality_axioms_imp_Pf:
  assumes "\<alpha> \<in> equality_axioms" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<in> Equality_ax" using assms [unfolded equality_axioms_def]
    by (auto simp: Equality_ax_def eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma HF_axioms_imp_Pf:
  assumes "\<alpha> \<in> HF_axioms" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<in> HF_ax" using assms [unfolded HF_axioms_def]
    by (auto simp: HF_ax_def eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma special_axioms_imp_Pf:
  assumes "\<alpha> \<in> special_axioms" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<in> Special_ax"
    by (metis special_axioms_into_Special_ax assms)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma induction_axioms_imp_Pf:
  assumes "\<alpha> \<in> induction_axioms" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
proof -
  have "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<in> Induction_ax"
    by (metis induction_axioms_into_Induction_ax assms)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma ModPon_imp_Pf: "\<lbrakk>Pf \<lbrakk>Q_Imp x y\<rbrakk>e; Pf \<lbrakk>x\<rbrakk>e\<rbrakk> \<Longrightarrow> Pf \<lbrakk>y\<rbrakk>e"
  by (auto simp: Pf_def Prf_def ModPon_def q_defs intro: BuildSeq_combine)

lemma quot_ModPon_imp_Pf: "\<lbrakk>Pf \<lbrakk>\<lceil>\<alpha> IMP \<beta>\<rceil>\<rbrakk>e; Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e\<rbrakk> \<Longrightarrow> Pf \<lbrakk>\<lceil>\<beta>\<rceil>\<rbrakk>e"
  by (simp add: ModPon_imp_Pf quot_fm_def quot_simps q_defs)

lemma quot_Exists_imp_Pf: "\<lbrakk>Pf \<lbrakk>\<lceil>\<alpha> IMP \<beta>\<rceil>\<rbrakk>e; atom i \<sharp> \<beta>\<rbrakk> \<Longrightarrow> Pf \<lbrakk>\<lceil>Ex i \<alpha> IMP \<beta>\<rceil>\<rbrakk>e"
  by (force simp: Pf_def Prf_def Exists_def quot_simps q_defs
            intro: BuildSeq_combine AbstForm_trans_fm_eq fresh_imp_VarNonOccForm)

lemma proved_imp_Pf: assumes "H \<turnstile> \<alpha>" "H={}" shows "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e"
using assms
proof (induct)
  case (Hyp A H) thus ?case
    by auto
next
  case (Extra H) thus ?case
    by (metis extra_axiom_imp_Pf)
next
  case (Bool A H) thus ?case
    by (metis boolean_axioms_imp_Pf)
next
  case (Eq A H) thus ?case
    by (metis equality_axioms_imp_Pf)
next
  case (HF A H) thus ?case
    by (metis HF_axioms_imp_Pf)
next
  case (Spec A H) thus ?case
    by (metis special_axioms_imp_Pf)
next
  case (Ind A H) thus ?case
    by (metis induction_axioms_imp_Pf)
next
  case (MP H A B H') thus ?case
    by (metis quot_ModPon_imp_Pf Un_empty)
next
  case (Exists H A B i) thus ?case
    by (metis quot_Exists_imp_Pf)
qed

corollary proved_imp_proved_PfP: "{} \<turnstile> \<alpha> \<Longrightarrow> {} \<turnstile> PfP \<lceil>\<alpha>\<rceil>"
  by (rule Sigma_fm_imp_thm [OF PfP_sf])
     (auto simp: ground_aux_def supp_conv_fresh proved_imp_Pf)

subsection{*Right-to-Left Proof*}

lemma Sent_imp_hfthm:
  assumes "x \<in> Sent" shows "\<exists>A. x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
proof -
  obtain y z w where "Form y" "Form z" "Form w" and axs: "Sent_axioms x y z w"
    using assms  by (auto simp: Sent_def)
  then obtain A::fm and B::fm and C::fm
         where A: "y = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" and B: "z = \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e" and C: "w = \<lbrakk>\<lceil>C\<rceil>\<rbrakk>e"
    by (metis Form_imp_is_fm)
  have "\<exists>A. q_Imp y y = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force simp add: A quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp y (q_Disj y z) = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="A IMP (A OR B)"]
                simp add: A B quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y y) y = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR A) IMP A"]
                simp add: A quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y (q_Disj z w)) (q_Disj (q_Disj y z) w) = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR (B OR C)) IMP ((A OR B) OR C)"]
                simp add: A B C quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y z) (q_Imp (q_Disj (q_Neg y) w) (q_Disj z w)) = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR B) IMP ((Neg A OR C) IMP (B OR C))"]
                simp add: A B C quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  ultimately show ?thesis using axs [unfolded Sent_axioms_def]
    by blast
qed

lemma Extra_ax_imp_hfthm:
  assumes "x \<in> Extra_ax" obtains A where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding Extra_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.Extra)

lemma Equality_ax_imp_hfthm:
  assumes "x \<in> Equality_ax" obtains A where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding Equality_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.Eq [unfolded equality_axioms_def])

lemma HF_ax_imp_hfthm:
  assumes "x \<in> HF_ax" obtains A where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding HF_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.HF [unfolded HF_axioms_def])

lemma Special_ax_imp_hfthm:
  assumes "x \<in> Special_ax" obtains A where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" "{} \<turnstile> A"
  by (metis Spec Special_ax_imp_special_axioms assms)

lemma Induction_ax_imp_hfthm:
  assumes "x \<in> Induction_ax" obtains A where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" "{} \<turnstile> A"
  by (metis Induction_ax_imp_induction_axioms assms hfthm.Ind)

lemma Exists_imp_hfthm: "\<lbrakk>Exists \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e y; {} \<turnstile> A\<rbrakk> \<Longrightarrow> \<exists>B. y = \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e \<and> {} \<turnstile> B"
  by (drule Exists_imp_exists [where e=e]) (auto intro: anti_deduction)

lemma Subst_imp_hfthm:  "\<lbrakk>Subst \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e y; {} \<turnstile> A\<rbrakk> \<Longrightarrow> \<exists>B. y = \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e \<and> {} \<turnstile> B"
  by (drule Subst_imp_subst [where e=e], auto intro: Subst)

lemma eval_Neg_imp_Neg: "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e = q_Neg x \<Longrightarrow> \<exists>A. \<alpha> = Neg A \<and> \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e = x"
  by (cases \<alpha> rule: fm.exhaust) (auto simp: quot_simps q_defs htuple_minus_1)

lemma eval_Disj_imp_Disj: "\<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e = q_Disj x y \<Longrightarrow> \<exists>A B. \<alpha> = A OR B \<and> \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e = x \<and> \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e = y"
  by (cases \<alpha> rule: fm.exhaust) (auto simp: quot_simps q_defs htuple_minus_1)

lemma Prf_imp_proved: assumes "Prf s k x" shows "\<exists>A. x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> {} \<turnstile> A"
using assms [unfolded Prf_def Axiom_def]
proof (induction x rule: BuildSeq_induct)
  case (B x) thus ?case
    by (auto intro: Extra_ax_imp_hfthm Sent_imp_hfthm Equality_ax_imp_hfthm HF_ax_imp_hfthm
                    Special_ax_imp_hfthm Induction_ax_imp_hfthm)
next
  case (C x y z)
  then obtain A::fm and B::fm where "y = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" "{} \<turnstile> A" "z = \<lbrakk>\<lceil>B\<rceil>\<rbrakk>e" "{} \<turnstile> B"
    by blast
  thus ?case using C.hyps ModPon_def q_Imp_def
    by (auto dest!: MP_same eval_Neg_imp_Neg eval_Disj_imp_Disj Exists_imp_hfthm Subst_imp_hfthm)
qed

corollary Pf_quot_imp_is_proved: "Pf \<lbrakk>\<lceil>\<alpha>\<rceil>\<rbrakk>e \<Longrightarrow> {} \<turnstile> \<alpha>"
  by (metis Pf_def Prf_imp_proved eval_fm_inject)

text{*Proposition 4.4!*}
theorem proved_iff_proved_PfP: "{} \<turnstile> \<alpha> \<longleftrightarrow> {} \<turnstile> PfP \<lceil>\<alpha>\<rceil>"
  by (metis Pf_quot_imp_is_proved emptyE eval_fm_PfP hfthm_sound proved_imp_proved_PfP)

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

header {* Some useful operators for calculational reasoning *}

theory
  xHOL_Defs

imports
  xHOL_Defs_Chap

begin

section {* Chained relations *}

text {*

We introduce syntax to aid in writing chained relation terms.

A chained relation is a conjunction of binary relations in which conjunctions and repeated
arguments and relations are elided for compactness of representation.

For example, the term
@{text [display] "    a = b \<and> b \<le> c \<and> b \<le> d"}
might be written in the following form
@{text [display] "    \<lch>a \<chEq> b \<chLe> c, d\<rch>."}

*}

definition
  ch_tail :: "'a set \<rightarrow> ('a set \<times> ('a \<rightarrow> \<bool>))"
where
  ch_tail_def [simp]: "ch_tail \<defs> (\<olambda> As \<bullet> (As, (\<olambda> a \<bullet> \<True>)))"

definition
  ch_cons :: "['a set, ['a, 'b] \<rightarrow> \<bool>, ('b set \<times> ('b \<rightarrow> \<bool>))] \<rightarrow> ('a set \<times> ('a \<rightarrow> \<bool>))"
where
  ch_cons_def: "ch_cons \<defs> (\<olambda> As r (Bs, BS_phi) \<bullet> (As, (\<olambda> a \<bullet> (\<forall> b | b \<in> Bs \<bullet> r a b \<and> BS_phi b))))"

definition
  ch_head :: "('a set \<times> ('a \<rightarrow> \<bool>)) \<rightarrow> \<bool>"
where
  ch_head_def: "ch_head \<defs> (\<olambda> (As, BS_phi) \<bullet> (\<forall> a | a \<in> As \<bullet> BS_phi a))"

definition
  ch_acc :: "['a set, ['a, 'b] \<rightarrow> \<bool>, ('b set \<times> ('b \<rightarrow> \<bool>))] \<rightarrow> ('a \<rightarrow> \<bool>)"
where
  ch_acc_def: "ch_acc \<defs> (\<olambda> a r (Bs, BS_phi) a \<bullet> (\<forall> b | b \<in> Bs \<bullet> r a b \<and> BS_phi b))"

lemma ch_cons_acc [simp]:
  "ch_cons As r (Bs, BS_phi) = (As, ch_acc As r (Bs, BS_phi))"
  by (simp add: ch_cons_def ch_acc_def)

lemma ch_acc_ins [simp]:
  "ch_acc As r (insert b BS, BS_phi) = (\<olambda> a \<bullet> r a b \<and> BS_phi b \<and> ch_acc As r (BS, BS_phi) a)"
  by (auto intro!: ext simp add: ch_acc_def)

lemma ch_acc_nil [simp]:
  "ch_acc As r (\<emptyset>, BS_phi) = (\<olambda> a \<bullet> \<True>)"
  by (auto intro!: ext simp add: ch_acc_def)

lemma ch_head_ins [simp]:
  "ch_head (insert a As, BS_phi) \<Leftrightarrow> BS_phi a \<and> ch_head (As, BS_phi)"
  by (auto simp add: ch_head_def)

lemma ch_head_nil [simp]:
  "ch_head (\<emptyset>, BS_phi) \<Leftrightarrow> \<True>"
  by (auto simp add: ch_head_def)

nonterminal
  chainrel and
  chainelt

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>ch_true" :: "chainrel \<rightarrow> \<bool>" ("_")
  "_xHOL_Defs\<ZZ>ch_base" :: "args \<rightarrow> chainelt" ("_")

syntax (zed)
  "_xHOL_Defs\<ZZ>ch_true" :: "chainrel \<rightarrow> \<bool>" ("\<lch>_")
  "" :: "chainrel \<rightarrow> chainelt" ("_")
  "_xHOL_Defs\<ZZ>ch_base" :: "args \<rightarrow> chainelt" ("_\<rch>")

parse_translation {*

let

fun set_tr (Const("_args", _) $ a $ As) = Const("insert", dummyT) $ a $ set_tr As
  | set_tr a = Const("insert", dummyT) $ a $ Const("Set.empty", dummyT);

fun chTrue_tr _ [X] = Const(@{const_syntax "ch_head"}, dummyT) $ X;

fun chBase_tr _ [As] = Const(@{const_syntax "ch_tail"}, dummyT) $ (set_tr As);

in

[
  ("_xHOL_Defs\<ZZ>ch_true", chTrue_tr),
  ("_xHOL_Defs\<ZZ>ch_base", chBase_tr)
]

end;

*}

definition
  ch_eq :: "['a, 'a] \<rightarrow> \<bool>"
where
  ch_eq_def [simp]: "ch_eq x y \<defs> x = y"

definition
  ch_iff :: "[\<bool>, \<bool>] \<rightarrow> \<bool>"
where
  ch_iff_def [simp]: "ch_iff x y \<defs> x \<Leftrightarrow> y"

definition
  ch_neq :: "['a, 'a] \<rightarrow> \<bool>"
where
  ch_neq_def [simp]: "ch_neq x y \<defs> x \<noteq> y"

definition
  ch_le :: "['a::ord, 'a] \<rightarrow> \<bool>"
where
  ch_le_def [simp]: "ch_le x y \<defs> x \<le> y"

definition
  ch_lt :: "['a::ord, 'a] \<rightarrow> \<bool>"
where
  ch_lt_def [simp]: "ch_lt x y \<defs> x < y"

definition
  ch_subeq :: "['a set, 'a set] \<rightarrow> \<bool>"
where
  ch_subeq_def [simp]: "ch_subeq x y \<defs> x \<subseteq> y"

definition
  ch_sub :: "['a set, 'a set] \<rightarrow> \<bool>"
where
  ch_sub_def [simp]: "ch_sub x y \<defs> x \<subset> y"

definition
  ch_imp :: "[\<bool>, \<bool>] \<rightarrow> \<bool>"
where
  ch_imp_def [simp]: "ch_imp x y \<defs> x \<Rightarrow> y"

definition
  ch_in :: "['a, 'a set] \<rightarrow> \<bool>"
where
  ch_in_def [simp]: "ch_in x y \<defs> x \<in> y"

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>ch_eq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "=" 50)
  "_xHOL_Defs\<ZZ>ch_iff" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<Leftrightarrow>" 50)
  "_xHOL_Defs\<ZZ>ch_neq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<noteq>" 50)
  "_xHOL_Defs\<ZZ>ch_le" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<le>" 50)
  "_xHOL_Defs\<ZZ>ch_lt" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "<" 50)
  "_xHOL_Defs\<ZZ>ch_subeq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<subseteq>" 50)
  "_xHOL_Defs\<ZZ>ch_sub" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<subset>" 50)
  "_xHOL_Defs\<ZZ>ch_imp" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<Rightarrow>" 50)
  "_xHOL_Defs\<ZZ>ch_in" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<in>" 50)

syntax (zed)
  "_xHOL_Defs\<ZZ>ch_eq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chEq>" 50)
  "_xHOL_Defs\<ZZ>ch_iff" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chIff>" 50)
  "_xHOL_Defs\<ZZ>ch_neq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chNeq>" 50)
  "_xHOL_Defs\<ZZ>ch_le" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chLe>" 50)
  "_xHOL_Defs\<ZZ>ch_lt" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chLt>" 50)
  "_xHOL_Defs\<ZZ>ch_subeq" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chSubseteq>" 50)
  "_xHOL_Defs\<ZZ>ch_sub" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chSubset>" 50)
  "_xHOL_Defs\<ZZ>ch_imp" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chImp>" 50)
  "_xHOL_Defs\<ZZ>ch_in" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chIn>" 50)

ML {*

local

fun set_tr (Const("_args", _) $ a $ As) = Const("insert", dummyT) $ a $ set_tr As
  | set_tr a = Const("insert", dummyT) $ a $ Const("Set.empty", dummyT);

fun mk_simpOp th r = Const("\<^const>"^th^"."^r, dummyT);

in

fun chNode_tr th r = ("_"^th^"\<ZZ>"^r, (fn _ => (fn [As, X] => Const(@{const_syntax "ch_cons"}, dummyT) $ (set_tr As) $ (mk_simpOp th r) $ X)));

end;

*}

parse_translation {*

[chNode_tr "xHOL_Defs" "ch_eq", chNode_tr "xHOL_Defs" "ch_iff", chNode_tr "xHOL_Defs" "ch_neq", chNode_tr "xHOL_Defs" "ch_lt", chNode_tr "xHOL_Defs" "ch_le", chNode_tr "xHOL_Defs" "ch_subeq", chNode_tr "xHOL_Defs" "ch_sub", chNode_tr "xHOL_Defs" "ch_imp", chNode_tr "xHOL_Defs" "ch_in"]

*}

ML {*

local

fun args_of (Const(@{const_syntax "Set.insert"}, _) $ a $ Const(@{const_syntax "Set.empty"}, _)) = a
  | args_of (Const(@{const_syntax "Set.insert"}, _) $ a $ As) = Const("_args", dummyT) $ a $ (args_of As);

in

fun simpOp_tr' R [] = Const(R, dummyT);

fun ch_head_tr' _ [X] = Const("_xHOL_Defs\<ZZ>ch_true", dummyT) $ X;

fun ch_cons_tr' _ [As, r, X] = (r) $ (args_of As) $ X;

fun ch_tail_tr' _ [As] = Const("_xHOL_Defs\<ZZ>ch_base", dummyT) $ (args_of As);

fun chNode_tr' th s = ("\<^const>"^th^"."^s, (fn _ => fn t => funap_tr (Const("_"^th^"\<ZZ>"^s, dummyT)) t));

end;

*}

print_translation {*

[
  (@{const_syntax "ch_head"}, ch_head_tr'),
  (@{const_syntax "ch_tail"}, ch_tail_tr'),
  (@{const_syntax "ch_cons"}, ch_cons_tr')
];

*}

print_translation {*

  [ chNode_tr' "xHOL_Defs" "ch_eq", chNode_tr' "xHOL_Defs" "ch_neq", chNode_tr' "xHOL_Defs" "ch_iff",
    chNode_tr' "xHOL_Defs" "ch_le", chNode_tr' "xHOL_Defs" "ch_lt", chNode_tr' "xHOL_Defs" "ch_subeq",
    chNode_tr' "xHOL_Defs" "ch_sub", chNode_tr' "xHOL_Defs" "ch_imp", chNode_tr' "xHOL_Defs" "ch_in"];

*}

subsection {* Reverse implication *}

text {*

A reverse implication operator is useful for doing calculational proofs.

*}

definition
  rimplies :: "[\<bool>, \<bool>] \<rightarrow> \<bool>" (infixr "\<Leftarrow>" 25)
where
  impliedby_def: "a \<Leftarrow> b \<defs> b \<Rightarrow> a"

lemma [trans]: "\<lbrakk>a \<Leftarrow> b; b \<Leftarrow> c \<rbrakk> \<turnstile> a \<Leftarrow> c"
  by (auto simp add: impliedby_def)

lemma [trans]: "\<lbrakk>a \<Leftarrow> b; b = c \<rbrakk> \<turnstile> a \<Leftarrow> c"
  by (auto simp add: impliedby_def)

lemma [trans]: "\<lbrakk>a = b; b \<Leftarrow> c \<rbrakk> \<turnstile> a \<Leftarrow> c"
  by (auto simp add: impliedby_def)

lemma [trans]: "\<lbrakk> a; b \<Leftarrow> a \<rbrakk> \<turnstile> b"
  by (auto simp add: impliedby_def)

lemma [trans]: "\<lbrakk> b \<Leftarrow> a; a \<rbrakk> \<turnstile> b"
  by (auto simp add: impliedby_def)

lemmas impbyI [intro!] =  impI [folded impliedby_def]

lemma impbyD [dest!]: "\<lbrakk>a \<Leftarrow> b; b \<rbrakk> \<turnstile> a"
  by (auto simp add: impliedby_def)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftarrow> B) \<turnstile> A \<and> C \<Leftarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftarrow> B) \<turnstile> A \<and> C \<Leftarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftarrow> B) \<turnstile> C \<and> A \<Leftarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftarrow> B) \<turnstile> C \<and> A \<Leftarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Leftarrow> A \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Leftarrow> B \<and> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<and> B \<Leftarrow> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> B \<and> A \<Leftarrow> A"
  by (auto)

definition
  ch_rimp :: "[\<bool>, \<bool>] \<rightarrow> \<bool>"
where
  ch_rimp_def [simp]: "ch_rimp x y \<defs> x \<Leftarrow> y"

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>ch_rimp" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<Leftarrow>" 50)

syntax (zed)
  "_xHOL_Defs\<ZZ>ch_rimp" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chRimp>" 50)

parse_translation {*

[chNode_tr "xHOL_Defs" "ch_rimp"]

*}

print_translation {*

[chNode_tr' "xHOL_Defs" "ch_rimp"]

*}

subsection {* Reverse ordering *}

text {*

Equally reverse ordering is also useful in calculational reasoning.
The base HOL library includes a reverse ordering syntax, but an actual
operator works better with the calculational reasoning package.

*}

context ord

begin

no_notation (input)
  Orderings.greater (infix ">" 50) and
  Orderings.greater_eq (infix ">=" 50)

no_notation (input)
  Orderings.greater_eq (infix "\<ge>" 50)

definition
  great_eq :: "['a, 'a] => bool"
where
  ge_def: "great_eq \<defs> (\<olambda> x y \<bullet> y \<le> x)"

definition
  great :: "['a, 'a] => bool"
where
  gt_def: "great \<defs> (\<olambda> x y \<bullet> y < x)"

notation
  great ("op >") and
  great_eq ("op >=") and
  great ("(_/ > _)"  [51, 51] 50) and
  great_eq ("(_/ >= _)" [51, 51] 50)

notation (xsymbols output)
  great_eq ("op \<ge>") and
  great_eq ("(_/ \<ge> _)"  [51, 51] 50)

notation (zed)
  great_eq ("(_/ \<ge> _)"  [51, 51] 50)

end

definition
  ch_ge :: "['a::ord, 'a] => bool"
where
  ch_ge_def [simp]: "ch_ge x y \<defs> x \<ge> y"

definition
  ch_gt :: "['a::ord, 'a] => bool"
where
  ch_gt_def [simp]: "ch_gt x y \<defs> x > y"

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>ch_ge" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<ge>" 50)
  "_xHOL_Defs\<ZZ>ch_gt" :: "[args, chainelt] \<rightarrow> chainrel" (infixr ">" 50)

syntax (zed)
  "_xHOL_Defs\<ZZ>ch_ge" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chGe>" 50)
  "_xHOL_Defs\<ZZ>ch_gt" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chGt>" 50)

parse_translation {*

[
  chNode_tr "xHOL_Defs" "ch_gt",
  chNode_tr "xHOL_Defs" "ch_ge"
]

*}

print_translation {*

[
  chNode_tr' "xHOL_Defs" "ch_gt",
  chNode_tr' "xHOL_Defs" "ch_ge"
]

*}

no_notation (xsymbols)
  Set.supset ("op \<supset>") and
  Set.supset  ("(_/ \<supset> _)" [51, 51] 50) and
  Set.supset_eq  ("op \<supseteq>") and
  Set.supset_eq  ("(_/ \<supseteq> _)" [51, 51] 50)

abbreviation
  supset :: "'a set \<rightarrow> 'a set \<rightarrow> bool" where
  "supset \<equiv> great"

abbreviation
  supset_eq :: "'a set \<rightarrow> 'a set \<rightarrow> bool" where
  "supset_eq \<equiv> great_eq"

notation (xsymbols)
  supset  ("op \<supset>") and
  supset  ("(_/ \<supset> _)" [50, 51] 50) and
  supset_eq  ("op \<supseteq>") and
  supset_eq  ("(_/ \<supseteq> _)" [50, 51] 50)

lemma [trans]: "\<lbrakk>(a::'a::order) = b; b > c \<rbrakk> \<turnstile> a > c"
  by (auto simp add: gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) > b; b = c \<rbrakk> \<turnstile> a > c"
  by (auto simp add: gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) > b; b > c \<rbrakk> \<turnstile> a > c"
  by (auto simp add: gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) > b; b > a \<rbrakk> \<turnstile> P"
  by (auto simp add: gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) = b; b \<ge> c \<rbrakk> \<turnstile> a \<ge> c"
  by (auto simp add: ge_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<ge> b; b = c \<rbrakk> \<turnstile> a \<ge> c"
  by (auto simp add: ge_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<ge> b; b \<ge> c \<rbrakk> \<turnstile> a \<ge> c"
  by (auto simp add: ge_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<ge> b; b \<ge> a \<rbrakk> \<turnstile> a = b"
  by (auto simp add: ge_def)

lemma [trans]: "\<lbrakk>(a::'a::order) > b; b \<ge> c \<rbrakk> \<turnstile> a > c"
  by (auto simp add: ge_def gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<ge> b; b > c \<rbrakk> \<turnstile> a > c"
  by (auto simp add: ge_def gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<ge> b; a \<noteq> b \<rbrakk> \<turnstile> a > b"
  by (auto simp add: ge_def gt_def)

lemma [trans]: "\<lbrakk>(a::'a::order) \<noteq> b; a \<ge> b \<rbrakk> \<turnstile> a > b"
  by (auto simp add: ge_def gt_def)

lemma [iff]: "(a::'a::order) \<ge> a"
  by (unfold ge_def, blast)

(*

lemma [trans]:
  "\<lbrakk>(a::'a::order) = f b; b > (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> a > f c"
  by (subgoal_tac "f b > f c", unfold gt_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) > b; f b = (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> f a > c"
  by (subgoal_tac "f a > f b", unfold gt_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) = f b; b \<ge> (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> a \<ge> f c"
  by (subgoal_tac "f b \<ge> f c", unfold ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) \<ge> b; f b = (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> f a \<ge> c"
  by (subgoal_tac "f a \<ge> f b", unfold ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) \<ge> f b; b \<ge> (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> a \<ge> f c"
  by (subgoal_tac "f b \<ge> f c", unfold ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) \<ge> b; f b \<ge> (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> f a \<ge> c"
  by (subgoal_tac "f a \<ge> f b", unfold ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) > f b; b \<ge> (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> a > f c"
  by (subgoal_tac "f b \<ge> f c", unfold gt_def ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) > b; f b \<ge> (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> f a > c"
  by (subgoal_tac "f a > f b", unfold gt_def ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) \<ge> f b; b > (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> a > f c"
  by (subgoal_tac "f b > f c", unfold gt_def ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) \<ge> b; f b > (c::'b::order); \<And> x y \<bullet> x \<le> y \<turnstile> f x \<le> f y\<rbrakk> \<turnstile> f a > c"
  by (subgoal_tac "f a \<ge> f b", unfold gt_def ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) > f b; b > (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> a > f c"
  by (subgoal_tac "f b > f c", unfold gt_def ge_def, force, force)

lemma [trans]:
  "\<lbrakk>(a::'a::order) > b; f b > (c::'b::order); \<And> x y \<bullet> x < y \<turnstile> f x < f y\<rbrakk> \<turnstile> f a > c"
  by (subgoal_tac "f a > f b", unfold gt_def ge_def, force, force)
*)

section {* Product space operators *}

subsection {* Finite set products *}

definition
  linsert :: "['b, 'a set] \<rightarrow> ('b \<times> 'a) set"
where
  linsert_def: "linsert b A \<defs> { a | a \<in> A \<bullet> (b, a) }"

lemma finite_cross [simp]:
  "{} \<times> A = {}"
  "(insert b B) \<times> A = linsert b A \<union> (B \<times> A)"
  "linsert b (insert a A) = insert (b, a) (linsert b A)"
  "linsert b {} = {}"
  by (auto simp add: linsert_def)

lemma linsert_mem [simp]:
  "(b, a) \<in> linsert c A \<Leftrightarrow> b = c \<and> a \<in> A"
  by (auto simp add: linsert_def)

subsection {* Product functions *}

text {*

We consider reasoning about functions on tuples.

Pair-valued functions admit a splitting law.

*}

lemma PairFunE: "(\<And> g h \<bullet> f = (\<olambda> c \<bullet> (g c, h c)) \<turnstile> P) \<turnstile> P"
proof -
  assume a1: "\<And> g h \<bullet> f = (\<olambda> c \<bullet> (g c, h c)) \<turnstile> P"
  have a2: "f = (\<olambda> c \<bullet> (fst (f c),snd (f c)))"
    by (intro ext, rule surjective_pairing)
  from a1 a2 show "P"
    by (this)
qed

text {*

In fact we find it useful to introduce an operator for expressing tuple valued
functions.

*}

definition
  ffst :: "('a \<rightarrow> ('b \<times> 'c)) \<rightarrow> 'a \<rightarrow> 'b"
where
  ffst_def: "ffst g \<defs> (\<olambda> x \<bullet> fst (g x))"

definition
  fsnd :: "('a \<rightarrow> ('b \<times> 'c)) \<rightarrow> 'a \<rightarrow> 'c"
where
  fsnd_def: "fsnd g \<defs> (\<olambda> x \<bullet> snd (g x))"

definition
  fusion :: "['a \<rightarrow> 'b, 'a \<rightarrow> 'c] \<rightarrow> 'a \<rightarrow> ('b \<times> 'c)"
where
  fusion_def: "fusion f g \<defs> (\<olambda> a \<bullet> (f a, g a))"

notation (xsymbols output)
  fusion (infixr "\<nabla>" 80)

notation (zed)
  fusion (infixr "\<fus>" 80)

lemma PairFunE': "(\<And> g h \<bullet> f = g \<fus> h \<turnstile> P) \<turnstile> P"
  apply (cases f rule: PairFunE)
  apply (simp add: fusion_def)
  done

text {*

Next we introduce support for definition of fusions using case-statements and argument patterns.

*}

definition
  fusion_case :: "(['a \<rightarrow> 'b, 'a \<rightarrow> 'c] \<rightarrow> 'd) \<rightarrow> (('a \<rightarrow> ('b \<times> 'c)) \<rightarrow> 'd)"
where
  fusion_case_def: "fusion_case \<defs> (\<olambda> F f \<bullet> F (ffst f) (fsnd f))"

nonterminal
  ftuple_args and
  fpatterns

syntax ("" output)
  "_xHOL_Defs\<ZZ>fpattern"    :: "[pttrn, fpatterns] \<rightarrow> pttrn"         ("'(_ \\'/ _')")
  "_xHOL_Defs\<ZZ>fpatterns"   :: "[pttrn, fpatterns] \<rightarrow> fpatterns"      ("_ \\'/ _")

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>fpattern"    :: "[pttrn, fpatterns] \<rightarrow> pttrn"         ("'(_ \<nabla>/ _')")
  "_xHOL_Defs\<ZZ>fpatterns"   :: "[pttrn, fpatterns] \<rightarrow> fpatterns"      ("_ \<nabla>/ _")

syntax (zed)
  "_xHOL_Defs\<ZZ>fpattern"    :: "[pttrn, fpatterns] \<rightarrow> pttrn"         ("'(_ \<fus>/ _')")
  ""            :: "pttrn \<rightarrow> fpatterns"                  ("_")
  "_xHOL_Defs\<ZZ>fpatterns"   :: "[pttrn, fpatterns] \<rightarrow> fpatterns"      ("_ \<fus>/ _")

translations
  "(\<olambda> (x \<fus> y \<fus> zs) \<bullet> b)" \<rightleftharpoons> "CONST xHOL_Defs.fusion_case (\<olambda> x (y \<fus> zs) \<bullet> b)"
  "(\<olambda> (x \<fus> y) \<bullet> b)" \<rightleftharpoons> "CONST xHOL_Defs.fusion_case (\<olambda> x y \<bullet> b)"

setup {*

let

val fp = Ast.mk_appl (Ast.Constant "xHOL_Defs.fusion") [Ast.Variable "f1", Ast.Variable "f2"];
val fus = Ast.mk_appl (Ast.Constant "_case1") [fp, Ast.Variable "f"];
val ast = Ast.mk_appl (Ast.Constant "_case_syntax") [Ast.Variable "t", fus]

val fus2' = Ast.mk_appl (Ast.Constant "_abs") [Ast.Variable "f2", Ast.Variable "f"]
val fus1' = Ast.mk_appl (Ast.Constant "_abs") [Ast.Variable "f1", fus2']
val ast' = Ast.mk_appl (Ast.Constant "xHOL_Defs.fusion_case") [fus1', Ast.Variable "t"]
in
  Sign.add_trrules [Syntax.Parse_Print_Rule (ast, ast')]
end;

*}

lemma ffst_conv [simp]:
  "ffst (f \<fus> g) = f"
  apply (intro ext)
  apply (simp add: fusion_def ffst_def)
  done

lemma fsnd_conv [simp]:
  "fsnd (f \<fus> g) = g"
  apply (intro ext)
  apply (simp add: fusion_def fsnd_def)
  done

lemma fusion_collapse [simp]:
  "(ffst f \<fus> fsnd f) = f"
  apply (intro ext)
  apply (simp add: fusion_def ffst_def fsnd_def)
  done

lemma surj_fusion [simp]:
  "(\<exists> g h \<bullet> f = (g \<fus> h))"
  apply (witness "ffst f")
  apply (witness "fsnd f")
  apply (simp)
  done

lemma fusion_case_beta [simp]:
  "fusion_case H (f \<fus> g) = H f g"
  by (simp add: fusion_case_def ffst_conv fsnd_conv)

lemma fusion_case_beta' [simp]:
  "fusion_case H (\<olambda> x \<bullet> (f x, g x)) = H f g"
  by (simp add: fusion_case_def ffst_def fsnd_def)

lemma split_fused_Ex [simp]:
  "(\<exists> f \<bullet> P f) = (\<exists> g h \<bullet> P (g \<fus> h))"
proof (auto simp add: fusion_def)
  fix f
  assume b1: "P f"
  then show "(\<exists> g h \<bullet> P (\<olambda> a \<bullet> (g a, h a)))"
    apply (cases f rule: PairFunE)
    apply (auto)
    done
qed

lemma split_fused_All [simp]:
  "(\<forall> f \<bullet> P f) = (\<forall> g h \<bullet> P (g \<fus> h))"
proof (auto simp add: fusion_def)
  fix f
  assume "(\<forall> g h \<bullet> P (\<olambda> a \<bullet> (g a, h a)))"
  then show "P f"
    apply (cases f rule: PairFunE)
    apply (auto)
    done
qed

notation (xsymbols output)
  map_pair (infixr "\<parallel>" 75)

notation (zed)
  map_pair (infixr "\<par>" 75)

lemma map_fusion [simp]:
  "(f \<par> g) \<circ> (h \<fus> k) = (f \<circ> h) \<fus> (g \<circ> k)"
  apply (rule ext)
  apply (simp add: fusion_def)
  done

section {* Miscellaneous definitions *}

subsection {* Exclusive or *}

text {*

The exclusive or is also a useful operator.

*}

definition
  xor :: "[\<bool>, \<bool>] \<rightarrow> \<bool>"
where
  xor_def: "xor x y \<defs> x \<Leftrightarrow> \<not> y"

notation (xsymbols output)
  "xor" (infixr "<\<noteq>>" 30)

notation (zed)
  "xor" (infixr "\<xor>" 30)

lemma xorAC [simp]:
  shows
    xorC: "x \<xor> y \<Leftrightarrow> y \<xor> x" and
    xorA: "(x \<xor> y) \<xor> z \<Leftrightarrow> x \<xor> (y \<xor> z)" and
    xorLC: "x \<xor> (y \<xor> z) \<Leftrightarrow> y \<xor> (x \<xor> z)"
  by (auto simp add: xor_def)

lemma xorI1 [intro]:
  assumes a1: "\<not>y \<turnstile> x" and a2: "y \<turnstile> \<not>x"
  shows "x \<xor> y"
  using a1 a2
  by (auto simp add: xor_def)

lemma xorI2 [intro]:
  assumes a1: "\<not>x \<turnstile> y" and a2: "x \<turnstile> \<not>y"
  shows "x \<xor> y"
  using a1 a2
  by (auto simp add: xor_def)

lemma xor_conv:
  "x \<xor> y \<Leftrightarrow> (x \<and> \<not>y) \<or> (y \<and> \<not>x)"
  by (auto simp add: xor_def)

lemma xorE [elim!]:
  assumes a1: "x \<xor> y" and a2: "\<lbrakk> x; \<not>y \<rbrakk> \<turnstile> R" and a3: "\<lbrakk> y; \<not>x \<rbrakk> \<turnstile> R"
  shows "R"
  using a1 a2 a3
  by (auto simp add: xor_conv)

lemma
  assumes a1: "x \<xor> y"
  shows xorD1: "x \<turnstile> \<not>y" and xorD2: "y \<turnstile> \<not>x"
  using a1
  by (auto simp add: xor_def)

definition
  ch_xor :: "[\<bool>, \<bool>] \<rightarrow> \<bool>"
where
  ch_xor_def [simp]: "ch_xor x y \<defs> x \<xor> y"

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>ch_xor" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "<\<noteq>>" 50)

syntax (zed)
  "_xHOL_Defs\<ZZ>ch_xor" :: "[args, chainelt] \<rightarrow> chainrel" (infixr "\<chXor>" 50)

parse_translation {*

[chNode_tr "xHOL_Defs" "ch_xor"]

*}

print_translation {*

[chNode_tr' "xHOL_Defs" "ch_xor"]

*}

subsection {* Definedness *}

text {*

A definedness operator for optional values is useful.

*}

fun
  defOpt :: "'a\<option> \<rightarrow> \<bool>"
where
    "defOpt \<None> = \<False>"
  | "defOpt a\<option> = \<True>"

notation (xsymbols output)
  defOpt ("\<Delta>")

notation (zed)
  defOpt ("\<defOpt>")

(*
text {*

Some Z-style syntax for the @{term Least} operator.

*}

definition
  set_Least :: "('a::ord) set \<rightarrow> 'a"
where
  set_Least_def: "set_Least X \<defs> (\<sthe> x | x \<in> X \<and> (\<forall> y \<bullet> y \<in> X \<Rightarrow> x \<le> y))"

definition
  set_Greatest :: "('a::ord) set \<rightarrow> 'a"
where
  set_Greatest_def: "set_Greatest X \<defs> (\<sthe> x | x \<in> X \<and> (\<forall> y \<bullet> y \<in> X \<Rightarrow> y \<le> x))"

syntax ("" output)
  "_xHOL_Defs\<ZZ>st_Least" :: "schematext \<rightarrow> logic" ("LEAST _" 0)
  "_xHOL_Defs\<ZZ>st_Greatest" :: "schematext \<rightarrow> logic" ("GREATEST _" 0)

syntax (xsymbols output)
  "_xHOL_Defs\<ZZ>st_Least" :: "schematext \<rightarrow> logic" ("\<mu> _" 0)
  "_xHOL_Defs\<ZZ>st_Greatest" :: "schematext \<rightarrow> logic" ("\<nu> _" 0)

syntax (zed)
  "_xHOL_Defs\<ZZ>st_Least" :: "schematext \<rightarrow> logic" ("\<LEAST> _" 0)
  "_xHOL_Defs\<ZZ>st_Greatest" :: "schematext \<rightarrow> logic" ("\<GREATEST> _" 0)

translations
  "_xHOL_Defs\<ZZ>st_Least S" \<rightleftharpoons> "CONST xHOL_Defs.set_Least (_xHOL_Syntax\<ZZ>coll S)"
  "_xHOL_Defs\<ZZ>st_Greatest S" \<rightleftharpoons> "CONST xHOL_Defs.set_Greatest (_xHOL_Syntax\<ZZ>coll S)"

lemma set_LeastI2_order:
  "\<lbrakk> (x::'a::order) \<in> X;
     (\<And> y \<bullet> y \<in> X \<turnstile> x \<le> y);
     (\<And> x \<bullet> \<lbrakk> x \<in> X; \<forall> y \<bullet> y \<in> X \<Rightarrow> x \<le> y \<rbrakk> \<turnstile> Q x) \<rbrakk>
   \<turnstile> Q (set_Least X)"
  apply (unfold set_Least_def)
  apply (rule set_theI2)
  apply (simp_all)
  apply (blast intro: order_antisym)+
  done

lemma set_GreatestI2_order:
  "\<lbrakk> (x::'a::order) \<in> X;
     (\<And> y \<bullet> y \<in> X \<turnstile> y \<le> x);
     (\<And> x \<bullet> \<lbrakk> x \<in> X; \<forall> y \<bullet> y \<in> X \<Rightarrow> y \<le> x \<rbrakk> \<turnstile> Q x) \<rbrakk>
   \<turnstile> Q (set_Greatest X)"
  apply (unfold set_Greatest_def)
  apply (rule set_theI2)
  apply (simp_all)
  apply (blast intro: order_antisym)+
  done

lemma collect_LeastI2_order:
  "\<lbrakk> P (x::'a::order);
     (\<And> y \<bullet> P y \<turnstile> x \<le> y);
     (\<And> x \<bullet> \<lbrakk> P x; \<forall> y \<bullet> P y \<Rightarrow> x \<le> y \<rbrakk> \<turnstile> Q x) \<rbrakk>
   \<turnstile> Q (set_Least (Collect P))"
  apply (unfold set_Least_def)
  apply (rule set_theI2)
  apply (simp_all)
  apply (blast intro: order_antisym)+
  done

lemma collect_GreatestI2_order:
  "\<lbrakk> P (x::'a::order);
     (\<And> y \<bullet> P y \<turnstile> y \<le> x);
     (\<And> x \<bullet> \<lbrakk> P x; \<forall> y \<bullet> P y \<Rightarrow> y \<le> x \<rbrakk> \<turnstile> Q x) \<rbrakk>
   \<turnstile> Q (set_Greatest (Collect P))"
  apply (unfold set_Greatest_def)
  apply (rule set_theI2)
  apply (simp_all)
  apply (blast intro: order_antisym)+
  done

lemma set_Least_equality:
  "\<lbrakk> (k::'a::order) \<in> X; (\<And> x \<bullet> x \<in> X \<turnstile> k \<le> x) \<rbrakk> \<turnstile> set_Least X = k"
  apply (simp add: set_Least_def)
  apply (rule set_the_equality)
  apply (auto intro!: order_antisym)
  done

lemma set_Greatest_equality:
  "\<lbrakk> (k::'a::order) \<in> X; (\<And> x \<bullet> x \<in> X \<turnstile> x \<le> k) \<rbrakk> \<turnstile> set_Greatest X = k"
  apply (simp add: set_Greatest_def)
  apply (rule set_the_equality)
  apply (auto intro!: order_antisym)
  done

lemma collect_Least_equality:
  "\<lbrakk> P (k::'a::order); (\<And> x \<bullet> P x \<turnstile> k \<le> x) \<rbrakk> \<turnstile> set_Least (Collect P) = k"
  apply (simp add: set_Least_def)
  apply (rule set_the_equality)
  apply (auto intro!: order_antisym)
  done

lemma collect_Greatest_equality:
  "\<lbrakk> P (k::'a::order); (\<And> x \<bullet> P x \<turnstile> x \<le> k) \<rbrakk> \<turnstile> set_Greatest (Collect P) = k"
  apply (simp add: set_Greatest_def)
  apply (rule set_the_equality)
  apply (auto intro!: order_antisym)
  done

lemma wellorder_set_Least_lemma [rule_format]:
  "(k::'a::wellorder) \<in> X \<Rightarrow> set_Least X \<in> X \<and> set_Least X \<le> k"
  apply (rule_tac a = k in wf [THEN wf_induct])
  apply (rule impI)
  apply (rule classical)
  apply (rule_tac s = x in set_Least_equality [THEN ssubst], auto)
  apply (auto simp add: linorder_not_less [symmetric])
  done

lemma wellorder_collect_Least_lemma [rule_format]:
  "P (k::'a::wellorder) \<Rightarrow> P (set_Least (Collect P)) \<and> set_Least (Collect P) \<le> k"
  apply (rule_tac a = k in wf [THEN wf_induct])
  apply (rule impI)
  apply (rule classical)
  apply (rule_tac s = x in collect_Least_equality [THEN ssubst], auto)
  apply (auto simp add: linorder_not_less [symmetric])
  done

lemmas set_LeastI   = wellorder_set_Least_lemma [THEN conjunct1, standard]
lemmas set_Least_le = wellorder_set_Least_lemma [THEN conjunct2, standard]

lemmas collect_LeastI   = wellorder_collect_Least_lemma [THEN conjunct1, standard]
lemmas collect_Least_le = wellorder_collect_Least_lemma [THEN conjunct2, standard]

-- "The following 3 lemmas are due to Brian Huffman"
lemma set_LeastI_ex:
  "(\<exists> x::'a::wellorder \<bullet> x \<in> X) \<turnstile> set_Least X \<in> X"
  apply (erule exE)
  apply (erule set_LeastI)
  done

lemma collect_LeastI_ex:
  "(\<exists> x::'a::wellorder \<bullet> P x) \<turnstile> P (set_Least (Collect P))"
  apply (erule exE)
  apply (erule collect_LeastI)
  done

lemma set_LeastI2:
  "\<lbrakk> (a::'a::wellorder) \<in> X; (\<And> x \<bullet> x \<in> X \<turnstile> Q x) \<rbrakk> \<turnstile> Q (set_Least X)"
  by (blast intro: set_LeastI)

lemma collect_LeastI2:
  "\<lbrakk> P (a::'a::wellorder); (\<And> x \<bullet> P x \<turnstile> Q x) \<rbrakk> \<turnstile> Q (set_Least (Collect P))"
  by (blast intro: collect_LeastI)

lemma not_less_set_Least: "[| k < (set_Least X) |] ==> (k::'a::wellorder) \<notin> X"
apply (simp (no_asm_use) add: linorder_not_le [symmetric])
apply (erule contrapos_nn)
apply (erule set_Least_le)
done

lemma not_less_collect_Least: "[| k < (set_Least (Collect P)) |] ==> \<not>(P (k::'a::wellorder))"
apply (simp (no_asm_use) add: linorder_not_le [symmetric])
apply (erule contrapos_nn)
apply (erule collect_Least_le)
done

lemma set_Least_singleton:
  "set_Least {x::('a::order)} = x"
  apply (rule set_Least_equality)
  apply (auto)
  done

*)

subsection {* Disjoint sets *}

text {*

The concept of disjointness is frequently useful.

*}

definition
  disjoint :: "['a set, 'a set] \<rightarrow> \<bool>"
  where
  disjoint_def: "disjoint \<defs> (\<olambda> X Y \<bullet> X \<inter> Y = \<emptyset>)"

lemma disjoint_union:
  assumes
    a1: "disjoint X Y" and
    a2: "x \<in> X \<union> Y"
  shows "x \<in> X \<xor> x \<in> Y"
  using a1 a2
  by (auto simp add: disjoint_def)

lemma disjointI:
  assumes
    a1: "\<And> x \<bullet> \<lbrakk> x \<in> X; x \<in> Y \<rbrakk> \<turnstile> \<False>"
  shows
    "disjoint X Y"
  by (auto intro!: a1 simp add: disjoint_def)

lemma disjointD1:
  assumes
    a1: "disjoint X Y" and
    a2: "x \<in> X"
  shows
    "x \<notin> Y"
  using a1 a2
  by (auto simp add: disjoint_def)

lemma disjointD2:
  assumes
    a1: "disjoint X Y" and
    a2: "x \<in> Y"
  shows
    "x \<notin> X"
  using a1 a2
  by (auto simp add: disjoint_def)

lemma disjointE1:
  assumes
    a1: "disjoint X Y" "x \<in> X \<union> Y" and
    a2: "\<lbrakk> x \<in> X; x \<notin> Y \<rbrakk> \<turnstile> R" and
    a3: "\<lbrakk> x \<in> Y; x \<notin> X \<rbrakk> \<turnstile> R"
  shows
    "R"
  using a1
  by (auto intro: a2 a3 simp add: disjoint_def set_eq_iff)

lemma disjointE:
  assumes
    a1: "disjoint X Y" and
    a2: "\<not> R \<turnstile> x \<in> X" and
    a3: "\<not> R \<turnstile> x \<in> Y"
  shows
    "R"
  using a1 a2 a3
  by (auto simp add: disjoint_def set_eq_iff)

lemma disjoint_el_ne:
  assumes
    a1: "disjoint X Y" and
    a2: "x \<in> X" and
    a3: "y \<in> Y"
  shows
    "x \<noteq> y"
  using a1 a2 a3
  by (auto simp add: disjoint_def)

lemma disjoint_right_mono:
  assumes
    a1: "B \<subseteq> C" "disjoint A C"
  shows
    "disjoint A B"
  using a1
  by (auto simp add: disjoint_def)

lemma disjoint_left_mono:
  assumes
    a1: "B \<subseteq> C" "disjoint C A"
  shows
      "disjoint B A"
  using a1
  by (auto simp add: disjoint_def)

lemma disjoint_right_Union_iff:
  "disjoint A (\<Union>\<B>) \<Leftrightarrow> (\<forall> B | B \<in> \<B> \<bullet> disjoint A B)"
  by (auto simp add: disjoint_def)

lemma disjoint_left_Union_iff:
  "disjoint (\<Union>\<B>) A \<Leftrightarrow> (\<forall> B | B \<in> \<B> \<bullet> disjoint B A)"
      by (auto simp add: disjoint_def)

primrec
  disj_list :: "'a set list \<rightarrow> \<bool>"
where
  "disj_list [] \<Leftrightarrow> \<True>"
| "disj_list (A#S) \<Leftrightarrow> (\<forall> X | X \<in> set S \<bullet> disjoint A X) \<and> disj_list S"

lemma
  "disj_list [{1::nat}, {2}, {3}]"
  by (simp add: disjoint_def)

definition
  part_list :: "['a set, 'a set list] \<rightarrow> \<bool>"
where
  "part_list A \<AA> \<Leftrightarrow> disj_list \<AA> \<and> A = (\<Union>(set \<AA>))"

lemma
  "part_list {1, 2, 3} [{1::nat}, {2}, {3}]"
  "part_list {1, 2, 3} [{1::nat, 2}, {3}]"
  by (auto simp add: part_list_def disjoint_def)

lemma
  "part_list A [X, Y, Z] \<Rightarrow> X \<inter> Y = \<emptyset>"
  "part_list A [X, Y, Z] \<and> a \<in> A \<Rightarrow> a \<in> X \<or> a \<in> Y \<or> a \<in> Z"
  by (auto simp add: part_list_def disjoint_def)

definition
  "Disjoint \<X> \<Leftrightarrow> (\<forall> X Y | X \<in> \<X> \<and> Y \<in> \<X> \<bullet> disjoint X Y \<Leftrightarrow> X \<noteq> Y)"

lemma Disjoint_def':
  "Disjoint \<X> \<Leftrightarrow> (\<forall> X Y | X \<in> \<X> \<and> Y \<in> \<X> \<bullet> \<not> disjoint X Y \<Leftrightarrow> X = Y)"
  by (auto simp add: Disjoint_def)

lemma DisjointI:
  assumes
    a1: "\<emptyset> \<notin> \<X>" and
    a2: "(\<And> X Y \<bullet> \<lbrakk> X \<in> \<X>; Y \<in> \<X>; X \<noteq> Y \<rbrakk> \<turnstile> disjoint X Y)"
  shows
    "Disjoint \<X>"
  apply (simp add: Disjoint_def)
  apply (mauto(inference) mintro!: a2)
  apply (auto simp add: disjoint_def a1)
  done

lemma DisjointD0:
  assumes
    a1: "Disjoint \<X>"
  shows
    "\<emptyset> \<notin> \<X>"
  using a1
  by (auto simp add: Disjoint_def disjoint_def)

lemma DisjointD1:
  assumes
    a1: "Disjoint \<X>" and
    a2: "X \<in> \<X>" and
    a3: "Y \<in> \<X>" and
    a4: "X \<noteq> Y"
  shows
    "disjoint X Y"
  using a1 a2 a3 a4
  by (auto simp add: Disjoint_def)

lemma DisjointD1':
  assumes
    a1: "Disjoint \<X>" and
    a2: "X \<in> \<X>" and
    a3: "Y \<in> \<X>" and
    a4: "\<not>disjoint X Y"
  shows
    "X = Y"
  using a1 a2 a3 a4
  by (auto simp add: Disjoint_def)

lemma DisjointD2:
  assumes
    a1: "Disjoint \<X>" and
    a2: "X \<in> \<X>" and
    a3: "Y \<in> \<X>" and
    a4: "disjoint X Y"
  shows
    "X \<noteq> Y"
  using a1 a2 a3 a4
  by (auto simp add: Disjoint_def)

lemma DisjointD2':
  assumes
    a1: "Disjoint \<X>" and
    a2: "X \<in> \<X>" and
    a3: "Y \<in> \<X>" and
    a4: "X = Y"
  shows
    "\<not> disjoint X Y"
  using a1 a2 a3 a4
  by (auto simp add: Disjoint_def)

definition
  "Partition A \<X> \<Leftrightarrow> Disjoint \<X> \<and> \<Union>\<X> = A"

lemmas PartitionI = Partition_def [THEN iffD2, OF conjI, OF DisjointI]

lemmas PartitionD1 = Partition_def [THEN iffD1, THEN conjunct1]
lemmas PartitionD10 = PartitionD1 [THEN DisjointD0]
lemmas PartitionD11 = PartitionD1 [THEN DisjointD1]
lemmas PartitionD12 = PartitionD1 [THEN DisjointD2]
lemmas PartitionD2 = Partition_def [THEN iffD1, THEN conjunct2]

subsection {* Constant-valued functions *}

text {*

A constant valued function constructor is of occasional use.

*}

definition
  funK :: "'a \<rightarrow> ('b \<rightarrow> 'a)"
where
  funK_def: "funK c \<defs> (\<olambda> b \<bullet> c)"

notation (zed)
  funK ("\<^funK>{:_:}")

subsection {* Relation Operators *}

text {*

Although
operator relations often have their own infix syntax, this is not
always the case,
so we introduce syntax for infix application of operator relations,
similar to that for infix application of graph relations.

*}

syntax (zed)
  "_xHOL_Defs\<ZZ>infop" :: "['a, ['a, 'b] \<rightarrow> 'c, 'b] \<rightarrow> 'c" ("\<^infop>{:_:}{:_:}{:_:}")
  "_xHOL_Defs\<ZZ>infopa" :: "['a, ['a, 'b] \<rightarrow> 'c, 'b] \<rightarrow> 'c" ("\<^infopa>{:_:}{:_:}{:_:}")

translations
  "\<^infop>{:a:}{:R:}{:b:}" \<rightharpoonup> "R a b"
  "\<^infopa>{:a:}{:R:}{:b:}" \<rightharpoonup> "R a b"

subsection {* Hidden identity *}

text {*

We introduce a copy of the identity, to act either as a placeholder for translations or
else to suppress print translations.

*}

definition
  zid :: "'a \<rightarrow> 'a"
where
  zid_def [simp]: "zid a \<defs> a"

notation (xsymbols output)
  zid ("_" [1000] 1000)

notation (zed)
  zid ("\<^zid>{:_:}" [1000] 1000)

subsection {* Intervals *}

definition
  oINTVLo :: "['a::linorder, 'a] \<rightarrow> 'a set"
where
  oINTVLo_def: "oINTVLo a b \<defs> {x | a < x \<and> x < b}"

definition
  oINTVLc :: "['a::linorder, 'a] \<rightarrow> 'a set"
where
  oINTVLc_def: "oINTVLc a b \<defs> {x | a < x \<and> x \<le> b}"

definition
  cINTVLo :: "['a::linorder, 'a] \<rightarrow> 'a set"
where
  cINTVLo_def: "cINTVLo a b \<defs> {x | a \<le> x \<and> x < b}"

definition
  cINTVLc :: "['a::linorder, 'a] \<rightarrow> 'a set"
where
  cINTVLc_def: "cINTVLc a b \<defs> {x | a \<le> x \<and> x \<le> b}"

notation (xsymbols output)
  oINTVLo ("'(-_\<dots>_-')") and
  oINTVLc ("'(-_\<dots>_-]") and
  cINTVLo ("[-_\<dots>_-')") and
  cINTVLc ("[-_\<dots>_-]")

notation (zed)
  oINTVLo ("\<lopen>_\<dots>_\<ropen>") and
  oINTVLc ("\<lopen>_\<dots>_\<rclose>") and
  cINTVLo ("\<lclose>_\<dots>_\<ropen>") and
  cINTVLc ("\<lclose>_\<dots>_\<rclose>")

definition
  neighbourhood :: "['a::{plus, minus, linorder}, 'a] \<rightarrow> 'a set"
where
  neighbourhood_def: "neighbourhood x BS_delta \<defs> {x - BS_delta<..<x + BS_delta}"

notation (xsymbols output)
  neighbourhood  ("_\<plusminus>_" [1000, 1000] 1000)

notation (zed)
  neighbourhood ("_\<plusminus>_" [1000, 1000] 1000)

lemmas interval_defs =
  lessThan_def atMost_def greaterThan_def atLeast_def
  greaterThanLessThan_def atLeastLessThan_def greaterThanAtMost_def atLeastAtMost_def
  oINTVLo_def oINTVLc_def cINTVLo_def cINTVLc_def neighbourhood_def

lemma cINTVLo_atLeastLessThan:
  "\<lclose>0\<dots>N\<ropen> = {0..<N}"
  by (auto simp add: atLeastLessThan_def)

lemma cINTVLc_atLeastAtMost:
  "\<lclose>0\<dots>N\<rclose> = {0..N}"
  by (auto simp add: atLeastAtMost_def)

lemma oINTVLo_greaterThanLessThan:
  "\<lopen>0\<dots>N\<ropen> = {0<..<N}"
  by (auto simp add: greaterThanLessThan_def)

lemma oINTVLc_greaterThanAtMost:
  "\<lopen>0\<dots>N\<rclose> = {0<..N}"
  by (auto simp add: greaterThanAtMost_def)

text {*

It may sometimes be useful to force elements to be in the representation
set, for example to stop repeated unnecessary calculation of membership.

*}

definition
  force :: "['a set, 'a] \<rightarrow> 'a"
where
  force_def: "force A x \<defs> \<if> x \<in> A \<then> x \<else> (\<some> y | y \<in> A) \<fi>"

definition
  pforce :: "['a \<rightarrow> \<bool>, 'a] \<rightarrow> 'a"
where
  pforce_def: "pforce \<phi> x \<defs> \<if> \<phi> x \<then> x \<else> (\<some> y | \<phi> y) \<fi>"

text {*

A dual space is simply a distinguished copy of a given type that
can be given a variant algebraic structure. For example, we
give the dual the reverse of the original order on a type.

*}

typedef
  'a dual = "{a::'a | \<True>}"
  by (auto)

notation (xsymbols output)
  Abs_dual ("_\<^sup>\<circ>" [1000] 1000) and
  Rep_dual ("_\<^sup>\<bullet>" [1000] 1000)

notation (zed)
  Abs_dual ("\<^adual>{:_:}" [1000] 1000) and
  Rep_dual ("\<^rdual>{:_:}" [1000] 1000)

interpretation Abs_TD : type_definition "Rep_dual" "Abs_dual" "{ x | \<True> }"
  by (rule type_definition_dual)

lemma Abs_dual:
  "a \<in> { x | \<True> }"
  by (simp)

lemma Abs_dual_inverse2:
  "\<^rdual>{:(\<^adual>{:y:}):} = y"
  by (rule Abs_dual [THEN Abs_dual_inverse])

lemma Abs_dual_inject2:
  "\<^adual>{:x:} = \<^adual>{:y:} \<Leftrightarrow> x = y"
  by (rule Abs_dual_inject [OF Abs_dual Abs_dual])

end


theory Typing
  imports Nat_ZF
begin

text \<open>
  We define a meta-type of types, which is isomorphic to predicates. Pi-types
  and the type of sets can then be introduced as definitions.

  We define some syntax translations to introduce a telescope-like syntax.
\<close>

(* Just an embedding of Pure predicates into a new type, for more explicit handling *)
typedecl 'a type

axiomatization
  Type :: "('a::{} \<Rightarrow> prop) \<Rightarrow> 'a type"
  and pred_of :: "'a type \<Rightarrow> 'a \<Rightarrow> prop"
  where pred_of_Type: "pred_of (Type t) \<equiv> t"

definition has_type :: "'a::{} \<Rightarrow> 'a type \<Rightarrow> prop" (infix ":::" 40)
  where "x ::: T \<equiv> pred_of T x"

lemma has_type_Type[simp]: "x ::: Type P \<equiv> P x"
  unfolding has_type_def pred_of_Type .

subsection \<open> Pi-Types \<close>

definition Pi_type :: "'a::{} type \<Rightarrow> ('a \<Rightarrow> 'b::{} type) \<Rightarrow> ('a \<Rightarrow> 'b) type"
  where
  "Pi_type \<sigma> \<tau> \<equiv> Type (\<lambda>f. (\<And>x. x ::: \<sigma> \<Longrightarrow> f x ::: \<tau> x))"

syntax
  "_telescope" :: "[pttrn, 'a type, 'b type] \<Rightarrow> 'c type"  ("'(_ : _') \<Rightarrow> _" 50)
translations
  "(x : A) \<Rightarrow> B" \<rightleftharpoons> "CONST Pi_type A (\<lambda>x. B)"

term "(x : A) \<Rightarrow> (y : B) \<Rightarrow> C y"
term "t ::: (x : set A) \<Rightarrow> (set (A + B))"

lemma Pi_typeI:
  assumes a: "\<And>(x::'a::{}). x ::: A \<Longrightarrow> f x ::: B x"
  shows "f ::: (x:A) \<Rightarrow> B x"
  unfolding Pi_type_def has_type_Type
  by (rule a)

lemma Pi_typeE:
  assumes 1: "f ::: (x: A) \<Rightarrow> B x"
  assumes 2: "x ::: A"
  shows "f x ::: B x"
proof -
  from 2
  show "PROP ?thesis"
    by (rule 1[unfolded Pi_type_def has_type_Type, rule_format])
qed

(* Implicit version. Currently unused

axiomatization
  Implicit_Pi_type :: "'a type \<Rightarrow> ('a::{} \<Rightarrow> 'b::{} type) \<Rightarrow> ('a \<Rightarrow> 'b) type"

syntax
  "_telescope_implicit" :: "[pttrn, 'a type, 'b type] \<Rightarrow> 'c type"  ("'{_ : _'} \<Rightarrow> _" 50)
translations
  "{x : A} \<Rightarrow> B" \<rightleftharpoons> "CONST Implicit_Pi_type A (\<lambda>x. B)"

*)

subsection \<open> Type of sets \<close>
definition Set :: "i type"
  where "Set \<equiv> Type (\<lambda>x::i. (x == x))"

lemma Set_TypeI: "(x::i) ::: Set"
  unfolding Set_def has_type_Type .

subsection \<open> Type of elements of a given set \<close>

definition set :: "i \<Rightarrow> i type"
  where "set A == Type (%x. Trueprop (x \<in> A))"

lemma set_typeI: "x \<in> A \<Longrightarrow> x ::: set A"
  unfolding set_def has_type_Type .

lemma set_typeE: "x ::: set A \<Longrightarrow> x \<in> A"
  unfolding set_def has_type_Type .

subsection \<open> Type of object-level propositions \<close>

definition o :: "o type"
  where "o \<equiv> Type (\<lambda>x::o. (x == x))"

lemma o_TypeI: "(P::o) ::: o"
  unfolding o_def has_type_Type .

ML_file "soft_type.ML"
ML_file "zf_logic.ML"
ML_file "soft_type_context.ML"
ML_file "soft_type_inference.ML"

lemma eq[type]: "((=)::(i \<Rightarrow> i \<Rightarrow> o)) ::: (x: A) \<Rightarrow> (y: A) \<Rightarrow> o"
  by (intro Pi_typeI o_TypeI)

text \<open> Example: Inferring types for list append \<close>

context
  fixes List :: "i \<Rightarrow> i"
    and Nil :: "i \<Rightarrow> i"
    and Cons :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
    and append :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
  assumes [type]: "Nil ::: (A: Set) \<Rightarrow> set (List A)"
    and [type]: "Cons ::: (A: Set) \<Rightarrow> (x: set A) \<Rightarrow> (xs : set (List A)) \<Rightarrow> set (List A)"
    and [type]: "append ::: (A: Set) \<Rightarrow> (xs: set (List A)) \<Rightarrow> (ys : set (List A)) \<Rightarrow> set (List A)"
begin

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "Nil A = B"}
]\<close>

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "%A. Nil A"}
]\<close>

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "%A x xs. Cons A x xs"}
]\<close>

ML \<open>

Soft_Type_Inference.print_inferred_types @{context} [
  @{term "append A (Cons A x xs) ys = Cons A x (append A xs ys)"},
  @{term "append A (Nil A) ys = ys"}
]
\<close>

(*
ML \<open>

Soft_Type_Inference.print_inferred_types @{context} [
  @{term "\<And>A x xs ys. append A (Cons A x xs) ys = Cons A x (append A xs ys)"},
  @{term "\<And>A ys. append A (Nil A) ys = ys"}
]
\<close>
*)

end

text \<open> Example: Inferring types for vectors of given length \<close>

context
  fixes Vec :: "i \<Rightarrow> i \<Rightarrow> i"
    and VNil :: "i \<Rightarrow> i"
    and VCons :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
    and add :: "i \<Rightarrow> i \<Rightarrow> i"
    and vappend :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
  assumes [type]: "Vec ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> Set"
    and [type]: "VNil ::: (A: Set) \<Rightarrow> set (Vec A 0)"
    and [type]: "VCons ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> (x: set A) \<Rightarrow> (xs : set (Vec A n)) \<Rightarrow> set (Vec A (succ n))"
    and [type]: "add ::: (n : set nat) \<Rightarrow> (m : set nat) \<Rightarrow> set nat"
    and [type]: "succ ::: (n : set nat) \<Rightarrow> set nat"
    and [type]: "0 ::: set nat"
    and [type]: "vappend ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> (m: set nat) \<Rightarrow> (xs: set (Vec A n))
\<Rightarrow> (ys: set (Vec A m)) \<Rightarrow> set (Vec A (add n m))"
begin

(*

ML \<open> Soft_Type_Inference.print_inferred_types @{context} [
  @{term "vappend A (succ n) m (VCons A n x xs) ys
   = VCons A (add n m) x (vappend A n m xs ys)"}
]\<close>
*)

end

(*

axiomatization
  bijective :: "i \<Rightarrow> i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> o"
and compose :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> i \<Rightarrow> i"
lemma "bijective ::: (A: Type) \<Rightarrow> (B: Type) \<Rightarrow> (f:(x:A)\<Rightarrow>B) \<Rightarrow> Type"]]

lemma "f \<in> bij A B \<Longrightarrow> g \<in> bij B C \<Longrightarrow> g O f \<in> bij A C"

*)

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory UnboxedNats
imports
  HOLCF
  Nats
  WorkerWrapperNew
begin
(*>*)

section{* Unboxing types. *}

text{* The original application of the worker/wrapper transformation
was the unboxing of flat types by \citet{SPJ-JL:1991}. We can model
the boxed and unboxed types as (respectively) pointed and unpointed
domains in HOLCF. Concretely @{typ "UNat"} denotes the discrete domain
of naturals, @{typ "UNat\<^sub>\<bottom>"} the lifted (flat and pointed) variant, and
@{typ "Nat"} the standard boxed domain, isomorphic to @{typ
"UNat\<^sub>\<bottom>"}. This latter distinction helps us keep the boxed naturals and
lifted function codomains separated; applications of @{term "unbox"}
should be thought of in the same way as Haskell's @{term "newtype"}
constructors, i.e. operationally equivalent to @{term "ID"}.

The divergence monad is used to handle the unboxing, see below. *}

subsection{* Factorial example. *}

text{* Standard definition of factorial. *}

fixrec fac :: "Nat \<rightarrow> Nat"
where
  "fac\<cdot>n = If n =\<^sub>B 0 then 1 else n * fac\<cdot>(n - 1)"

declare fac.simps[simp del]

lemma fac_strict[simp]: "fac\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  fac_body :: "(Nat \<rightarrow> Nat) \<rightarrow> Nat \<rightarrow> Nat" where
  "fac_body \<equiv> \<Lambda> r n. If n =\<^sub>B 0 then 1 else n * r\<cdot>(n - 1)"

lemma fac_body_strict[simp]: "fac_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
  unfolding fac_body_def by simp

lemma fac_fac_body_eq: "fac = fix\<cdot>fac_body"
  unfolding fac_body_def by (rule cfun_eqI, subst fac_def, simp)

text{* Wrap / unwrap functions. Note the explicit lifting of the
co-domain. For some reason the published version of
\citet{GillHutton:2009} does not discuss this point: if we're going to
handle recursive functions, we need a bottom.

@{term "unbox"} simply removes the tag, yielding a possibly-divergent
unboxed value, the result of the function. *}

definition
  unwrapB :: "(Nat \<rightarrow> Nat) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "unwrapB \<equiv> \<Lambda> f. unbox oo f oo box"

text{* Note that the monadic bind operator @{term "op >>="} here stands
in for the \textsf{case} construct in the paper. *}

definition
  wrapB :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> Nat \<rightarrow> Nat" where
  "wrapB \<equiv> \<Lambda> f x . unbox\<cdot>x >>= f >>= box"

lemma wrapB_unwrapB_body:
  assumes strictF: "f\<cdot>\<bottom> = \<bottom>"
  shows "(wrapB oo unwrapB)\<cdot>f = f" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x :: Nat
  have "?lhs\<cdot>x = unbox\<cdot>x >>= (\<Lambda> x'. unwrapB\<cdot>f\<cdot>x' >>= box)"
    unfolding wrapB_def by simp
  also have "\<dots> = unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>(f\<cdot>(box\<cdot>x')) >>= box)"
    unfolding unwrapB_def by simp
  also from strictF have "\<dots> = f\<cdot>x" by (cases x, simp_all)
  finally show "?lhs\<cdot>x = ?rhs\<cdot>x" .
qed

text{* Apply worker/wrapper. *}

definition
  fac_work :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work \<equiv> fix\<cdot>(unwrapB oo fac_body oo wrapB)"

definition
  fac_wrap :: "Nat \<rightarrow> Nat" where
  "fac_wrap \<equiv> wrapB\<cdot>fac_work"

lemma fac_fac_ww_eq: "fac = fac_wrap" (is "?lhs = ?rhs")
proof -
  have "wrapB oo unwrapB oo fac_body = fac_body"
    using wrapB_unwrapB_body[OF fac_body_strict]
    by - (rule cfun_eqI, simp)
  thus ?thesis
    using worker_wrapper_body[where computation=fac and body=fac_body and wrap=wrapB and unwrap=unwrapB]
    unfolding fac_work_def fac_wrap_def by (simp add: fac_fac_body_eq)
qed

text{* This is not entirely faithful to the paper, as they don't
explicitly handle the lifting of the codomain. *}

definition
  fac_body' :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body' \<equiv> \<Lambda> r n.
     unbox\<cdot>(If box\<cdot>n =\<^sub>B 0
              then 1
              else unbox\<cdot>(box\<cdot>n - 1) >>= r >>= (\<Lambda> b. box\<cdot>n * box\<cdot>b))"

text{* The @{term "up"} constructors here again mediate the
isomorphism, operationally doing nothing. Note the switch to the
machine-oriented \emph{if} construct: the test @{term "n = 0"} cannot
diverge. *}

definition
  fac_body_final :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body_final \<equiv> \<Lambda> r n.
     if n = 0 then up\<cdot>1 else r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> b. up\<cdot>(n *\<^sub># b))"

lemma fac_body_final_fac_body': "fac_body_final = fac_body'" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix r x
  show "?lhs\<cdot>r\<cdot>x = ?rhs\<cdot>r\<cdot>x"
    using bbind_case_distr_strict[where f="unbox" and g="r\<cdot>(x -\<^sub># 1)" and h="(\<Lambda> b. box\<cdot>(x *\<^sub># b))"]
    unfolding fac_body_final_def fac_body'_def uMinus_def uMult_def zero_Nat_def one_Nat_def
    by simp
qed

definition
  fac_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work_final \<equiv> fix\<cdot>fac_body_final"

definition
  fac_final :: "Nat \<rightarrow> Nat" where
  "fac_final \<equiv> \<Lambda> n. unbox\<cdot>n >>= fac_work_final >>= box"

lemma fac_fac_final: "fac = fac_final" (is "?lhs=?rhs")
proof -
  have "?lhs = fac_wrap" by (rule fac_fac_ww_eq)
  also have "\<dots> = wrapB\<cdot>fac_work" by (simp only: fac_wrap_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>(unwrapB oo fac_body oo wrapB))" by (simp only: fac_work_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>fac_body')" by (simp only: fac_body'_fac_body)
  also have "\<dots> = wrapB\<cdot>fac_work_final" by (simp only: fac_body_final_fac_body' fac_work_final_def)
  also have "\<dots> = fac_final" by (simp add: fac_final_def wrapB_def)
  finally show ?thesis .
qed

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

subsection{* Introducing an accumulator. *}

text{*

The final version of factorial uses unboxed naturals but is not
tail-recursive. We can apply worker/wrapper once more to introduce an
accumulator, similar to \S\ref{sec:accum}.

The monadic machinery complicates things slightly here. We use
\emph{Kleisli composition}, denoted @{term "op >=>"}, in the
homomorphism.

Firstly we introduce an ``accumulator'' monoid and show the
homomorphism.

*}

type_synonym UNatAcc = "UNat \<rightarrow> UNat\<^sub>\<bottom>"

definition
  n2a :: "UNat \<rightarrow> UNatAcc" where
  "n2a \<equiv> \<Lambda> m n. up\<cdot>(m *\<^sub># n)"

definition
  a2n :: "UNatAcc \<rightarrow> UNat\<^sub>\<bottom>" where
  "a2n \<equiv> \<Lambda> a. a\<cdot>1"

lemma a2n_strict[simp]: "a2n\<cdot>\<bottom> = \<bottom>"
  unfolding a2n_def by simp

lemma a2n_n2a: "a2n\<cdot>(n2a\<cdot>u) = up\<cdot>u"
  unfolding a2n_def n2a_def by (simp add: uMult_arithmetic)

lemma A_hom_mult: "n2a\<cdot>(x *\<^sub># y) = (n2a\<cdot>x >=> n2a\<cdot>y)"
  unfolding n2a_def bKleisli_def by (simp add: uMult_arithmetic)

definition
  unwrapA :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "unwrapA \<equiv> \<Lambda> f n. f\<cdot>n >>= n2a"

lemma unwrapA_strict[simp]: "unwrapA\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapA_def by (rule cfun_eqI) simp

definition
  wrapA :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "wrapA \<equiv> \<Lambda> f. a2n oo f"

lemma wrapA_unwrapA_id: "wrapA oo unwrapA = ID"
  unfolding wrapA_def unwrapA_def
  apply (rule cfun_eqI)+
  apply (case_tac "x\<cdot>xa")
  apply (simp_all add: a2n_n2a)
  done

text{* Some steps along the way. *}

definition
  fac_acc_body1 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body1 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>(n *\<^sub># res))"

lemma fac_acc_body1_fac_body_final_eq: "fac_acc_body1 = unwrapA oo fac_body_final oo wrapA"
  unfolding fac_acc_body1_def fac_body_final_def wrapA_def unwrapA_def
  by (rule cfun_eqI)+ simp

text{* Use the homomorphism. *}

definition
  fac_acc_body2 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body2 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>n >=> n2a\<cdot>res)"

lemma fac_acc_body2_body1_eq: "fac_acc_body2 = fac_acc_body1"
  unfolding fac_acc_body1_def fac_acc_body2_def
  by (rule cfun_eqI)+ (simp add: A_hom_mult)

text{* Apply worker/wrapper. *}

definition
  fac_acc_body3 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body3 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else n2a\<cdot>n >=> r\<cdot>(n -\<^sub># 1)"

lemma fac_acc_body3_body2: "fac_acc_body3 oo (unwrapA oo wrapA) = fac_acc_body2" (is "?lhs=?rhs")
proof(rule cfun_eqI)+
  fix r n acc
  show "((fac_acc_body3 oo (unwrapA oo wrapA))\<cdot>r\<cdot>n\<cdot>acc) = fac_acc_body2\<cdot>r\<cdot>n\<cdot>acc"
    unfolding fac_acc_body2_def fac_acc_body3_def unwrapA_def
    using bbind_case_distr_strict[where f="\<Lambda> y. n2a\<cdot>n >=> y" and h="n2a", symmetric]
    by simp
qed

lemma fac_work_final_body3_eq: "fac_work_final = wrapA\<cdot>(fix\<cdot>fac_acc_body3)"
  unfolding fac_work_final_def
  by (rule worker_wrapper_fusion_new[OF wrapA_unwrapA_id unwrapA_strict])
     (simp add: fac_acc_body3_body2 fac_acc_body2_body1_eq fac_acc_body1_fac_body_final_eq)

definition
  fac_acc_body_final :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body_final \<equiv> \<Lambda> r n acc.
     if n = 0 then up\<cdot>acc else r\<cdot>(n -\<^sub># 1)\<cdot>(n *\<^sub># acc)"

definition
  fac_acc_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_acc_work_final \<equiv> \<Lambda> x. fix\<cdot>fac_acc_body_final\<cdot>x\<cdot>1"

lemma fac_acc_work_final_fac_acc_work3_eq: "fac_acc_body_final = fac_acc_body3" (is "?lhs=?rhs")
  unfolding fac_acc_body3_def fac_acc_body_final_def n2a_def bKleisli_def
  by (rule cfun_eqI)+
     (simp add: uMult_arithmetic)

lemma fac_acc_work_final_fac_work: "fac_acc_work_final = fac_work_final" (is "?lhs=?rhs")
proof -
  have "?rhs = wrapA\<cdot>(fix\<cdot>fac_acc_body3)" by (rule fac_work_final_body3_eq)
  also have "\<dots> = wrapA\<cdot>(fix\<cdot>fac_acc_body_final)"
    using fac_acc_work_final_fac_acc_work3_eq by simp
  also have "\<dots> = ?lhs"
    unfolding fac_acc_work_final_def wrapA_def a2n_def
    by (simp add: cfcomp1)
  finally show ?thesis by simp
qed

(*<*)
end
(*>*)