theory Nielson_Hoare
imports Big_StepT
begin

section "Nielson Style Hoare Logic with logical variables"

abbreviation "eq a b == (And (Not (Less a b)) (Not (Less b a)))"

type_synonym lvname = string
type_synonym assn2 = "(lvname \<Rightarrow> nat) \<Rightarrow> state \<Rightarrow> bool"
type_synonym tbd = "state \<Rightarrow> nat" (* time bound *)

subsection \<open>The support of an assn2\<close>

definition support :: "assn2 \<Rightarrow> string set" where
"support P = {x. \<exists>l1 l2 s. (\<forall>y. y \<noteq> x \<longrightarrow> l1 y = l2 y) \<and> P l1 s \<noteq> P l2 s}"

lemma support_and: "support (\<lambda>l s. P l s \<and> Q l s) \<subseteq> support P \<union> support Q"
unfolding support_def by blast

lemma support_impl: "support (\<lambda>l s. P s \<longrightarrow> Q l s) \<subseteq> support Q"
unfolding support_def by blast

lemma support_exist: "support (\<lambda>l s. \<exists> z::nat. Q z l s) \<subseteq> (UN n. support (Q n))"
  unfolding support_def apply(auto)
  by blast+

lemma support_all: "support (\<lambda>l s. \<forall>z. Q z l s) \<subseteq> (UN n. support (Q n))"
  unfolding support_def apply(auto)
  by blast+

lemma support_single: "support (\<lambda>l s. P (l a) s) \<subseteq> {a}"
  unfolding support_def by fastforce

lemma support_inv: "\<And>P. support (\<lambda>l s. P s) = {}"
unfolding support_def by blast

lemma assn2_lupd: "x \<notin> support Q \<Longrightarrow> Q (l(x:=n)) = Q l"
by(simp add: support_def fun_upd_other fun_eq_iff)
  (metis (no_types, lifting) fun_upd_def)

subsection "Validity"

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

definition hoare1_valid :: "assn2 \<Rightarrow> com \<Rightarrow> tbd \<Rightarrow> assn2 \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>1 {(1_)}/ (_)/ { _ \<Down>(1_)}" 50) where
"\<Turnstile>\<^sub>1 {P} c {q \<Down> Q}  \<longleftrightarrow>  (\<exists>k>0. (\<forall>l s. P l s \<longrightarrow> (\<exists>t p. ((c,s) \<Rightarrow> p \<Down> t) \<and>  p \<le> k * (q s) \<and> Q l t)))"

subsection "Hoare rules"

inductive
  hoare1 :: "assn2 \<Rightarrow> com \<Rightarrow> tbd \<Rightarrow> assn2 \<Rightarrow> bool" ("\<turnstile>\<^sub>1 ({(1_)}/ (_)/ { _ \<Down> (1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>1 {P} SKIP { (%s. Suc 0) \<Down> P}"  |

Assign:  "\<turnstile>\<^sub>1 {\<lambda>l s. P l (s[a/x])} x::=a {  (%s. Suc 0) \<Down> P}"  |

If: "\<lbrakk> \<turnstile>\<^sub>1 {\<lambda>l s. P l s \<and> bval b s} c\<^sub>1 { e1 \<Down> Q};
       \<turnstile>\<^sub>1 {\<lambda>l s. P l s \<and> \<not> bval b s} c\<^sub>2 { e1 \<Down> Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>1 {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 { (\<lambda>s. e1 s + Suc 0 ) \<Down> Q}"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>1 { (%l s. P\<^sub>1 l s \<and> l x = e2' s ) } c\<^sub>1 { e1 \<Down> (%l s. P\<^sub>2 l s \<and>  e2 s \<le> l x )};
         \<turnstile>\<^sub>1 {P\<^sub>2} c\<^sub>2 { e2 \<Down> P\<^sub>3}; x \<notin> support P\<^sub>1; x \<notin> support P\<^sub>2;
         \<And>l s. P\<^sub>1 l s \<Longrightarrow> e1 s + e2' s \<le> e s\<rbrakk>
          \<Longrightarrow> \<turnstile>\<^sub>1 {P\<^sub>1} c\<^sub>1;;c\<^sub>2 { e \<Down> P\<^sub>3}"  |

While:
  "\<lbrakk> \<turnstile>\<^sub>1 {\<lambda>l s. P l s \<and> bval b s \<and> e' s = l y} c {  e'' \<Down> \<lambda>l s. P l s \<and> e s \<le> l y};
       \<forall>l s. bval b s \<and> P l s \<longrightarrow>  e s \<ge> 1  +  e' s + e'' s  ;
     \<forall>l s. ~ bval b s \<and> P l s \<longrightarrow> 1 \<le> e s;
     y \<notin> support P  \<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>1 {P} WHILE b DO c { e \<Down> \<lambda>l s. P l s \<and> \<not> bval b s}" |

conseq: "\<lbrakk> \<exists>k>0. \<forall>l s. P' l s \<longrightarrow> ( e s \<le> k * (e' s) \<and>(\<forall>t. \<exists>l'. P l' s \<and> ( Q l' t \<longrightarrow> Q' l t) ));
           \<turnstile>\<^sub>1 {P}c{ e \<Down> Q}   \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>1 {P'}c{e' \<Down> Q'}"

text\<open>Derived Rules:\<close>

lemma conseq_old: "\<lbrakk>\<exists>k>0. \<forall>l s. P' l s \<longrightarrow> (P l s \<and> ( e' s \<le>  k * (e s))); \<turnstile>\<^sub>1 {P}c{ e' \<Down>  Q}; \<forall>l s. Q l s \<longrightarrow> Q' l s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>1 {P'}c{e \<Down> Q'}"
  using conseq apply(metis) done

lemma If2: "\<lbrakk> \<turnstile>\<^sub>1 {\<lambda>l s. P l s \<and> bval b s} c\<^sub>1 { e \<Down> Q}; \<turnstile>\<^sub>1 {\<lambda>l s. P l s \<and> \<not> bval b s} c\<^sub>2 { e \<Down> Q};
        \<And>l s. P l s \<Longrightarrow> e s + 1 = e' s \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>1 {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 { e' \<Down> Q}"
apply(rule conseq[OF _ If, where P=P and P'=P]) by(auto)

lemma ub_cost:
  "\<lbrakk> (\<exists>k>0. \<forall>l s. P l s \<longrightarrow> e' s \<le> k * (e s));  \<turnstile>\<^sub>1 {P} c {e' \<Down> Q} \<rbrakk> \<Longrightarrow>  \<turnstile>\<^sub>1 {P} c {e \<Down> Q}"
  apply(rule conseq_old[where e'=e' and Q=Q and P=P])
  by(auto)

lemma Assign': "\<forall>l s. P l s \<longrightarrow> Q l (s[a/x]) \<Longrightarrow> (\<turnstile>\<^sub>1 {P} x ::= a { (%s. 1) \<Down> Q})"
using strengthen_pre[OF _ Assign]
by (simp )

subsection "Soundness"

text\<open>The soundness theorem:\<close>

theorem hoare1_sound: "\<turnstile>\<^sub>1 {P}c{e \<Down> Q}  \<Longrightarrow>  \<Turnstile>\<^sub>1 {P}c{e \<Down> Q}"
apply(unfold hoare1_valid_def)
proof(  induction  rule: hoare1.induct)
  case (Skip P)
  show ?case  by fastforce
next
  case (Assign P a x)
  show ?case  by fastforce
next
  case (Seq P1 x e2' c1 e1 P2 e2 c2 P3 e)
  from Seq(6) obtain k where k: "k>0" and  S6: "\<forall>l s. P1 l s \<and> l x = e2' s \<longrightarrow> (\<exists>t p. (c1, s) \<Rightarrow> p \<Down> t \<and> p \<le> k * e1 s \<and> P2 l t \<and> e2 t \<le> l x)" by auto
  from Seq(7) obtain k' where k': "k'>0" and  S7:  "\<forall>l s. P2 l s \<longrightarrow> (\<exists>t p. (c2, s) \<Rightarrow> p \<Down> t \<and> p \<le> k' * e2 s \<and> P3 l t)" by auto
  from k k' have "0 < max k k'" by auto
  show ?case
  proof (rule exI[where x="max k k'"], safe)
    fix l s
    have x_supp: "x \<notin> support P1" by fact
    have x_supp2: "x \<notin> support P2" by fact

    from S6 have S: "P1 (l(x := e2' s)) s \<and> (l(x := e2' s)) x = e2' s \<longrightarrow> (\<exists>t p. (c1, s) \<Rightarrow> p \<Down> t \<and>  p \<le> k * e1 s \<and> P2 (l(x := e2' s)) t \<and> e2 t \<le> (l(x := e2' s)) x) "
       by blast

    assume a: "P1 l s"

    with Seq(5) have 1: " e1 s + e2' s \<le>   e s" by simp
    with a S assn2_lupd[OF x_supp] have "(\<exists>t p. (c1, s) \<Rightarrow> p \<Down> t \<and> p \<le> k * e1 s \<and> P2 (l(x := e2' s)) t \<and> e2 t \<le> (l(x := e2' s)) x)" by simp
    then obtain t p where c1: "(c1, s) \<Rightarrow> p \<Down> t" and cost1: " p \<le> k * e1 s" and P2': "P2 (l(x := e2' s)) t" and 31: "e2 t \<le> (l(x := e2' s)) x" by blast
    from P2' assn2_lupd[OF x_supp2] have P2: "P2 l t" by auto
    from 31 have 3: "e2 t \<le> e2' s" by simp
    from S7 P2 have "(\<exists>t' p'. ((c2, t) \<Rightarrow> p' \<Down> t') \<and>   p' \<le> k' * e2 t \<and> P3 l t')" by blast
    then obtain t' p'  where c2: "(c2, t) \<Rightarrow> p' \<Down> t'" and cost2: " p' \<le> k' * (e2 t)" and P3: "P3 l t'" by blast

    from c1 c2 have weg: "(c1;; c2, s) \<Rightarrow> p + p' \<Down> t'"
      apply (rule Big_StepT.Seq) by simp
    from cost1 cost2 3 have " (p+p') \<le> k * (e1 s) + k' * (e2' s)"
      by (meson add_mono mult_le_mono2 order_subst1)
    also have "\<dots> \<le> (max k k') * (e1 s) + (max k k') * (e2' s)"
      by (simp add: add_mono)
    also have "\<dots> \<le> (max k k') * (e1 s + e2' s)"
      by (simp add: add_mult_distrib2)
    also have "\<dots> \<le> (max k k') * (e s)" using 1 by simp
  finally
    have cost: " (p + p') \<le> (max k k') * (e s)" .

    from weg cost P3
    have "(c1;; c2, s) \<Rightarrow> p+p' \<Down> t' \<and>   (p+p') \<le> (max k k') * (e s) \<and> P3 l t'" by blast
    then show "(\<exists>t p. (c1;; c2, s) \<Rightarrow> p \<Down> t \<and>  p \<le> (max k k') * (e s) \<and> P3 l t)" by metis
  qed fact
next
  case (If P b c1 e Q c2)
  from If(3) obtain k1 where k1: "k1>0" and If1: "\<forall>l s. P l s \<and> bval b s \<longrightarrow> (\<exists>t p. (c1, s) \<Rightarrow> p \<Down> t \<and> p \<le> k1 * e s \<and> Q l t)" by auto
  from If(4) obtain k2 where  k2: "k2>0" and If2: "\<forall>l s. P l s \<and> \<not> bval b s \<longrightarrow> (\<exists>t p. (c2, s) \<Rightarrow> p \<Down> t \<and> p \<le> k2 * e s \<and> Q l t)" by auto
  let ?k' = "max (k1+1) (k2+1)"
  have "?k'>0" by auto
  show ?case
  proof (rule exI[where x="?k'"], safe)
    fix l s
    assume P1: "P l s"
    show "\<exists>t p. (IF b THEN c1 ELSE c2, s) \<Rightarrow> p \<Down> t \<and>  p \<le> ?k' * (e s + Suc 0) \<and> Q l t"
    proof (cases "bval b s")
      case True
      with If1 P1 obtain t p where "(c1, s) \<Rightarrow> p \<Down> t" "p \<le> k1 * (e s)" "Q l t" by blast
      with True have 1: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p+1 \<Down> t" "(p + 1) \<le> (k1+1) * (e s  + Suc 0)"
          "Q l t"
        by auto
      have "(k1+1) * (e s  + Suc 0) \<le> ?k' * (e s  + Suc 0)"
        by (simp add: nat_mult_max_left)
      with 1 have 2: "p+1   \<le> ?k' * (e s  + Suc 0)"
        by linarith
      from 1 2 show "\<exists>t p. (IF b THEN c1 ELSE c2, s) \<Rightarrow> p \<Down> t \<and> p \<le> ?k' * (e s + Suc 0) \<and> Q l t" by metis
    next
      case False
      with If2 P1 obtain t p where "(c2, s) \<Rightarrow> p \<Down> t" "p \<le> k2 * (e s)" "Q l t" by blast
      with False have 1: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p+1 \<Down> t" "(p + 1) \<le> (k2+1) * ( e s  + Suc 0)"
          "Q l t"
        by auto
      have "(k2+1) * (e s  + Suc 0) \<le> ?k' * (e s  + Suc 0)"
        by (simp add: nat_mult_max_left)
      with 1 have 2: "p+1   \<le> ?k' * (e s  + Suc 0)"
        by linarith
      from 1 2 show "\<exists>t p. (IF b THEN c1 ELSE c2, s) \<Rightarrow> p \<Down> t \<and>  p \<le> ?k' * (e s + Suc 0) \<and> Q l t" by metis
    qed
  qed fact
next
  case (conseq P' e e' P Q Q' c)
  from conseq(1) obtain k1 where k1: "k1>0" and c1: "\<forall>l s. P' l s \<longrightarrow> e s \<le> k1 * e' s \<and> (\<forall>t. \<exists>l'. P l' s \<and> (Q l' t \<longrightarrow> Q' l t))" by auto
  then have c1': "\<And>l s. P' l s \<Longrightarrow> e s \<le> k1 * e' s \<and> (\<forall>t. \<exists>l'. P l' s \<and> (Q l' t \<longrightarrow> Q' l t))"
    by auto
  from conseq(3) obtain k2 where k2: "k2>0" and c2: "\<forall>l s. P l s \<longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le> k2 * e s \<and> Q l t)" by auto
  then have c2': "\<And>l s.  P l s \<Longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le> k2 * e s \<and> Q l t)" by auto
  have "k2*k1 > 0" using k1 k2 by auto
  show ?case
  proof (rule exI[where x="k2*k1"], safe)
    fix l s
    assume "P' l s"
    with c1' have A: "e s \<le> k1 * e' s" and "\<And>t. \<exists>l'. P l' s \<and> (Q l' t \<longrightarrow> Q' l t)" by auto
    then obtain fl where "\<And>t. P (fl t) s" and B: "\<And>t. Q (fl t) t \<longrightarrow> Q' l t" by metis
    with c2' obtain ft fp where i: "\<And>t. (c, s) \<Rightarrow> (fp t) \<Down> (ft t)" and ii: "\<And>t. (fp t) \<le> k2 * e s"
        and iii: "\<And>t. Q (fl t) (ft t)"
      by meson
    from i obtain t p where tt: "\<And>x. ft x = t" "\<And>x. fp x = p" using big_step_t_determ2
      by meson
    with i have c: "(c, s) \<Rightarrow> p \<Down> t" by simp
    from tt ii iii have p: "p \<le> k2 * e s" and Q: "\<And>x. Q (fl x) t" by auto
    have p: "p \<le> k2 * k1 * e' s" using p A
      by (metis le_trans mult.assoc mult_le_mono2)
    from B Q have q: "Q' l t" by fast

    from c p q
    show "\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le>  k2 *k1 * e' s \<and> Q' l t"
      by blast
  qed fact
next
  case (While INV b e' y c e'' e)
  from While(5) obtain k where W6: "\<forall>l s. INV l s \<and> bval b s \<and> e' s = l y \<longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> p \<le> k * e'' s \<and> INV l t \<and> e t \<le> l y)" by auto
  let ?k' = "k+1"
  {
    fix n l s
    have "\<lbrakk> e s = n; INV l s \<rbrakk> \<Longrightarrow> \<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> p \<le> ?k' * e s \<and> INV l t \<and> \<not> bval b t"
    proof(induction "n" arbitrary: l s rule: less_induct)
      case (less x)

      show ?case
      proof (cases "bval b s")
        case False
        with less(2,3) While(3) have  b: "1 \<le> e s" by auto

        show ?thesis
          apply(rule exI[where x=s])
          apply(rule exI[where x=1]) apply safe
          subgoal using  WhileFalse[OF False] by simp
          subgoal using b by auto
          subgoal using less by auto
          subgoal using False by auto
          done

      next
      case True
      with less(2,3) While(2) have bT: "bval b s" and cost1: "  1 + e' s + e'' s \<le> e s" by auto
      let ?l' = "l(y := e' s)"

      have y_supp: "y \<notin> support INV" by fact

      from cost1 have Z: "e' s < x" using less(2) by auto
      from W6
      have "INV ?l' s \<and> bval b s \<and> e' s = ?l' y
            \<longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and>   p \<le> k * e'' s  \<and> INV ?l' t \<and> e t \<le> ?l' y)"
          by blast
      with less(3) bT
      have "(\<exists>t p. ((c, s) \<Rightarrow> p \<Down> t) \<and>   p \<le> k * e'' s  \<and> INV ?l' t \<and> e t \<le> e' s)"
            using   assn2_lupd[OF y_supp]
        by(auto)
      then obtain t p   where ceff: "(c, s) \<Rightarrow> p \<Down> t" and cost2: " p \<le>  k * e'' s"
                    and INVz': "INV ?l' t" and cost3: "  e t \<le>   e' s"
        by blast

      from INVz' have INVz: "INV l t" using assn2_lupd[OF y_supp] by auto
      have "e t < x" using Z cost3 by auto
      with less(1)[OF _ _ INVz, of "e t"]  obtain t' p'
        where weff: "(WHILE b DO c, t) \<Rightarrow> p' \<Down> t'" and cost4: " p' \<le> ?k' *  e t" and INV0: "INV l t'"
            and nb: "\<not> bval b t'"
          by fastforce

      have "(WHILE b DO c, s) \<Rightarrow> 1 + p + p'  \<Down> t'"
        apply(rule WhileTrue)
          apply fact
          apply (fact ceff)
          apply (fact weff) by simp
    moreover
      note INV0 nb
      moreover
      {
        have "(1 + p + p') \<le> 1 + k * e'' s + ?k' * e t" using cost2 cost4 by linarith
        also have "\<dots> \<le>  1 + k * e'' s + ?k' * e' s" using cost3
          using add_left_mono mult_le_mono2 by blast
        also have "\<dots> \<le> ?k'*1 + ?k'* e'' s + ?k' * e' s " by force
        also have "\<dots> = ?k' * (1+ e' s + e'' s)" by algebra
        also have "\<dots> \<le> ?k' * e s" using cost1
          using mult_le_mono2 by blast
        finally have " (1 + p + p') \<le> ?k' * e s" .
      }
    ultimately
      show ?thesis by metis
    qed
    qed
  }
  then have erg: "\<And>l s. INV l s \<Longrightarrow> \<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> p \<le> (k + 1) * e s \<and> INV l t \<and> \<not> bval b t" by auto
  show ?case apply(rule exI[where x="?k'"]) using erg by fastforce
qed

subsection "Completeness"

definition wp1 :: "com \<Rightarrow> assn2 \<Rightarrow> assn2" ("wp\<^sub>1") where
"wp\<^sub>1 c Q  =  (\<lambda>l s. \<exists>t p. (c,s) \<Rightarrow> p \<Down> t \<and> Q l t)"

lemma support_wpt: "support (wp\<^sub>1 c Q) \<subseteq> support Q"
by(simp add: support_def wp1_def) blast

lemma wp1_terminates: "wp\<^sub>1 c Q l s \<Longrightarrow> \<down> (c, s)" unfolding wp1_def by auto

lemma wp1_SKIP[simp]: "wp\<^sub>1 SKIP Q = Q" by(auto intro!: ext simp: wp1_def)

lemma wp1_Assign[simp]: "wp\<^sub>1 (x ::= e) Q = (\<lambda>l s. Q l (s(x := aval e s)))" by(auto intro!: ext simp: wp1_def)

lemma wp1_Seq[simp]: "wp\<^sub>1 (c\<^sub>1;;c\<^sub>2) Q = wp\<^sub>1 c\<^sub>1 (wp\<^sub>1 c\<^sub>2 Q)" by (auto simp: wp1_def fun_eq_iff)

lemma wp1_If[simp]: "wp\<^sub>1 (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>l s. wp\<^sub>1 (if bval b s then c\<^sub>1 else c\<^sub>2) Q l s)" by (auto simp: wp1_def fun_eq_iff)

definition "prec c E == %s. E (THE t. (\<exists>p. (c,s) \<Rightarrow> p \<Down> t))"

lemma wp1_prec_Seq_correct: "wp\<^sub>1 (c1;;c2) Q l s \<Longrightarrow> \<down>\<^sub>t (c1, s) + prec c1 (\<lambda>s. \<down>\<^sub>t (c2, s)) s \<le> \<down>\<^sub>t (c1;; c2, s)"
proof -
  assume "wp\<^sub>1 (c1;;c2) Q l s"
  then have wp: "wp\<^sub>1 c1 (wp\<^sub>1 c2 Q) l s" by simp
  then obtain t p where c1_term: "(c1, s) \<Rightarrow> p \<Down> t" and "(\<exists>ta p. (c2, t) \<Rightarrow> p \<Down> ta \<and> Q l ta)" unfolding wp1_def by blast
  then obtain t' p' where c2_term: "(c2, t) \<Rightarrow> p' \<Down> t'" and  "Q l t'" by blast

  have p: "\<down>\<^sub>t (c1, s) = p" using c1_term bigstepT_the_cost by simp
  have "\<down>\<^sub>t (c2, t) = p'" using c2_term bigstepT_the_cost by simp

  have f: "(THE t. \<exists>p. (c1, s) \<Rightarrow> p \<Down> t) = t" using c1_term bigstepT_the_state by simp

  have " prec c1 (\<lambda>s. \<down>\<^sub>t (c2, s)) s = p'" unfolding prec_def f using c2_term bigstep_det by blast
  then have p': " prec c1 (\<lambda>s.  (THE n. \<exists>a. (c2, s) \<Rightarrow> n \<Down> a)) s
        =  p'" unfolding prec_def by blast

  from wp have "wp\<^sub>1 (c1;;c2) Q l s" by simp
  then obtain T P where c12_term: "(c1;;c2, s) \<Rightarrow> P \<Down> T" and "Q l T" unfolding wp1_def by blast

  have P: "(THE n. (\<exists>a. (c1;;c2, s) \<Rightarrow> n \<Down> a)) = P" using c12_term bigstepT_the_cost by simp

  from c12_term have Ppp': "P = p + p'"
    apply(elim Seq_tE)
    using c1_term bigstep_det c2_term by blast

  have " (THE n. \<exists>a. (c1, s) \<Rightarrow> n \<Down> a) + prec c1 (\<lambda>s.  (THE n. \<exists>a. (c2, s) \<Rightarrow> n \<Down> a)) s
        =  p +  p'" using p p' by auto
  also have "\<dots> =  P" using Ppp' by auto
  also have "\<dots> =  (THE n. (\<exists>a. (c1;;c2, s) \<Rightarrow> n \<Down> a))" using P by auto
  finally
  show "\<down>\<^sub>t (c1, s) + prec c1 (\<lambda>s. \<down>\<^sub>t (c2, s)) s \<le> \<down>\<^sub>t (c1;; c2, s)"
    by simp
qed

abbreviation "new Q \<equiv> SOME x. x \<notin> support Q"

lemma bigstep_det: "(c1, s) \<Rightarrow> p1 \<Down> t1 \<Longrightarrow> (c1, s) \<Rightarrow> p \<Down> t \<Longrightarrow> p1=p \<and> t1=t"
  using big_step_t_determ2 by simp

lemma bigstepT_the_cost: "(c, s) \<Rightarrow> P \<Down> T \<Longrightarrow> (THE n. \<exists>a. (c, s) \<Rightarrow> n \<Down> a) = P"
  using bigstep_det by blast

lemma bigstepT_the_state: "(c, s) \<Rightarrow> P \<Down> T \<Longrightarrow> (THE a. \<exists>n. (c, s) \<Rightarrow> n \<Down> a) = T"
  using bigstep_det by blast

lemma assumes b: "bval b s"
  shows wp1WhileTrue': "wp\<^sub>1 (WHILE b DO c) Q l s = wp\<^sub>1 c (wp\<^sub>1 (WHILE b DO c) Q) l s"
proof
  assume "wp\<^sub>1 c (wp\<^sub>1 (WHILE b DO c) Q) l s"
  from this[unfolded wp1_def]
  obtain t s' t' s'' where "(c, s) \<Rightarrow> t \<Down> s'" "(WHILE b DO c, s') \<Rightarrow> t' \<Down> s''" and Q: "Q l s''" by blast
  with b have "(WHILE b DO c, s) \<Rightarrow> 1+t+t' \<Down> s''" by auto
  with Q show "wp\<^sub>1 (WHILE b DO c) Q l s" unfolding wp1_def by auto
next
  assume "wp\<^sub>1 (WHILE b DO c) Q l s"
  from this[unfolded wp1_def]
  obtain t s'' where "(WHILE b DO c, s) \<Rightarrow> t \<Down> s''" and Q: "Q l s''" by blast
  with b  obtain t1 t2 s' where "(c, s) \<Rightarrow> t1 \<Down> s'" "(WHILE b DO c, s') \<Rightarrow> t2 \<Down> s''" by auto
  with Q show "wp\<^sub>1 c (wp\<^sub>1 (WHILE b DO c) Q) l s " unfolding wp1_def by auto
qed

lemma assumes b: "~ bval b s"
  shows wp1WhileFalse': "wp\<^sub>1 (WHILE b DO c) Q l s =  Q l s"
proof
  assume "wp\<^sub>1 (WHILE b DO c) Q l s"
  from this[unfolded wp1_def]
  obtain t s' where "(WHILE b DO c, s) \<Rightarrow> t \<Down> s'" and Q: "Q l s'" by blast
  with b  have "s=s'" by auto
  with Q show "Q l s" by auto
next
  assume "Q l s"
  with b show  "wp\<^sub>1 (WHILE b DO c) Q l s" unfolding wp1_def by auto
qed

lemma wp1While: "wp\<^sub>1 (WHILE b DO c) Q l s = (if bval b s then wp\<^sub>1 c (wp\<^sub>1 (WHILE b DO c) Q) l s else Q l s)"
  apply(cases "bval b s")
  using wp1WhileTrue' apply simp
  using wp1WhileFalse' apply simp   done

lemma wp1_prec2: fixes e::tbd
    shows "(wp\<^sub>1 c1 Q l s \<and>
           l x = prec c1 e s) = wp\<^sub>1 c1 (\<lambda>l s. Q l s \<and> e s = l x) l s"
      by (metis (mono_tags, lifting) Big_StepT.bigstepT_the_state prec_def wp1_def)

lemma wp1_prec: fixes e::tbd
    shows "wp\<^sub>1 c1 Q l s \<Longrightarrow>
           l x = prec c1 e s \<Longrightarrow> wp\<^sub>1 c1 (\<lambda>l s. Q l s \<and> e s = l x) l s"
unfolding wp1_def prec_def apply(auto)
proof -
  fix p t
  assume "l x = e (THE t. \<exists>p. (c1, s) \<Rightarrow> p \<Down> t)"
  assume 2: "Q l t"
  assume 1: "(c1, s) \<Rightarrow> p \<Down> t "
  show "\<exists>t. (\<exists>p. (c1, s) \<Rightarrow> p \<Down> t) \<and> Q l t \<and> e t = e (THE t. \<exists>p. (c1, s) \<Rightarrow> p \<Down> t) "
    apply(rule exI[where x=t])
    apply(safe)
      apply(rule exI[where x=p]) using 1 apply simp
      apply(fact)
      using 1 by(simp add: bigstepT_the_state)
qed

lemma wp1_is_pre: "finite (support Q) \<Longrightarrow> \<turnstile>\<^sub>1 {wp\<^sub>1 c Q} c { \<lambda>s. \<down>\<^sub>t (c, s) \<Down> Q}"
proof (induction c arbitrary: Q)
  case SKIP
  have ff: "\<And>s n. (\<exists>a. (SKIP, s) \<Rightarrow> n \<Down> a) = (n=Suc 0)" by blast
  show ?case apply (auto intro:hoare1.Skip simp add: ff) using ff done
next
  have gg: "\<And>x1 x2 s n. (\<exists>a. (x1 ::= x2, s) \<Rightarrow> n \<Down> a) = (n=Suc 0)" by blast
  case Assign show ?case apply (auto intro:hoare1.Assign simp add: gg) done
next
  case (Seq c1 c2)
  \<comment> \<open>choose a fresh logical variable x\<close>
  let ?x = "new Q"
  have "\<exists>x. x \<notin> support Q" using Seq.prems infinite_UNIV_listI
    using ex_new_if_finite by blast
  hence  "?x \<notin> support Q" by (rule someI_ex)
  then have x2: "?x \<notin> support (wp\<^sub>1 c2 Q)"  using support_wpt by (fast)
  then have x12: "?x \<notin> support (wp\<^sub>1 (c1;;c2) Q)" apply simp using support_wpt by fast

  \<comment> \<open>assemble a postcondition Q1 that ensures the weakest precondition of Q before c2
        and saves the running time of c2 into the logical variable x\<close>
  let ?Q1 = "(\<lambda>l s. (wp\<^sub>1 c2 Q) l s \<and>  \<down>\<^sub>t (c2, s) = l ?x)"
  have "finite (support ?Q1)" apply(rule rev_finite_subset[OF _ support_and])
     apply(rule finite_UnI)
      apply(rule rev_finite_subset[OF _ support_wpt]) apply(fact)
    apply(rule rev_finite_subset[OF _ support_single]) by simp
  \<comment> \<open>we can now specify this Q1 in the first Induction Hypothesis\<close>
  then have pre: "\<And>u. \<turnstile>\<^sub>1 {wp\<^sub>1 c1 ?Q1 } c1 { \<lambda>s. \<down>\<^sub>t (c1, s) \<Down>  ?Q1  }"
    using Seq(1) by simp

  \<comment> \<open>we can rewrite this into the form we need for the Seq rule\<close>
  have A: " \<turnstile>\<^sub>1 {\<lambda>l s. wp\<^sub>1 (c1;;c2) Q l s \<and> l ?x = (prec c1 (%s. \<down>\<^sub>t (c2, s))) s} c1 { \<lambda>s. \<down>\<^sub>t (c1, s) \<Down> \<lambda>l s. wp\<^sub>1 c2 Q l s \<and>  \<down>\<^sub>t (c2, s) \<le> l ?x}"
    apply(rule conseq_old[OF _ pre ])
    by(auto simp add: wp1_prec)

  \<comment> \<open>we can now apply the Seq rule with the first IH (in the right shape A) and the second IH\<close>
  show "\<turnstile>\<^sub>1 {wp\<^sub>1 (c1;; c2) Q} c1;; c2 { \<lambda>s. \<down>\<^sub>t (c1;; c2, s) \<Down> Q}"
    apply(rule hoare1.Seq[OF A Seq(2)])
       \<comment> \<open>finally some side conditions have to be proven\<close>
       using Seq(3) x12 x2 wp1_prec_Seq_correct .
next
  case (If b c1 c2)

  show ?case apply(simp)
  apply(rule If2[where e="%s. if bval b s then \<down>\<^sub>t (c1, s) else \<down>\<^sub>t (c2, s)"])
    apply(simp_all  cong:rev_conj_cong)
    apply(rule conseq_old[where Q=Q and Q'=Q])
      prefer 2
      apply(rule If.IH(1)) apply(fact)
      apply(simp_all) apply(auto)[1]
    apply(rule conseq_old[where Q=Q and Q'=Q])
      prefer 2
      apply(rule If.IH(2)) apply(fact)
      apply(simp_all) apply(auto)[1]
      apply (blast intro: If_THE_True wp1_terminates If_THE_False)
     done

next
  case (While b c)

      let ?y = "(new (wp\<^sub>1 (WHILE b DO c) Q))"
    have "finite (support (wp\<^sub>1 (WHILE b DO c) Q))"
      apply(rule finite_subset[OF support_wpt]) apply fact done
    then have "\<exists>x. x \<notin> support (wp\<^sub>1 (WHILE b DO c) Q)" using infinite_UNIV_listI
      using ex_new_if_finite by blast
    hence yQx: "?y \<notin> support (wp\<^sub>1 (WHILE b DO c) Q)" by (rule someI_ex)

  show ?case
  proof (rule conseq_old[OF _  hoare1.While], safe )
    show "\<exists>k>0. \<forall>l s. wp\<^sub>1 (WHILE b DO c) Q l s \<longrightarrow> wp\<^sub>1 (WHILE b DO c) Q l s \<and>  \<down>\<^sub>t (WHILE b DO c, s) \<le> k * \<down>\<^sub>t (WHILE b DO c, s)"
      apply auto done
  next
    fix l s
    assume "wp\<^sub>1 (WHILE b DO c) Q l s" "\<not> bval b s"
    then show "Q l s" by (simp add: wp1While)
  next
    fix l s
    assume "wp\<^sub>1 (WHILE b DO c) Q l s"
    from this[unfolded wp1_def] obtain t s' where t: "(WHILE b DO c, s) \<Rightarrow> t \<Down> s'" and "Q l s'" by blast
    then have r: "\<down>\<^sub>t (WHILE b DO c, s) = t" using Nielson_Hoare.bigstepT_the_cost by auto
    assume "\<not> bval b s"
    with r t have   t2: "t=1" by auto
    from r t2 show "1 \<le> \<down>\<^sub>t (WHILE b DO c, s)" by auto
  next
    fix l s
    assume "wp\<^sub>1 (WHILE b DO c) Q l s"
    from this[unfolded wp1_def] obtain t s'' where t: "(WHILE b DO c, s) \<Rightarrow> t \<Down> s''" "Q l s''" by blast
    then have r: "\<down>\<^sub>t (WHILE b DO c, s) = t" using Nielson_Hoare.bigstepT_the_cost by auto
    assume "bval b s"
    with t obtain t1 t2 s' where 1: "(c,s) \<Rightarrow> t1 \<Down> s'" and 2: "(WHILE b DO c, s') \<Rightarrow> t2 \<Down> s''" and sum: "t=t1+t2+1" and "bval b s" by auto
    from 1 have A: "\<down>\<^sub>t (c,s) = t1" and s': "\<down>\<^sub>s (c,s) = s'" using Nielson_Hoare.bigstepT_the_cost bigstepT_the_state by auto
    from 2 s' have B: "\<down>\<^sub>t (WHILE b DO c, \<down>\<^sub>s(c,s)) = t2" using Nielson_Hoare.bigstepT_the_cost by auto

    show "1 + (%s. \<down>\<^sub>t (WHILE b DO c, \<down>\<^sub>s(c,s))) s  + (%s. \<down>\<^sub>t (c,s)) s \<le> \<down>\<^sub>t (WHILE b DO c, s)"
      apply(simp add: r A B sum) done
  next

    show "\<turnstile>\<^sub>1 {\<lambda>l s. wp\<^sub>1 (WHILE b DO c) Q l s \<and> bval b s \<and> \<down>\<^sub>t (WHILE b DO c, \<down>\<^sub>s (c, s)) = l ?y} c
         { \<lambda>s. \<down>\<^sub>t (c, s) \<Down> \<lambda>l s. wp\<^sub>1 (WHILE b DO c) Q l s \<and> \<down>\<^sub>t (WHILE b DO c, s) \<le> l ?y}"
       apply(rule conseq_old[OF _ While(1), of _ "%l s. wp\<^sub>1 (WHILE b DO c) Q l s \<and> \<down>\<^sub>t (WHILE b DO c, s) = l ?y"])
        apply(rule exI[where x=1]) apply simp
      subgoal apply safe
        apply(subst (asm) wp1While) apply simp
      proof - fix l s
        assume 1: "wp\<^sub>1 c (wp\<^sub>1 (WHILE b DO c) Q) l s"
        assume 2: "\<down>\<^sub>t (WHILE b DO c, \<down>\<^sub>s (c, s)) = l ?y"
        then have "l ?y = prec c (%s. \<down>\<^sub>t (WHILE b DO c, s)) s" unfolding prec_def by auto
        with 1 wp1_prec2[of c "(wp\<^sub>1 (WHILE b DO c) Q)" l s _ "(\<lambda>s. \<down>\<^sub>t (WHILE b DO c, s))"]
          show "wp\<^sub>1 c (\<lambda>l s. wp\<^sub>1 (WHILE b DO c) Q l s \<and>  \<down>\<^sub>t (WHILE b DO c, s) = l ?y) l s" by auto
        qed
        subgoal apply(rule finite_subset[OF support_and]) apply auto
           apply(rule finite_subset[OF support_wpt]) apply fact
             apply(rule finite_subset) apply(rule support_single)  by auto
        apply auto done
    next
      assume "new (wp\<^sub>1 (WHILE b DO c) Q) \<in> support (wp\<^sub>1 (WHILE b DO c) Q)"
      with yQx show "False"
        by blast

    qed
  qed

lemma valid_wp: "\<Turnstile>\<^sub>1 {P}c{p \<Down> Q} \<longleftrightarrow> (\<exists>k>0. (\<forall>l s. P l s \<longrightarrow> (wp\<^sub>1 c Q l s \<and> ((THE n. (\<exists> t. ((c,s) \<Rightarrow> n \<Down> t)))) \<le> k * p s)))"
  apply(rule)
   apply(auto simp: hoare1_valid_def wp1_def)
  subgoal for k apply(rule exI[where x=k]) using bigstepT_the_cost by fast
  subgoal for k apply(rule exI[where x=k]) using bigstepT_the_cost by fast
  done

theorem hoare1_complete: "finite (support Q) \<Longrightarrow> \<Turnstile>\<^sub>1 {P}c{p \<Down> Q} \<Longrightarrow> \<turnstile>\<^sub>1 {P}c{p \<Down> Q}"
  apply(rule conseq_old[OF _ wp1_is_pre, where Q'=Q and Q=Q, simplified])
  by (auto simp: valid_wp)

corollary hoare1_sound_complete: "finite (support Q) \<Longrightarrow> \<turnstile>\<^sub>1 {P}c{p \<Down> Q} \<longleftrightarrow> \<Turnstile>\<^sub>1 {P}c{p \<Down> Q}"
  by (metis hoare1_sound hoare1_complete)

end


theory ConnectionBase
  imports ModelTypes
begin

locale ConnectionBase = opening lifting_syntax +
  fixes Abs :: \<open>('a :: ModelBase) \<Rightarrow> 'b\<close>
    and Rep :: \<open>'b \<Rightarrow> 'a\<close>
  assumes tydef : \<open>type_definition Rep Abs (Set.Collect (\<lambda>x. x : M))\<close>
begin

interpretation c : type_definition \<open>Rep :: 'b \<Rightarrow> 'a\<close> \<open>Abs :: 'a \<Rightarrow> 'b\<close> \<open>(Set.Collect (\<lambda>x. x : M))\<close>
  by (rule tydef)

lemma M_abs_inverse :
  assumes b:"b : M"
  shows "Rep (Abs b) = b"
  using c.Abs_inverse b by auto

lemma M_rep :
  "Rep b : M"
  using c.Rep by auto

lemmas isom [simp] =  M_abs_inverse M_rep c.Rep_inverse

definition ConnectionRelation :: \<open>['a, 'b] \<Rightarrow> bool\<close>  (infix \<open>\<simeq>\<close> 50)
  where "x \<simeq> y \<equiv> x = Rep y"

lemma ceqD1 [dest] : "x \<simeq> y \<Longrightarrow> Abs x = y"
  unfolding ConnectionRelation_def by auto

lemma ceqD2 [dest] : "x \<simeq> y \<Longrightarrow> x = Rep y"
  unfolding ConnectionRelation_def by auto

lemma ceq_rep_refl [simp] : "(Rep x) \<simeq> x"
  unfolding ConnectionRelation_def by auto

lemma ceq_abs_refl [simp] :
  assumes "x : M"
    shows "x \<simeq> (Abs x)"
  unfolding ConnectionRelation_def
  using assms by auto

subsection \<open>Transfer rules for logical constants\<close>

lemma eq_transfer [transfer_rule] :
  "((\<simeq>) ===> (\<simeq>) ===> (\<longleftrightarrow>)) (=) (=)"
  by auto

lemma all_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mall) (All)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mall P \<longleftrightarrow> All Q"
    unfolding mall_def
    using x[OF ceq_rep_refl] x[OF ceq_abs_refl] M_rep
    by blast
qed

lemma ex_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mex) (Ex)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mex P \<longleftrightarrow> Ex Q"
    unfolding mex_def
    using x[OF ceq_rep_refl] x[OF ceq_abs_refl] M_rep
    by blast
qed

lemma ex1_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mex1) (Ex1)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mex1 P \<longleftrightarrow> Ex1 Q"
  proof
    assume P:"mex1 P" show "Ex1 Q"
    proof (insert P, unfold mex1_def tex1_def, erule ex1E, rule ex1I)
      fix x assume
        "x : M \<and> P x" and uniq:"\<forall>y. y : M \<and> P y \<longrightarrow> y = x"
      thus "Q (Abs x)" "\<And>y. Q y \<Longrightarrow> y = (Abs x)"
      proof (metis x[OF ceq_abs_refl])
        fix y assume "Q y"
        hence "(Rep y) = x" using uniq x[OF ceq_rep_refl] by auto
        thus "y = Abs x" using c.Rep_inverse by auto
      qed
    qed
  next
    assume Q:"Ex1 Q" show "mex1 P"
      unfolding mex1_def tex1_def
    proof (rule ex1E[OF Q], rule ex1I)
      fix y assume "Q y" and uniq:"\<forall>z. Q z \<longrightarrow> z = y"
      thus "Rep y : M \<and> P (Rep y)" using M_rep[of y] x[OF ceq_rep_refl, of y] by metis
      fix y' assume y': "y' : M \<and> P y'"
      hence "Abs y' = y" using uniq x[OF ceq_abs_refl, of y'] by auto
      thus "y' = Rep y" using M_abs_inverse y' by auto
    qed
  qed
qed

lemma uniq_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (muniq) (Uniq)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "muniq P \<longleftrightarrow> Uniq Q"
  proof
    assume P:"muniq P" show "Uniq Q"
    proof (rule)
      fix x y assume "Q x" "Q y"
      hence "P (Rep x)" "P (Rep y)" using x[OF ceq_rep_refl] by auto
      hence "Rep x = Rep y" using P
        unfolding muniq_def tuniq_def Uniq_def by auto
      thus "x = y" using c.Rep_inject by auto
     qed
  next
    assume Q:"Uniq Q" show "muniq P"
      unfolding muniq_def tuniq_def
    proof (rule, auto)
      fix x y assume "x : M" "P x" "y : M" "P y"
      hence "Q (Abs x)" "Q (Abs y)" using x[OF ceq_abs_refl] by auto
      hence "Abs x = Abs y" using Q unfolding Uniq_def by auto
      thus "x = y" using c.Abs_inject \<open>x : M\<close> \<open>y : M\<close> by auto
    qed
  qed
qed

lemma unary_pred_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> iff) ===> iff) ===> iff) All All"
proof
  fix U :: "('a \<Rightarrow> bool) \<Rightarrow> bool" and V
  assume "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) U V"
  hence pq:"\<And>P Q. (\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> P a \<longleftrightarrow> Q a') \<Longrightarrow> U P \<longleftrightarrow> V Q"
    unfolding rel_fun_def by auto
  show "All U = All V"
  proof
    assume U:"All U"
    show "All V"
    proof
      fix Q :: "'b \<Rightarrow> bool"
      let ?P = "\<lambda>a. Q (Abs a)"
      have "\<And>a a'. a \<simeq> a' \<Longrightarrow> ?P a \<longleftrightarrow> Q a'" by auto
      hence "U ?P \<longleftrightarrow> V Q" by (rule pq)
      thus "V Q" using U by simp
    qed
  next
    assume V: "All V"
    show "All U"
    proof
      fix P :: "'a \<Rightarrow> bool"
      let ?Q = "\<lambda>a'. P (Rep a')"
      have "\<And>a a'. a \<simeq> a' \<Longrightarrow> P a \<longleftrightarrow> ?Q a'" by auto
      hence "U P \<longleftrightarrow> V ?Q" by (rule pq)
      thus "U P" using V by simp
    qed
  qed
qed

lemma binary_pred_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> (\<simeq>) ===> iff) ===> iff) ===> iff) All All"
proof
  fix U :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" and V
  assume "(((\<simeq>) ===> (\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) U V"
  hence pq:"\<And>P Q. (\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> P a b \<longleftrightarrow> Q a' b') \<Longrightarrow> U P \<longleftrightarrow> V Q"
    unfolding rel_fun_def by auto
  show "All U = All V"
  proof
    assume U:"All U"
    show "All V"
    proof
      fix Q :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
      let ?P = "\<lambda>a b. Q (Abs a) (Abs b)"
      have "\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> ?P a b \<longleftrightarrow> Q a' b'" by auto
      hence "U ?P \<longleftrightarrow> V Q" by (rule pq)
      thus "V Q" using U by simp
    qed
  next
    assume V: "All V"
    show "All U"
    proof
      fix P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
      let ?Q = "\<lambda>a' b'. P (Rep a') (Rep b')"
      have "\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> P a b \<longleftrightarrow> ?Q a' b'" by auto
      hence "U P \<longleftrightarrow> V ?Q" by (rule pq)
      thus "U P" using V by simp
    qed
  qed
qed

lemma binary_fun_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> (\<simeq>) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>))
      (\<lambda>P. \<forall>F : M \<rightarrow> M \<rightarrow> M. P F) (\<lambda>P. \<forall>F. P F)"
proof
  fix P Q assume "(((\<simeq>) ===> (\<simeq>) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) P Q"
  hence FG: "\<And>F G. (\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> F x y = Rep (G x' y')) \<Longrightarrow> P F \<longleftrightarrow> Q G"
    unfolding rel_fun_def by auto
  show "(\<forall>F : M \<rightarrow> M \<rightarrow> M. P F) \<longleftrightarrow> (\<forall>F. Q F)"
  proof (rule)
    assume P:"\<forall>F : M \<rightarrow> M \<rightarrow> M. P F"
    show "\<forall>G. Q G"
    proof
      fix G
      let ?F = "\<lambda>x y. Rep (G (Abs x) (Abs y))"
      have F_typ:"?F : M \<rightarrow> M \<rightarrow> M" by (rule funI, rule funI, auto)
      have "\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> ?F x y = Rep (G x' y')" by (auto)
      hence "P ?F \<longleftrightarrow> Q G" using FG by auto
      thus "Q G" using P F_typ by auto
    qed
  next
    assume Q:"All Q"
    show "\<forall>F : M \<rightarrow> M \<rightarrow> M. P F"
    proof (rule)
      fix F :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
      assume F_typ:"F : M \<rightarrow> M \<rightarrow> M"
      let ?G = "\<lambda>x y. Abs (F (Rep x) (Rep y))"
      have "\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> F x y = Rep (?G x' y')"
        using funE[OF funE[OF F_typ]] by auto
      hence "P F \<longleftrightarrow> Q ?G" using FG by auto
      thus "P F" using Q by auto
    qed
  qed
qed

(* text \<open>Generating locales for connections of model components\<close>
local_setup \<open>snd o mk_connection_locale @{theory} set_model\<close>
local_setup \<open>snd o mk_connection_locale @{theory} ord_model\<close>
local_setup \<open>snd o mk_connection_locale @{theory} ordrec_model\<close>
local_setup \<open>snd o mk_connection_locale @{theory} pair_model\<close>
local_setup \<open>snd o mk_connection_locale @{theory} nat_model\<close>
 *)
end
end


(* Note: Same as AxiomaticCategoryTheory except that full free logic is employed here (i.e.
with * and definite description) and that the model consisting of only one existing object that
was previously constructed by nitpick for the axiom system FS-I (resp. FS-II) by Freyd Scedrov can
obviously no longer be obtained. This is because * has now been axiomatized as a
distinguished non-existing  object; therefore lines 293-296 (resp. 337-340) have been
commented. *)

theory AxiomaticCategoryTheory_FullFreeLogic imports Main
begin
typedecl i  (*Type for individuals*)
consts fExistence:: "i\<Rightarrow>bool" ("E") (*Existence/definedness predicate in free logic*)
consts fStar:: "i" ("\<^bold>\<star>")   (*Distinguished symbol for undefinedness*)
axiomatization where fStarAxiom: "\<not>E(\<^bold>\<star>)" (*\<star> is a ``non-existing'' object in D.*)

abbreviation fNot ("\<^bold>\<not>") (*Free negation*)
 where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
abbreviation fImplies (infixr "\<^bold>\<rightarrow>" 13) (*Free implication*)
 where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<phi> \<longrightarrow> \<psi>"
abbreviation fIdentity (infixr "\<^bold>=" 13) (*Free identity*)
 where "l \<^bold>= r \<equiv> l = r"
abbreviation fForall ("\<^bold>\<forall>") (*Free universal quantification guarded by @{text "E"}*)
 where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
abbreviation fForallBinder (binder "\<^bold>\<forall>" [8] 9) (*Binder notation*)
 where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"
abbreviation fThat:: "(i\<Rightarrow>bool)\<Rightarrow>i" ("\<^bold>I")
 where "\<^bold>I\<Phi> \<equiv> if \<exists>x. E(x) \<and> \<Phi>(x) \<and> (\<forall>y. (E(y) \<and> \<Phi>(y)) \<longrightarrow> (y = x))
              then THE x. E(x) \<and> \<Phi>(x)
              else \<^bold>\<star>"
abbreviation fThatBinder:: "(i\<Rightarrow>bool)\<Rightarrow>i"  (binder "\<^bold>I" [8] 9)
 where "\<^bold>Ix. \<phi>(x) \<equiv> \<^bold>I(\<phi>)"

text \<open> Further free logic connectives can now be defined as usual. \<close>

abbreviation fOr (infixr "\<^bold>\<or>" 11)
 where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<psi>"
abbreviation fAnd (infixr "\<^bold>\<and>" 12)
 where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
abbreviation fImplied (infixr "\<^bold>\<leftarrow>" 13)
 where "\<phi> \<^bold>\<leftarrow> \<psi> \<equiv> \<psi> \<^bold>\<rightarrow> \<phi>"
abbreviation fEquiv (infixr "\<^bold>\<leftrightarrow>" 15)
 where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"
abbreviation fExists ("\<^bold>\<exists>")
 where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
abbreviation fExistsBinder (binder "\<^bold>\<exists>" [8]9)
 where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"

declare [[smt_solver = cvc4,smt_oracle]]

section \<open> Preliminaries \<close>

consts
 domain:: "i\<Rightarrow>i" ("dom _" [108] 109)
 codomain:: "i\<Rightarrow>i" ("cod _" [110] 111)
 composition:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<cdot>" 110)

abbreviation KlEq (infixr "\<cong>" 56) (* Kleene equality *)
 where "x \<cong> y \<equiv> (E x \<^bold>\<or> E y) \<^bold>\<rightarrow> x \<^bold>= y"

abbreviation ExId (infixr "\<simeq>" 56) (* Existing identity *)
 where "x \<simeq> y \<equiv> E x \<^bold>\<and> E y \<^bold>\<and> x \<^bold>= y"

lemma "x \<cong> x \<^bold>\<and> (x \<cong> y \<^bold>\<rightarrow> y \<cong> x) \<^bold>\<and> ((x \<cong> y \<^bold>\<and> y \<cong> z) \<^bold>\<rightarrow> x \<cong> z)" by blast
lemma "x \<simeq> x" nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
lemma " (x \<simeq> y \<^bold>\<rightarrow> y \<simeq> x) \<^bold>\<and> ((x \<simeq> y \<^bold>\<and> y \<simeq> z) \<^bold>\<rightarrow> x \<simeq> z)" by blast
lemma "x \<simeq> y \<^bold>\<rightarrow> x \<cong> y" by simp
lemma "x \<simeq> y \<^bold>\<leftarrow> x \<cong> y" nitpick [user_axioms, show_all, format = 2, expect = genuine] oops

abbreviation I where "I i \<equiv> (\<^bold>\<forall>x. E(i\<cdot>x) \<^bold>\<rightarrow> i\<cdot>x \<cong> x) \<^bold>\<and> (\<^bold>\<forall>x. E(x\<cdot>i) \<^bold>\<rightarrow> x\<cdot>i \<cong> x)"

section \<open> Axioms Set I \<close>

locale Axioms_Set_I =
assumes
 S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
 E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
 A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y" and
 D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i C\<^sub>i S\<^sub>i)
  lemma UC\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y \<^bold>\<and> (\<^bold>\<forall>j.(I j \<^bold>\<and> j\<cdot>y \<cong> y) \<^bold>\<rightarrow> i \<cong> j)"
    by (smt A\<^sub>i C\<^sub>i S\<^sub>i)
  lemma UD\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x \<^bold>\<and> (\<^bold>\<forall>i.(I i \<^bold>\<and> x\<cdot>i \<cong> x) \<^bold>\<rightarrow> j \<cong> i)"
    by (smt A\<^sub>i D\<^sub>i S\<^sub>i)
 lemma "(\<exists>C D. (\<^bold>\<forall>y. I (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. I (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
 lemma "(\<exists>x. E x) \<^bold>\<and> (\<exists>C D. (\<^bold>\<forall>y. I (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. I (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

section \<open> Axioms Set II \<close>

locale Axioms_Set_II =
assumes
 S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
 A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
 D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>i\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i\<^sub>i C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)

context Axioms_Set_II
begin
  lemma S\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"
    using S\<^sub>i\<^sub>i by blast
  lemma E\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    using E\<^sub>i\<^sub>i by blast
  lemma A\<^sub>iFromII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i by blast
  lemma C\<^sub>iFromII: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y"
    by (metis C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
  lemma D\<^sub>iFromII: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x"
    by (metis D\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
end

section \<open> Axioms Set III \<close>

locale Axioms_Set_III =
assumes
 S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
 A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
 D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
begin
  lemma True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>i\<^sub>i\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"
    by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
end

context Axioms_Set_III
begin
  lemma S\<^sub>i\<^sub>iFromIII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>iFromIII: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>iFromIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>iFromIII: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    using C\<^sub>i\<^sub>i\<^sub>i by auto
  lemma D\<^sub>i\<^sub>iFromIII: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    using D\<^sub>i\<^sub>i\<^sub>i by auto
end

context Axioms_Set_II
begin
  lemma S\<^sub>i\<^sub>i\<^sub>iFromII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>i\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))"
    by (metis C\<^sub>i\<^sub>i D\<^sub>i\<^sub>i E\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>i\<^sub>iFromII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>i\<^sub>iFromII: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    using C\<^sub>i\<^sub>i by auto
  lemma D\<^sub>i\<^sub>i\<^sub>iFromII: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    using D\<^sub>i\<^sub>i by auto
end

section \<open> Axioms Set IV \<close>

locale Axioms_Set_IV =
assumes
 S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
 A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" and
 D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_IV
begin
  lemma S\<^sub>i\<^sub>i\<^sub>iFromIV: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>v by blast
  lemma E\<^sub>i\<^sub>i\<^sub>iFromIV: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))"
    using E\<^sub>i\<^sub>v by blast
  lemma A\<^sub>i\<^sub>i\<^sub>iFromIV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>v by blast
  lemma C\<^sub>i\<^sub>i\<^sub>iFromIV: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
  lemma D\<^sub>i\<^sub>i\<^sub>iFromIV: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
end

context Axioms_Set_III
begin
  lemma S\<^sub>i\<^sub>vFromIII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>vFromIII: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"
    by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>vFromIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>vFromIII: "(cod y)\<cdot>y \<cong> y"
    using C\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma D\<^sub>i\<^sub>vFromIII: "x\<cdot>(dom x) \<cong> x"
    using D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
end

section \<open> Axioms Set V \<close>

locale Axioms_Set_V =
assumes
 S1: "E(dom x) \<^bold>\<rightarrow> E x" and
 S2: "E(cod y) \<^bold>\<rightarrow> E y" and
 S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 S5: "x\<cdot>(dom x) \<cong> x" and
 S6: "(cod y)\<cdot>y \<cong> y"
begin  (*The obligatory consistency checks*)
  lemma True
     nitpick [satisfy, user_axioms, expect=genuine] oops (*model found*)
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, expect=genuine] oops (*model found*)
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms,  expect=genuine] oops (*model found*)
end

context Axioms_Set_V   (*Axioms Set IV is implied by Axioms Set V*)
begin
  lemma S\<^sub>i\<^sub>vFromV: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S1 S2 S3 by blast
  lemma E\<^sub>i\<^sub>vFromV: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"  using S3 by metis
  lemma A\<^sub>i\<^sub>vFromV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"  using S4 by blast
  lemma C\<^sub>i\<^sub>vFromV: "(cod y)\<cdot>y \<cong> y"  using S6 by blast
  lemma D\<^sub>i\<^sub>vFromV: "x\<cdot>(dom x) \<cong> x"  using S5 by blast
end

context Axioms_Set_IV  (*Axioms Set V is implied by Axioms Set IV*)
begin
  lemma S1FromIV:  "E(dom x) \<^bold>\<rightarrow> E x"  using S\<^sub>i\<^sub>v by blast
  lemma S2FromIV:  "E(cod y) \<^bold>\<rightarrow> E y"  using S\<^sub>i\<^sub>v by blast
  lemma S3FromIV:  "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"  using E\<^sub>i\<^sub>v by metis
  lemma S4FromIV:  "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"  using A\<^sub>i\<^sub>v by blast
  lemma S5FromIV:  "x\<cdot>(dom x) \<cong> x"  using D\<^sub>i\<^sub>v by blast
  lemma S6FromIV:  "(cod y)\<cdot>y \<cong> y"  using C\<^sub>i\<^sub>v by blast
end

section \<open> Axioms Set FS-I \<close>

consts
   source:: "i\<Rightarrow>i" ("\<box>_" [108] 109)
   target:: "i\<Rightarrow>i" ("_\<box>" [110] 111)
   compositionF:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<^bold>\<cdot>" 110)

locale Axioms_Set_FS_I =
assumes
  A1: "E(x\<^bold>\<cdot>y) \<^bold>\<leftrightarrow> (x\<box> \<cong> \<box>y)" and
 A2a: "((\<box>x)\<box>) \<cong> \<box>x" and
 A2b: "\<box>(x\<box>) \<cong> \<box>x" and
 A3a: "(\<box>x)\<^bold>\<cdot>x \<cong> x" and
 A3b: "x\<^bold>\<cdot>(x\<box>) \<cong> x" and
 A4a: "\<box>(x\<^bold>\<cdot>y) \<cong> \<box>(x\<^bold>\<cdot>(\<box>y))" and
 A4b: "(x\<^bold>\<cdot>y)\<box> \<cong> ((x\<box>)\<^bold>\<cdot>y)\<box>" and
  A5: "x\<^bold>\<cdot>(y\<^bold>\<cdot>z) \<cong> (x\<^bold>\<cdot>y)\<^bold>\<cdot>z"
begin
(* Commented (see explanation in header of file)
  lemma True
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
*)
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = none] oops
  lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False"
    by (metis A1 A2a A3a)
  lemma InconsistencyInteractive: assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
      (* Let @{text "a"} be an undefined object *)
     obtain a where 1: "\<^bold>\<not>(E a)" using assms by auto
      (* We instantiate axiom @{text "A3a"} with @{text "a"}. *)
     have 2: "(\<box>a)\<^bold>\<cdot>a \<cong> a" using A3a by blast
      (* By unfolding the definition of @{text "\<cong>"} we get from 1 that @{text "(\<box>a)\<^bold>\<cdot>a"} is
           not defined. This is
           easy to see, since if @{text "(\<box>a)\<^bold>\<cdot>a"} were defined, we also had that  @{text "a"} is
           defined, which is not the case by assumption. *)
     have 3: "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))" using 1 2 by metis
      (* We instantiate axiom @{text "A1"} with @{text "\<box>a"} and @{text "a"}. *)
     have 4: "E((\<box>a)\<^bold>\<cdot>a) \<^bold>\<leftrightarrow> (\<box>a)\<box> \<cong> \<box>a" using A1 by blast
      (* We instantiate axiom @{text "A2a"} with @{text "a"}. *)
     have 5: "(\<box>a)\<box> \<cong> \<box>a" using A2a by blast
      (* From 4 and 5 we obtain @{text "\<^bold>(E((\<box>a)\<^bold>\<cdot>a))"} by propositional logic. *)
     have 6: "E((\<box>a)\<^bold>\<cdot>a)" using 4 5 by blast
      (* We have @{text "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))"} and @{text "E((\<box>a)\<^bold>\<cdot>a)"}, hence Falsity. *)
     then show ?thesis using 6 3 by blast
    qed
end

section \<open> Axioms Set FS-II \<close>

locale Axioms_Set_FS_II =
assumes
  A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 A2a: "cod(dom x) \<cong> dom x " and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
(* Commented (see explanation in header of file)
  lemma True
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
*)
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = none] oops
  lemma InconsistencyAutomaticVII: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False"
    by (metis A1 A2a A3a)
  lemma "\<forall>x. E x"
    using InconsistencyAutomaticVII by auto
  lemma InconsistencyInteractiveVII:
    assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
      (* Let @{text "a"} be an undefined object *)
     obtain a where 1: "\<^bold>\<not>(E a)" using NEx by auto
      (* We instantiate axiom @{text "A3a"} with @{text "a"}. *)
     have 2: "a\<cdot>(dom a) \<cong> a" using A3a by blast
      (* By unfolding the definition of @{text "\<cong>"} we get from 1 that
          @{text "a\<cdot>(dom a)"} is not defined. This is
          easy to see, since if @{text "a\<cdot>(dom a)"} were defined, we also had that @{text "a"} is
          defined, which is not the case by assumption.*)
     have 3: "\<^bold>\<not>(E(a\<cdot>(dom a)))" using 1 2 by metis
      (* We instantiate axiom @{text "A1"} with @{text "a"} and @{text "dom a"}. *)
     have 4: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> cod(dom a)" using A1 by blast
      (* We instantiate axiom @{text "A2a"} with @{text "a"}. *)
     have 5: "cod(dom a) \<cong> dom a" using A2a by blast
      (* We use 5 (and symmetry and transitivity of @{text "\<cong>"}) to rewrite the
           right-hand of the equivalence 4 into @{text "dom a \<cong> dom a"}. *)
     have 6: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> dom a" using 4 5 by auto
      (* By reflexivity of @{text "\<cong>"} we get that @{text "a\<cdot>(dom a)"} must be defined. *)
     have 7: "E(a\<cdot>(dom a))" using 6 by blast
      (* We have shown in 7 that @{text "a\<cdot>(dom a)"} is defined, and in 3
           that it is undefined. Contradiction. *)
     then show ?thesis using 7 3 by blast
   qed
end

section \<open> Axioms Set VI \<close>

locale Axioms_Set_VI =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A2a: "cod(dom x) \<cong> dom x" and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma A4aRedundant: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)"
    using A1' A2a A3a A5 by metis
  lemma A4bRedundant: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))"
    using A1' A2b A3b A5 by smt
  lemma A2aRedundant: "cod(dom x) \<cong> dom x"
    using A1' A3a A3b A4a A4b by smt
  lemma A2bRedundant: "dom(cod y) \<cong> cod y"
    using A1' A3a A3b A4a A4b by smt
end

context Axioms_Set_VI
begin
  lemma S1FromVI: "E(dom x) \<^bold>\<rightarrow> E x"
    by (metis A1' A2a A3a)
  lemma S2FromVI: "E(cod y) \<^bold>\<rightarrow> E y"
    using A1' A2b A3b by metis
  lemma S3FromVI: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI: "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI: "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

context Axioms_Set_V
begin
  lemma A1'FromV: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    using S3 by blast
  lemma A2aFromV: "cod(dom x) \<cong> dom x"
    by (metis S1 S2 S3 S5)
  lemma A2bFromV: "dom(cod y) \<cong> cod y"
    using S1 S2 S3 S6 by metis
  lemma A3aFromV: "x\<cdot>(dom x) \<cong> x"
    using S5 by blast
  lemma A3bFromV: "(cod y)\<cdot>y \<cong> y"
    using S6 by blast
  lemma A4aFromV: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)"
    by (metis S1 S3 S4 S5 S6)
  lemma A4bFromV: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))"
    by (metis S2 S3 S4 S5 S6)
  lemma  A5FromV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using S4 by blast
end

section \<open> Axioms Set VI reduced a \<close>

locale Axioms_Set_VI_reduced_a =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_a
begin
  lemma S1FromVI: "E(dom x) \<^bold>\<rightarrow> E x"
    using A1' A3a A4a by smt
  lemma S2FromVI: "E(cod y) \<^bold>\<rightarrow> E y"
    by (smt A1' A3b A4b)
  lemma S3FromVI: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI: "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI: "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

section \<open> Axioms Set VI reduced b \<close>

locale Axioms_Set_VI_reduced_b =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A2a: "cod(dom x) \<cong> dom x" and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_b
begin
  lemma S1FromVI_new': "E(dom x) \<^bold>\<rightarrow> E x"
    by (metis A1' A2a A3a)
  lemma S2FromVI_new': "E(cod y) \<^bold>\<rightarrow> E y"
    using A1' A2b A3b by smt
  lemma S3FromVI_new': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI_new': "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI_new': "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI_new': "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

section \<open> Axioms Set VI reduced c \<close>

locale Axioms_Set_VI_reduced_c =
assumes
 S1\<^sub>v: "E(dom x) \<^bold>\<rightarrow> E x" and
 S2\<^sub>v: "E(cod y) \<^bold>\<rightarrow> E y" and
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_c
begin
  lemma S1FromVI_new'': "E(dom x) \<^bold>\<rightarrow> E x"
    using S1\<^sub>v by blast
  lemma S2FromVI_new'': "E(cod y) \<^bold>\<rightarrow> E y"
    using S2\<^sub>v by blast
  lemma S3FromVI_new'': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI_new'': "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI_new'': "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI_new'': "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

section \<open> Axioms Set FS-III \<close>

locale Axioms_Set_FS_III =
  assumes
  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
 B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
 B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
 B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
 B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_FS_III
begin
  lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S5: "x\<cdot>(dom x) \<cong> x"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S6: "(cod y)\<cdot>y \<cong> y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
end

section \<open> Axioms Set FS-IV \<close>

locale Axioms_Set_FS_IV =
assumes
 B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
 B0b: "E(dom x) \<^bold>\<rightarrow> E x" and
 B0c: "E(cod x) \<^bold>\<rightarrow> E x" and
  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
 B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
 B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
 B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
 B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_FS_IV
begin
  lemma S1FromVIII: "E(dom x) \<^bold>\<rightarrow> E x"  using B0b by blast
  lemma S2FromVIII: "E(cod y) \<^bold>\<rightarrow> E y"  using B0c by blast
  lemma S3FromVIII: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis B0a B0b B0c B1 B3a)
  lemma S4FromVIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (meson B0a B5)
  lemma S5FromVIII: "x\<cdot>(dom x) \<cong> x" using B0a B3a by blast
  lemma S6FromVIII: "(cod y)\<cdot>y \<cong> y" using B0a B3b by blast
end

context Axioms_Set_V
begin
  lemma B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S1 S2 S3 by blast
  lemma B0b: "E(dom x) \<^bold>\<rightarrow> E x" using S1 by blast
  lemma B0c: "E(cod x) \<^bold>\<rightarrow> E x" using S2 by blast
  lemma  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" by (metis S3 S5)
  lemma B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis S3 S5)
  lemma B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis S3 S6)
  lemma B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" using S5 by auto
  lemma B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" using S6 by blast
  lemma B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis S1 S3 S4 S5)
  lemma B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis S2 S3 S4 S6)
  lemma  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
end

context Axioms_Set_FS_IV
begin
  lemma B2aRedundant: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis B0a B1 B3a)
  lemma B2bRedundant: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis B0a B1 B3b)
  lemma B4aRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis B0a B0b B1 B3a B5)
  lemma B4bRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis B0a B0c B1 B3b B5)
end

end


section \<open>A simple example demonstrating parallelism for code generated towards Isabelle/ML\<close>

theory Parallel_Example
imports Complex_Main "HOL-Library.Parallel" "HOL-Library.Debug"
begin

subsection \<open>Compute-intensive examples.\<close>

subsubsection \<open>Fragments of the harmonic series\<close>

definition harmonic :: "nat \<Rightarrow> rat" where
  "harmonic n = sum_list (map (\<lambda>n. 1 / of_nat n) [1..<n])"

subsubsection \<open>The sieve of Erathostenes\<close>

text \<open>
  The attentive reader may relate this ad-hoc implementation to the
  arithmetic notion of prime numbers as a little exercise.
\<close>

primrec mark :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "mark _ _ [] = []"
| "mark m n (p # ps) = (case n of 0 \<Rightarrow> False # mark m m ps
    | Suc n \<Rightarrow> p # mark m n ps)"

lemma length_mark [simp]:
  "length (mark m n ps) = length ps"
  by (induct ps arbitrary: n) (simp_all split: nat.split)

function sieve :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "sieve m ps = (case dropWhile Not ps
   of [] \<Rightarrow> ps
    | p#ps' \<Rightarrow> let n = m - length ps' in takeWhile Not ps @ p # sieve m (mark n n ps'))"
by pat_completeness auto

termination \<comment> \<open>tuning of this proof is left as an exercise to the reader\<close>
  apply (relation "measure (length \<circ> snd)")
  apply rule
  apply (auto simp add: length_dropWhile_le)
proof -
  fix ps qs q
  assume "dropWhile Not ps = q # qs"
  then have "length qs < length (dropWhile Not ps)"
    by simp
  also have "length (dropWhile Not ps) \<le> length ps"
    by (simp add: length_dropWhile_le)
  finally show "length qs < length ps" .
qed

primrec natify :: "nat \<Rightarrow> bool list \<Rightarrow> nat list" where
  "natify _ [] = []"
| "natify n (p#ps) = (if p then n # natify (Suc n) ps else natify (Suc n) ps)"

primrec list_primes where
  "list_primes (Suc n) = natify 1 (sieve n (False # replicate n True))"

subsubsection \<open>Naive factorisation\<close>

function factorise_from :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "factorise_from k n = (if 1 < k \<and> k \<le> n
    then
      let (q, r) = Euclidean_Rings.divmod_nat n k
      in if r = 0 then k # factorise_from k q
        else factorise_from (Suc k) n
    else [])"
by pat_completeness auto

termination factorise_from \<comment> \<open>tuning of this proof is left as an exercise to the reader\<close>
  apply (relation "measure (\<lambda>(k, n). 2 * n - k)")
  apply (auto simp add: Euclidean_Rings.divmod_nat_def algebra_simps elim!: dvdE)
  subgoal for m n
    apply (cases "m \<le> n * 2")
     apply (auto intro: diff_less_mono)
    done
  done

definition factorise :: "nat \<Rightarrow> nat list" where
  "factorise n = factorise_from 2 n"

subsection \<open>Concurrent computation via futures\<close>

definition computation_harmonic :: "unit \<Rightarrow> rat" where
  "computation_harmonic _ = Debug.timing (STR ''harmonic example'') harmonic 300"

definition computation_primes :: "unit \<Rightarrow> nat list" where
  "computation_primes _ = Debug.timing (STR ''primes example'') list_primes 4000"

definition computation_future :: "unit \<Rightarrow> nat list \<times> rat" where
  "computation_future = Debug.timing (STR ''overall computation'')
   (\<lambda>() \<Rightarrow> let c = Parallel.fork computation_harmonic
     in (computation_primes (), Parallel.join c))"

value "computation_future ()"

definition computation_factorise :: "nat \<Rightarrow> nat list" where
  "computation_factorise = Debug.timing (STR ''factorise'') factorise"

definition computation_parallel :: "unit \<Rightarrow> nat list list" where
  "computation_parallel _ = Debug.timing (STR ''overall computation'')
     (Parallel.map computation_factorise) [20000..<20100]"

value "computation_parallel ()"

end


(*  Title:      HOL/Library/Numeral_Type.thy
    Author:     Brian Huffman
*)

section \<open>Numeral Syntax for Types\<close>

theory Numeral_Type
imports Cardinality
begin

subsection \<open>Numeral Types\<close>

typedef num0 = "UNIV :: nat set" ..
typedef num1 = "UNIV :: unit set" ..

typedef 'a bit0 = "{0 ..< 2 * int CARD('a::finite)}"
proof
  show "0 \<in> {0 ..< 2 * int CARD('a)}"
    by simp
qed

typedef 'a bit1 = "{0 ..< 1 + 2 * int CARD('a::finite)}"
proof
  show "0 \<in> {0 ..< 1 + 2 * int CARD('a)}"
    by simp
qed

lemma card_num0 [simp]: "CARD (num0) = 0"
  unfolding type_definition.card [OF type_definition_num0]
  by simp

lemma infinite_num0: "\<not> finite (UNIV :: num0 set)"
  using card_num0[unfolded card_eq_0_iff]
  by simp

lemma card_num1 [simp]: "CARD(num1) = 1"
  unfolding type_definition.card [OF type_definition_num1]
  by (simp only: card_UNIV_unit)

lemma card_bit0 [simp]: "CARD('a bit0) = 2 * CARD('a::finite)"
  unfolding type_definition.card [OF type_definition_bit0]
  by simp

lemma card_bit1 [simp]: "CARD('a bit1) = Suc (2 * CARD('a::finite))"
  unfolding type_definition.card [OF type_definition_bit1]
  by simp

subsection \<open>@{typ num1}\<close>

instance num1 :: finite
proof
  show "finite (UNIV::num1 set)"
    unfolding type_definition.univ [OF type_definition_num1]
    using finite by (rule finite_imageI)
qed

instantiation num1 :: CARD_1
begin

instance
proof
  show "CARD(num1) = 1" by auto
qed

end

lemma num1_eq_iff: "(x::num1) = (y::num1) \<longleftrightarrow> True"
  by (induct x, induct y) simp

instantiation num1 :: "{comm_ring,comm_monoid_mult,numeral}"
begin

instance
  by standard (simp_all add: num1_eq_iff)

end

lemma num1_eqI:
  fixes a::num1 shows "a = b"
by(simp add: num1_eq_iff)

lemma num1_eq1 [simp]:
  fixes a::num1 shows "a = 1"
  by (rule num1_eqI)

lemma forall_1[simp]: "(\<forall>i::num1. P i) \<longleftrightarrow> P 1"
  by (metis (full_types) num1_eq_iff)

lemma ex_1[simp]: "(\<exists>x::num1. P x) \<longleftrightarrow> P 1"
  by auto (metis (full_types) num1_eq_iff)

instantiation num1 :: linorder begin
definition "a < b \<longleftrightarrow> Rep_num1 a < Rep_num1 b"
definition "a \<le> b \<longleftrightarrow> Rep_num1 a \<le> Rep_num1 b"
instance
  by intro_classes (auto simp: less_eq_num1_def less_num1_def intro: num1_eqI)
end

instance num1 :: wellorder
  by intro_classes (auto simp: less_eq_num1_def less_num1_def)

instance bit0 :: (finite) card2
proof
  show "finite (UNIV::'a bit0 set)"
    unfolding type_definition.univ [OF type_definition_bit0]
    by simp
  show "2 \<le> CARD('a bit0)"
    by simp
qed

instance bit1 :: (finite) card2
proof
  show "finite (UNIV::'a bit1 set)"
    unfolding type_definition.univ [OF type_definition_bit1]
    by simp
  show "2 \<le> CARD('a bit1)"
    by simp
qed

subsection \<open>Locales for for modular arithmetic subtypes\<close>

locale mod_type =
  fixes n :: int
  and Rep :: "'a::{zero,one,plus,times,uminus,minus} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus}"
  assumes type: "type_definition Rep Abs {0..<n}"
  and size1: "1 < n"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod n)"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod n)"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod n)"
  and minus_def: "- x = Abs ((- Rep x) mod n)"
begin

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < n"
by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> n"
by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<n} \<Longrightarrow> Rep (Abs m) = m"
by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod n)) = m mod n"
  using size0 by (simp add: Abs_inverse)

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
by (simp add: Abs_inverse size0)

lemma Rep_0: "Rep 0 = 0"
by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
by (simp add: Abs_inverse size1)

lemma Rep_1: "Rep 1 = 1"
by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod n = Rep x"
apply (rule_tac x=x in type_definition.Abs_cases [OF type])
apply (simp add: type_definition.Abs_inverse [OF type])
done

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

lemma comm_ring_1: "OFCLASS('a, comm_ring_1_class)"
apply (intro_classes, unfold definitions)
apply (simp_all add: Rep_simps mod_simps field_simps)
done

end

locale mod_ring = mod_type n Rep Abs
  for n :: int
  and Rep :: "'a::{comm_ring_1} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{comm_ring_1}"
begin

lemma of_nat_eq: "of_nat k = Abs (int k mod n)"
apply (induct k)
apply (simp add: zero_def)
apply (simp add: Rep_simps add_def one_def mod_simps ac_simps)
done

lemma of_int_eq: "of_int z = Abs (z mod n)"
apply (cases z rule: int_diff_cases)
apply (simp add: Rep_simps of_nat_eq diff_def mod_simps)
done

lemma Rep_numeral:
  "Rep (numeral w) = numeral w mod n"
using of_int_eq [of "numeral w"]
by (simp add: Rep_inject_sym Rep_Abs_mod)

lemma iszero_numeral:
  "iszero (numeral w::'a) \<longleftrightarrow> numeral w mod n = 0"
by (simp add: Rep_inject_sym Rep_numeral Rep_0 iszero_def)

lemma cases:
  assumes 1: "\<And>z. \<lbrakk>(x::'a) = of_int z; 0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P"
  shows "P"
apply (cases x rule: type_definition.Abs_cases [OF type])
apply (rule_tac z="y" in 1)
apply (simp_all add: of_int_eq)
done

lemma induct:
  "(\<And>z. \<lbrakk>0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P (of_int z)) \<Longrightarrow> P (x::'a)"
by (cases x rule: cases) simp

lemma UNIV_eq: "(UNIV :: 'a set) = Abs ` {0..<n}"
  using type type_definition.univ by blast

lemma CARD_eq: "CARD('a) = nat n"
proof -
  have "CARD('a) = card (Abs ` {0..<n})"
    by (simp add: UNIV_eq)
  also have "inj_on Abs {0..<n}"
    by (metis Abs_inverse inj_onI)
  hence "card (Abs ` {0..<n}) = nat n"
    using size1 by (subst card_image) auto
  finally show ?thesis .
qed

lemma CHAR_eq [simp]: "CHAR('a) = CARD('a)"
proof (rule CHAR_eqI)
  show "of_nat (CARD('a)) = (0 :: 'a)"
    by (simp add: CARD_eq of_nat_eq zero_def)
next
  fix n assume "of_nat n = (0 :: 'a)"
  thus "CARD('a) dvd n"
    by (metis CARD_eq Rep_0 Rep_Abs_mod Rep_le_n mod_0_imp_dvd nat_dvd_iff of_nat_eq)
qed

end

subsection \<open>Ring class instances\<close>

text \<open>
  Unfortunately \<open>ring_1\<close> instance is not possible for
  \<^typ>\<open>num1\<close>, since 0 and 1 are not distinct.
\<close>

instantiation
  bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus}"
begin

definition Abs_bit0' :: "int \<Rightarrow> 'a bit0" where
  "Abs_bit0' x = Abs_bit0 (x mod int CARD('a bit0))"

definition Abs_bit1' :: "int \<Rightarrow> 'a bit1" where
  "Abs_bit1' x = Abs_bit1 (x mod int CARD('a bit1))"

definition "0 = Abs_bit0 0"
definition "1 = Abs_bit0 1"
definition "x + y = Abs_bit0' (Rep_bit0 x + Rep_bit0 y)"
definition "x * y = Abs_bit0' (Rep_bit0 x * Rep_bit0 y)"
definition "x - y = Abs_bit0' (Rep_bit0 x - Rep_bit0 y)"
definition "- x = Abs_bit0' (- Rep_bit0 x)"

definition "0 = Abs_bit1 0"
definition "1 = Abs_bit1 1"
definition "x + y = Abs_bit1' (Rep_bit1 x + Rep_bit1 y)"
definition "x * y = Abs_bit1' (Rep_bit1 x * Rep_bit1 y)"
definition "x - y = Abs_bit1' (Rep_bit1 x - Rep_bit1 y)"
definition "- x = Abs_bit1' (- Rep_bit1 x)"

instance ..

end

interpretation bit0:
  mod_type "int CARD('a::finite bit0)"
           "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
           "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
apply (rule mod_type.intro)
apply (simp add: type_definition_bit0)
apply (rule one_less_int_card)
apply (rule zero_bit0_def)
apply (rule one_bit0_def)
apply (rule plus_bit0_def [unfolded Abs_bit0'_def])
apply (rule times_bit0_def [unfolded Abs_bit0'_def])
apply (rule minus_bit0_def [unfolded Abs_bit0'_def])
apply (rule uminus_bit0_def [unfolded Abs_bit0'_def])
done

interpretation bit1:
  mod_type "int CARD('a::finite bit1)"
           "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
           "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
apply (rule mod_type.intro)
apply (simp add: type_definition_bit1)
apply (rule one_less_int_card)
apply (rule zero_bit1_def)
apply (rule one_bit1_def)
apply (rule plus_bit1_def [unfolded Abs_bit1'_def])
apply (rule times_bit1_def [unfolded Abs_bit1'_def])
apply (rule minus_bit1_def [unfolded Abs_bit1'_def])
apply (rule uminus_bit1_def [unfolded Abs_bit1'_def])
done

instance bit0 :: (finite) comm_ring_1
  by (rule bit0.comm_ring_1)

instance bit1 :: (finite) comm_ring_1
  by (rule bit1.comm_ring_1)

interpretation bit0:
  mod_ring "int CARD('a::finite bit0)"
           "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
           "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
  ..

interpretation bit1:
  mod_ring "int CARD('a::finite bit1)"
           "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
           "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
  ..

text \<open>Set up cases, induction, and arithmetic\<close>

lemmas bit0_cases [case_names of_int, cases type: bit0] = bit0.cases
lemmas bit1_cases [case_names of_int, cases type: bit1] = bit1.cases

lemmas bit0_induct [case_names of_int, induct type: bit0] = bit0.induct
lemmas bit1_induct [case_names of_int, induct type: bit1] = bit1.induct

lemmas bit0_iszero_numeral [simp] = bit0.iszero_numeral
lemmas bit1_iszero_numeral [simp] = bit1.iszero_numeral

lemmas [simp] = eq_numeral_iff_iszero [where 'a="'a bit0"] for dummy :: "'a::finite"
lemmas [simp] = eq_numeral_iff_iszero [where 'a="'a bit1"] for dummy :: "'a::finite"

subsection \<open>Order instances\<close>

instantiation bit0 and bit1 :: (finite) linorder begin
definition "a < b \<longleftrightarrow> Rep_bit0 a < Rep_bit0 b"
definition "a \<le> b \<longleftrightarrow> Rep_bit0 a \<le> Rep_bit0 b"
definition "a < b \<longleftrightarrow> Rep_bit1 a < Rep_bit1 b"
definition "a \<le> b \<longleftrightarrow> Rep_bit1 a \<le> Rep_bit1 b"

instance
  by(intro_classes)
    (auto simp add: less_eq_bit0_def less_bit0_def less_eq_bit1_def less_bit1_def Rep_bit0_inject Rep_bit1_inject)
end

lemma (in preorder) tranclp_less: "(<) \<^sup>+\<^sup>+ = (<)"
by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

instance bit0 and bit1 :: (finite) wellorder
proof -
  have "wf {(x :: 'a bit0, y). x < y}"
    by(auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a bit0, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
next
  have "wf {(x :: 'a bit1, y). x < y}"
    by(auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a bit1, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
qed

subsection \<open>Code setup and type classes for code generation\<close>

text \<open>Code setup for \<^typ>\<open>num0\<close> and \<^typ>\<open>num1\<close>\<close>

definition Num0 :: num0 where "Num0 = Abs_num0 0"
code_datatype Num0

instantiation num0 :: equal begin
definition equal_num0 :: "num0 \<Rightarrow> num0 \<Rightarrow> bool"
  where "equal_num0 = (=)"
instance by intro_classes (simp add: equal_num0_def)
end

lemma equal_num0_code [code]:
  "equal_class.equal Num0 Num0 = True"
by(rule equal_refl)

code_datatype "1 :: num1"

instantiation num1 :: equal begin
definition equal_num1 :: "num1 \<Rightarrow> num1 \<Rightarrow> bool"
  where "equal_num1 = (=)"
instance by intro_classes (simp add: equal_num1_def)
end

lemma equal_num1_code [code]:
  "equal_class.equal (1 :: num1) 1 = True"
by(rule equal_refl)

instantiation num1 :: enum begin
definition "enum_class.enum = [1 :: num1]"
definition "enum_class.enum_all P = P (1 :: num1)"
definition "enum_class.enum_ex P = P (1 :: num1)"
instance
  by intro_classes
     (auto simp add: enum_num1_def enum_all_num1_def enum_ex_num1_def num1_eq_iff Ball_def)
end

instantiation num0 and num1 :: card_UNIV begin
definition "finite_UNIV = Phantom(num0) False"
definition "card_UNIV = Phantom(num0) 0"
definition "finite_UNIV = Phantom(num1) True"
definition "card_UNIV = Phantom(num1) 1"
instance
  by intro_classes
     (simp_all add: finite_UNIV_num0_def card_UNIV_num0_def infinite_num0 finite_UNIV_num1_def card_UNIV_num1_def)
end

text \<open>Code setup for \<^typ>\<open>'a bit0\<close> and \<^typ>\<open>'a bit1\<close>\<close>

declare
  bit0.Rep_inverse[code abstype]
  bit0.Rep_0[code abstract]
  bit0.Rep_1[code abstract]

lemma Abs_bit0'_code [code abstract]:
  "Rep_bit0 (Abs_bit0' x :: 'a :: finite bit0) = x mod int (CARD('a bit0))"
by(auto simp add: Abs_bit0'_def intro!: Abs_bit0_inverse)

lemma inj_on_Abs_bit0:
  "inj_on (Abs_bit0 :: int \<Rightarrow> 'a bit0) {0..<2 * int CARD('a :: finite)}"
by(auto intro: inj_onI simp add: Abs_bit0_inject)

declare
  bit1.Rep_inverse[code abstype]
  bit1.Rep_0[code abstract]
  bit1.Rep_1[code abstract]

lemma Abs_bit1'_code [code abstract]:
  "Rep_bit1 (Abs_bit1' x :: 'a :: finite bit1) = x mod int (CARD('a bit1))"
  by(auto simp add: Abs_bit1'_def intro!: Abs_bit1_inverse)

lemma inj_on_Abs_bit1:
  "inj_on (Abs_bit1 :: int \<Rightarrow> 'a bit1) {0..<1 + 2 * int CARD('a :: finite)}"
by(auto intro: inj_onI simp add: Abs_bit1_inject)

instantiation bit0 and bit1 :: (finite) equal begin

definition "equal_class.equal x y \<longleftrightarrow> Rep_bit0 x = Rep_bit0 y"
definition "equal_class.equal x y \<longleftrightarrow> Rep_bit1 x = Rep_bit1 y"

instance
  by intro_classes (simp_all add: equal_bit0_def equal_bit1_def Rep_bit0_inject Rep_bit1_inject)

end

instantiation bit0 :: (finite) enum begin
definition "(enum_class.enum :: 'a bit0 list) = map (Abs_bit0' \<circ> int) (upt 0 (CARD('a bit0)))"
definition "enum_class.enum_all P = (\<forall>b :: 'a bit0 \<in> set enum_class.enum. P b)"
definition "enum_class.enum_ex P = (\<exists>b :: 'a bit0 \<in> set enum_class.enum. P b)"

instance proof
  show "distinct (enum_class.enum :: 'a bit0 list)"
    by (simp add: enum_bit0_def distinct_map inj_on_def Abs_bit0'_def Abs_bit0_inject)

  let ?Abs = "Abs_bit0 :: _ \<Rightarrow> 'a bit0"
  interpret type_definition Rep_bit0 ?Abs "{0..<2 * int CARD('a)}"
    by (fact type_definition_bit0)
  have "UNIV = ?Abs ` {0..<2 * int CARD('a)}"
    by (simp add: Abs_image)
  also have "\<dots> = ?Abs ` (int ` {0..<2 * CARD('a)})"
    by (simp add: image_int_atLeastLessThan)
  also have "\<dots> = (?Abs \<circ> int) ` {0..<2 * CARD('a)}"
    by (simp add: image_image cong: image_cong)
  also have "\<dots> = set enum_class.enum"
    by (simp add: enum_bit0_def Abs_bit0'_def cong: image_cong_simp)
  finally show univ_eq: "(UNIV :: 'a bit0 set) = set enum_class.enum" .

  fix P :: "'a bit0 \<Rightarrow> bool"
  show "enum_class.enum_all P = Ball UNIV P"
    and "enum_class.enum_ex P = Bex UNIV P"
    by(simp_all add: enum_all_bit0_def enum_ex_bit0_def univ_eq)
qed

end

instantiation bit1 :: (finite) enum begin
definition "(enum_class.enum :: 'a bit1 list) = map (Abs_bit1' \<circ> int) (upt 0 (CARD('a bit1)))"
definition "enum_class.enum_all P = (\<forall>b :: 'a bit1 \<in> set enum_class.enum. P b)"
definition "enum_class.enum_ex P = (\<exists>b :: 'a bit1 \<in> set enum_class.enum. P b)"

instance
proof(intro_classes)
  show "distinct (enum_class.enum :: 'a bit1 list)"
    by(simp only: Abs_bit1'_def zmod_int[symmetric] enum_bit1_def distinct_map Suc_eq_plus1 card_bit1 o_apply inj_on_def)
      (clarsimp simp add: Abs_bit1_inject)

  let ?Abs = "Abs_bit1 :: _ \<Rightarrow> 'a bit1"
  interpret type_definition Rep_bit1 ?Abs "{0..<1 + 2 * int CARD('a)}"
    by (fact type_definition_bit1)
  have "UNIV = ?Abs ` {0..<1 + 2 * int CARD('a)}"
    by (simp add: Abs_image)
  also have "\<dots> = ?Abs ` (int ` {0..<1 + 2 * CARD('a)})"
    by (simp add: image_int_atLeastLessThan)
  also have "\<dots> = (?Abs \<circ> int) ` {0..<1 + 2 * CARD('a)}"
    by (simp add: image_image cong: image_cong)
  finally show univ_eq: "(UNIV :: 'a bit1 set) = set enum_class.enum"
    by (simp only: enum_bit1_def set_map set_upt) (simp add: Abs_bit1'_def cong: image_cong_simp)

  fix P :: "'a bit1 \<Rightarrow> bool"
  show "enum_class.enum_all P = Ball UNIV P"
    and "enum_class.enum_ex P = Bex UNIV P"
    by(simp_all add: enum_all_bit1_def enum_ex_bit1_def univ_eq)
qed

end

instantiation bit0 and bit1 :: (finite) finite_UNIV begin
definition "finite_UNIV = Phantom('a bit0) True"
definition "finite_UNIV = Phantom('a bit1) True"
instance by intro_classes (simp_all add: finite_UNIV_bit0_def finite_UNIV_bit1_def)
end

instantiation bit0 and bit1 :: ("{finite,card_UNIV}") card_UNIV begin
definition "card_UNIV = Phantom('a bit0) (2 * of_phantom (card_UNIV :: 'a card_UNIV))"
definition "card_UNIV = Phantom('a bit1) (1 + 2 * of_phantom (card_UNIV :: 'a card_UNIV))"
instance by intro_classes (simp_all add: card_UNIV_bit0_def card_UNIV_bit1_def card_UNIV)
end

subsection \<open>Syntax\<close>

syntax
  "_NumeralType" :: "num_token => type"  ("_")
  "_NumeralType0" :: type ("0")
  "_NumeralType1" :: type ("1")

translations
  (type) "1" == (type) "num1"
  (type) "0" == (type) "num0"

parse_translation \<open>
  let
    fun mk_bintype n =
      let
        fun mk_bit 0 = Syntax.const \<^type_syntax>\<open>bit0\<close>
          | mk_bit 1 = Syntax.const \<^type_syntax>\<open>bit1\<close>;
        fun bin_of n =
          if n = 1 then Syntax.const \<^type_syntax>\<open>num1\<close>
          else if n = 0 then Syntax.const \<^type_syntax>\<open>num0\<close>
          else if n = ~1 then raise TERM ("negative type numeral", [])
          else
            let val (q, r) = Integer.div_mod n 2;
            in mk_bit r $ bin_of q end;
      in bin_of n end;

    fun numeral_tr [Free (str, _)] = mk_bintype (the (Int.fromString str))
      | numeral_tr ts = raise TERM ("numeral_tr", ts);

  in [(\<^syntax_const>\<open>_NumeralType\<close>, K numeral_tr)] end
\<close>

print_translation \<open>
  let
    fun int_of [] = 0
      | int_of (b :: bs) = b + 2 * int_of bs;

    fun bin_of (Const (\<^type_syntax>\<open>num0\<close>, _)) = []
      | bin_of (Const (\<^type_syntax>\<open>num1\<close>, _)) = [1]
      | bin_of (Const (\<^type_syntax>\<open>bit0\<close>, _) $ bs) = 0 :: bin_of bs
      | bin_of (Const (\<^type_syntax>\<open>bit1\<close>, _) $ bs) = 1 :: bin_of bs
      | bin_of t = raise TERM ("bin_of", [t]);

    fun bit_tr' b [t] =
          let
            val rev_digs = b :: bin_of t handle TERM _ => raise Match
            val i = int_of rev_digs;
            val num = string_of_int (abs i);
          in
            Syntax.const \<^syntax_const>\<open>_NumeralType\<close> $ Syntax.free num
          end
      | bit_tr' b _ = raise Match;
  in
   [(\<^type_syntax>\<open>bit0\<close>, K (bit_tr' 0)),
    (\<^type_syntax>\<open>bit1\<close>, K (bit_tr' 1))]
  end
\<close>

subsection \<open>Examples\<close>

lemma "CARD(0) = 0" by simp
lemma "CARD(17) = 17" by simp
lemma "CHAR(23) = 23" by simp
lemma "8 * 11 ^ 3 - 6 = (2::5)" by simp

end