theory RelationalIncorrectness
  imports "HOL-IMP.Big_Step"
begin

(* Author: Toby Murray *)

section "Under-Approximate Relational Judgement"

text {*
  This is the relational analogue of OHearn's~\cite{OHearn_19} and de Vries \& Koutavas'~\cite{deVries_Koutavas_11}
  judgements.

  Note that in our case it doesn't really make sense to talk about ``erroneous'' states: the
  presence of an error can be seen only by the violation of a relation. Unlike O'Hearn, we cannot
  encode it directly into the semantics of our programs, without giving them a relational semantics.
  We use the standard big step semantics of IMP unchanged.
*}

type_synonym rassn = "state \<Rightarrow> state \<Rightarrow> bool"

definition
  ir_valid :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  "ir_valid P c c' Q \<equiv> (\<forall> t t'. Q t t' \<longrightarrow> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"

section "Rules of the Logic"

definition
  flip :: "rassn \<Rightarrow> rassn"
  where
  "flip P \<equiv> \<lambda>s s'. P s' s"

inductive
  ir_hoare :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  ir_Skip: "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c',s') \<Rightarrow> t') \<Longrightarrow>
            ir_hoare P SKIP c' Q" |
  ir_If_True:   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) c\<^sub>1 c' Q \<Longrightarrow>
                 ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_If_False:   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) c\<^sub>2 c' Q \<Longrightarrow>
                  ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_Seq1: "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d SKIP R \<Longrightarrow> ir_hoare P (Seq c d) c' R" |
  ir_Assign: "ir_hoare (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow>
              ir_hoare P (Assign x e) c' Q" |
  ir_While_False: "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_True: "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) (c;; WHILE b DO c) c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_backwards_frontier: "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                                ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
                                ir_hoare (P 0) (WHILE b DO c) c' Q" |
  ir_conseq:      "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                   ir_hoare P' c c' Q'" |
  ir_disj:        "ir_hoare P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_hoare P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                   ir_hoare (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')" |
  ir_sym: "ir_hoare (flip P) c c' (flip Q) \<Longrightarrow> ir_hoare P c' c Q"

section "Simple Derived Rules"

lemma meh_simp[simp]: "(SKIP, s') \<Rightarrow> t' = (s' = t')"
  by auto

lemma ir_pre: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s')  \<Longrightarrow>
                  ir_hoare P' c c' Q"
  by(erule ir_conseq, blast+)

lemma ir_post: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s')  \<Longrightarrow>
                  ir_hoare P c c' Q'"
  by(erule ir_conseq, blast+)

section "Soundness"

lemma Skip_ir_valid[intro]:
  "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c', s') \<Rightarrow> t') \<Longrightarrow> ir_valid P SKIP c' Q"
  by(auto simp: ir_valid_def)

lemma sym_ir_valid[intro]:
  "ir_valid (flip P) c' c (flip Q) \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def flip_def)

lemma If_True_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> bval b a) c\<^sub>1 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma If_False_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> \<not> bval b a) c\<^sub>2 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma Seq1_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d SKIP R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq2_ir_valid[intro]:
  "ir_valid P c SKIP Q \<Longrightarrow> ir_valid Q d c' R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d d' R \<Longrightarrow> ir_valid P (c;; d) (c';; d') R"
  by(fastforce simp: ir_valid_def)

lemma Assign_blah[intro]:
  "t x = aval e (t(x := v))
       \<Longrightarrow> (x ::= e, t(x := v)) \<Rightarrow> t"
  using Assign
  by (metis fun_upd_triv fun_upd_upd)

lemma Assign_ir_valid[intro]:
  "ir_valid (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow> ir_valid P (Assign x e) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_False_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_True_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> bval b s) (Seq c (WHILE b DO c)) c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(clarsimp simp: ir_valid_def, blast)

lemma While_backwards_frontier_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s. P (k + n) s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t)"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q r' \<and> bval b q \<and>  (c, q) \<Rightarrow> r"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) c' Q"
  by(auto simp: meh_simp ir_valid_def intro: While_backwards_frontier_ir_valid')

lemma conseq_ir_valid:
  "ir_valid P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                  ir_valid P' c c' Q'"
  by(clarsimp simp: ir_valid_def, blast)

lemma disj_ir_valid[intro]:
  "ir_valid P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_valid P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                  ir_valid (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  by(fastforce simp: ir_valid_def)

theorem soundness:
  "ir_hoare P c c' Q \<Longrightarrow> ir_valid P c c' Q"
  apply(induction rule: ir_hoare.induct)
              apply(blast intro!: Skip_ir_valid)
  by (blast intro: conseq_ir_valid)+

section "Completeness"

lemma ir_Skip_Skip[intro]:
  "ir_hoare P SKIP SKIP P"
  by(rule ir_Skip, simp)

lemma ir_hoare_Skip_Skip[simp]:
  "ir_hoare P SKIP SKIP Q = (\<forall>s s'. Q s s' \<longrightarrow> P s s')"
  using soundness ir_valid_def meh_simp ir_conseq ir_Skip by metis

lemma ir_valid_Seq1:
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_Seq1':
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t')) c2 SKIP Q"
  by(clarsimp simp: ir_valid_def, meson SeqE)

lemma ir_valid_track_history:
  "ir_valid P c c' Q \<Longrightarrow>
   ir_valid P c c' (\<lambda>t t'. Q s s' \<and> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_If:
  "ir_valid (\<lambda>s s'. P s s') (IF b THEN c1 ELSE c2) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> bval b s) c1 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> bval b s)) \<and>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) c2 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> \<not> bval b s))"
  by(clarsimp simp: ir_valid_def, blast)

text {*
  Inspired by the
  ``@{text "p(n) = {\<sigma> | you can get back from \<sigma> to some state in p by executing C backwards n times}"}''
  part of OHearn~\cite{OHearn_19}.
*}
primrec get_back where
  "get_back P b c 0 = (\<lambda>t t'. P t t')" |
  "get_back P b c (Suc n) = (\<lambda>t t'. \<exists>s. (c,s) \<Rightarrow> t \<and> bval b s \<and> get_back P b c n s t')"

(* Currently not used anywhere *)
lemma ir_valid_get_back:
  "ir_valid (get_back P b c (Suc k)) (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
proof(induct k)
  case 0
  then show ?case by(clarsimp simp: ir_valid_def, blast)
next
  case (Suc k)
  then show ?case  using  WhileTrue get_back.simps(2) ir_valid_def by smt
qed

(* both this an the next one get used in the completeness proof *)
lemma ir_valid_While1:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c SKIP (\<lambda>t t'. get_back P b c (Suc k) t t' \<and> (\<exists>u u'. (WHILE b DO c,t) \<Rightarrow> u \<and> (c',t') \<Rightarrow> u' \<and> Q u u')))"
proof (subst ir_valid_def, clarsimp)
  fix t t' s u u'
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', t') \<Rightarrow> u'"
         "Q u u'"
         "bval b s"
         "get_back P b c k s t'"
  thus "\<exists>s. get_back P b c k s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t"
  proof(induction k arbitrary: t t' s u u')
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

lemma ir_valid_While3:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c c' (\<lambda>t t'. (\<exists>s'. (c',s') \<Rightarrow> t' \<and> get_back P b c (Suc k) t s' \<and> (\<exists>u. (WHILE b DO c,t) \<Rightarrow> u \<and>  Q u t'))))"
  apply(subst ir_valid_def, clarsimp)
proof -
  fix t t' s' s u
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', s') \<Rightarrow> t'"
         "Q u t'"
         "bval b s"
         "get_back P b c k s s'"
  thus "\<exists>s s'. get_back P b c k s s' \<and> bval b s \<and> (c, s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
  proof(induction k arbitrary: t t' s' s u)
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(4) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

(* not used anywhere *)
lemma ir_valid_While2:
   "ir_valid P (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' (\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c',s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval b t))"
  by(clarsimp simp: ir_valid_def, blast)

lemma assign_upd_blah:
  "(\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) = s"
  by(rule ext, auto)

lemma Assign_complete:
  assumes v: "ir_valid P (x1 ::= x2) c' Q"
  assumes q: "Q t t'"
  shows  "\<exists>s'. (\<exists>v. P (t(x1 := v)) s' \<and> t x1 = aval x2 (t(x1 := v))) \<and> (c', s') \<Rightarrow> t'"
proof -
  from v and q obtain s s' where a: "P s s' \<and> (x1 ::= x2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
    using ir_valid_def by smt
  hence "P (\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) s' \<and> aval x2 s = aval x2 (s(x1 := s x1))"
    using assign_upd_blah
    by simp
  thus ?thesis
    using assign_upd_blah a
    by (metis AssignE fun_upd_same fun_upd_triv fun_upd_upd)
qed

lemmas ir_Skip_sym = ir_sym[OF ir_Skip, simplified flip_def]

theorem completeness:
  "ir_valid P c c' Q \<Longrightarrow> ir_hoare P c c' Q"
proof(induct c arbitrary: P c' Q)
case SKIP
  show ?case
    apply(rule ir_Skip)
    using SKIP by(fastforce simp: ir_valid_def)
next
  case (Assign x1 x2)
  show ?case
    apply(rule ir_Assign)
    apply(rule ir_Skip)
    using Assign_complete Assign by blast
next
  case (Seq c1 c2)
  have a: "ir_hoare P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> (\<exists>u. (c2, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_Seq1 Seq by blast
  show ?case
    apply(rule ir_Seq1)
     apply (blast intro: a)
    apply(rule ir_Skip_sym)
    by(metis SeqE ir_valid_def Seq)
next
  case (If x1 c1 c2)
  have t: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c1 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> bval x1 s))" and
       f: " ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval x1 s) c2 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> \<not> bval x1 s))"
    using ir_valid_If If by blast+
  show ?case
    (* consider both cases of the if via conseq, disj, then _True and _False *)
    apply(rule ir_conseq)
      apply(rule ir_disj)
       apply(rule ir_If_True,fastforce intro: t)
      apply(rule ir_If_False, fastforce intro: f)
     apply blast
    by (smt IfE ir_valid_def If)
next
  case (While x1 c)
  have a: "\<And>n. ir_hoare (\<lambda>s s'. get_back P x1 c n s s' \<and> bval x1 s) c SKIP (get_back P x1 c (Suc n))"
    using ir_valid_While1  While
    by (smt get_back.simps(2) ir_valid_def meh_simp)
  have b: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c c'
                    (\<lambda>t t'.  \<exists>s'. (c', s') \<Rightarrow> t' \<and> (\<exists>s. (c, s) \<Rightarrow> t \<and> bval x1 s \<and> P s s') \<and>
                    (\<exists>u. (WHILE x1 DO c, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_While3[where k=0,simplified] While by blast
  have gb: "\<And>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t) \<Longrightarrow>
                    \<exists>s'. ((\<exists>n. get_back P x1 c n t s') \<and> \<not> bval x1 t) \<and> (c', s') \<Rightarrow> t'"
    by (meson get_back.simps(1))

  show ?case
    (* use the frontier rule much as in OHearn POPL *)
    apply(rule ir_conseq)
      apply(rule_tac P="get_back P x1 c" in ir_While_backwards_frontier)
       apply(blast intro: a)
      (* consider both cases of the While via conseq, disj, then _True and _False *)
      apply(rule ir_conseq)
        apply(rule ir_disj)
         apply(rule_tac P="\<lambda>s s'. \<exists>n. get_back P x1 c n s s'" and Q="(\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t))" in ir_While_False)
         apply(rule ir_Skip, blast intro: gb)
        apply(rule ir_While_True)
        apply(rule ir_Seq1[OF b])
        apply(rule ir_Skip_sym)
        apply(fastforce)
       apply (metis get_back.simps(1))
      apply assumption
     apply simp
    by (metis While.prems WhileE ir_valid_def)
qed

section "A Decomposition Principle: Proofs via Under-Approximate Hoare Logic"

text {*
  We show the under-approximate analogue holds for Beringer's~\cite{Beringer_11} decomposition
  principle for over-approximate relational logic.
*}

definition
  decomp :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> rassn" where
  "decomp P c c' Q \<equiv> \<lambda>t s'. \<exists>s t'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> Q t t'"

lemma ir_valid_decomp1:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp2:
  "ir_valid P c SKIP R \<and> ir_valid R SKIP c' Q \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp:
  "ir_valid P c c' Q = (ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q)"
  using ir_valid_decomp1 ir_valid_decomp2 by blast

text {*
  Completeness with soundness means we can prove proof rules about @{term ir_hoare} in terms
  of @{term ir_valid}.
*}

lemma ir_to_Skip:
  "ir_hoare P c c' Q = (ir_hoare P c SKIP (decomp P c c' Q) \<and> ir_hoare (decomp P c c' Q) SKIP c' Q)"
  using soundness completeness ir_valid_decomp
  by meson

text {*
  O'Hearn's under-approximate Hoare triple, for the ``ok'' case (since that is the only case we have)
  This is also likely the same as from the "Reverse Hoare Logic" paper (SEFM).
*}
type_synonym assn = "state \<Rightarrow> bool"
definition
  ohearn :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  where
  "ohearn P c Q \<equiv> (\<forall>t. Q t \<longrightarrow> (\<exists>s. P s \<and> (c,s) \<Rightarrow> t))"

lemma fold_ohearn2:
  "ir_valid P SKIP c' Q = (\<forall>t. ohearn (P t) c' (Q t))"
  by(simp add: ir_valid_def ohearn_def)

theorem relational_via_hoare:
  "ir_hoare P c c' Q = ((\<forall>t'. ohearn (\<lambda>t. P t t') c (\<lambda>t. decomp P c c' Q t t')) \<and> (\<forall>t. ohearn (decomp P c c' Q t) c' (Q t)))"
proof -
  have a: "\<And>P c c' Q. ir_hoare P c c' Q = ir_valid P c c' Q"
    using soundness completeness by auto
  show ?thesis
    using ir_to_Skip a fold_ohearn1 fold_ohearn2 by metis
qed

section "Deriving Proof Rules from Completeness"

text {*
  Note that we can more easily derive proof rules sometimes by appealing to the
   corresponding properties of @{term ir_valid} than from the proof rules directly.

  We see more examples of this later on when we consider examples.
*}

lemma ir_Seq2:
  "ir_hoare P c SKIP Q \<Longrightarrow> ir_hoare Q d c' R \<Longrightarrow> ir_hoare P (Seq c d) c' R"
  using soundness completeness Seq2_ir_valid by metis

lemma ir_Seq:
  "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d d' R \<Longrightarrow> ir_hoare P (Seq c d) (Seq c' d') R"
  using soundness completeness Seq_ir_valid by metis

section "Examples"

subsection "Some Derived Proof Rules"

text {*
First derive some proof rules -- here not by appealing to completeness but just using
the existing rules
*}

lemma ir_If_True_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> \<not> bval b' s') c\<^sub>1 c\<^sub>2' Q \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') Q"
  apply(rule ir_If_True)
  apply(rule ir_sym)
  apply(rule ir_If_False)
  apply(rule ir_sym)
  by(simp add: flip_def)

lemma ir_Assign_Assign:
  "ir_hoare P (x ::= e) (x' ::= e') (\<lambda>t t'. \<exists>v v'. P (t(x := v)) (t'(x' := v')) \<and> t x = aval e (t(x := v)) \<and> t' x' = aval e' (t'(x' := v')))"
  apply(rule ir_Assign)
  apply(rule ir_sym)
  apply(rule ir_Assign)
  by(simp add: flip_def, auto)

subsection "prog1"

text {*
  A tiny insecure program. Note that we only need to reason on one path through this program to
  detect that it is insecure.
*}

abbreviation low_eq :: rassn where "low_eq s s' \<equiv> s ''low'' = s' ''low''"
abbreviation low_neq :: rassn where "low_neq s s' \<equiv> \<not> low_eq s s'"
definition prog1 :: com where
  "prog1 \<equiv> (IF (Less (N 0) (V ''x'')) THEN (Assign ''low'' (N 1)) ELSE (Assign ''low'' (N 0)))"

text {*
  We prove that @{term prog1} is definitely insecure. To do that, we need to find some non-empty
  post-relation that implies insecurity. The following property encodes the idea that the
  post-relation is non-empty, i.e. represents a feasible pair of execution paths.
*}
definition
  nontrivial :: "rassn \<Rightarrow> bool"
  where
  "nontrivial Q \<equiv> (\<exists>t t'. Q t t')"

text {*
  Note the property we prove here explicitly encodes the fact that the postcondition can be anything
  that implies insecurity, i.e. implies @{term low_neq}. In particular we should not necessarily
  expect it to cover the entirely of all states that satisfy @{term low_neq}.

  Also note that we also have to prove that the postcondition is non-trivial. This is necessary to
  make sure that the violation we find is not an infeasible path.
*}
lemma prog1:
  "\<exists>Q. ir_hoare low_eq prog1 prog1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI)
  apply(rule conjI)
   apply(simp add: prog1_def)
   apply(rule ir_If_True_False)
   apply(rule ir_Assign_Assign)
  apply(rule conjI)
   apply auto[1]
  apply(clarsimp simp: nontrivial_def)
  apply(rule_tac x="\<lambda>v. 1" in exI)
  apply simp
  apply(rule_tac x="\<lambda>v. 0" in exI)
  by auto

subsection "More Derived Proof Rules for Examples"

definition BEq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "BEq a b \<equiv> And (Less a (Plus b (N 1))) (Less b (Plus a (N 1)))"

lemma BEq_aval[simp]:
  "bval (BEq a b) s = ((aval a s) = (aval b s))"
  by(auto simp add: BEq_def)

lemma ir_If_True_True:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t')"
  by(simp add: ir_If_True ir_sym flip_def)

lemma ir_If_False_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>2 t t')"
  by(simp add: ir_If_False ir_sym flip_def)

lemma ir_If':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  apply(rule ir_pre)
   apply(rule ir_disj)
    apply(rule ir_If_True_True)
    apply assumption
   apply(rule ir_If_False_False)
   apply assumption
  apply blast
  done

lemma ir_While_triv:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>2 s s'))"
  by(simp add: ir_While_False ir_sym flip_def)

lemma ir_While':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') (c;;WHILE b DO c) (c';;WHILE b' DO c') Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>1 s s' \<or> Q\<^sub>2 s s'))"
  apply(rule ir_pre)
   apply(rule ir_disj)
     apply(rule ir_While_True)
     apply(rule ir_sym)
     apply(simp add: flip_def)
     apply(rule ir_While_True)
     apply(rule ir_sym)
    apply(simp add: flip_def)
   apply(rule ir_While_triv)
   apply assumption
  apply simp
  done

subsection "client0"

definition low_eq_strong where
  "low_eq_strong s s' \<equiv> (s ''high'' \<noteq> s' ''high'') \<and> low_eq s s'"

lemma low_eq_strong_upd[simp]:
  "var \<noteq> ''high'' \<and> var \<noteq> ''low'' \<Longrightarrow> low_eq_strong(s(var := v)) (s'(var := v')) = low_eq_strong s s'"
  by(auto simp: low_eq_strong_def)

text {*
  A variation on client0 from O'Hearn~\cite{OHearn_19}: how to reason about loops via a single unfolding
*}
definition client0 :: com where
  "client0 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (N 0) (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (V ''n'')));;
                      (Assign ''n'' (V ''nondet''))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client0:
  "\<exists>Q. ir_hoare low_eq client0 client0 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client0_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

    apply(rule ir_While')
      apply clarsimp

      apply(rule ir_Seq)
       apply(rule ir_Seq)
        apply(rule ir_Assign_Assign)
       apply(rule ir_Assign_Assign)
      apply clarsimp

      apply(rule ir_While_triv)
      apply clarsimp
      apply assumption

     apply clarsimp
     apply assumption

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

(* Not needed? *)
lemma ir_While_backwards:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                       ir_hoare (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) c' Q"
  apply(rule ir_While_backwards_frontier)
   apply assumption
  apply(rule ir_While_False)
  apply auto
  done

subsection "Derive a variant of the backwards variant rule"

text {* Here we appeal to completeness again to derive this rule from the corresponding
        property about @{term ir_valid}. *}

subsection "A variant of the frontier rule"

text {*
  Agin we derive this rule by appealing to completeness and the corresponding property of
  @{term ir_valid}
*}

lemma While_backwards_frontier_both_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s s'. P (k + n) s s' \<and> bval b s \<and> bval b' s' \<and> (c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(WHILE b' DO c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(WHILE b' DO c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q q' \<and> bval b q \<and> bval b' q' \<and> (c, q) \<Rightarrow> r \<and> (c', q') \<Rightarrow> r'"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_both_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  by(auto simp: ir_valid_def intro: While_backwards_frontier_both_ir_valid')

lemma ir_While_backwards_frontier_both:
  "\<lbrakk>\<And>n. ir_hoare (\<lambda>s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n));
   ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q\<rbrakk>
   \<Longrightarrow> ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  using soundness completeness While_backwards_frontier_both_ir_valid by auto

text {*
  The following rule then follows easily as a special case
*}
lemma ir_While_backwards_both:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s \<and> \<not> bval b' s')"
  apply(rule ir_While_backwards_frontier_both)
   apply blast
  by(simp add: ir_While_False ir_sym flip_def)

subsection "client1"

text {*
  An example roughly equivalent to cient1 from O'Hearn~\cite{OHearn_19}0

  In particular we use the backwards variant rule to reason about the loop.
*}
definition client1 :: com where
  "client1 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client1:
  "\<exists>Q. ir_hoare low_eq client1 client1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client1_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
      apply(rule ir_While_backwards_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> int n \<le> s ''n'' \<and> int n \<le> s' ''n''"])
      apply(rule ir_post)
       apply(rule ir_Assign_Assign)
      apply clarsimp

     apply clarsimp

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

subsection "client2"

text {*
  An example akin to client2 from O'Hearn~\cite{OHearn_19}.

  Note that this example is carefully written to show use of the frontier rule first to
  reason up to the broken loop iteration, and then we unfold the loop at that point to
  reason about the broken iteration, and then use the plain backwards variant rule to
  reason over the remainder of the loop.
*}
definition client2 :: com where
  "client2 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (N 4000000))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)));;
                       (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))
                       )
              )"

lemma client2:
  "\<exists>Q. ir_hoare low_eq client2 client2 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client2_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
     apply(rule ir_Assign_Assign)
    apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_frontier_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> s ''x'' \<ge> 0 \<and> s ''x'' \<le> 2000000 - 1 \<and> s' ''x'' \<ge> 0 \<and> s' ''x'' \<le> 2000000 - 1"])
      apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
  apply clarsimp
      apply(rule ir_post)
       apply(rule ir_If')
        apply(rule ir_Assign_Assign)
       apply(rule ir_Skip_Skip)
      apply clarsimp

     apply clarsimp
     apply(rule ir_While')
      apply clarsimp
      apply(rule ir_Seq)
       apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
      apply(rule ir_If_True_True)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_both[where P="\<lambda>n s s'.  s ''x'' = 2000000 + int n \<and> s' ''x'' = 2000000 + int n \<and> s ''x'' \<ge> 2000000 \<and> s ''x'' \<le> 4000000 \<and> s' ''x'' \<ge> 2000000 \<and> s' ''x'' \<le> 4000000 \<and> s ''low'' = s ''high'' \<and> s' ''low'' = s' ''high'' \<and> s ''high'' \<noteq> s' ''high''"])

     apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
      apply(rule ir_If_False_False)
       apply fastforce
      apply (fastforce simp: low_eq_strong_def)
     apply fastforce
    apply(fastforce simp: low_eq_strong_def)
   apply(fastforce simp: low_eq_strong_def)

  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

end


(*  Title:      HOL/Library/Cardinality.thy
    Author:     Brian Huffman, Andreas Lochbihler
*)

section \<open>Cardinality of types\<close>

theory Cardinality
imports Phantom_Type
begin

subsection \<open>Preliminary lemmas\<close>
(* These should be moved elsewhere *)

lemma (in type_definition) univ:
  "UNIV = Abs ` A"
proof
  show "Abs ` A \<subseteq> UNIV" by (rule subset_UNIV)
  show "UNIV \<subseteq> Abs ` A"
  proof
    fix x :: 'b
    have "x = Abs (Rep x)" by (rule Rep_inverse [symmetric])
    moreover have "Rep x \<in> A" by (rule Rep)
    ultimately show "x \<in> Abs ` A" by (rule image_eqI)
  qed
qed

lemma (in type_definition) card: "card (UNIV :: 'b set) = card A"
  by (simp add: univ card_image inj_on_def Abs_inject)

lemma finite_range_Some: "finite (range (Some :: 'a \<Rightarrow> 'a option)) = finite (UNIV :: 'a set)"
by(auto dest: finite_imageD intro: inj_Some)

lemma infinite_literal: "\<not> finite (UNIV :: String.literal set)"
proof -
  have "inj STR" by(auto intro: injI)
  thus ?thesis
    by(auto simp add: type_definition.univ[OF type_definition_literal] infinite_UNIV_listI dest: finite_imageD)
qed

subsection \<open>Cardinalities of types\<close>

syntax "_type_card" :: "type => nat" ("(1CARD/(1'(_')))")

translations "CARD('t)" => "CONST card (CONST UNIV :: 't set)"

print_translation \<open>
  let
    fun card_univ_tr' ctxt [Const (@{const_syntax UNIV}, Type (_, [T]))] =
      Syntax.const @{syntax_const "_type_card"} $ Syntax_Phases.term_of_typ ctxt T
  in [(@{const_syntax card}, card_univ_tr')] end
\<close>

lemma card_prod [simp]: "CARD('a \<times> 'b) = CARD('a) * CARD('b)"
  unfolding UNIV_Times_UNIV [symmetric] by (simp only: card_cartesian_product)

lemma card_UNIV_sum: "CARD('a + 'b) = (if CARD('a) \<noteq> 0 \<and> CARD('b) \<noteq> 0 then CARD('a) + CARD('b) else 0)"
unfolding UNIV_Plus_UNIV[symmetric]
by(auto simp add: card_eq_0_iff card_Plus simp del: UNIV_Plus_UNIV)

lemma card_sum [simp]: "CARD('a + 'b) = CARD('a::finite) + CARD('b::finite)"
by(simp add: card_UNIV_sum)

lemma card_UNIV_option: "CARD('a option) = (if CARD('a) = 0 then 0 else CARD('a) + 1)"
proof -
  have "(None :: 'a option) \<notin> range Some" by clarsimp
  thus ?thesis
    by (simp add: UNIV_option_conv card_eq_0_iff finite_range_Some card_image)
qed

lemma card_option [simp]: "CARD('a option) = Suc CARD('a::finite)"
by(simp add: card_UNIV_option)

lemma card_UNIV_set: "CARD('a set) = (if CARD('a) = 0 then 0 else 2 ^ CARD('a))"
by(simp add: Pow_UNIV[symmetric] card_eq_0_iff card_Pow del: Pow_UNIV)

lemma card_set [simp]: "CARD('a set) = 2 ^ CARD('a::finite)"
by(simp add: card_UNIV_set)

lemma card_nat [simp]: "CARD(nat) = 0"
  by (simp add: card_eq_0_iff)

lemma card_fun: "CARD('a \<Rightarrow> 'b) = (if CARD('a) \<noteq> 0 \<and> CARD('b) \<noteq> 0 \<or> CARD('b) = 1 then CARD('b) ^ CARD('a) else 0)"
proof -
  {  assume "0 < CARD('a)" and "0 < CARD('b)"
    hence fina: "finite (UNIV :: 'a set)" and finb: "finite (UNIV :: 'b set)"
      by(simp_all only: card_ge_0_finite)
    from finite_distinct_list[OF finb] obtain bs
      where bs: "set bs = (UNIV :: 'b set)" and distb: "distinct bs" by blast
    from finite_distinct_list[OF fina] obtain as
      where as: "set as = (UNIV :: 'a set)" and dista: "distinct as" by blast
    have cb: "CARD('b) = length bs"
      unfolding bs[symmetric] distinct_card[OF distb] ..
    have ca: "CARD('a) = length as"
      unfolding as[symmetric] distinct_card[OF dista] ..
    let ?xs = "map (\<lambda>ys. the o map_of (zip as ys)) (List.n_lists (length as) bs)"
    have "UNIV = set ?xs"
    proof(rule UNIV_eq_I)
      fix f :: "'a \<Rightarrow> 'b"
      from as have "f = the \<circ> map_of (zip as (map f as))"
        by(auto simp add: map_of_zip_map)
      thus "f \<in> set ?xs" using bs by(auto simp add: set_n_lists)
    qed
    moreover have "distinct ?xs" unfolding distinct_map
    proof(intro conjI distinct_n_lists distb inj_onI)
      fix xs ys :: "'b list"
      assume xs: "xs \<in> set (List.n_lists (length as) bs)"
        and ys: "ys \<in> set (List.n_lists (length as) bs)"
        and eq: "the \<circ> map_of (zip as xs) = the \<circ> map_of (zip as ys)"
      from xs ys have [simp]: "length xs = length as" "length ys = length as"
        by(simp_all add: length_n_lists_elem)
      have "map_of (zip as xs) = map_of (zip as ys)"
      proof
        fix x
        from as bs have "\<exists>y. map_of (zip as xs) x = Some y" "\<exists>y. map_of (zip as ys) x = Some y"
          by(simp_all add: map_of_zip_is_Some[symmetric])
        with eq show "map_of (zip as xs) x = map_of (zip as ys) x"
          by(auto dest: fun_cong[where x=x])
      qed
      with dista show "xs = ys" by(simp add: map_of_zip_inject)
    qed
    hence "card (set ?xs) = length ?xs" by(simp only: distinct_card)
    moreover have "length ?xs = length bs ^ length as" by(simp add: length_n_lists)
    ultimately have "CARD('a \<Rightarrow> 'b) = CARD('b) ^ CARD('a)" using cb ca by simp }
  moreover {
    assume cb: "CARD('b) = 1"
    then obtain b where b: "UNIV = {b :: 'b}" by(auto simp add: card_Suc_eq)
    have eq: "UNIV = {\<lambda>x :: 'a. b ::'b}"
    proof(rule UNIV_eq_I)
      fix x :: "'a \<Rightarrow> 'b"
      { fix y
        have "x y \<in> UNIV" ..
        hence "x y = b" unfolding b by simp }
      thus "x \<in> {\<lambda>x. b}" by(auto)
    qed
    have "CARD('a \<Rightarrow> 'b) = 1" unfolding eq by simp }
  ultimately show ?thesis
    by(auto simp del: One_nat_def)(auto simp add: card_eq_0_iff dest: finite_fun_UNIVD2 finite_fun_UNIVD1)
qed

corollary finite_UNIV_fun:
  "finite (UNIV :: ('a \<Rightarrow> 'b) set) \<longleftrightarrow>
   finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set) \<or> CARD('b) = 1"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have "?lhs \<longleftrightarrow> CARD('a \<Rightarrow> 'b) > 0" by(simp add: card_gt_0_iff)
  also have "\<dots> \<longleftrightarrow> CARD('a) > 0 \<and> CARD('b) > 0 \<or> CARD('b) = 1"
    by(simp add: card_fun)
  also have "\<dots> = ?rhs" by(simp add: card_gt_0_iff)
  finally show ?thesis .
qed

lemma card_literal: "CARD(String.literal) = 0"
by(simp add: card_eq_0_iff infinite_literal)

subsection \<open>Classes with at least 1 and 2\<close>

text \<open>Class finite already captures "at least 1"\<close>

lemma zero_less_card_finite [simp]: "0 < CARD('a::finite)"
  unfolding neq0_conv [symmetric] by simp

lemma one_le_card_finite [simp]: "Suc 0 \<le> CARD('a::finite)"
  by (simp add: less_Suc_eq_le [symmetric])

text \<open>Class for cardinality "at least 2"\<close>

class card2 = finite +
  assumes two_le_card: "2 \<le> CARD('a)"

lemma one_less_card: "Suc 0 < CARD('a::card2)"
  using two_le_card [where 'a='a] by simp

lemma one_less_int_card: "1 < int CARD('a::card2)"
  using one_less_card [where 'a='a] by simp

subsection \<open>A type class for deciding finiteness of types\<close>

type_synonym 'a finite_UNIV = "('a, bool) phantom"

class finite_UNIV =
  fixes finite_UNIV :: "('a, bool) phantom"
  assumes finite_UNIV: "finite_UNIV = Phantom('a) (finite (UNIV :: 'a set))"

lemma finite_UNIV_code [code_unfold]:
  "finite (UNIV :: 'a :: finite_UNIV set)
  \<longleftrightarrow> of_phantom (finite_UNIV :: 'a finite_UNIV)"
by(simp add: finite_UNIV)

subsection \<open>A type class for computing the cardinality of types\<close>

definition is_list_UNIV :: "'a list \<Rightarrow> bool"
where "is_list_UNIV xs = (let c = CARD('a) in if c = 0 then False else size (remdups xs) = c)"

lemma is_list_UNIV_iff: "is_list_UNIV xs \<longleftrightarrow> set xs = UNIV"
by(auto simp add: is_list_UNIV_def Let_def card_eq_0_iff List.card_set[symmetric]
   dest: subst[where P="finite", OF _ finite_set] card_eq_UNIV_imp_eq_UNIV)

type_synonym 'a card_UNIV = "('a, nat) phantom"

class card_UNIV = finite_UNIV +
  fixes card_UNIV :: "'a card_UNIV"
  assumes card_UNIV: "card_UNIV = Phantom('a) CARD('a)"

subsection \<open>Instantiations for \<open>card_UNIV\<close>\<close>

instantiation nat :: card_UNIV begin
definition "finite_UNIV = Phantom(nat) False"
definition "card_UNIV = Phantom(nat) 0"
instance by intro_classes (simp_all add: finite_UNIV_nat_def card_UNIV_nat_def)
end

instantiation int :: card_UNIV begin
definition "finite_UNIV = Phantom(int) False"
definition "card_UNIV = Phantom(int) 0"
instance by intro_classes (simp_all add: card_UNIV_int_def finite_UNIV_int_def infinite_UNIV_int)
end

instantiation natural :: card_UNIV begin
definition "finite_UNIV = Phantom(natural) False"
definition "card_UNIV = Phantom(natural) 0"
instance
  by standard
    (auto simp add: finite_UNIV_natural_def card_UNIV_natural_def card_eq_0_iff
      type_definition.univ [OF type_definition_natural] natural_eq_iff
      dest!: finite_imageD intro: inj_onI)
end

instantiation integer :: card_UNIV begin
definition "finite_UNIV = Phantom(integer) False"
definition "card_UNIV = Phantom(integer) 0"
instance
  by standard
    (auto simp add: finite_UNIV_integer_def card_UNIV_integer_def card_eq_0_iff
      type_definition.univ [OF type_definition_integer] infinite_UNIV_int
      dest!: finite_imageD intro: inj_onI)
end

instantiation list :: (type) card_UNIV begin
definition "finite_UNIV = Phantom('a list) False"
definition "card_UNIV = Phantom('a list) 0"
instance by intro_classes (simp_all add: card_UNIV_list_def finite_UNIV_list_def infinite_UNIV_listI)
end

instantiation unit :: card_UNIV begin
definition "finite_UNIV = Phantom(unit) True"
definition "card_UNIV = Phantom(unit) 1"
instance by intro_classes (simp_all add: card_UNIV_unit_def finite_UNIV_unit_def)
end

instantiation bool :: card_UNIV begin
definition "finite_UNIV = Phantom(bool) True"
definition "card_UNIV = Phantom(bool) 2"
instance by(intro_classes)(simp_all add: card_UNIV_bool_def finite_UNIV_bool_def)
end

instantiation char :: card_UNIV begin
definition "finite_UNIV = Phantom(char) True"
definition "card_UNIV = Phantom(char) 256"
instance by intro_classes (simp_all add: card_UNIV_char_def card_UNIV_char finite_UNIV_char_def)
end

instantiation prod :: (finite_UNIV, finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a \<times> 'b)
  (of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> of_phantom (finite_UNIV :: 'b finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_prod_def finite_UNIV finite_prod)
end

instantiation prod :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a \<times> 'b)
  (of_phantom (card_UNIV :: 'a card_UNIV) * of_phantom (card_UNIV :: 'b card_UNIV))"
instance by intro_classes (simp add: card_UNIV_prod_def card_UNIV)
end

instantiation sum :: (finite_UNIV, finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a + 'b)
  (of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> of_phantom (finite_UNIV :: 'b finite_UNIV))"
instance
  by intro_classes (simp add: UNIV_Plus_UNIV[symmetric] finite_UNIV_sum_def finite_UNIV del: UNIV_Plus_UNIV)
end

instantiation sum :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a + 'b)
  (let ca = of_phantom (card_UNIV :: 'a card_UNIV);
       cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in if ca \<noteq> 0 \<and> cb \<noteq> 0 then ca + cb else 0)"
instance by intro_classes (auto simp add: card_UNIV_sum_def card_UNIV card_UNIV_sum)
end

instantiation "fun" :: (finite_UNIV, card_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a \<Rightarrow> 'b)
  (let cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in cb = 1 \<or> of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> cb \<noteq> 0)"
instance
  by intro_classes (auto simp add: finite_UNIV_fun_def Let_def card_UNIV finite_UNIV finite_UNIV_fun card_gt_0_iff)
end

instantiation "fun" :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a \<Rightarrow> 'b)
  (let ca = of_phantom (card_UNIV :: 'a card_UNIV);
       cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in if ca \<noteq> 0 \<and> cb \<noteq> 0 \<or> cb = 1 then cb ^ ca else 0)"
instance by intro_classes (simp add: card_UNIV_fun_def card_UNIV Let_def card_fun)
end

instantiation option :: (finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a option) (of_phantom (finite_UNIV :: 'a finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_option_def finite_UNIV)
end

instantiation option :: (card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a option)
  (let c = of_phantom (card_UNIV :: 'a card_UNIV) in if c \<noteq> 0 then Suc c else 0)"
instance by intro_classes (simp add: card_UNIV_option_def card_UNIV card_UNIV_option)
end

instantiation String.literal :: card_UNIV begin
definition "finite_UNIV = Phantom(String.literal) False"
definition "card_UNIV = Phantom(String.literal) 0"
instance
  by intro_classes (simp_all add: card_UNIV_literal_def finite_UNIV_literal_def infinite_literal card_literal)
end

instantiation set :: (finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a set) (of_phantom (finite_UNIV :: 'a finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_set_def finite_UNIV Finite_Set.finite_set)
end

instantiation set :: (card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a set)
  (let c = of_phantom (card_UNIV :: 'a card_UNIV) in if c = 0 then 0 else 2 ^ c)"
instance by intro_classes (simp add: card_UNIV_set_def card_UNIV_set card_UNIV)
end

lemma UNIV_finite_1: "UNIV = set [finite_1.a\<^sub>1]"
by(auto intro: finite_1.exhaust)

lemma UNIV_finite_2: "UNIV = set [finite_2.a\<^sub>1, finite_2.a\<^sub>2]"
by(auto intro: finite_2.exhaust)

lemma UNIV_finite_3: "UNIV = set [finite_3.a\<^sub>1, finite_3.a\<^sub>2, finite_3.a\<^sub>3]"
by(auto intro: finite_3.exhaust)

lemma UNIV_finite_4: "UNIV = set [finite_4.a\<^sub>1, finite_4.a\<^sub>2, finite_4.a\<^sub>3, finite_4.a\<^sub>4]"
by(auto intro: finite_4.exhaust)

lemma UNIV_finite_5:
  "UNIV = set [finite_5.a\<^sub>1, finite_5.a\<^sub>2, finite_5.a\<^sub>3, finite_5.a\<^sub>4, finite_5.a\<^sub>5]"
by(auto intro: finite_5.exhaust)

instantiation Enum.finite_1 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_1) True"
definition "card_UNIV = Phantom(Enum.finite_1) 1"
instance
  by intro_classes (simp_all add: UNIV_finite_1 card_UNIV_finite_1_def finite_UNIV_finite_1_def)
end

instantiation Enum.finite_2 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_2) True"
definition "card_UNIV = Phantom(Enum.finite_2) 2"
instance
  by intro_classes (simp_all add: UNIV_finite_2 card_UNIV_finite_2_def finite_UNIV_finite_2_def)
end

instantiation Enum.finite_3 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_3) True"
definition "card_UNIV = Phantom(Enum.finite_3) 3"
instance
  by intro_classes (simp_all add: UNIV_finite_3 card_UNIV_finite_3_def finite_UNIV_finite_3_def)
end

instantiation Enum.finite_4 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_4) True"
definition "card_UNIV = Phantom(Enum.finite_4) 4"
instance
  by intro_classes (simp_all add: UNIV_finite_4 card_UNIV_finite_4_def finite_UNIV_finite_4_def)
end

instantiation Enum.finite_5 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_5) True"
definition "card_UNIV = Phantom(Enum.finite_5) 5"
instance
  by intro_classes (simp_all add: UNIV_finite_5 card_UNIV_finite_5_def finite_UNIV_finite_5_def)
end

subsection \<open>Code setup for sets\<close>

text \<open>
  Implement @{term "CARD('a)"} via @{term card_UNIV} and provide
  implementations for @{term "finite"}, @{term "card"}, @{term "op \<subseteq>"},
  and @{term "op ="}if the calling context already provides @{class finite_UNIV}
  and @{class card_UNIV} instances. If we implemented the latter
  always via @{term card_UNIV}, we would require instances of essentially all
  element types, i.e., a lot of instantiation proofs and -- at run time --
  possibly slow dictionary constructions.
\<close>

context
begin

qualified definition card_UNIV' :: "'a card_UNIV"
where [code del]: "card_UNIV' = Phantom('a) CARD('a)"

lemma CARD_code [code_unfold]:
  "CARD('a) = of_phantom (card_UNIV' :: 'a card_UNIV)"
by(simp add: card_UNIV'_def)

lemma card_UNIV'_code [code]:
  "card_UNIV' = card_UNIV"
by(simp add: card_UNIV card_UNIV'_def)

end

lemma card_Compl:
  "finite A \<Longrightarrow> card (- A) = card (UNIV :: 'a set) - card (A :: 'a set)"
by (metis Compl_eq_Diff_UNIV card_Diff_subset top_greatest)

context fixes xs :: "'a :: finite_UNIV list"
begin

qualified definition finite' :: "'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "finite' = finite"

lemma finite'_code [code]:
  "finite' (set xs) \<longleftrightarrow> True"
  "finite' (List.coset xs) \<longleftrightarrow> of_phantom (finite_UNIV :: 'a finite_UNIV)"
by(simp_all add: card_gt_0_iff finite_UNIV)

end

context fixes xs :: "'a :: card_UNIV list"
begin

qualified definition card' :: "'a set \<Rightarrow> nat"
where [simp, code del, code_abbrev]: "card' = card"

lemma card'_code [code]:
  "card' (set xs) = length (remdups xs)"
  "card' (List.coset xs) = of_phantom (card_UNIV :: 'a card_UNIV) - length (remdups xs)"
by(simp_all add: List.card_set card_Compl card_UNIV)

qualified definition subset' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "subset' = op \<subseteq>"

lemma subset'_code [code]:
  "subset' A (List.coset ys) \<longleftrightarrow> (\<forall>y \<in> set ys. y \<notin> A)"
  "subset' (set ys) B \<longleftrightarrow> (\<forall>y \<in> set ys. y \<in> B)"
  "subset' (List.coset xs) (set ys) \<longleftrightarrow> (let n = CARD('a) in n > 0 \<and> card(set (xs @ ys)) = n)"
by(auto simp add: Let_def card_gt_0_iff dest: card_eq_UNIV_imp_eq_UNIV intro: arg_cong[where f=card])
  (metis finite_compl finite_set rev_finite_subset)

qualified definition eq_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del, code_abbrev]: "eq_set = op ="

lemma eq_set_code [code]:
  fixes ys
  defines "rhs \<equiv>
  let n = CARD('a)
  in if n = 0 then False else
        let xs' = remdups xs; ys' = remdups ys
        in length xs' + length ys' = n \<and> (\<forall>x \<in> set xs'. x \<notin> set ys') \<and> (\<forall>y \<in> set ys'. y \<notin> set xs')"
  shows "eq_set (List.coset xs) (set ys) \<longleftrightarrow> rhs"
  and "eq_set (set ys) (List.coset xs) \<longleftrightarrow> rhs"
  and "eq_set (set xs) (set ys) \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys) \<and> (\<forall>y \<in> set ys. y \<in> set xs)"
  and "eq_set (List.coset xs) (List.coset ys) \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys) \<and> (\<forall>y \<in> set ys. y \<in> set xs)"
proof goal_cases
  {
    case 1
    show ?case (is "?lhs \<longleftrightarrow> ?rhs")
    proof
      show ?rhs if ?lhs
        using that
        by (auto simp add: rhs_def Let_def List.card_set[symmetric]
          card_Un_Int[where A="set xs" and B="- set xs"] card_UNIV
          Compl_partition card_gt_0_iff dest: sym)(metis finite_compl finite_set)
      show ?lhs if ?rhs
      proof -
        have "\<lbrakk> \<forall>y\<in>set xs. y \<notin> set ys; \<forall>x\<in>set ys. x \<notin> set xs \<rbrakk> \<Longrightarrow> set xs \<inter> set ys = {}" by blast
        with that show ?thesis
          by (auto simp add: rhs_def Let_def List.card_set[symmetric]
            card_UNIV card_gt_0_iff card_Un_Int[where A="set xs" and B="set ys"]
            dest: card_eq_UNIV_imp_eq_UNIV split: if_split_asm)
      qed
    qed
  }
  moreover
  case 2
  ultimately show ?case unfolding eq_set_def by blast
next
  case 3
  show ?case unfolding eq_set_def List.coset_def by blast
next
  case 4
  show ?case unfolding eq_set_def List.coset_def by blast
qed

end

text \<open>
  Provide more informative exceptions than Match for non-rewritten cases.
  If generated code raises one these exceptions, then a code equation calls
  the mentioned operator for an element type that is not an instance of
  @{class card_UNIV} and is therefore not implemented via @{term card_UNIV}.
  Constrain the element type with sort @{class card_UNIV} to change this.
\<close>

lemma card_coset_error [code]:
  "card (List.coset xs) =
   Code.abort (STR ''card (List.coset _) requires type class instance card_UNIV'')
     (\<lambda>_. card (List.coset xs))"
by(simp)

lemma coset_subseteq_set_code [code]:
  "List.coset xs \<subseteq> set ys \<longleftrightarrow>
  (if xs = [] \<and> ys = [] then False
   else Code.abort
     (STR ''subset_eq (List.coset _) (List.set _) requires type class instance card_UNIV'')
     (\<lambda>_. List.coset xs \<subseteq> set ys))"
by simp

notepad begin \<comment> "test code setup"
have "List.coset [True] = set [False] \<and>
      List.coset [] \<subseteq> List.set [True, False] \<and>
      finite (List.coset [True])"
  by eval
end

end


section \<open>Lazy Lists\<close>

theory LazyList
imports HOLCF "HOLCF-Library.Int_Discrete"
begin

domain 'a LList = LNil | LCons (lazy 'a) (lazy "'a LList")

fixrec
  mapL :: "('a \<rightarrow> 'b) \<rightarrow> 'a LList \<rightarrow> 'b LList"
where
  "mapL\<cdot>f\<cdot>LNil = LNil"
| "mapL\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs) = LCons\<cdot>(f\<cdot>x)\<cdot>(mapL\<cdot>f\<cdot>xs)"

lemma mapL_strict [simp]: "mapL\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec
  filterL :: "('a \<rightarrow> tr) \<rightarrow> 'a LList \<rightarrow> 'a LList"
where
  "filterL\<cdot>p\<cdot>LNil = LNil"
| "filterL\<cdot>p\<cdot>(LCons\<cdot>x\<cdot>xs) =
    (If p\<cdot>x then LCons\<cdot>x\<cdot>(filterL\<cdot>p\<cdot>xs) else filterL\<cdot>p\<cdot>xs)"

lemma filterL_strict [simp]: "filterL\<cdot>p\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec
  foldrL :: "('a \<rightarrow> 'b \<rightarrow> 'b) \<rightarrow> 'b \<rightarrow> 'a LList \<rightarrow> 'b"
where
  "foldrL\<cdot>f\<cdot>z\<cdot>LNil = z"
| "foldrL\<cdot>f\<cdot>z\<cdot>(LCons\<cdot>x\<cdot>xs) = f\<cdot>x\<cdot>(foldrL\<cdot>f\<cdot>z\<cdot>xs)"

lemma foldrL_strict [simp]: "foldrL\<cdot>f\<cdot>z\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec
  enumFromToL :: "int\<^sub>\<bottom> \<rightarrow> int\<^sub>\<bottom> \<rightarrow> (int\<^sub>\<bottom>) LList"
where
  "enumFromToL\<cdot>(up\<cdot>x)\<cdot>(up\<cdot>y) =
    (if x \<le> y then LCons\<cdot>(up\<cdot>x)\<cdot>(enumFromToL\<cdot>(up\<cdot>(x+1))\<cdot>(up\<cdot>y)) else LNil)"

lemma enumFromToL_simps' [simp]:
  "x \<le> y \<Longrightarrow>
    enumFromToL\<cdot>(up\<cdot>x)\<cdot>(up\<cdot>y) = LCons\<cdot>(up\<cdot>x)\<cdot>(enumFromToL\<cdot>(up\<cdot>(x+1))\<cdot>(up\<cdot>y))"
  "\<not> x \<le> y \<Longrightarrow> enumFromToL\<cdot>(up\<cdot>x)\<cdot>(up\<cdot>y) = LNil"
  by simp_all

declare enumFromToL.simps [simp del]

lemma enumFromToL_strict [simp]:
  "enumFromToL\<cdot>\<bottom>\<cdot>y = \<bottom>"
  "enumFromToL\<cdot>x\<cdot>\<bottom> = \<bottom>"
apply (subst enumFromToL.unfold, simp)
apply (induct x)
apply (subst enumFromToL.unfold, simp)+
done

fixrec
  appendL :: "'a LList \<rightarrow> 'a LList \<rightarrow> 'a LList"
where
  "appendL\<cdot>LNil\<cdot>ys = ys"
| "appendL\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>ys = LCons\<cdot>x\<cdot>(appendL\<cdot>xs\<cdot>ys)"

lemma appendL_strict [simp]: "appendL\<cdot>\<bottom>\<cdot>ys = \<bottom>"
by fixrec_simp

lemma appendL_LNil_right: "appendL\<cdot>xs\<cdot>LNil = xs"
by (induct xs) simp_all

fixrec
  zipWithL :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> 'a LList \<rightarrow> 'b LList \<rightarrow> 'c LList"
where
  "zipWithL\<cdot>f\<cdot>LNil\<cdot>ys = LNil"
| "zipWithL\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>LNil = LNil"
| "zipWithL\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>(LCons\<cdot>y\<cdot>ys) = LCons\<cdot>(f\<cdot>x\<cdot>y)\<cdot>(zipWithL\<cdot>f\<cdot>xs\<cdot>ys)"

lemma zipWithL_strict [simp]:
  "zipWithL\<cdot>f\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "zipWithL\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

fixrec
  concatMapL :: "('a \<rightarrow> 'b LList) \<rightarrow> 'a LList \<rightarrow> 'b LList"
where
  "concatMapL\<cdot>f\<cdot>LNil = LNil"
| "concatMapL\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs) = appendL\<cdot>(f\<cdot>x)\<cdot>(concatMapL\<cdot>f\<cdot>xs)"

lemma concatMapL_strict [simp]: "concatMapL\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

end


theory prop_42
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun union :: "Nat list => Nat list => Nat list" where
  "union (Nil2) y = y"
  | "union (Cons2 z xs) y =
       (if elem z y then union xs y else Cons2 z (union xs y))"
  (*hipster equal2 elem union *)

(*hipster equal2*)
lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

(*hipster_cond equal2*)

lemma lemma_ac [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ae [thy_expl]: "elem x9 z9 \<Longrightarrow> elem x9 (union y9 z9) = True"
by (hipster_induct_schemes elem.simps equal2.simps union.simps elem.simps)

lemma lemma_af [thy_expl]: "elem x1 z1 \<Longrightarrow> union (Cons2 x1 y1) (union z1 xa1) = union y1 (union z1 xa1)"
by (hipster_induct_schemes elem.simps equal2.simps union.simps elem.simps)

lemma lemma_ag [thy_expl]: "elem x1 y1 \<Longrightarrow> union (Cons2 x1 Nil2) (union y1 z1) = union y1 z1"
by (hipster_induct_schemes elem.simps equal2.simps union.simps elem.simps)

  theorem x0 :
    "(elem x y) ==> (elem x (union y z))"
    by (hipster_induct_schemes equal2.simps union.simps elem.simps)

end


theory Memdata
  imports Main Integers Values AST Archi
begin

(** In-memory representation of values. *)

section \<open>Properties of memory chunks\<close>

(** Memory reads and writes are performed by quantities called memory chunks,
  encoding the type, size and signedness of the chunk being addressed.
  The following functions extract the size information from a chunk. *)

fun size_chunk_nat :: "memory_chunk \<Rightarrow> nat" where
  "size_chunk_nat Mint8signed = 1"
| "size_chunk_nat Mint8unsigned = 1"
| "size_chunk_nat Mint16signed = 2"
| "size_chunk_nat Mint16unsigned = 2"
| "size_chunk_nat Mint32 = 4"
| "size_chunk_nat Mint64 = 8"
| "size_chunk_nat Mfloat32 = 4"
| "size_chunk_nat Mfloat64 = 8"
| "size_chunk_nat Many32 = 4"
| "size_chunk_nat Many64 = 8"

lemma size_chunk_nat_pos[iff]: "0 < size_chunk_nat chunk"
  by (cases chunk) auto

fun size_chunk :: "memory_chunk \<Rightarrow> Z" where
  "size_chunk chunk = int (size_chunk_nat chunk)"

(** Memory reads and writes must respect alignment constraints:
  the byte offset of the location being addressed should be an exact
  multiple of the natural alignment for the chunk being addressed.
  This natural alignment is defined by the following
  [align_chunk] function.  Some target architectures
  (e.g. PowerPC and x86) have no alignment constraints, which we could
  reflect by taking [align_chunk chunk = 1].  However, other architectures
  have stronger alignment requirements.  The following definition is
  appropriate for PowerPC, ARM and x86. *)

fun align_chunk :: "memory_chunk \<Rightarrow> Z" where
  "align_chunk Mint8signed = 1"
| "align_chunk Mint8unsigned = 1"
| "align_chunk Mint16signed = 2"
| "align_chunk Mint16unsigned = 2"
| "align_chunk Mint32 = 4"
| "align_chunk Mint64 = 8"
| "align_chunk Mfloat32 = 4"
| "align_chunk Mfloat64 = 4"
| "align_chunk Many32 = 4"
| "align_chunk Many64 = 4"

lemma align_dvd_size[iff]: "align_chunk chunk dvd int (size_chunk_nat chunk)"
  apply (cases chunk)
  by auto

lemma align_dvd_size_mult: "align_chunk chunk dvd i*size_chunk chunk"
  apply (cases chunk)
  by auto

datatype quantity = Q32 | Q64

fun size_quantity_nat :: "quantity \<Rightarrow> nat" where
  "size_quantity_nat Q32 = 4" | "size_quantity_nat Q64 = 8"

lemma [iff]: "(0::nat) < size_quantity_nat q"
  apply (cases q)
  by auto

lemma size_quantity_nat_set: "size_quantity_nat q \<in> {4,8}"
  apply (cases q)
  by auto

section \<open>Memory values\<close>

(** A ``memory value'' is a byte-sized quantity that describes the current
  content of a memory cell.  It can be either:
- a concrete 8-bit integer;
- a byte-sized fragment of an opaque value;
- the special constant [Undef] that represents uninitialized memory.
*)

(** Values stored in memory cells. *)

datatype memval =
    Undef
  | Byte m_byte
  | Fragment val quantity nat

subsection \<open>Encoding and decoding integers\<close>

(** We define functions to convert between integers and lists of bytes
  of a given length *)

fun bytes_of_int :: "nat \<Rightarrow> int \<Rightarrow> (m_byte list)" where
  "bytes_of_int 0 _ = []"
| "bytes_of_int (Suc m) x = Byte.repr x # bytes_of_int m (x div 256)"

fun int_of_bytes :: "(m_byte list) \<Rightarrow> int" where
  "int_of_bytes [] = 0"
| "int_of_bytes (b # l') = Byte.unsigned b + int_of_bytes l' * 256"

lemma int_to_bytes_to_int[simp]: "int_of_bytes (bytes_of_int n x) = (x mod (2 ^ (8 * n)))"
proof (induction n x rule: bytes_of_int.induct)
  case (1 uu)
  then show ?case
    by auto
next
  case (2 m x)

  note steps =
    mod_div_mult_eq[of "x mod 2 ^ (8 + 8 * m)" "256", symmetric]
    mod_exp_eq[of x "8 + 8 * m" "8", simplified]
    div_exp_mod_exp_eq[of x 8 "8 * m", simplified]

  show ?case
    apply (simp add: 2)
    apply (subst steps(1))
    apply (subst steps(2))
    apply (subst steps(3))
    by (simp add: take_bit_eq_mod)
qed

lemma length_bytes_of_int[simp]: "length (bytes_of_int sz i) = sz"
  apply (induction sz i rule: bytes_of_int.induct)
  by (auto)

lemma bytes_of_int_truncate: "x = (2 ^ (8*sz)) \<Longrightarrow> bytes_of_int sz (i mod x) = bytes_of_int sz i"
  apply (induction sz i arbitrary: x rule: bytes_of_int.induct)
   apply (auto simp add: Byte.repr_mod)
  subgoal for m x
    using div_exp_mod_exp_eq[of x 8 "8*m"]
    by auto
  done

declare bytes_of_int.simps[simp del] int_of_bytes.simps[simp del]

definition rev_if_be :: "(m_byte list) \<Rightarrow> (m_byte list)" where
  "rev_if_be l = (if Archi.big_endian then List.rev l else l)"

(* only valid for 64bit *)

definition encode_int :: "nat \<Rightarrow> int \<Rightarrow> (m_byte list)" where
  "encode_int sz x = rev_if_be (bytes_of_int sz x)"

lemma encode_int_length[simp]:
  "length (encode_int sz x) = sz"
  unfolding encode_int_def by simp

lemma encode_int_truncate: "x = (2 ^ (8*sz)) \<Longrightarrow> encode_int sz (i mod x) = encode_int sz i"
  unfolding encode_int_def
  using bytes_of_int_truncate by simp

lemma encode_int_truncate':
  assumes "LENGTH('w::len) = 8*sz"
  shows "(encode_int sz (uint (UCAST('x::len \<rightarrow> 'w) i))) = (encode_int sz (uint i))"
  apply (simp add: unsigned_ucast_eq take_bit_eq_mod)
  using assms(1) encode_int_truncate
  by simp

definition decode_int :: "(m_byte list) \<Rightarrow> int" where
  "decode_int b = int_of_bytes (rev_if_be b)"

lemma encode_decode_int[simp]: "decode_int (encode_int sz x) = (x mod (2 ^ (8 * sz)))"
  unfolding encode_int_def decode_int_def
  using int_to_bytes_to_int
  by auto

subsection \<open>Encoding and decoding values\<close>

definition inj_bytes :: "(m_byte list) \<Rightarrow> (memval list)" where
  "inj_bytes bl = List.map Byte bl"

lemma inj_bytes_length[simp]:
  "length (inj_bytes bl) = length bl"
  unfolding inj_bytes_def by simp

lemma inj_bytes_valid[iff]:
  "Undef \<notin> set (inj_bytes bl)"
  unfolding inj_bytes_def
  by auto

fun proj_bytes :: "(memval list) \<Rightarrow> ((m_byte list) option)" where
  "proj_bytes [] = Some []"
| "proj_bytes (Byte b # vl) = (case proj_bytes vl of None \<Rightarrow> None | Some bl \<Rightarrow> Some(b # bl))"
| "proj_bytes _ = None"

lemma proj_inj_bytes[simp]: "proj_bytes (inj_bytes bs) = Some bs"
  unfolding inj_bytes_def
  by (induction bs) auto

lemma proj_bytes_undef[simp]: "proj_bytes (replicate l Undef) = None" if "l > 0"
  using that
  by (cases l) auto

fun inj_value_rec :: "nat \<Rightarrow> val \<Rightarrow> quantity \<Rightarrow> (memval list)" where
  "inj_value_rec 0 v q = []"
| "inj_value_rec (Suc m) v q = Fragment v q m # inj_value_rec m v q"

lemma inj_value_rec_n: "n > 0 \<Longrightarrow> inj_value_rec n v q = Fragment v q (n-1) # inj_value_rec (n-1) v q"
  by (metis Suc_diff_1 inj_value_rec.simps(2))

lemma inj_value_rec_length[simp]: "length (inj_value_rec s v q) = s"
  apply (induction s)
  by auto

lemma inj_value_rec_valid[iff]:
  "Undef \<notin> set (inj_value_rec s v q)"
  apply (induction s)
  by auto

definition inj_value :: "quantity \<Rightarrow> val \<Rightarrow> (memval list)" where
  "inj_value q v = inj_value_rec (size_quantity_nat q) v q"

lemma inj_value_first: "inj_value q v = Fragment v q (size_quantity_nat q - 1) # inj_value_rec (size_quantity_nat q - 1) v q"
  unfolding inj_value_def
  using inj_value_rec_n by simp

lemma inj_value_length[simp]: "length (inj_value q v) = size_quantity_nat q"
  unfolding inj_value_def
  by simp

lemma inj_value_valid[iff]:
  "Undef \<notin> set (inj_value q v)"
  unfolding inj_value_def
  by simp

fun check_value :: "nat \<Rightarrow> val \<Rightarrow> quantity \<Rightarrow> (memval list) \<Rightarrow> bool" where
  "check_value 0 v q [] = True"
| "check_value (Suc m) v q (Fragment v' q' m' # vl') =
    (v = v' \<and> q = q' \<and> m = m' \<and> check_value m v q vl')"
| "check_value _ v q _ = False"

lemma check_inj_value[simp]: "check_value sz v q (inj_value_rec sz v q) = True"
  apply (induction sz v q rule: inj_value_rec.induct)
  by auto

definition proj_value :: "quantity \<Rightarrow> (memval list) \<Rightarrow> val" where
  "proj_value q vl = (case vl of
    (Fragment v q' n # vl') \<Rightarrow> (if check_value (size_quantity_nat q) v q vl then v else Vundef)
  | _ \<Rightarrow> Vundef)"

lemma proj_inj_value[simp]: "proj_value q (inj_value q v) = v"
  unfolding inj_value_def proj_value_def
  apply (subst (2) inj_value_rec_n)
   apply (cases q)
  by auto

lemma proj_bytes_inj_value[simp]: "proj_bytes (inj_value v q) = None"
  unfolding inj_value_def
  apply (subst inj_value_rec_n)
  by auto

lemma proj_value_undef[simp]: "proj_value x (Undef # l) = Vundef"
  unfolding proj_value_def by simp

lemma proj_value_undef'[simp]: "proj_value q (replicate l Undef) = Vundef"
  unfolding proj_value_def
  by (cases l) auto

fun encode_val :: "memory_chunk \<Rightarrow> val \<Rightarrow> (memval list)" where
  "encode_val chunk v =
  (case (v, chunk) of
    (Vint n, Mint8signed) \<Rightarrow> inj_bytes (encode_int 1 (uint n))
  | (Vint n, Mint8unsigned) \<Rightarrow> inj_bytes (encode_int 1 (uint n))
  | (Vint n, Mint16signed) \<Rightarrow> inj_bytes (encode_int 2 (uint n))
  | (Vint n, Mint16unsigned) \<Rightarrow> inj_bytes (encode_int 2 (uint n))
  | (Vint n, Mint32) \<Rightarrow> inj_bytes (encode_int 4 (uint n))
  | (Vptr b ofs, Mint32) \<Rightarrow> if Archi.ptr64 then replicate 4 Undef else inj_value Q32 v
  | (Vlong n, Mint64) \<Rightarrow> inj_bytes (encode_int 8 (uint n))
  | (Vptr b ofs, Mint64) \<Rightarrow> if Archi.ptr64 then inj_value Q64 v else replicate 8 Undef
  | (Vsingle n, Mfloat32) \<Rightarrow> inj_bytes (encode_int 4 (uint (fp32_of_float n)))
  | (Vfloat n, Mfloat64) \<Rightarrow> inj_bytes (encode_int 8 (uint (fp64_of_float n)))
  | (_, Many32) \<Rightarrow> inj_value Q32 v
  | (_, Many64) \<Rightarrow> inj_value Q64 v
  | (_, _) \<Rightarrow> replicate (size_chunk_nat chunk) Undef
  )"

lemma encode_val_length[simp]:
  "length (encode_val chunk v) = size_chunk_nat chunk"
  apply (cases chunk; cases v)
  by auto

lemma encode_val_length'[simp]: "int (length (encode_val chunk v)) = size_chunk chunk"
  using encode_val_length by auto

fun decode_val :: "memory_chunk \<Rightarrow> (memval list) \<Rightarrow> val" where
  "decode_val chunk vl =
  (case proj_bytes vl of
    Some bl \<Rightarrow>
      (case chunk of
        Mint8signed \<Rightarrow> Vint(scast (Byte.repr (decode_int bl)))
      | Mint8unsigned \<Rightarrow> Vint(ucast (Byte.repr (decode_int bl)))
      | Mint16signed \<Rightarrow> Vint(scast (Short.repr (decode_int bl)))
      | Mint16unsigned \<Rightarrow> Vint(ucast (Short.repr (decode_int bl)))
      | Mint32 \<Rightarrow> Vint(Int.repr(decode_int bl))
      | Mint64 \<Rightarrow> Vlong(Int64.repr(decode_int bl))
      | Mfloat32 \<Rightarrow> Vsingle(Float32_repr (decode_int bl))
      | Mfloat64 \<Rightarrow> Vfloat(Float64_repr (decode_int bl))
      | Many32 \<Rightarrow> Vundef
      | Many64 \<Rightarrow> Vundef
      )
  | None \<Rightarrow>
      (case chunk of
        Mint32 \<Rightarrow> if Archi.ptr64 then Vundef else Val.load_result chunk (proj_value Q32 vl)
      | Many32 \<Rightarrow> Val.load_result chunk (proj_value Q32 vl)
      | Mint64 \<Rightarrow> if Archi.ptr64 then Val.load_result chunk (proj_value Q64 vl) else Vundef
      | Many64 \<Rightarrow> Val.load_result chunk (proj_value Q64 vl)
      | _ \<Rightarrow> Vundef
      )
  )"

lemma load_result[simp]:
  "decode_val chunk (encode_val chunk v) = Val.load_result chunk v"
  apply (cases chunk; cases v)
  by (auto)

section \<open>Compatibility with memory injections\<close>

(** Relating two memory values according to a memory injection. *)

inductive memval_inject :: "meminj \<Rightarrow> memval \<Rightarrow> memval \<Rightarrow> bool" where
    memval_inject_byte:
      "memval_inject f (Byte n) (Byte n)"
  | memval_inject_frag:
      "Val.inject f v1 v2 \<Longrightarrow>
      memval_inject f (Fragment v1 q n) (Fragment v2 q n)"
    | memval_inject_undef:
      "memval_inject f Undef mv"

lemmas encode_simps = encode_val.simps decode_val.simps

declare encode_simps[simp del]

end


theory Ltake_lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"
codatatype ENat = is_zero: EZ | ESuc (epred: ENat)
primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "is_zero n \<or> lnull xs \<Longrightarrow> lnull (ltake n xs)"
| "lhd (ltake n xs) = lhd xs"
| "ltl (ltake n xs) = ltake (epred n) (ltl xs)"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

(*hipster ltake lmap*)
lemma lemma_a [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
  apply (coinduction  arbitrary: y z rule: Ltake_lmap.Llist.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
apply (coinduction  arbitrary: x2 y z rule: Ltake_lmap.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "ltake y (ltake y z) = ltake y z"
apply (coinduction  arbitrary: y z rule: Ltake_lmap.Llist.coinduct_strong)
apply simp
by blast

lemma lemma_ac [thy_expl]: "ltl (ltake (ESuc y) z) = ltake y (ltl z)"
apply (coinduction  arbitrary: y z rule: Ltake_lmap.Llist.coinduct_strong)
apply simp
by (metis ENat.discI(2) ENat.sel Llist.sel(2) lnull_def ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_ad [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
apply (coinduction  arbitrary: x2 y z rule: Ltake_lmap.Llist.coinduct_strong)
apply simp
by blast

lemma lemma_ae [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y (ltake y z)"
apply (coinduction  arbitrary: y z rule: Ltake_lmap.Llist.coinduct_strong)
apply simp
by force

lemma lemma_af [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
apply (coinduction  arbitrary: x2 y z rule: Ltake_lmap.Llist.coinduct_strong)
by simp

lemma unknown [thy_expl]: "ltake (ESuc y) (ltl (ltl z)) = ltl (ltl z)"
oops

theorem ltake_lmap: "ltake n (lmap f xs) = lmap f (ltake n xs)"
 (* by hipster_coinduct_sledgehammer
  Metis: Failed to replay Metis proof
resynchronize: Out of sync
Failed to apply initial proof method
both before and after exploration
*)
  apply(coinduction arbitrary: n f xs rule: Llist.coinduct_strong)
    by (smt Llist.case_eq_if lmap.disc_iff(2) lmap.sel(1) lmap.simps(4) ltake.disc(1) ltake.disc(2) ltake.simps(3) ltake.simps(4))

end


subsection\<open>Peirce\<close>

theory Peirce
  imports Types
begin

text\<open>As an example of our $\lambda\mu$ formalisation, we show show a
     $\lambda\mu$-term inhabiting Peirce's Law. The example is due to
     Parigot~\<^cite>\<open>"DBLP:conf/lpar/Parigot92"\<close>.\<close>

text\<open>Peirce's law: $((A \rightarrow B) \rightarrow A) \rightarrow A$.\<close>

lemma "\<Gamma>, \<Delta> \<turnstile>\<^sub>T \<lambda> (A\<rightarrow>B)\<rightarrow>A: (\<mu> A:(<0>((`0) \<degree> (\<lambda> A: (\<mu> B:(<1> (`0)))))))
    : ((A\<rightarrow>B)\<rightarrow>A)\<rightarrow>A"
  by fastforce

end


theory DefNats
imports "../Naturals"

begin

(* less or equal to Z *)
definition leZ :: "Nat => bool" where
  "leZ x = (x = Z)"

(* greater or equal to Z *)
definition geZ :: "Nat => bool" where
  "geZ _ = True"

definition less :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "less a b = (leq a b \<and> \<not> leq b a)"

definition greater :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "greater a b = (geq a b \<and> (\<not> geq b a))"

definition leZZ :: "Nat \<Rightarrow> bool" where
  "leZZ x = eqN x Z"

(* TEST: hipster leq leZZ *)
lemma unknown2 [thy_expl]: "leZZ (S x) = False"
by(simp add: leZZ_def)

(* hipster_cond leZ add mul leq *)

(* hipster_cond leZ add leq
hipster_cond (leq x) leq leZ *)

(* for some reason, Naturals.leZ.simps appears BUT it should be Naturals.leZ_def since it is a definition...
    is it because we ourselves add it artificially to the simpset somewhere? or what is behind the appearance
    of leZ as a function with an associated simplification rule? *)
(* Uncomment: hipster_cond leZ leq *)
lemma unknown [thy_expl]: "leq x Z = leZ x" oops (*apply(induction x) apply(simp_all add: leZ_def)*)
lemma unknown [thy_expl]: "leZ Z = True" oops (* by (metis leZ_def) *)
lemma unknown [thy_expl]: "leZ (S x) = False" oops (* by (simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ (S Z) = False" oops (* by (simp add: leZ_def) BUT: is actually simpler than prior cases *)
lemma unknown [thy_expl]: "leq (S x) (S Z) = leZ x" oops (* redundant *)
lemma unknown [thy_expl]: "leZ x \<Longrightarrow> Z = x" oops (* again ... apply(simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ x \<Longrightarrow> leq x y = True" oops (* apply(simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ x \<Longrightarrow> leq x (S y) = True" oops (* apply(simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ y \<Longrightarrow> leq (S x) y = False" oops (* apply(simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ x \<Longrightarrow> leq (S x) (S y) = True" oops (* apply(simp add: leZ_def) *)
lemma unknown [thy_expl]: "leZ y \<and> leZ x \<Longrightarrow> x = y"  oops (* apply(simp add: leZ_def) *)

(*
(* cannot use \<Longleftrightarrow> ... is it because of the definitional nature of lt lifting it into meta-equality? *)
lemma lesslt : "less m n = lt m n"
apply(auto)
apply(induction m)
*)

end


theory Find_First imports Main begin

fun plus :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
where
  "plus None r = r"
| "plus l r = l"

lemma plus_assoc [simp]: "plus (plus x y) z = plus x (plus y z)"
by(cases x) simp_all

lemma plus_None [simp]: "plus x None = x"
by(cases x) simp_all

type_synonym ('a, 'b) af = "'a option \<times> 'b"

definition pure :: "'b \<Rightarrow> ('a, 'b) af"
where "pure x = (None, x)"

fun ap :: "('a, 'b \<Rightarrow> 'c) af \<Rightarrow> ('a, 'b) af \<Rightarrow> ('a, 'c) af" (infixl "\<diamond>" 60)
where "ap (u, f) (v, x) = (plus u v, f x)"

lemma af_identity: "pure id \<diamond> x = x"
unfolding pure_def by(cases x) simp

lemma af_homomorphism: "pure f \<diamond> pure x = pure (f x)"
unfolding pure_def by simp

lemma af_composition: "\<And>g f x. pure comp \<diamond> g \<diamond> f \<diamond> x = g \<diamond> (f \<diamond> x)"
unfolding pure_def by(clarsimp)

lemma af_interchange: "f \<diamond> pure x = pure (\<lambda>g. g x) \<diamond> f"
unfolding pure_def by(cases f) simp

definition H :: "('x, ('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c) af"
where "H = pure (\<lambda>f x y. f x y x)"

lemma ap_H: "H \<diamond> f \<diamond> x \<diamond> y = f \<diamond> x \<diamond> y \<diamond> x"
unfolding H_def pure_def
apply(cases f)
apply(cases x)
apply(cases y)
apply(rename_tac u f' v g' w x')
apply(case_tac u)
 apply(case_tac v)
  apply(case_tac w)
 apply simp_all
done

end