(*  Title:      HOL/HOLCF/Adm.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section \<open>Admissibility and compactness\<close>

theory Adm
  imports Cont
begin

default_sort cpo

subsection \<open>Definitions\<close>

definition adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool"
  where "adm P \<longleftrightarrow> (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"

lemma admI: "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
  unfolding adm_def by fast

lemma admD: "adm P \<Longrightarrow> chain Y \<Longrightarrow> (\<And>i. P (Y i)) \<Longrightarrow> P (\<Squnion>i. Y i)"
  unfolding adm_def by fast

lemma admD2: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> chain Y \<Longrightarrow> P (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. P (Y i)"
  unfolding adm_def by fast

lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
  by (rule admI) (erule spec)

subsection \<open>Admissibility on chain-finite types\<close>

text \<open>For chain-finite (easy) types every formula is admissible.\<close>

lemma adm_chfin [simp]: "adm P"
  for P :: "'a::chfin \<Rightarrow> bool"
  by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)

subsection \<open>Admissibility of special formulae and propagation\<close>

lemma adm_const [simp]: "adm (\<lambda>x. t)"
  by (rule admI, simp)

lemma adm_conj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
  by (fast intro: admI elim: admD)

lemma adm_all [simp]: "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
  by (fast intro: admI elim: admD)

lemma adm_ball [simp]: "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
  by (fast intro: admI elim: admD)

text \<open>Admissibility for disjunction is hard to prove. It requires 2 lemmas.\<close>

lemma adm_disj_lemma1:
  assumes adm: "adm P"
  assumes chain: "chain Y"
  assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
  shows "P (\<Squnion>i. Y i)"
proof -
  define f where "f i = (LEAST j. i \<le> j \<and> P (Y j))" for i
  have chain': "chain (\<lambda>i. Y (f i))"
    unfolding f_def
    apply (rule chainI)
    apply (rule chain_mono [OF chain])
    apply (rule Least_le)
    apply (rule LeastI2_ex)
     apply (simp_all add: P)
    done
  have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
    using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
  have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
    apply (rule below_antisym)
     apply (rule lub_mono [OF chain chain'])
     apply (rule chain_mono [OF chain f1])
    apply (rule lub_range_mono [OF _ chain chain'])
    apply clarsimp
    done
  show "P (\<Squnion>i. Y i)"
    unfolding lub_eq using adm chain' f2 by (rule admD)
qed

lemma adm_disj_lemma2: "\<forall>n::nat. P n \<or> Q n \<Longrightarrow> (\<forall>i. \<exists>j\<ge>i. P j) \<or> (\<forall>i. \<exists>j\<ge>i. Q j)"
  apply (erule contrapos_pp)
  apply (clarsimp, rename_tac a b)
  apply (rule_tac x="max a b" in exI)
  apply simp
  done

lemma adm_disj [simp]: "adm (\<lambda>x. P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
  apply (rule admI)
  apply (erule adm_disj_lemma2 [THEN disjE])
   apply (erule (2) adm_disj_lemma1 [THEN disjI1])
  apply (erule (2) adm_disj_lemma1 [THEN disjI2])
  done

lemma adm_imp [simp]: "adm (\<lambda>x. \<not> P x) \<Longrightarrow> adm (\<lambda>x. Q x) \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
  by (subst imp_conv_disj) (rule adm_disj)

lemma adm_iff [simp]: "adm (\<lambda>x. P x \<longrightarrow> Q x) \<Longrightarrow> adm (\<lambda>x. Q x \<longrightarrow> P x) \<Longrightarrow> adm (\<lambda>x. P x \<longleftrightarrow> Q x)"
  by (subst iff_conv_conj_imp) (rule adm_conj)

text \<open>admissibility and continuity\<close>

lemma adm_below [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
  by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)

lemma adm_eq [simp]: "cont (\<lambda>x. u x) \<Longrightarrow> cont (\<lambda>x. v x) \<Longrightarrow> adm (\<lambda>x. u x = v x)"
  by (simp add: po_eq_conv)

lemma adm_subst: "cont (\<lambda>x. t x) \<Longrightarrow> adm P \<Longrightarrow> adm (\<lambda>x. P (t x))"
  by (simp add: adm_def cont2contlubE ch2ch_cont)

lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<notsqsubseteq> u)"
  by (rule admI) (simp add: cont2contlubE ch2ch_cont lub_below_iff)

subsection \<open>Compactness\<close>

definition compact :: "'a::cpo \<Rightarrow> bool"
  where "compact k = adm (\<lambda>x. k \<notsqsubseteq> x)"

lemma compactI: "adm (\<lambda>x. k \<notsqsubseteq> x) \<Longrightarrow> compact k"
  unfolding compact_def .

lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> x)"
  unfolding compact_def .

lemma compactI2: "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
  unfolding compact_def adm_def by fast

lemma compactD2: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
  unfolding compact_def adm_def by fast

lemma compact_below_lub_iff: "compact x \<Longrightarrow> chain Y \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
  by (fast intro: compactD2 elim: below_lub)

lemma compact_chfin [simp]: "compact x"
  for x :: "'a::chfin"
  by (rule compactI [OF adm_chfin])

lemma compact_imp_max_in_chain: "chain Y \<Longrightarrow> compact (\<Squnion>i. Y i) \<Longrightarrow> \<exists>i. max_in_chain i Y"
  apply (drule (1) compactD2, simp)
  apply (erule exE, rule_tac x=i in exI)
  apply (rule max_in_chainI)
  apply (rule below_antisym)
   apply (erule (1) chain_mono)
  apply (erule (1) below_trans [OF is_ub_thelub])
  done

text \<open>admissibility and compactness\<close>

lemma adm_compact_not_below [simp]:
  "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> t x)"
  unfolding compact_def by (rule adm_subst)

lemma adm_neq_compact [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
  by (simp add: po_eq_conv)

lemma adm_compact_neq [simp]: "compact k \<Longrightarrow> cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
  by (simp add: po_eq_conv)

lemma compact_bottom [simp, intro]: "compact \<bottom>"
  by (rule compactI) simp

text \<open>Any upward-closed predicate is admissible.\<close>

lemma adm_upward:
  assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
  shows "adm P"
  by (rule admI, drule spec, erule P, erule is_ub_thelub)

lemmas adm_lemmas =
  adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
  adm_below adm_eq adm_not_below
  adm_compact_not_below adm_compact_neq adm_neq_compact

end


theory v1_isar_new_K
  imports Main "../QML"
begin

text \<open>
@{text "Compossibility\<^sub>6'"}: Necessarily, given a table,  @{term x}, made from a hunk, @{term y},
for any table, @{term x'} which might be made from a hunk, @{term z}, distinct from @{term y}, it
is also possible that both @{term x} is a table made from @{term y} and @{term x'} is a table made
from @{term z}.

@{text "Origin Uniqueness\<^sub>6'"}:
Necessarily, if  @{term x} is a table made from  @{term y} and  @{term x'} is a table made
from  @{term z} and @{text "y\<noteq>z"}, then @{text "x\<noteq>x'"}.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>6'"}: Necessarily, given a table, @{term x}, made from a hunk, @{term y}, any table, @{term x'},
which might be made from a hunk, @{term z}, distinct from @{term y}, is distinct from @{term x}.
\<close>

subsection \<open>Our Formulation\<close>

text \<open>
We paraphrased the arguments mentioned above to a more logically readable form, without distorting
their essence.
\<close>

text \<open>
@{text "Compossibility\<^sub>6"}: If any table, say @{term x}, is made from any hunk of matter, say @{term y},
then necessarily if any table, say @{term x'}, is made from any hunk of matter, say @{term z},
such that @{term y} and @{term z} are distinct, then it is possible that both tables @{term x} (made from @{term y})
and @{term x'} (made from @{term z}) exist together.

@{text "Origin Uniqueness\<^sub>6"}:
If any table, say @{term x}, is made from any hunk of matter, say @{term y}, and any table,
say @{term x'}, is made from any hunk of matter, say @{term z}, such that @{term y} and @{term z} are distinct,
then @{term x} and @{term x'} are distinct.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>6"}: If any table, say @{term x}, is made from any hunk of matter, say @{term y},
then necessarily if any table, say @{term x'}, is made from any hunk of matter, say @{term z},
such that @{term y} and @{term z} are distinct, then @{term x} and @{term x'} are distinct
\<close>

text \<open> We will using this version henceforth.\<close>

subsection \<open>Overview of the Proof\<close>

text \<open>

\begin{enumerate}

\item Setting-up the worlds:
We begin in world @{term w} by assuming the antecedent of the thesis @{text "Origin Essentialism\<^sub>6"}
@{text "table_x1_from_y1: T x y w"}. On expanding the necessity operator in its consequent,
we obtain @{text "antecedent: (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> T x' z) v"} i.e. @{term y}
and @{term z} are distinct and table @{term x'} can be made from @{term z} in @{term v} are both true.
We fix all the variables of universal quantifiers to maintain uniformity of meaning.
We assume the negation of the consequent in a world @{term v} i.e. tables @{term x} and  @{term x'} are
identical, @{text "identity: (x\<^bold>=\<^sup>Lx') v"}.

\item Deriving co-existence of tables @{term x} and @{term x'} in @{term u}:
We use @{text "Compossibility\<^sub>6"} to show that tables @{term x} and @{term x'} co-exist in a world.
We derive the  @{text "Compossibility\<^sub>6 Consequent"} in @{term u} using @{term antecedent}. Using this
we obtain @{text "Origin Uniqueness\<^sub>6 Antecedent"}
@{text "origin_uniqueness1_ante: (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z))) u"}.

\item Falsifying @{term identity}:
We obtain @{text "Origin Uniqueness\<^sub>6 Consequent"} @{text "((x\<^bold>\<noteq>\<^sup>Lx')) u"} using previously derived
@{term origin_uniqueness1_ante}. We use this obtained result to falsify @{term identity}.

\end{enumerate}
\<close>

(* (T x y) \<equiv> x made from y *)
consts makeTable ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("T")
(* lemma necessity_of_distinctness: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y.(\<^bold>\<not>(x\<^bold>=\<^sup>Ly) \<^bold>\<rightarrow> \<^bold>\<box>((x\<^bold>\<noteq>\<^sup>Ly)))\<rfloor>" by auto *)

lemma
  assumes compossibilty6: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))\<rfloor>"
  assumes origin_uniqueness6: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x y \<^bold>\<and> T x' z) \<^bold>\<rightarrow> x\<^bold>\<noteq>\<^sup>Lx'\<rfloor>"
  shows origin_essentialism6: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> x\<^bold>\<noteq>\<^sup>Lx')\<rfloor>"
  text \<open>\<^item> Setting-up the worlds\<close>
(*<*)
proof(rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
  proof(rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
    proof(rule allI)
      fix y
      show  "(\<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
      proof(rule allI)
        fix x'
        show  "(\<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
        proof(rule allI)
          fix z
          show  "(T x y \<^bold>\<rightarrow> \<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
(*>*)
          proof(rule impI)
            assume table_x1_from_y1: "T x y w"
            show  "(\<^bold>\<box>(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) w"
            proof(rule allI)
              fix v
              show  "(w r v) \<longrightarrow> (((((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) v)"
              proof (rule impI)
                assume "w r v"
                show "(((((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> (x\<^bold>\<noteq>\<^sup>Lx'))) v)"
                proof(rule impI)
                  assume antecedent: "(y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) v"
                  show "((x\<^bold>\<noteq>\<^sup>Lx')) v"
                  proof(rule notI)
                    assume identity: "(x\<^bold>=\<^sup>Lx') v"
                    from antecedent have table_x2_from_y2: "(T x' z) v" by (rule conjE)
                    from antecedent have non_overlapping: "(y\<^bold>\<noteq>\<^sup>Lz) v" by (rule conjE)
                    text\<open>\<^item> Deriving @{text "T x' z"} in @{term u} using @{term compossibilty6}\<close>
                    from compossibilty6 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w"..
(*<*)
                    then have "(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w" by (rule allE)
                    then have "(\<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w" by (rule allE)
                    then have "(\<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w" by (rule allE)
                    then have "(T x y \<^bold>\<rightarrow> \<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w" by (rule allE)
(*>*)
                    then have "(\<^bold>\<box>((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z))) w"
                      using table_x1_from_y1 by (rule mp)
                    then have "((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z)) v" using `w r v` by auto
                    then have "\<^bold>\<diamond>(T x y \<^bold>\<and> T x' z) v" using antecedent by (rule mp)
                    then obtain u where u: "v r u \<and> ((T x y \<^bold>\<and> T x' z) u)" by (rule exE)
                    text\<open>\<^item> Framing the @{term origin_uniqueness6_ante}\<close>
                    then have origin_uniqueness6_ante: "(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z))) u"
                      using non_overlapping by auto
                    from u have "v r u" by (rule conjE)
                    text\<open>\<^item> Falsifying the @{term identity} using @{term origin_uniqueness6}\<close>
                    from origin_uniqueness6 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> ((x\<^bold>\<noteq>\<^sup>Lx')))) u"..
(*<*)
                    then have "(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> ((x\<^bold>\<noteq>\<^sup>Lx')))) u" by (rule allE)
                    then have "(\<^bold>\<forall>x'. \<^bold>\<forall>z. (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> ((x\<^bold>\<noteq>\<^sup>Lx')))) u" by (rule allE)
                    then have "(\<^bold>\<forall>z. (((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> ((x\<^bold>\<noteq>\<^sup>Lx')))) u" by (rule allE)
                    then have "((((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (T x y) \<^bold>\<and> (T x' z)) \<^bold>\<rightarrow> ((x\<^bold>\<noteq>\<^sup>Lx')))) u" by (rule allE)
(*>*)
                    then have "((x\<^bold>\<noteq>\<^sup>Lx')) u" using origin_uniqueness6_ante by (rule mp)
                    then show "False" using identity and `v r u` by auto
(*<*)
                  qed
                qed
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed
(*>*)

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header "Loops"

theory LoopExamples imports "../pGCL" begin

text {* Reasoning about loops in pGCL is mostly familiar, in particular in the use of invariants.
Proving termination for truly probabilistic loops is slightly different: We appeal to a 0--1 law
to show that the loop terminates \emph{with probability 1}.  In our semantic model, terminating
with certainty and with probability 1 are exactly equivalent. *}

subsection {* Guaranteed Termination *}

text {* We start with a completely classical loop, to show that standard techniques apply. Here, we
have a program that simply decrements a counter until it hits zero: *}

definition countdown :: "int prog"
where
  "countdown = do (\<lambda>x. 0 < x) \<longrightarrow> Apply (\<lambda>s. s - 1) od"

text {* Clearly, this loop will only terminate from a state where @{term "0 \<le> x"}. This is, in fact,
also a loop invariant. *}

definition inv_count :: "int \<Rightarrow> bool"
where
  "inv_count = (\<lambda>x. 0 \<le> x)"

text {* Read @{term "wp_inv G body I"} as: @{term I} is an invariant of the loop
@{term "do G \<longrightarrow> body od"}, or @{term "\<guillemotleft>G\<guillemotright> && I \<tturnstile> wp body I"}. *}

lemma wp_inv_count:
  "wp_inv (\<lambda>x. 0 < x) (Apply (\<lambda>s. s - 1)) \<guillemotleft>inv_count\<guillemotright>"
  unfolding wp_inv_def inv_count_def wp_eval o_def
proof(clarify, cases)
  fix x::int
  assume "0 \<le> x"
  then show "\<guillemotleft>\<lambda>x. 0 < x\<guillemotright> x * \<guillemotleft>\<lambda>x. 0 \<le> x\<guillemotright> x \<le> \<guillemotleft>\<lambda>x. 0 \<le> x\<guillemotright> (x - 1)"
    by(simp add:embed_bool_def)
next
  fix x::int
  assume "\<not> 0 \<le> x"
  then show "\<guillemotleft>\<lambda>x. 0 < x\<guillemotright> x * \<guillemotleft>\<lambda>x. 0 \<le> x\<guillemotright> x \<le> \<guillemotleft>\<lambda>x. 0 \<le> x\<guillemotright> (x - 1)"
    by(simp add:embed_bool_def)
qed

text {* This example is contrived to give us an obvious variant, or measure function: the counter
itself. *}

lemma term_countdown:
  "\<guillemotleft>inv_count\<guillemotright> \<tturnstile> wp countdown (\<lambda>s. 1)"
  unfolding countdown_def
proof(intro loop_term_nat_measure[where m="\<lambda>x. nat (max x 0)"] wp_inv_count)
  let ?p = "Apply (\<lambda>x. x - 1::int)"

  txt {* As usual, well-definedness is trivial. *}
  show "well_def ?p"
    by(rule wd_intros)

  txt {* A measure of 0 imples termination. *}
  show "\<And>x. nat (max x 0) = 0 \<longrightarrow> \<not> 0 < x"
    by(auto)

  txt {* This is the meat of the proof: that the measure must decrease,
    whenever the invariant holds.  Note that the invariant is essential
    here, as if @{term "x \<le> 0"}, the measure will \emph{not} decrease.

    This is the kind of proof that the VCG is good at.  It leaves a purely
    logical goal, which we can solve with auto. *}
  show "\<And>n. \<guillemotleft>\<lambda>x. nat (max x 0) = Suc n\<guillemotright> && \<guillemotleft>inv_count\<guillemotright> \<tturnstile>
         wp ?p \<guillemotleft>\<lambda>x. nat (max x 0) = n\<guillemotright>"
    unfolding inv_count_def
    by(pvcg,
       auto simp:  o_def exp_conj_std_split[symmetric]
            intro: implies_entails)
qed

subsection {* Probabilistic Termination *}

text {* Loops need not terminate deterministically: it is sufficient to terminate with probability
1. Here we show the intuitively obvious result that by flipping a coin repeatedly, you will
eventually see heads. *}

type_synonym coin = bool
definition "Heads = True"
definition "Tails = False"

definition
  flip :: "coin prog"
where
  "flip = Apply (\<lambda>_. Heads) \<^bsub>(\<lambda>s. 1/2)\<^esub>\<oplus> Apply (\<lambda>_. Tails)"

text {* We can't define a measure here, as we did previously, as neither of the
  two possible states guarantee termination. *}
definition
  wait_for_heads :: "coin prog"
where
  "wait_for_heads = do (op \<noteq> Heads) \<longrightarrow> flip od"

text {* Nonetheless, we can show termination .*}
lemma wait_for_heads_term:
  "\<lambda>s. 1 \<tturnstile> wp wait_for_heads (\<lambda>s. 1)"
  unfolding wait_for_heads_def
  txt {* We use one of the zero-one laws for termination, specifically that
    if, from every state there is a nonzero probability of satisfying the
    guard (and thus terminating) in a single step, then the loop terminates
    from \emph{any} state, with probability 1. *}
proof(rule termination_0_1)
  show "well_def flip"
    unfolding flip_def
    by(auto intro:wd_intros)

  txt {* We must show that the loop body is deterministic, meaning that
    it cannot diverge by itself. *}
  show "maximal (wp flip)"
    unfolding flip_def by(auto intro:max_intros)

  txt {* The verification condition for the loop body is one-step-termination,
    here shown to hold with probability 1/2.  As usual, this result falls to
    the VCG. *}
  show "\<lambda>s. 1/2 \<tturnstile> wp flip \<guillemotleft>\<N> (op \<noteq> Heads)\<guillemotright>"
    unfolding flip_def
    by(pvcg, simp add:o_def Heads_def Tails_def)

  txt {* Finally, the one-step escape probability is non-zero. *}
  show "(0::real) < 1/2" by(simp)
qed

end


chapter \<open>Standard Models with Two Provability Relations\<close>

(*<*)
(* Abstract notion of standard model and truth  *)
theory Standard_Model_More
imports Derivability_Conditions "Syntax_Independent_Logic.Standard_Model"
begin
(*>*)

locale Minimal_Truth_Soundness_Proof_Repr =
CleanRepr_Proofs
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  fls
  dsj
  "proof" prfOf
  encPf
  Pf
+ \<comment> \<open>The label "B" stands for "basic", as a reminder that soundness
refers to the basic provability relation:\<close>
B: Minimal_Truth_Soundness
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  bprv
  isTrue
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv bprv
and isTrue
and enc ("\<langle>_\<rangle>")
and "proof" :: "'proof set" and prfOf
and encPf Pf
begin

lemmas prfOf_iff_PPf = B_consistent_prfOf_iff_PPf[OF B.consistent]

text \<open>The provability predicate is decided by basic provability on encodings:\<close>
lemma isTrue_prv_PPf_prf_or_neg:
"prf \<in> proof \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
    bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>) \<or> bprv (neg (PPf (encPf prf) \<langle>\<phi>\<rangle>))"
  using not_prfOf_PPf prfOf_PPf by blast

text \<open>... hence that predicate is complete w.r.t. truth:\<close>
lemma isTrue_PPf_Implies_bprv_PPf:
"prf \<in> proof \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
   isTrue (PPf (encPf prf) \<langle>\<phi>\<rangle>) \<Longrightarrow> bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>)"
  by (metis FvarsT_num Fvars_PPf Fvars_fls PPf
Un_empty empty_iff enc encPf fls in_num isTrue_prv_PPf_prf_or_neg
neg_def B.not_isTrue_fls B.prv_imp_implies_isTrue)

text \<open>... and thanks cleanness we can replace encoded proofs
with arbitrary numerals in the completeness property:\<close>
lemma isTrue_implies_bprv_PPf:
assumes [simp]: "n \<in> num" "\<phi> \<in> fmla" "Fvars \<phi> = {}"
and iT: "isTrue (PPf n \<langle>\<phi>\<rangle>)"
shows "bprv (PPf n \<langle>\<phi>\<rangle>)"
proof(cases "n \<in> encPf ` proof")
  case True
  thus ?thesis
    using iT isTrue_PPf_Implies_bprv_PPf by auto
next
  case False
  hence "bprv (neg (PPf n \<langle>\<phi>\<rangle>))" by (simp add: Clean_PPf_encPf)
  hence "isTrue (neg (PPf n \<langle>\<phi>\<rangle>))" by (intro B.sound_isTrue) auto
  hence False using iT by (intro B.isTrue_neg_excl) auto
  thus ?thesis by auto
qed

text \<open>... in fact, by @{locale Minimal_Truth_Soundness} we even have an iff:\<close>
lemma isTrue_iff_bprv_PPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> isTrue (PPf n \<langle>\<phi>\<rangle>) \<longleftrightarrow> bprv (PPf n \<langle>\<phi>\<rangle>)"
using isTrue_implies_bprv_PPf
using exists_no_Fvars B.not_isTrue_fls B.sound_isTrue by auto

text \<open>Truth of the provability representation implies provability (TIP):\<close>
lemma TIP:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
and iPP: "isTrue (wrepr.PP \<langle>\<phi>\<rangle>)"
shows "prv \<phi>"
proof-
  have "isTrue (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))" using iPP unfolding PP_PPf[OF \<phi>(1)] .
  from B.isTrue_exi[OF _ _ _ this]
  obtain n where n[simp]: "n \<in> num" and "isTrue (PPf n \<langle>\<phi>\<rangle>)" by auto
  hence pP: "bprv (PPf n \<langle>\<phi>\<rangle>)" using isTrue_implies_bprv_PPf by auto
  hence "\<not> bprv (neg (PPf n \<langle>\<phi>\<rangle>))"
  using B.prv_neg_excl[of "PPf n \<langle>\<phi>\<rangle>"] by auto
  then obtain "prf" where "prf"[simp]: "prf \<in> proof" and nn: "n = encPf prf"
  using assms n Clean_PPf_encPf \<phi>(1) by blast
  have "prfOf prf \<phi>" using pP unfolding nn using prfOf_iff_PPf by auto
  thus ?thesis using prv_prfOf by auto
qed

text \<open>The reverse HBL1 -- now without the $\omega$-consistency assumption which holds here
thanks to our truth-in-standard-model assumption:\<close>

lemmas HBL1_rev = \<omega>consistentStd1_HBL1_rev[OF B.\<omega>consistentStd1]
text \<open>Note that the above would also follow by @{locale Minimal_Truth_Soundness} from TIP:\<close>
lemma TIP_implies_HBL1_rev:
assumes TIP: "\<forall>\<phi>. \<phi> \<in> fmla \<and> Fvars \<phi> = {} \<and> isTrue (wrepr.PP \<langle>\<phi>\<rangle>) \<longrightarrow> prv \<phi>"
shows "\<forall>\<phi>. \<phi> \<in> fmla \<and> Fvars \<phi> = {} \<and> bprv (wrepr.PP \<langle>\<phi>\<rangle>) \<longrightarrow> prv \<phi>"
using B.sound_isTrue[of "wrepr.PP \<langle>_\<rangle>"] TIP by auto

end \<comment> \<open>context @{locale Minimal_Truth_Soundness_Proof_Repr}\<close>

section \<open>Proof recovery from $\mathit{HBL1\_iff}$\<close>

locale Minimal_Truth_Soundness_HBL1iff_Compl_Pf =
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
+
B : Minimal_Truth_Soundness
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  bprv
  isTrue
+
Deduct_with_False_Disj
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and enc ("\<langle>_\<rangle>")
and prv bprv
and P
and isTrue
+
fixes Pf :: 'fmla
assumes
\<comment> \<open>@{term Pf} is a formula with free variables @{term xx} @{term yy}:\<close>
Pf[simp,intro!]: "Pf \<in> fmla"
and
Fvars_Pf[simp]: "Fvars Pf = {yy,xx}"
and
\<comment> \<open>@{term P} relates to @{term Pf} internally (inside basic provability)
just like a @{term prv} and a @{term prfOf} would relate---via an existential:\<close>
P_Pf:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
 bprv (eqv (subst P \<langle>\<phi>\<rangle> xx) (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)))"
assumes
\<comment> \<open>We assume both $\mathit{HBL1}$ and $\mathit{HBL1\_rev}$, i.e., an iff version:\<close>
HBL1_iff: "\<And> \<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> bprv (PP \<langle>\<phi>\<rangle>) \<longleftrightarrow> prv \<phi>"
and
Compl_Pf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
 isTrue (PPf n \<langle>\<phi>\<rangle>) \<longrightarrow> bprv (PPf n \<langle>\<phi>\<rangle>)"
begin

definition PPf where "PPf \<equiv> \<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]"

lemma PP_deff: "PP t = subst P t xx" using PP_def by auto

lemma PP_PPf_eqv:
  "\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> bprv (eqv (PP \<langle>\<phi>\<rangle>) (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)))"
  using PP_deff PPf_def P_Pf by auto

(*  *)

lemma PPf[simp,intro!]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow> PPf t1 t2 \<in> fmla"
  unfolding PPf_def by auto

lemma PPf_def2: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow>
  PPf t1 t2 = subst (subst Pf t1 yy) t2 xx"
  unfolding PPf_def by (rule psubst_eq_rawpsubst2[simplified]) auto

lemma Fvars_PPf[simp]:
  "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow> Fvars (PPf t1 t2) = FvarsT t1 \<union> FvarsT t2"
  by (auto simp add: PPf_def2 subst2_fresh_switch)

(* *)

lemma PP_PPf:
assumes "\<phi> \<in> fmla" "Fvars \<phi> = {}" shows "bprv (PP \<langle>\<phi>\<rangle>) \<longleftrightarrow> bprv (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))"
  using assms PP_PPf_eqv[OF assms] B.prv_eqv_sym[OF _ _ PP_PPf_eqv[OF assms]]
  by (auto intro!: B.prv_eqv_prv[of "PP \<langle>\<phi>\<rangle>" "exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)"]
    B.prv_eqv_prv[of "exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)" "PP \<langle>\<phi>\<rangle>"])

lemma isTrue_implies_bprv_PPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 isTrue (PPf n \<langle>\<phi>\<rangle>) \<Longrightarrow> bprv (PPf n \<langle>\<phi>\<rangle>)"
  using Compl_Pf by(simp add: PPf_def)

lemma isTrue_iff_bprv_PPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> isTrue (PPf n \<langle>\<phi>\<rangle>) \<longleftrightarrow> bprv (PPf n \<langle>\<phi>\<rangle>)"
using isTrue_implies_bprv_PPf
  using exists_no_Fvars B.not_isTrue_fls B.sound_isTrue by auto

text \<open>Preparing to instantiate this "proof recovery" alternative into our
mainstream locale hierarchy, which assumes proofs.
We define the "missing" proofs to be numerals, we encode them as the identity,
and we "copy" @{term prfOf} from the corresponding predicate one-level-up, @{term PPf}:\<close>

definition "proof" :: "'trm set" where [simp]: "proof = num"
definition prfOf :: "'trm \<Rightarrow> 'fmla \<Rightarrow> bool" where
  "prfOf n \<phi> \<equiv> bprv (PPf n \<langle>\<phi>\<rangle>)"
definition encPf :: "'trm \<Rightarrow> 'trm" where [simp]: "encPf \<equiv> id"
(*  *)

lemma isTrue_exi_iff:
assumes [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows "isTrue (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)) \<longleftrightarrow> (\<exists>n\<in>num. isTrue (PPf n \<langle>\<phi>\<rangle>))" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L thus ?R using B.isTrue_exi[OF _ _ _ \<open>?L\<close>] by auto
next
  assume ?R
  then obtain n where n[simp]: "n \<in> num" and i: "isTrue (PPf n \<langle>\<phi>\<rangle>)" by auto
  hence "bprv (PPf n \<langle>\<phi>\<rangle>)" by (auto simp: isTrue_iff_bprv_PPf)
  hence "bprv (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))" by (intro B.prv_exiI[of _ _ n]) auto
  thus ?L by (intro B.sound_isTrue) auto
qed

lemma prv_prfOf:
assumes "\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows "prv \<phi> \<longleftrightarrow> (\<exists>n\<in>num. prfOf n \<phi>)"
proof-
  have "prv \<phi> \<longleftrightarrow> bprv (PP \<langle>\<phi>\<rangle>)" using HBL1_iff[OF assms] by simp
  also have "\<dots> \<longleftrightarrow> bprv (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))" unfolding PP_PPf[OF assms] ..
  also have "\<dots> \<longleftrightarrow> isTrue (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))" using prv_exi_PPf_iff_isTrue[OF assms] .
  also have "\<dots> \<longleftrightarrow> (\<exists>n\<in>num. isTrue (PPf n \<langle>\<phi>\<rangle>))" using isTrue_exi_iff[OF assms] .
  also have "\<dots> \<longleftrightarrow> (\<exists>n\<in>num. bprv (PPf n \<langle>\<phi>\<rangle>))" using isTrue_iff_bprv_PPf[OF _ assms] by auto
  also have "\<dots> \<longleftrightarrow> (\<exists>n\<in>num. prfOf n \<phi>)" unfolding prfOf_def ..
  finally show ?thesis .
qed

lemma isTrue_exi_iff_PP:
assumes [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows "isTrue (PP \<langle>\<phi>\<rangle>) \<longleftrightarrow> (\<exists>n\<in>num. isTrue (PPf n \<langle>\<phi>\<rangle>))"
proof-
  have "bprv (eqv (PP \<langle>\<phi>\<rangle>) (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)))"
    using PP_PPf_eqv by auto
  hence "bprv (imp (PP \<langle>\<phi>\<rangle>) (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)))"
  and "bprv (imp (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)) (PP \<langle>\<phi>\<rangle>))"
  by (simp_all add: B.prv_imp_eqvEL B.prv_imp_eqvER)
  thus ?thesis unfolding isTrue_exi_iff[OF assms, symmetric]
    by (intro iffI) (rule B.prv_imp_implies_isTrue; simp)+
qed

lemma bprv_compl_isTrue_PP_enc:
assumes 1: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and 2: "isTrue (PP \<langle>\<phi>\<rangle>)"
shows "bprv (PP \<langle>\<phi>\<rangle>)"
proof-
  obtain n where nn: "n \<in> num" and i: "isTrue (PPf n \<langle>\<phi>\<rangle>)"
   using 2 unfolding isTrue_exi_iff_PP[OF 1] ..
  hence "bprv (PPf n \<langle>\<phi>\<rangle>)"
    using i using nn assms isTrue_iff_bprv_PPf by blast
  hence "bprv (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>))"
  using 2 assms isTrue_exi_iff isTrue_exi_iff_PP prv_exi_PPf_iff_isTrue by auto
  thus ?thesis using PP_PPf 1 by blast
qed

lemma TIP:
assumes 1: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and 2: "isTrue (PP \<langle>\<phi>\<rangle>)"
shows "prv \<phi>"
using bprv_compl_isTrue_PP_enc[OF assms] HBL1_iff assms by blast

end \<comment> \<open>context @{locale Minimal_Truth_Soundness_HBL1iff_Compl_Pf}\<close>

locale Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf =
Minimal_Truth_Soundness_HBL1iff_Compl_Pf
+
assumes
Compl_NegPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
 isTrue (B.neg (PPf n \<langle>\<phi>\<rangle>)) \<longrightarrow> bprv (B.neg (PPf n \<langle>\<phi>\<rangle>))"
begin

lemma isTrue_implies_prv_neg_PPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 isTrue (B.neg (PPf n \<langle>\<phi>\<rangle>)) \<Longrightarrow> bprv (B.neg (PPf n \<langle>\<phi>\<rangle>))"
  using Compl_NegPf by(simp add: PPf_def)

lemma isTrue_iff_prv_neg_PPf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> isTrue (B.neg (PPf n \<langle>\<phi>\<rangle>)) \<longleftrightarrow> bprv (B.neg (PPf n \<langle>\<phi>\<rangle>))"
using isTrue_implies_prv_neg_PPf
  using exists_no_Fvars B.not_isTrue_fls B.sound_isTrue by auto

lemma prv_PPf_decide:
assumes [simp]: "n \<in> num" "\<phi> \<in> fmla" "Fvars \<phi> = {}"
and np: "\<not> bprv (PPf n \<langle>\<phi>\<rangle>)"
shows "bprv (B.neg (PPf n \<langle>\<phi>\<rangle>))"
proof-
  have "\<not> isTrue (PPf n \<langle>\<phi>\<rangle>)" using assms by (auto simp: isTrue_iff_bprv_PPf)
  hence "isTrue (B.neg (PPf n \<langle>\<phi>\<rangle>))" using B.isTrue_neg[of "PPf n \<langle>\<phi>\<rangle>"] by auto
  thus ?thesis by (auto simp: isTrue_iff_prv_neg_PPf)
qed

lemma not_prfOf_prv_neg_Pf:
assumes n\<phi>: "n \<in> num" "\<phi> \<in> fmla" "Fvars \<phi> = {}" and "\<not> prfOf n \<phi>"
shows "bprv (B.neg (psubst Pf [(n, yy), (\<langle>\<phi>\<rangle>, xx)]))"
  using assms prv_PPf_decide[OF n\<phi>] by (auto simp: prfOf_def PPf_def2 psubst_eq_rawpsubst2)

end \<comment> \<open>context @{locale Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf}\<close>

sublocale Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf <
   repr: CleanRepr_Proofs
(* added label to avoid duplicated constant P, which is assumed
in Minimal_Truth_Soundness_HBL1iff_Compl_Pf but defined in CleanRepr_Proofs
(they are of course extensionally equal).
*)
  where "proof" = "proof" and prfOf = prfOf and encPf = encPf
  by standard (auto simp: bprv_prv prv_prfOf prfOf_prv_Pf not_prfOf_prv_neg_Pf)

(* Lemma 6 ("proof recovery") from the JAR paper: *)
sublocale Minimal_Truth_Soundness_HBL1iff_Compl_Pf_Compl_NegPf <
  min_truth: Minimal_Truth_Soundness_Proof_Repr
where "proof" = "proof" and prfOf = prfOf and encPf = encPf
  by standard

(* FOR THE CLASSICAL REASONING VERSION *)

locale Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf =
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
+
B: Minimal_Truth_Soundness
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  bprv
  isTrue
+
Deduct_with_False_Disj
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and enc ("\<langle>_\<rangle>")
and prv bprv
and P
and isTrue
+
fixes Pf :: 'fmla
assumes
(* Pf is a formula with free variables xx yy  *)
Pf[simp,intro!]: "Pf \<in> fmla"
and
Fvars_Pf[simp]: "Fvars Pf = {yy,xx}"
and
(* P relates to Pf internally just like a prv and a proofOf would
relate: via an existential *)
P_Pf:
"\<phi> \<in> fmla \<Longrightarrow>
 let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
 bprv (eqv (subst P \<langle>\<phi>\<rangle> xx) (exi yy (PPf (Var yy) \<langle>\<phi>\<rangle>)))"
assumes
(* We assume, in addition to HBL1, the strong form of HBL1_rev: *)
HBL1_rev_prv: "\<And> \<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv (PP \<langle>\<phi>\<rangle>) \<Longrightarrow> prv \<phi>"
and
Compl_Pf:
"\<And> n \<phi>. n \<in> num \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
 isTrue (PPf n \<langle>\<phi>\<rangle>) \<longrightarrow> bprv (PPf n \<langle>\<phi>\<rangle>)"
begin

lemma HBL1_rev:
  assumes f: "\<phi> \<in> fmla" and fv: "Fvars \<phi> = {}" and bp: "bprv (PP \<langle>\<phi>\<rangle>)"
  shows "prv \<phi>"
  using assms by (auto intro!: HBL1_rev_prv bprv_prv[OF _ _ bp])

lemma HBL1_iff: "\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> bprv (PP \<langle>\<phi>\<rangle>) \<longleftrightarrow> prv \<phi>"
  using HBL1 HBL1_rev unfolding PP_def by auto

lemma HBL1_iff_prv: "\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv (PP \<langle>\<phi>\<rangle>) \<longleftrightarrow> prv \<phi>"
  by (intro iffI bprv_prv[OF _ _ HBL1_PP], elim HBL1_rev_prv[rotated -1]) auto

end \<comment> \<open>context @{locale Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf}\<close>

sublocale Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf <
  mts_prv_mts: Minimal_Truth_Soundness_HBL1iff_Compl_Pf where Pf = Pf
  using P_Pf HBL1_rev HBL1_PP Compl_Pf
  by unfold_locales auto

locale Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf_Classical =
Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf
+
assumes
\<comment> \<open>NB: we don't really need to assume classical reasoning (double negation) all throughout,
but only for the provability predicate:\<close>
classical_P: "\<And> \<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> let PP = (\<lambda>t. subst P t xx) in
  prv (B.neg (B.neg (PP \<langle>\<phi>\<rangle>))) \<Longrightarrow> prv (PP \<langle>\<phi>\<rangle>)"
begin

lemma classical_PP: "\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv (B.neg (B.neg (PP \<langle>\<phi>\<rangle>))) \<Longrightarrow> prv (PP \<langle>\<phi>\<rangle>)"
  using classical_P unfolding PP_def by auto

end \<comment> \<open>context @{locale Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf_Classical}\<close>

(*<*)
end
(*>*)


(* A simple comment *)

theory week01A_demo imports Main
begin

text {* This is also a comment but it generates nice \LaTeX-text! *}

text {*
 Note that free variables (eg @{term x}),
 bound variables (eg @{term "\<lambda>n. n"}) and
 constants (eg @{term Suc}) are displayed differently.
*}

text {* To display more types inside terms: *}
declare [[show_types]]
term "Suc x = Succ y"

text {* To switch off again: *}
declare [[show_types=false]]
term "Suc x = Succ y"

text {* 0 and + are overloaded: *}

prop "n + n = 0"
prop "(n::nat) + n = 0"
prop "(n::int) + n = 0"
prop "n + n = Suc m"

text{* A bound variable: *}
term "\<lambda>x. x v"
term "\<lambda>x. Suc x < y"
prop "map (\<lambda>n. Suc n + 1) [0, 1] = [2, 3]"

text {* Terms must be type correct! *}
text {* term "Suc n = True" *}

text {* Displaying theorems, schematic variables *}

thm conjI
text {* Schematic variables have question marks and can be instantiated: *}
thm conjI [where ?Q = "x"]
thm impI
thm disjE

text {*
  You can use \texttt{term}, \texttt{prop} and \texttt{thm} in \LaTeX
  sections, too!  The lemma conjI is: @{thm conjI}. Nicer version,
  without schematic variables: @{thm conjI [no_vars]}.
*}

thm conjI [no_vars]

text {* Finding theorems *}

text {* Searching for constants/functions: *}
find_theorems "map"

text {* A list of search criteria finds thms that match all of them: *}
find_theorems "map" "zip"

text {* To search for patterns, use underscore: *}
find_theorems "_ + _ = _ - _"
find_theorems "_ + _" "_ < _" "Suc"

text {* Searching for theorem names: *}
find_theorems name: "conj"

text {* They can all be combined, theorem names include the theory name: *}
find_theorems "_ \<and> _" name: "HOL." -name: "conj"

text {* Stating theorems and a first proof *}

lemma "A \<longrightarrow> A"
  -- "a single line comment"
  -- "note the goals window"
  apply (rule impI)
  apply assumption
  done

text {*
  A proof is a list of {\tt apply} statements, terminated by {\tt done}.

  {\tt apply} takes a proof method as argument (assumption, rule,
  etc.). It needs parentheses when the method consists of more than
  one word.
*}

text {* Isabelle doesn't care if you call it lemma, theorem or corollary *}

theorem "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

corollary "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

text {* You can give it a name, too *}

lemma mylemma: "A \<longrightarrow> A" by (rule impI)

text {* Abandoning a proof *}

lemma "P = NP"
  -- "this is too hard"
  oops

text {* Isabelle forgets the lemma and you cannot use it later *}

text {* Faking a proof *}

lemma "P \<noteq> NP"
  -- "have an idea, will show this later"
  sorry

text {*
  {\tt sorry} only works interactively (and in {\em quick-and-dirty-mode}),
  and Isabelle keeps track of what you have faked.
*}

text {* Proof styles *}

-- "automatic"
theorem Cantor: "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)" by best

-- "exploring, but unstructured"
theorem Cantor': "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  apply (rule_tac x = "{x. x \<notin> f x}" in exI)
  apply (rule notI)
  apply clarsimp
  apply blast
  done

-- "structured, explaining"
theorem Cantor'': "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where fy: "?S = f y" ..
    show False
    proof cases
      assume yin: "y \<in> ?S"
      hence "y \<notin> f y" by simp
      hence "y \<notin> ?S"  by(simp add:fy)
      thus False using yin by contradiction
    next
      assume yout: "y \<notin> ?S"
      hence "y \<in> f y" by simp
      hence "y \<in> ?S"  by(simp add:fy)
      thus False using yout by contradiction
    qed
  qed
qed

end


(* Title: Examples/SML_Relativization/Foundations/Lifting_Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Extension of the theory \<^text>\<open>Lifting_Set\<close>\<close>
theory Lifting_Set_Ext
  imports Main
begin

context
  includes lifting_syntax
begin

lemma set_pred_eq_transfer[transfer_rule]:
  assumes "right_total A"
  shows
    "((rel_set A ===> (=)) ===> (rel_set A ===> (=)) ===> (=))
      (\<lambda>X Y. \<forall>s\<subseteq>Collect (Domainp A). X s = Y s)
      ((=)::['b set \<Rightarrow> bool, 'b set \<Rightarrow> bool] \<Rightarrow> bool)"
proof(intro rel_funI)
  let ?sA = "Collect (Domainp A)"
  fix X Y :: "'a set \<Rightarrow> bool"
  fix X' Y' :: "'b set \<Rightarrow> bool"
  assume rs: "(rel_set A ===> (=)) X X'" "(rel_set A ===> (=)) Y Y'"
  show "(\<forall>s\<subseteq>?sA. X s = Y s) = (X' = Y')"
  proof
    assume X_eq_Y: "\<forall>s\<subseteq>?sA. X s = Y s"
    {
      fix s' assume "X' s'"
      then obtain s where "rel_set A s s'"
        by (meson assms right_total_def right_total_rel_set)
      then have "X s" using rs(1) unfolding rel_fun_def by (simp add: \<open>X' s'\<close>)
      moreover from \<open>rel_set A s s'\<close> have "s \<subseteq> ?sA"
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "Y' s'"
        using rs(2)[unfolded rel_fun_def] \<open>rel_set A s s'\<close> by (simp add: X_eq_Y)
    }
    note XY = this
    {
      fix s' assume "Y' s'"
      then obtain s where "rel_set A s s'"
        by (meson assms right_total_def right_total_rel_set)
      then have "Y s" using rs(2)[unfolded rel_fun_def] by (simp add: \<open>Y' s'\<close>)
      moreover from \<open>rel_set A s s'\<close> have "s \<subseteq> ?sA"
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "X' s'"
        using X_eq_Y rs(1)[unfolded rel_fun_def] \<open>rel_set A s s'\<close> by auto
    }
    with XY show "X' = Y'" by auto
  next
    assume "X' = Y'" show "\<forall>s\<subseteq>?sA. X s = Y s"
      unfolding Ball_Collect[symmetric]
      using rs[unfolded rel_fun_def] \<open>X' = Y'\<close> by (metis DomainpE Domainp_set)+
  qed
qed

private lemma vimage_fst_transfer_h:
  "
  pred_prod (Domainp A) (Domainp B) x =
    (x \<in> Collect (Domainp A) \<times> Collect (Domainp B))
  "
  unfolding pred_prod_beta mem_Times_iff by simp

lemma vimage_fst_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" "right_total B"
  shows
    "((rel_prod A B ===> A) ===> rel_set A ===> rel_set (rel_prod A B))
      (\<lambda>f S. (f -` S) \<inter> ((Collect (Domainp A)) \<times> (Collect (Domainp B))))
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h
  by auto

lemma vimage_snd_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B"
  shows
    "((rel_prod A B ===> B) ===> rel_set B ===> rel_set (rel_prod A B))
      (\<lambda>f S. (f -` S) \<inter> ((Collect (Domainp A)) \<times> (Collect (Domainp B))))
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h by auto

lemma vimage_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique B" "right_total A"
  shows
    "((A ===> B) ===> (rel_set B) ===> rel_set A)
      (\<lambda>f s. (vimage f s) \<inter> (Collect (Domainp A))) (-`)"
  by transfer_prover

lemma pairwise_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> A ===> (=)) ===> rel_set A  ===> (=)) pairwise pairwise"
  unfolding pairwise_def by transfer_prover

lemma disjnt_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A  ===> (=)) disjnt disjnt"
  unfolding disjnt_def by transfer_prover

lemma bij_betw_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "bi_unique B"
  shows "((A ===> B) ===> rel_set A ===> rel_set B ===> (=)) bij_betw bij_betw"
  unfolding bij_betw_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

text\<open>\newpage\<close>

end


theory ConcreteSemantics12_Hoare
  imports "~~/src/HOL/IMP/Big_Step"
begin

section "Hoare Logic"

subsection "Hoare Logic for Partial Correctness"

type_synonym assn = "state \<Rightarrow> bool"

definition hoare_valid:: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/(_)/{(1_)}" 50)where
"\<Turnstile> {P} c {Q} = (\<forall> s t. P s \<and> (c, s) \<Rightarrow> t \<longrightarrow> Q t)"

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999)
where "s[a/x] == s(x := aval a s)"

inductive hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> {(1_)}/(_)/{(1_)}" 50) where
Skip: "\<turnstile> {P} SKIP {P}" |
Assign: "\<turnstile> {\<lambda>s. P (s[a/x])} x ::= a {P}" |
Seq: "\<lbrakk>\<turnstile> {P} c\<^sub>1 {Q}; \<turnstile> {Q} c\<^sub>2 {R}\<rbrakk> \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}" |
If: "\<lbrakk>\<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q}; \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q}\<rbrakk> \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}" |
While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {P} \<Longrightarrow> \<turnstile> {P} WHILE b DO  c {\<lambda>s. P s \<and> \<not> bval b s}" |
conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile> {P} c {Q}; \<forall> s. Q s \<longrightarrow> Q' s \<rbrakk> \<Longrightarrow> \<turnstile> {P'} c {Q'}"

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

fun asubst:: "aexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> aexp" where
"asubst (N n) _ _ = N n" |
"asubst (V x) a y = (if x = y then a else (V x))" |
"asubst (Plus a1 a2) a y = Plus(asubst a1 a y) (asubst a2 a y)"

(*
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
*)

text\<open>bsubst b a x corresponds to b[a/x]\<close>
fun bsubst :: "bexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> bexp" where
"bsubst (Bc v) _ _ = Bc v" |
"bsubst (Not b) a s = Not ( bsubst b a s)" |
"bsubst (And b\<^sub>1 b\<^sub>2) a s = And (bsubst b\<^sub>1 a s) (bsubst b\<^sub>2 a s)" |
"bsubst (Less a\<^sub>1 a\<^sub>2) a s = Less (asubst a\<^sub>1 a s) (asubst a\<^sub>2 a s)"
(*
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
*)

lemma asubstitution: "aval (asubst a b x) s = aval a (s[b/x])"
proof(induction a)
  case (N x)
  then show ?case by simp
next
  case (V x)
  then show ?case by simp
next
  case (Plus a1 a2)
  then show ?case by simp
qed

(* Exercise 12.2. *)
(* Lemma 12.1 (Substitution lemma). *)
lemma bsubstitution: "bval (bsubst b a x) s = bval b (s[a/x])"
proof(induction b)
  case (Bc x)
  then show ?case
    by simp
next
  case (Not b)
  then show ?case by simp
next
  case (And b1 b2)
  then show ?case by simp
next
  case (Less x1a x2a)
(* \<And>x1a x2a. bval (bsubst (Less x1a x2a) a x) s = bval (Less x1a x2a) (s[a/x])*)
  then have "bval (bsubst (Less x1a x2a) a x) s = bval (Less (asubst x1a a x) (asubst x2a a x)) s" by simp
(*"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"*)
  also have "\<dots> = (aval (asubst x1a a x) s < aval (asubst x2a a x) s)" by simp
  also have "\<dots> = (aval x1a (s[a/x]) < aval x2a (s[a/x]))"
    by (simp add: asubstitution)
  finally show ?case
    using bval.simps(4) by blast
qed

(* Derived Rules*)

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
  by (simp add: strengthen_pre)
(* by (simp add: strengthen_pre[OF _ Assign]) *)

lemma While': "\<lbrakk>\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}; \<forall> s. P s \<and> \<not> bval b s \<longrightarrow> Q s\<rbrakk> \<Longrightarrow> \<turnstile> {P} WHILE b DO c {Q}"
  using While conseq by blast

lemma While'':
assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile> {P} WHILE b DO c {Q}"
by(rule weaken_post[OF While[OF assms(1)] assms(2)])

end


(*  Title:      ZF/Induct/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Primitive Recursive Functions: the inductive definition\<close>

theory Primrec imports ZF begin

text \<open>
  Proof adopted from @{cite szasz93}.

  See also @{cite \<open>page 250, exercise 11\<close> mendelson}.
\<close>

subsection \<open>Basic definitions\<close>

definition
  SC :: "i"  where
  "SC == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. succ(x), l)"

definition
  CONSTANT :: "i=>i"  where
  "CONSTANT(k) == \<lambda>l \<in> list(nat). k"

definition
  PROJ :: "i=>i"  where
  "PROJ(i) == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. x, drop(i,l))"

definition
  COMP :: "[i,i]=>i"  where
  "COMP(g,fs) == \<lambda>l \<in> list(nat). g ` map(\<lambda>f. f`l, fs)"

definition
  PREC :: "[i,i]=>i"  where
  "PREC(f,g) ==
     \<lambda>l \<in> list(nat). list_case(0,
                      \<lambda>x xs. rec(x, f`xs, \<lambda>y r. g ` Cons(r, Cons(y, xs))), l)"
  \<comment> \<open>Note that \<open>g\<close> is applied first to @{term "PREC(f,g)`y"} and then to \<open>y\<close>!\<close>

consts
  ACK :: "i=>i"
primrec
  "ACK(0) = SC"
  "ACK(succ(i)) = PREC (CONSTANT (ACK(i) ` [1]), COMP(ACK(i), [PROJ(0)]))"

abbreviation
  ack :: "[i,i]=>i" where
  "ack(x,y) == ACK(x) ` [y]"

text \<open>
  \medskip Useful special cases of evaluation.
\<close>

lemma SC: "[| x \<in> nat;  l \<in> list(nat) |] ==> SC ` (Cons(x,l)) = succ(x)"
  by (simp add: SC_def)

lemma CONSTANT: "l \<in> list(nat) ==> CONSTANT(k) ` l = k"
  by (simp add: CONSTANT_def)

lemma PROJ_0: "[| x \<in> nat;  l \<in> list(nat) |] ==> PROJ(0) ` (Cons(x,l)) = x"
  by (simp add: PROJ_def)

lemma COMP_1: "l \<in> list(nat) ==> COMP(g,[f]) ` l = g` [f`l]"
  by (simp add: COMP_def)

lemma PREC_0: "l \<in> list(nat) ==> PREC(f,g) ` (Cons(0,l)) = f`l"
  by (simp add: PREC_def)

lemma PREC_succ:
  "[| x \<in> nat;  l \<in> list(nat) |]
    ==> PREC(f,g) ` (Cons(succ(x),l)) =
      g ` Cons(PREC(f,g)`(Cons(x,l)), Cons(x,l))"
  by (simp add: PREC_def)

subsection \<open>Inductive definition of the PR functions\<close>

consts
  prim_rec :: i

inductive
  domains prim_rec \<subseteq> "list(nat)->nat"
  intros
    "SC \<in> prim_rec"
    "k \<in> nat ==> CONSTANT(k) \<in> prim_rec"
    "i \<in> nat ==> PROJ(i) \<in> prim_rec"
    "[| g \<in> prim_rec; fs\<in>list(prim_rec) |] ==> COMP(g,fs) \<in> prim_rec"
    "[| f \<in> prim_rec; g \<in> prim_rec |] ==> PREC(f,g) \<in> prim_rec"
  monos list_mono
  con_defs SC_def CONSTANT_def PROJ_def COMP_def PREC_def
  type_intros nat_typechecks list.intros
    lam_type list_case_type drop_type map_type
    apply_type rec_type

lemma prim_rec_into_fun [TC]: "c \<in> prim_rec ==> c \<in> list(nat) -> nat"
  by (erule subsetD [OF prim_rec.dom_subset])

lemmas [TC] = apply_type [OF prim_rec_into_fun]

declare prim_rec.intros [TC]
declare nat_into_Ord [TC]
declare rec_type [TC]

lemma ACK_in_prim_rec [TC]: "i \<in> nat ==> ACK(i) \<in> prim_rec"
  by (induct set: nat) simp_all

lemma ack_type [TC]: "[| i \<in> nat;  j \<in> nat |] ==>  ack(i,j) \<in> nat"
  by auto

subsection \<open>Ackermann's function cases\<close>

lemma ack_0: "j \<in> nat ==> ack(0,j) = succ(j)"
  \<comment> \<open>PROPERTY A 1\<close>
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  \<comment> \<open>PROPERTY A 2\<close>
  by (simp add: CONSTANT PREC_0)

lemma ack_succ_succ:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(succ(i), succ(j)) = ack(i, ack(succ(i), j))"
  \<comment> \<open>PROPERTY A 3\<close>
  by (simp add: CONSTANT PREC_succ COMP_1 PROJ_0)

lemmas [simp] = ack_0 ack_succ_0 ack_succ_succ ack_type
  and [simp del] = ACK.simps

lemma lt_ack2: "i \<in> nat ==> j \<in> nat ==> j < ack(i,j)"
  \<comment> \<open>PROPERTY A 4\<close>
  apply (induct i arbitrary: j set: nat)
   apply simp
  apply (induct_tac j)
   apply (erule_tac [2] succ_leI [THEN lt_trans1])
   apply (rule nat_0I [THEN nat_0_le, THEN lt_trans])
   apply auto
  done

lemma ack_lt_ack_succ2: "[|i\<in>nat; j\<in>nat|] ==> ack(i,j) < ack(i, succ(j))"
  \<comment> \<open>PROPERTY A 5-, the single-step lemma\<close>
  by (induct set: nat) (simp_all add: lt_ack2)

lemma ack_lt_mono2: "[| j<k; i \<in> nat; k \<in> nat |] ==> ack(i,j) < ack(i,k)"
  \<comment> \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ2)
  done

lemma ack_le_mono2: "[|j\<le>k;  i\<in>nat;  k\<in>nat|] ==> ack(i,j) \<le> ack(i,k)"
  \<comment> \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (i,j) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono2 ack_type [THEN nat_into_Ord])+
  done

lemma ack2_le_ack1:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(i, succ(j)) \<le> ack(succ(i), j)"
  \<comment> \<open>PROPERTY A 6\<close>
  apply (induct_tac j)
   apply simp_all
  apply (rule ack_le_mono2)
    apply (rule lt_ack2 [THEN succ_leI, THEN le_trans])
      apply auto
  done

lemma ack_lt_ack_succ1: "[| i \<in> nat; j \<in> nat |] ==> ack(i,j) < ack(succ(i),j)"
  \<comment> \<open>PROPERTY A 7-, the single-step lemma\<close>
  apply (rule ack_lt_mono2 [THEN lt_trans2])
     apply (rule_tac [4] ack2_le_ack1)
      apply auto
  done

lemma ack_lt_mono1: "[| i<j; j \<in> nat; k \<in> nat |] ==> ack(i,k) < ack(j,k)"
  \<comment> \<open>PROPERTY A 7, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ1)
  done

lemma ack_le_mono1: "[| i\<le>j; j \<in> nat; k \<in> nat |] ==> ack(i,k) \<le> ack(j,k)"
  \<comment> \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (j,k) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono1 ack_type [THEN nat_into_Ord])+
  done

lemma ack_1: "j \<in> nat ==> ack(1,j) = succ(succ(j))"
  \<comment> \<open>PROPERTY A 8\<close>
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat ==> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  \<comment> \<open>PROPERTY A 9\<close>
  by (induct set: nat) (simp_all add: ack_1)

lemma ack_nest_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1, ack(i2,j)) < ack(succ(succ(i1#+i2)), j)"
  \<comment> \<open>PROPERTY A 10\<close>
  apply (rule lt_trans2 [OF _ ack2_le_ack1])
    apply simp
    apply (rule add_le_self [THEN ack_le_mono1, THEN lt_trans1])
       apply auto
  apply (force intro: add_le_self2 [THEN ack_lt_mono1, THEN ack_lt_mono2])
  done

lemma ack_add_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1,j) #+ ack(i2,j) < ack(succ(succ(succ(succ(i1#+i2)))), j)"
  \<comment> \<open>PROPERTY A 11\<close>
  apply (rule_tac j = "ack (succ (1), ack (i1 #+ i2, j))" in lt_trans)
   apply (simp add: ack_2)
   apply (rule_tac [2] ack_nest_bound [THEN lt_trans2])
      apply (rule add_le_mono [THEN leI, THEN leI])
         apply (auto intro: add_le_self add_le_self2 ack_le_mono1)
  done

lemma ack_add_bound2:
     "[| i < ack(k,j);  j \<in> nat;  k \<in> nat |]
      ==> i#+j < ack(succ(succ(succ(succ(k)))), j)"
  \<comment> \<open>PROPERTY A 12.\<close>
  \<comment> \<open>Article uses existential quantifier but the ALF proof used @{term "k#+#4"}.\<close>
  \<comment> \<open>Quantified version must be nested \<open>\<exists>k'. \<forall>i,j \<dots>\<close>.\<close>
  apply (rule_tac j = "ack (k,j) #+ ack (0,j) " in lt_trans)
   apply (rule_tac [2] ack_add_bound [THEN lt_trans2])
      apply (rule add_lt_mono)
         apply auto
  done

subsection \<open>Main result\<close>

declare list_add_type [simp]

lemma SC_case: "l \<in> list(nat) ==> SC ` l < ack(1, list_add(l))"
  apply (unfold SC_def)
  apply (erule list.cases)
   apply (simp add: succ_iff)
  apply (simp add: ack_1 add_le_self)
  done

lemma lt_ack1: "[| i \<in> nat; j \<in> nat |] ==> i < ack(i,j)"
  \<comment> \<open>PROPERTY A 4'? Extra lemma needed for \<open>CONSTANT\<close> case, constant functions.\<close>
  apply (induct_tac i)
   apply (simp add: nat_0_le)
  apply (erule lt_trans1 [OF succ_leI ack_lt_ack_succ1])
   apply auto
  done

lemma CONSTANT_case:
    "[| l \<in> list(nat);  k \<in> nat |] ==> CONSTANT(k) ` l < ack(k, list_add(l))"
  by (simp add: CONSTANT_def lt_ack1)

lemma PROJ_case [rule_format]:
    "l \<in> list(nat) ==> \<forall>i \<in> nat. PROJ(i) ` l < ack(0, list_add(l))"
  apply (unfold PROJ_def)
  apply simp
  apply (erule list.induct)
   apply (simp add: nat_0_le)
  apply simp
  apply (rule ballI)
  apply (erule_tac n = i in natE)
   apply (simp add: add_le_self)
  apply simp
  apply (erule bspec [THEN lt_trans2])
   apply (rule_tac [2] add_le_self2 [THEN succ_leI])
   apply auto
  done

text \<open>
  \medskip \<open>COMP\<close> case.
\<close>

lemma COMP_map_lemma:
  "fs \<in> list({f \<in> prim_rec. \<exists>kf \<in> nat. \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l))})
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat).
      list_add(map(\<lambda>f. f ` l, fs)) < ack(k, list_add(l))"
  apply (induct set: list)
   apply (rule_tac x = 0 in bexI)
    apply (simp_all add: lt_ack1 nat_0_le)
  apply clarify
  apply (rule ballI [THEN bexI])
  apply (rule add_lt_mono [THEN lt_trans])
       apply (rule_tac [5] ack_add_bound)
         apply blast
        apply auto
  done

lemma COMP_case:
 "[| kg\<in>nat;
     \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l));
     fs \<in> list({f \<in> prim_rec .
                 \<exists>kf \<in> nat. \<forall>l \<in> list(nat).
                        f`l < ack(kf, list_add(l))}) |]
   ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). COMP(g,fs)`l < ack(k, list_add(l))"
  apply (simp add: COMP_def)
  apply (frule list_CollectD)
  apply (erule COMP_map_lemma [THEN bexE])
  apply (rule ballI [THEN bexI])
   apply (erule bspec [THEN lt_trans])
    apply (rule_tac [2] lt_trans)
     apply (rule_tac [3] ack_nest_bound)
       apply (erule_tac [2] bspec [THEN ack_lt_mono2])
         apply auto
  done

text \<open>
  \medskip \<open>PREC\<close> case.
\<close>

lemma PREC_case_lemma:
 "[| \<forall>l \<in> list(nat). f`l #+ list_add(l) < ack(kf, list_add(l));
     \<forall>l \<in> list(nat). g`l #+ list_add(l) < ack(kg, list_add(l));
     f \<in> prim_rec;  kf\<in>nat;
     g \<in> prim_rec;  kg\<in>nat;
     l \<in> list(nat) |]
  ==> PREC(f,g)`l #+ list_add(l) < ack(succ(kf#+kg), list_add(l))"
  apply (unfold PREC_def)
  apply (erule list.cases)
   apply (simp add: lt_trans [OF nat_le_refl lt_ack2])
  apply simp
  apply (erule ssubst)  \<comment> \<open>get rid of the needless assumption\<close>
  apply (induct_tac a)
   apply simp_all
   txt \<open>base case\<close>
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt \<open>ind step\<close>
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ll #+ mm" for ll mm in lt_trans1)
    apply (erule_tac [2] bspec)
    apply (rule nat_le_refl [THEN add_le_mono])
       apply typecheck
   apply (simp add: add_le_self2)
   txt \<open>final part of the simplification\<close>
  apply simp
  apply (rule add_le_self2 [THEN ack_le_mono1, THEN lt_trans1])
     apply (erule_tac [4] ack_lt_mono2)
      apply auto
  done

lemma PREC_case:
   "[| f \<in> prim_rec;  kf\<in>nat;
       g \<in> prim_rec;  kg\<in>nat;
       \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l));
       \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l)) |]
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). PREC(f,g)`l< ack(k, list_add(l))"
  apply (rule ballI [THEN bexI])
   apply (rule lt_trans1 [OF add_le_self PREC_case_lemma])
          apply typecheck
     apply (blast intro: ack_add_bound2 list_add_type)+
  done

lemma ack_bounds_prim_rec:
    "f \<in> prim_rec ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). f`l < ack(k, list_add(l))"
  apply (induct set: prim_rec)
  apply (auto intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)
  done

theorem ack_not_prim_rec:
    "(\<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. ack(x,x), l)) \<notin> prim_rec"
  apply (rule notI)
  apply (drule ack_bounds_prim_rec)
  apply force
  done

end


(* I borrow the implementation from
    [Title:      Sequents/LK0.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1993  University of Cambridge]

But make a modification to adapt to our application.
*)

header {* Classical First-Order Sequent Calculus *}

theory DDLK0
imports DLK0
begin

datatype dexp = l | Dur fform ("Dur _" 80)
                  | DR real   ("DR _" 80)
                  | DAdd dexp dexp (infixl "[[+]]" 65)

(*dc formulas*)
datatype dform = DTrue | DFalse
               | DEq dexp dexp        (infixl "[[=]]" 50)
               | DLess dexp dexp       (infixl "[[<]]" 50)
               | DGreat dexp dexp      (infixl "[[>]]" 50)
               | DNot dform           ("[[~]] _" [40] 40)
               | DConj dform dform    (infixr "[[&]]" 35)
               | DDisj dform dform    (infixr "[[|]]" 30)
               | DImp dform dform      (infixr "[[-->]]" 30)
               | DIff dform dform      (infixr "[[<->]]" 25)
               | DAll string dform      ("DALL _ _ " 10)
               | DEx  string dform      ("DEX _ _" 10)
               | chop dform dform     (infixr "[^]" 38)

definition
dequal_less  (infixl "[[<=]]" 50) where
"x [[<=]] y == (x [[<]] y) [[|]] (x [[=]] y)"
definition
dequal_greater  (infixl "[[>=]]" 50) where
"x [[>=]] y == (x [[>]] y) [[|]] (x [[=]] y)"
definition
almost ("almost _" 60) where
"almost p == ((Dur p) [[=]] l [[&]] l [[>]] DR 0) "

definition
almostz ("almostz _" 60) where
"almostz p == almost p [[|]] l [[=]] DR 0"

axiomatization where
 (*Propositional rules*)

   dbasic: "$H, P, $G |- $E, P, $F" and
  dconjR: "[| $H|- $E, P, $F;  $H|- $E, Q, $F |] ==> $H|- $E, P [[&]] Q, $F"  and
  dconjL: "$H, P, Q, $G |- $E ==> $H, P [[&]] Q, $G |- $E" and

  ddisjR: "$H |- $E, P, Q, $F ==> $H |- $E, P [[|]] Q, $F" and
  ddisjL: "[| $H, P, $G |- $E;  $H, Q, $G |- $E |] ==> $H, P [[|]] Q, $G |- $E" and

  dimpR:  "$H, P |- $E, Q, $F ==> $H |- $E, P [[-->]] Q, $F" and
  dimpL:  "[| $H,$G |- $E,P;  $H, Q, $G |- $E |] ==> $H, P [[-->]] Q, $G |- $E" and

  dnotR:  "$H, P |- $E, $F ==> $H |- $E, [[~]] P, $F" and
  dnotL:  "$H, $G |- $E, P ==> $H, [[~]] P, $G |- $E" and

  dFalseL: "$H, DFalse, $G |- $E" and

  dTrue_def: "DTrue == DFalse [[-->]] DFalse" and
  diff_def:  "P [[<->]] Q == (P [[-->]] Q) [[&]] (Q [[-->]] P)"

axiomatization where
  (*Quantifiers*)

  dallR:  "(!!x.$H |- $E, P(x), $F) ==> $H |- $E, DALL x P(x), $F" and
  dallL:  "$H, P(t), $G, DALL x P(x) |- $E ==> $H, DALL x P(x), $G |- $E" and

  dexR:   "$H |- $E, P(t), $F, DEX x P(x) ==> $H |- $E, DEX  x P(x), $F" and
  dexL:   "(!!x.$H, P(x), $G |- $E) ==> $H, DEX x P(x), $G |- $E"

axiomatization where

 (*Equality*)

  drefl:  "$H |- $E, a [[=]] a, $F" and
  dsubst: "\<And>G H E. $H(a), $G(a) |- $E(a) ==> $H(b), a [[=]] b, $G(b) |- $E(b)" and

  (* Reflection *)

  deq_reflection:  "|- x [[=]] y ==> (x==y)" and
  diff_reflection: "|- P [[<->]] Q ==> (P==Q)"

(** Structural Rules on formulas are inherited from DLK0.thy **)

ML {*
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  rtac @{thm thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  rtac @{thm thinL} (i + 1)
*}

(** If-and-only-if rules **)
lemma diffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P [[<->]] Q, $F"
  apply (unfold diff_def)
  apply (assumption | rule dconjR dimpR)+
  done

lemma diffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P [[<->]] Q, $G |- $E"
  apply (unfold diff_def)
  apply (assumption | rule dconjL dimpL dbasic)+
   done

lemma diff_refl: "$H |- $E, (P [[<->]] P), $F"
  apply (rule diffR dbasic)+
  done

lemma dTrueR: "$H |- $E, DTrue, $F"
  apply (unfold dTrue_def)
  apply (rule dimpR)
  apply (rule dbasic)
  done

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma dallL_thin: "$H, P(x), $G |- $E ==> $H, DALL x P(x), $G |- $E"
  apply (rule dallL)
  apply (erule thinL)
  done

lemma dexR_thin: "$H |- $E, P(x), $F ==> $H |- $E, DEX x P(x), $F"
  apply (rule dexR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  diffR diffL
  dnotR dnotL
  dimpR dimpL
  ddisjR ddisjL
  dconjR dconjL
  dFalseL dTrueR
  drefl dbasic
ML {* val dprop_pack = Cla.get_pack @{context} *}

lemmas [safe] = dexL dallR
lemmas [unsafe] = the_equality dexR_thin dallL_thin
ML {* val dLK_pack = Cla.get_pack @{context} *}

ML {*
  val dLK_dup_pack =
    Cla.put_pack dprop_pack @{context}
    |> fold_rev Cla.add_safe @{thms dallR dexL}
    |> fold_rev Cla.add_unsafe @{thms dallL dexR the_equality}
    |> Cla.get_pack;
*}

method_setup dfast_prop =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack dprop_pack ctxt))) *}

method_setup dfast_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack dLK_dup_pack ctxt))) *}

method_setup dbest_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack dLK_dup_pack ctxt))) *}

method_setup lem = {*
  Attrib.thm >> (fn th => fn _ =>
    SIMPLE_METHOD' (fn i =>
      rtac (@{thm thinR} RS @{thm cut}) i THEN
      REPEAT (rtac @{thm thinL} i) THEN
      rtac th i))
*}

lemma dmp_R:
  assumes dmajor: "$H |- $E, $F, P [[-->]] Q"
    and dminor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule thinRS [THEN cut], rule dmajor)
  apply step
  apply (rule thinR, rule dminor)
  done

lemma dmp_L:
  assumes dmajor: "$H, $G |- $E, P [[-->]] Q"
    and dminor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule thinL [THEN cut], rule dmajor)
  apply step
  apply (rule thinL, rule dminor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma dR_of_imp:
  assumes dmajor: "|- P [[-->]] Q"
    and dminor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule dmp_R)
   apply (rule_tac [2] dminor)
  apply (rule thinRS, rule dmajor [THEN thinLS])
  done

lemma dL_of_imp:
  assumes dmajor: "|- P [[-->]] Q"
    and dminor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule dmp_L)
   apply (rule_tac [2] dminor)
  apply (rule thinRS, rule dmajor [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma dbackwards_impR:
  assumes prem: "$H, $G |- $E, $F, P [[-->]] Q"
  shows "$H, P, $G |- $E, Q, $F"
  apply (rule dmp_L)
   apply (rule_tac [2] dbasic)
  apply (rule thinR, rule prem)
  done

lemma dconjunct1: "|-P [[&]] Q ==> |-P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma dconjunct2: "|-P [[&]] Q ==> |-Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma dspec: "|- (DALL x P(x)) ==> |- P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma dsym: "|- a [[=]] b [[-->]] b [[=]] a"
  by (safe add!: dsubst)

lemma dtrans: "|- a [[=]] b [[-->]] b [[=]] c [[-->]] a [[=]] c"
   by (safe add!: dsubst)

(* Symmetry of equality in hypotheses *)
lemmas dsymL =dsym [THEN dL_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas dsymR = dsym [THEN dR_of_imp]

lemma dtransR: "[| $H|- $E, $F, a [[=]] b;  $H|- $E, $F, b [[=]] c |] ==> $H|- $E, a [[=]] c, $F"
  by (rule dtrans [THEN dR_of_imp, THEN dmp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma ddef_imp_iff: "(A == B) ==> |- A [[<->]] B"
  apply unfold
  apply (rule diff_refl)
  done

lemma dmeta_eq_to_obj_eq: "(A == B) ==> |- A [[=]] B"
  apply (unfold)
  apply (rule drefl)
  done

(*New added axioms for formulas of DC expressions are not specified here, since the expressions form are limited.*)
(*Arith*)

end


section \<open>Utilties\<close>

theory Util
  imports
    Main
    "HOL-Library.Sublist"
    "HOL-Library.Permutation"

begin

abbreviation swap_events where
  "swap_events i j t \<equiv> take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t) @ drop (j+1) t"

lemma swap_neighbors_2:
  shows
    "i+1 < length t \<Longrightarrow> swap_events i (i+1) t = (t[i := t ! (i+1)])[i+1 := t ! i]"
proof (induct i arbitrary: t)
  case 0
  then show ?case
    by (metis One_nat_def Suc_eq_plus1 add_lessD1 append.left_neutral append_Cons cancel_comm_monoid_add_class.diff_cancel drop_update_cancel length_list_update numeral_One take_0 take_Cons_numeral upd_conv_take_nth_drop zero_less_Suc)
next
  case (Suc n)
  let ?t = "tl t"
  have "t = hd t # ?t"
    by (metis Suc.prems hd_Cons_tl list.size(3) not_less_zero)
  moreover have "swap_events n (n+1) ?t = (?t[n := ?t ! (n+1)])[n+1 := ?t ! n]"
    by (metis Suc.hyps Suc.prems Suc_eq_plus1 length_tl less_diff_conv)
  ultimately show ?case
    by (metis Suc_eq_plus1 append_Cons diff_self_eq_0 drop_Suc_Cons list_update_code(3) nth_Cons_Suc take_Suc_Cons)
qed

lemma swap_identical_length:
  assumes
    "i < j" and
    "j < length t"
  shows
    "length t = length (swap_events i j t)"
proof -
  have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
      = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
    by simp
  then have "... = j+1"
    using assms(1) assms(2) by auto
  then show ?thesis using assms(2) by auto
qed

lemma swap_identical_heads:
  assumes
    "i < j" and
    "j < length t"
  shows
    "take i t = take i (swap_events i j t)"
  using assms by auto

lemma swap_identical_tails:
  assumes
    "i < j" and
    "j < length t"
  shows
    "drop (j+1) t = drop (j+1) (swap_events i j t)"
proof -
  have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
      = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
    by simp
  then have "... = j+1"
    using assms(1) assms(2) by auto
  then show ?thesis
    by (metis \<open>length (take i t @ [t ! j, t ! i] @ take (j - (i + 1)) (drop (i + 1) t)) = length (take i t) + length [t ! j, t ! i] + length (take (j - (i + 1)) (drop (i + 1) t))\<close> append.assoc append_eq_conv_conj)
qed

lemma swap_neighbors:
  shows
    "i+1 < length l \<Longrightarrow> (l[i := l ! (i+1)])[i+1 := l ! i] = take i l @ [l ! (i+1), l ! i] @ drop (i+2) l"
proof (induct i arbitrary: l)
  case 0
  then show ?case
    by (metis One_nat_def add.left_neutral add_lessD1 append_Cons append_Nil drop_update_cancel length_list_update one_add_one plus_1_eq_Suc take0 take_Suc_Cons upd_conv_take_nth_drop zero_less_two)
next
  case (Suc n)
  let ?l = "tl l"
  have "(l[Suc n := l ! (Suc n + 1)])[Suc n + 1 := l ! Suc n] = hd l # (?l[n := ?l ! (n+1)])[n+1 := ?l ! n]"
    by (metis Suc.prems add.commute add_less_same_cancel2 list.collapse list.size(3) list_update_code(3) not_add_less2 nth_Cons_Suc plus_1_eq_Suc)
  have "n + 1 < length ?l" using Suc.prems by auto
  then have "(?l[n := ?l ! (n+1)])[n+1 := ?l ! n] = take n ?l @ [?l ! (n+1), ?l ! n] @ drop (n+2) ?l"
    using Suc.hyps by simp
  then show ?case
    by (cases l) auto
qed

lemma swap_events_perm:
  assumes
    "i < j" and
    "j < length t"
  shows
    "perm (swap_events i j t) t"
proof -
  have swap: "swap_events i j t
      = take i t @ [t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t)) @ (drop (j+1) t)"
    by auto
  have reg: "t = take i t @ (take ((j+1) - i) (drop i t)) @ drop (j+1) t"
    by (metis add_diff_inverse_nat add_lessD1 append.assoc append_take_drop_id assms(1) less_imp_add_positive less_not_refl take_add)
  have "perm (take i t) (take i t)" by simp
  moreover have "perm (drop (j+1) t) (drop (j+1) t)" by simp
  moreover have "perm ([t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t))) (take ((j+1) - i) (drop i t))"
  proof -
    let ?l = "take (j - (i+1)) (drop (i+1) t)"
    have "take ((j+1) - i) (drop i t) = t ! i # ?l @ [t ! j]"
    proof -
      have f1: "Suc (j - Suc i) = j - i"
        by (meson Suc_diff_Suc assms(1))
      have f2: "i < length t"
        using assms(1) assms(2) by linarith
      have f3: "j - (i + 1) + (i + 1) = j"
        by (meson assms(1) discrete le_add_diff_inverse2)
      then have "drop (j - (i + 1)) (drop (i + 1) t) = drop j t"
        by (metis drop_drop)
      then show ?thesis
        using f3 f2 f1 by (metis (no_types) Cons_nth_drop_Suc Suc_diff_le Suc_eq_plus1 assms(1) assms(2) hd_drop_conv_nth length_drop less_diff_conv nat_less_le take_Suc_Cons take_hd_drop)
    qed
    then show ?thesis using mset_eq_perm by fastforce
  qed
  ultimately show ?thesis using swap reg
    by (metis append.assoc perm_append1 perm_append2)
qed

lemma sum_eq_if_same_subterms:
  fixes
    i :: nat
  shows
    "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> f k = f' k \<Longrightarrow> sum f {i..<j} = sum f' {i..<j}"
  by auto

lemma filter_neq_takeWhile:
  assumes
    "filter ((\<noteq>) a) l \<noteq> takeWhile ((\<noteq>) a) l"
  shows
    "\<exists>i j. i < j \<and> j < length l \<and> l ! i = a \<and> l ! j \<noteq> a" (is ?P)
proof (rule ccontr)
  assume "~ ?P"
  then have asm: "\<forall>i j. i < j \<and> j < length l \<longrightarrow> l ! i \<noteq> a \<or> l ! j = a" (is ?Q) by simp
  then have "filter ((\<noteq>) a) l = takeWhile ((\<noteq>) a) l"
  proof (cases "a : set l")
    case False
    then have "\<forall>i. i < length l \<longrightarrow> l ! i \<noteq> a" by auto
    then show ?thesis
      by (metis (mono_tags, lifting) False filter_True takeWhile_eq_all_conv)
  next
    case True
    then have ex_j: "\<exists>j. j < length l \<and> l ! j = a"
      by (simp add: in_set_conv_nth)
    let ?j = "Min {j. j < length l \<and> l ! j = a}"
    have fin_j: "finite {j. j < length l \<and> l ! j = a}"
      using finite_nat_set_iff_bounded by blast
    moreover have "{j. j < length l \<and> l ! j = a} \<noteq> empty" using ex_j by blast
    ultimately have "?j < length l"
      using Min_less_iff by blast
    have tail_all_a: "\<forall>j. j < length l \<and> j \<ge> ?j \<longrightarrow> l ! j = a"
    proof (rule allI, rule impI)
      fix j
      assume "j < length l \<and> j \<ge> ?j"
      moreover have "\<lbrakk> ?Q; j < length l \<and> j \<ge> ?j \<rbrakk> \<Longrightarrow> \<forall>k. k \<ge> ?j \<and> k \<le> j \<longrightarrow> l ! j = a"
      proof (induct "j - ?j")
        case 0
        then have "j = ?j" using 0 by simp
        then show ?case
          using Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j by blast
      next
        case (Suc n)
        then have "\<forall>k. k \<ge> ?j \<and> k < j \<longrightarrow> l ! j = a"
          by (metis (mono_tags, lifting) Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j le_eq_less_or_eq mem_Collect_eq)
        then show ?case
          using Suc.hyps(2) by auto
      qed
      ultimately show "l ! j = a" using asm by blast
    qed
    moreover have head_all_not_a: "\<forall>i. i < ?j \<longrightarrow> l ! i \<noteq> a" using asm calculation
      by (metis (mono_tags, lifting) Min_le \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> fin_j leD less_trans mem_Collect_eq)
    ultimately have "takeWhile ((\<noteq>) a) l = take ?j l"
    proof -
      have "length (takeWhile ((\<noteq>) a) l) = ?j"
      proof -
        have "length (takeWhile ((\<noteq>) a) l) \<le> ?j" (is ?S)
        proof (rule ccontr)
          assume "\<not> ?S"
          then have "l ! ?j \<noteq> a"
            by (metis (mono_tags, lifting) not_le_imp_less nth_mem set_takeWhileD takeWhile_nth)
          then show False
            using \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> tail_all_a by blast
        qed
        moreover have "length (takeWhile ((\<noteq>) a) l) \<ge> ?j" (is ?T)
        proof (rule ccontr)
          assume "\<not> ?T"
          then have "\<exists>j. j < ?j \<and> l ! j = a"
            by (metis (mono_tags, lifting) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> calculation le_less_trans not_le_imp_less nth_length_takeWhile)
          then show False
            using head_all_not_a by blast
        qed
        ultimately show ?thesis by simp
      qed
      moreover have "length (take ?j l) = ?j"
        by (metis calculation takeWhile_eq_take)
      ultimately show ?thesis
        by (metis takeWhile_eq_take)

    qed
    moreover have "filter ((\<noteq>) a) l = take ?j l"
    proof -
      have "filter ((\<noteq>) a) l = filter ((\<noteq>) a) (take ?j l) @ filter ((\<noteq>) a) (drop ?j l)"
        by (metis append_take_drop_id filter_append)
      moreover have "filter ((\<noteq>) a) (take ?j l) = take ?j l" using head_all_not_a
        by (metis \<open>takeWhile ((\<noteq>) a) l = take (Min {j. j < length l \<and> l ! j = a}) l\<close> filter_id_conv set_takeWhileD)
      moreover have "filter ((\<noteq>) a) (drop ?j l) = []"
      proof -
        have "\<forall>j. j \<ge> ?j \<and> j < length l \<longrightarrow> l ! j = drop ?j l ! (j - ?j)"
          by simp
        then have "\<forall>j. j < length l - ?j \<longrightarrow> drop ?j l ! j = a" using tail_all_a
          by (metis (no_types, lifting) Groups.add_ac(2) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> less_diff_conv less_imp_le_nat not_add_less2 not_le nth_drop)
        then show ?thesis
        proof -
          obtain aa :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a" where
            "\<forall>x0 x1. (\<exists>v2. v2 \<in> set x1 \<and> x0 v2) = (aa x0 x1 \<in> set x1 \<and> x0 (aa x0 x1))"
            by moura
          then have f1: "\<forall>as p. aa p as \<in> set as \<and> p (aa p as) \<or> filter p as = []"
            by (metis (full_types) filter_False)
          obtain nn :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
            f2: "\<forall>x0 x1. (\<exists>v2<length x0. x0 ! v2 = x1) = (nn x0 x1 < length x0 \<and> x0 ! nn x0 x1 = x1)"
          by moura
          { assume "drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) = a"
            then have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
              using f1 by (metis (full_types)) }
          moreover
          { assume "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length l - Min {n. n < length l \<and> l ! n = a}"
            then have "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
              by simp }
          ultimately have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
            using \<open>\<forall>j<length l - Min {j. j < length l \<and> l ! j = a}. drop (Min {j. j < length l \<and> l ! j = a}) l ! j = a\<close> by blast
          then show ?thesis
            using f2 f1 by (meson in_set_conv_nth)
        qed
      qed
      ultimately show ?thesis by simp
    qed
    ultimately show ?thesis by simp
  qed
  then show False using assms by simp
qed

lemma util_exactly_one_element:
  assumes
    "m \<notin> set l" and
    "l' = l @ [m]"
  shows
    "\<exists>!j. j < length l' \<and> l' ! j = m" (is ?P)
proof -
  have "\<forall>j. j < length l' - 1 \<longrightarrow> l' ! j \<noteq> m"
    by (metis assms(1) assms(2) butlast_snoc length_butlast nth_append nth_mem)
  then have one_j: "\<forall>j. j < length l' \<and> l' ! j = m \<longrightarrow> j = (length l' - 1)"
    by (metis (no_types, hide_lams) diff_Suc_1 lessE)
  show ?thesis
  proof (rule ccontr)
    assume "~ ?P"
    then obtain i j where "i \<noteq> j" "i < length l'" "j < length l'"
                          "l' ! i = m" "l' ! j = m"
      using assms by auto
    then show False using one_j by blast
  qed
qed

end