(* Author: Gerwin Klein, Tobias Nipkow *)

theory Repeat_Big_Step imports "~~/src/HOL/IMP/BExp" begin

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
(* begin mod *)
      | Repeat com bexp         ("(REPEAT _/ UNTIL _)"  [0, 61] 61)
(* end mod *)

subsection "Big-Step Semantics of Commands"

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
(* begin mod *) |
RepeatTrue: "\<lbrakk> (c,s\<^sub>1) \<Rightarrow> s\<^sub>2; bval b s\<^sub>2 \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b,s\<^sub>1) \<Rightarrow> s\<^sub>2" |
RepeatFalse:
"\<lbrakk> (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  \<not> bval b s\<^sub>2;  (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
(* end mod *)

text{* Proof automation: *}

declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

subsection "Rule inversion"

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"

(* begin mod *)
inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b,s) \<Rightarrow> t"
thm RepeatE
(* end mod *)

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

subsection "Execution is deterministic"

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

end


(*  Title:      HOL/Basic_BNFs.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012

Registration of basic types as bounded natural functors.
*)

section \<open>Registration of Basic Types as Bounded Natural Functors\<close>

theory Basic_BNFs
imports BNF_Def
begin

inductive_set setl :: "'a + 'b \<Rightarrow> 'a set" for s :: "'a + 'b" where
  "s = Inl x \<Longrightarrow> x \<in> setl s"
inductive_set setr :: "'a + 'b \<Rightarrow> 'b set" for s :: "'a + 'b" where
  "s = Inr x \<Longrightarrow> x \<in> setr s"

lemma sum_set_defs[code]:
  "setl = (\<lambda>x. case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {})"
  "setr = (\<lambda>x. case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {})"
  by (auto simp: fun_eq_iff intro: setl.intros setr.intros elim: setl.cases setr.cases split: sum.splits)

lemma rel_sum_simps[code, simp]:
  "rel_sum R1 R2 (Inl a1) (Inl b1) = R1 a1 b1"
  "rel_sum R1 R2 (Inl a1) (Inr b2) = False"
  "rel_sum R1 R2 (Inr a2) (Inl b1) = False"
  "rel_sum R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
  by (auto intro: rel_sum.intros elim: rel_sum.cases)

inductive
   pred_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> bool" for P1 P2
where
  "P1 a \<Longrightarrow> pred_sum P1 P2 (Inl a)"
| "P2 b \<Longrightarrow> pred_sum P1 P2 (Inr b)"

lemma pred_sum_inject[code, simp]:
  "pred_sum P1 P2 (Inl a) \<longleftrightarrow> P1 a"
  "pred_sum P1 P2 (Inr b) \<longleftrightarrow> P2 b"
  by (simp add: pred_sum.simps)+

bnf "'a + 'b"
  map: map_sum
  sets: setl setr
  bd: natLeq
  wits: Inl Inr
  rel: rel_sum
  pred: pred_sum
proof -
  show "map_sum id id = id" by (rule map_sum.id)
next
  fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
  show "map_sum (g1 \<circ> f1) (g2 \<circ> f2) = map_sum g1 g2 \<circ> map_sum f1 f2"
    by (rule map_sum.comp[symmetric])
next
  fix x and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
  assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
         a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
  thus "map_sum f1 f2 x = map_sum g1 g2 x"
  proof (cases x)
    case Inl thus ?thesis using a1 by (clarsimp simp: sum_set_defs(1))
  next
    case Inr thus ?thesis using a2 by (clarsimp simp: sum_set_defs(2))
  qed
next
  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
  show "setl \<circ> map_sum f1 f2 = image f1 \<circ> setl"
    by (rule ext, unfold o_apply) (simp add: sum_set_defs(1) split: sum.split)
next
  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
  show "setr \<circ> map_sum f1 f2 = image f2 \<circ> setr"
    by (rule ext, unfold o_apply) (simp add: sum_set_defs(2) split: sum.split)
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix x :: "'o + 'p"
  show "|setl x| \<le>o natLeq"
    apply (rule ordLess_imp_ordLeq)
    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    by (simp add: sum_set_defs(1) split: sum.split)
next
  fix x :: "'o + 'p"
  show "|setr x| \<le>o natLeq"
    apply (rule ordLess_imp_ordLeq)
    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    by (simp add: sum_set_defs(2) split: sum.split)
next
  fix R1 R2 S1 S2
  show "rel_sum R1 R2 OO rel_sum S1 S2 \<le> rel_sum (R1 OO S1) (R2 OO S2)"
    by (force elim: rel_sum.cases)
next
  fix R S
  show "rel_sum R S = (\<lambda>x y.
    \<exists>z. (setl z \<subseteq> {(x, y). R x y} \<and> setr z \<subseteq> {(x, y). S x y}) \<and>
    map_sum fst fst z = x \<and> map_sum snd snd z = y)"
  unfolding sum_set_defs relcompp.simps conversep.simps fun_eq_iff
  by (fastforce elim: rel_sum.cases split: sum.splits)
qed (auto simp: sum_set_defs fun_eq_iff pred_sum.simps split: sum.splits)

inductive_set fsts :: "'a \<times> 'b \<Rightarrow> 'a set" for p :: "'a \<times> 'b" where
  "fst p \<in> fsts p"
inductive_set snds :: "'a \<times> 'b \<Rightarrow> 'b set" for p :: "'a \<times> 'b" where
  "snd p \<in> snds p"

lemma prod_set_defs[code]: "fsts = (\<lambda>p. {fst p})" "snds = (\<lambda>p. {snd p})"
  by (auto intro: fsts.intros snds.intros elim: fsts.cases snds.cases)

inductive
  rel_prod :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b \<times> 'd \<Rightarrow> bool" for R1 R2
where
  "\<lbrakk>R1 a b; R2 c d\<rbrakk> \<Longrightarrow> rel_prod R1 R2 (a, c) (b, d)"

inductive
  pred_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" for P1 P2
where
  "\<lbrakk>P1 a; P2 b\<rbrakk> \<Longrightarrow> pred_prod P1 P2 (a, b)"

lemma rel_prod_inject [code, simp]:
  "rel_prod R1 R2 (a, b) (c, d) \<longleftrightarrow> R1 a c \<and> R2 b d"
  by (auto intro: rel_prod.intros elim: rel_prod.cases)

lemma pred_prod_inject [code, simp]:
  "pred_prod P1 P2 (a, b) \<longleftrightarrow> P1 a \<and> P2 b"
  by (auto intro: pred_prod.intros elim: pred_prod.cases)

lemma rel_prod_conv:
  "rel_prod R1 R2 = (\<lambda>(a, b) (c, d). R1 a c \<and> R2 b d)"
  by (rule ext, rule ext) auto

definition
  pred_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "pred_fun A B = (\<lambda>f. \<forall>x. A x \<longrightarrow> B (f x))"

lemma pred_funI: "(\<And>x. A x \<Longrightarrow> B (f x)) \<Longrightarrow> pred_fun A B f"
  unfolding pred_fun_def by simp

bnf "'a \<times> 'b"
  map: map_prod
  sets: fsts snds
  bd: natLeq
  rel: rel_prod
  pred: pred_prod
proof (unfold prod_set_defs)
  show "map_prod id id = id" by (rule map_prod.id)
next
  fix f1 f2 g1 g2
  show "map_prod (g1 \<circ> f1) (g2 \<circ> f2) = map_prod g1 g2 \<circ> map_prod f1 f2"
    by (rule map_prod.comp[symmetric])
next
  fix x f1 f2 g1 g2
  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
  thus "map_prod f1 f2 x = map_prod g1 g2 x" by (cases x) simp
next
  fix f1 f2
  show "(\<lambda>x. {fst x}) \<circ> map_prod f1 f2 = image f1 \<circ> (\<lambda>x. {fst x})"
    by (rule ext, unfold o_apply) simp
next
  fix f1 f2
  show "(\<lambda>x. {snd x}) \<circ> map_prod f1 f2 = image f2 \<circ> (\<lambda>x. {snd x})"
    by (rule ext, unfold o_apply) simp
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix x
  show "|{fst x}| \<le>o natLeq"
    by (rule ordLess_imp_ordLeq) (simp add: finite_iff_ordLess_natLeq[symmetric])
next
  fix x
  show "|{snd x}| \<le>o natLeq"
    by (rule ordLess_imp_ordLeq) (simp add: finite_iff_ordLess_natLeq[symmetric])
next
  fix R1 R2 S1 S2
  show "rel_prod R1 R2 OO rel_prod S1 S2 \<le> rel_prod (R1 OO S1) (R2 OO S2)" by auto
next
  fix R S
  show "rel_prod R S = (\<lambda>x y.
    \<exists>z. ({fst z} \<subseteq> {(x, y). R x y} \<and> {snd z} \<subseteq> {(x, y). S x y}) \<and>
      map_prod fst fst z = x \<and> map_prod snd snd z = y)"
  unfolding prod_set_defs rel_prod_inject relcompp.simps conversep.simps fun_eq_iff
  by auto
qed auto

bnf "'a \<Rightarrow> 'b"
  map: "(\<circ>)"
  sets: range
  bd: "natLeq +c |UNIV :: 'a set|"
  rel: "rel_fun (=)"
  pred: "pred_fun (\<lambda>_. True)"
proof
  fix f show "id \<circ> f = id f" by simp
next
  fix f g show "(\<circ>) (g \<circ> f) = (\<circ>) g \<circ> (\<circ>) f"
  unfolding comp_def[abs_def] ..
next
  fix x f g
  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
  thus "f \<circ> x = g \<circ> x" by auto
next
  fix f show "range \<circ> (\<circ>) f = (`) f \<circ> range"
    by (auto simp add: fun_eq_iff)
next
  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
  apply (rule card_order_csum)
  apply (rule natLeq_card_order)
  by (rule card_of_card_order_on)
(*  *)
  show "cinfinite (natLeq +c ?U)"
    apply (rule cinfinite_csum)
    apply (rule disjI1)
    by (rule natLeq_cinfinite)
next
  fix f :: "'d => 'a"
  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
  also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
  finally show "|range f| \<le>o natLeq +c ?U" .
next
  fix R S
  show "rel_fun (=) R OO rel_fun (=) S \<le> rel_fun (=) (R OO S)" by (auto simp: rel_fun_def)
next
  fix R
  show "rel_fun (=) R = (\<lambda>x y.
    \<exists>z. range z \<subseteq> {(x, y). R x y} \<and> fst \<circ> z = x \<and> snd \<circ> z = y)"
  unfolding rel_fun_def subset_iff by (force simp: fun_eq_iff[symmetric])
qed (auto simp: pred_fun_def)

end


text_raw \<open>\subsection[Permutability]{Permutability\isalabel{subsec:permutability}}\<close>

theory Permutability
  imports ParticularStructureMorphisms
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Besides the notion of isomorphically unique particulars, presented in
  \autoref{subsec:isomorphical-uniqueness}, we can also study the property
  of a particular in a particular structure through the endomorphisms of
  that structure.
\<close>

context ufo_particular_theory_sig
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  We say that a particular \<open>x\<close> in a particular structure \<open>\<Gamma>\<close> is permutable
  just in case there is an endomorphism \<open>\<phi>\<close> such that either \<open>\<phi> x \<noteq> x\<close>,
  i.e. it maps \<open>x\<close> to some other particular, or there is some particular
  \<open>y \<noteq> x\<close> such that \<open>\<phi> y = x\<close>, i.e. it maps some other particular to \<open>x\<close>.

  Conversely, we call it non-permutable if there is no other particular \<open>y\<close>
  such that \<open>x\<close> can be ``seen'' as \<open>y\<close> or that \<open>y\<close> can be ``seen'' as \<open>x\<close>,
  through an endomorphism.

  Formally, we define a non-permutable particular as:
\<close>

definition non_permutable :: \<open>'p \<Rightarrow> bool\<close> where
  \<open>non_permutable x \<longleftrightarrow> (\<forall>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>.\<forall>y \<in> \<P>. \<phi> y = x \<longleftrightarrow> y = x)\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> non_permutable_I[intro!]:
  assumes \<open>\<And>\<phi> y. \<lbrakk> \<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub> ; y \<in> \<P> \<rbrakk> \<Longrightarrow> \<phi> y = x \<longleftrightarrow> y = x\<close>
  shows \<open>non_permutable x\<close>
  using assms
  by (auto simp: non_permutable_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> non_permutable_E[elim]:
  assumes \<open>non_permutable x\<close> \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> \<open>y \<in> \<P>\<close>
  shows \<open>\<phi> y = x \<longleftrightarrow> y = x\<close>
  using assms
  by (auto simp: non_permutable_def)

lemmas non_permutable_iff[simp] = non_permutable_def

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The set of non-permutables particulars is defined as:
\<close>

definition non_permutables (\<open>\<P>\<^sub>1\<^sub>!\<close>) where
  \<open>\<P>\<^sub>1\<^sub>! \<equiv> { x . x \<in> \<P> \<and> non_permutable x }\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> non_permutables_I[intro!]:
  assumes \<open>x \<in> \<P>\<close> \<open>non_permutable x\<close>
  shows \<open>x \<in> \<P>\<^sub>1\<^sub>!\<close>
  using assms by (auto simp: non_permutables_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> non_permutables_E[elim!]:
  assumes \<open>x \<in> \<P>\<^sub>1\<^sub>!\<close>
  obtains \<open>x \<in> \<P>\<close> \<open>non_permutable x\<close>
  using assms by (auto simp: non_permutables_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> non_permutables_iff[simp]:
  \<open>x \<in> \<P>\<^sub>1\<^sub>! \<longleftrightarrow> x \<in> \<P> \<and> non_permutable x\<close>
  by (auto simp: non_permutables_def)

end

end


theory bin_times_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs) y = ZeroAnd (times xs y)"
| "times (OneAnd ys) y = plus (ZeroAnd (times ys y)) y"

(*hipster s plus times *)

theorem x0 :
  "!! (x :: Bin) (y :: Bin) . (times x y) = (times y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      JinjaThreads/J/DefAss.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section \<open>Definite assignment\<close>

theory DefAss
imports
  Expr
begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<squnion>" 65)
where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<sqinter>" 70)
where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "'a hyperset \<Rightarrow> 'a \<Rightarrow> 'a hyperset"   (infixl "\<ominus>" 65)
where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "'a \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50)
where
 "a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50)
where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "A \<sqsubseteq> A"
by(auto simp add: hyperset_defs)

lemma [iff]: "\<lfloor>A\<rfloor> \<sqsubseteq> \<lfloor>B\<rfloor> \<longleftrightarrow> A \<subseteq> B"
by(auto simp add: hyperset_defs)

lemma sqUn_lem2: "A \<sqsubseteq> A' \<Longrightarrow> B \<squnion> A \<sqsubseteq> B \<squnion> A'"
by(simp add:hyperset_defs) blast

lemma sqSub_trans [trans, intro]: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> C \<rbrakk> \<Longrightarrow> A \<sqsubseteq> C"
by(auto simp add: hyperset_defs)

lemma hyperUn_comm: "A \<squnion> B = B \<squnion> A"
by(auto simp add: hyperset_defs)

lemma hyperUn_leftComm: "A \<squnion> (B \<squnion> C) = B \<squnion> (A \<squnion> C)"
by(auto simp add: hyperset_defs)

lemmas hyperUn_ac = hyperUn_comm hyperUn_leftComm hyperUn_assoc

lemma [simp]: "\<lfloor>{}\<rfloor> \<squnion> B = B"
by(auto)

lemma [simp]: "\<lfloor>{}\<rfloor> \<sqsubseteq> A"
by(auto simp add: hyperset_defs)

lemma sqInt_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<sqinter> B \<sqsubseteq> A' \<sqinter> B"
by(auto simp add: hyperset_defs)

subsection "Definite assignment"

primrec \  :: "('a,'b,'addr) exp \<Rightarrow> 'a hyperset"
  and \s :: "('a,'b,'addr) exp list \<Rightarrow> 'a hyperset"
where
  "\ (new C) = \<lfloor>{}\<rfloor>"
| "\ (newA T\<lfloor>e\<rceil>) = \ e"
| "\ (Cast C e) = \ e"
| "\ (e instanceof T) = \ e"
| "\ (Val v) = \<lfloor>{}\<rfloor>"
| "\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (Var V) = \<lfloor>{}\<rfloor>"
| "\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e"
| "\ (a\<lfloor>i\<rceil>) = \ a \<squnion> \ i"
| "\ (a\<lfloor>i\<rceil> := e) = \ a \<squnion> \ i \<squnion> \ e"
| "\ (a\<bullet>length) = \ a"
| "\ (e\<bullet>F{D}) = \ e"
| "\ (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (e1\<bullet>compareAndSwap(D\<bullet>F, e2, e3)) = \ e1 \<squnion> \ e2 \<squnion> \ e3"
| "\ (e\<bullet>M(es)) = \ e \<squnion> \s es"
| "\ ({V:T=vo; e}) = \ e \<ominus> V"
| "\ (sync\<^bsub>V\<^esub> (o') e) = \ o' \<squnion> \ e"
| "\ (insync\<^bsub>V\<^esub> (a) e) = \ e"
| "\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)"
| "\ (while (b) e) = \ b"
| "\ (throw e) = None"
| "\ (try e\<^sub>1 catch(C V) e\<^sub>2) = \ e\<^sub>1 \<sqinter> (\ e\<^sub>2 \<ominus> V)"

| "\s ([]) = \<lfloor>{}\<rfloor>"
| "\s (e#es) = \ e \<squnion> \s es"

primrec \<D>  :: "('a,'b,'addr) exp \<Rightarrow> 'a hyperset \<Rightarrow> bool"
  and \<D>s :: "('a,'b,'addr) exp list \<Rightarrow> 'a hyperset \<Rightarrow> bool"
where
  "\<D> (new C) A = True"
| "\<D> (newA T\<lfloor>e\<rceil>) A = \<D> e A"
| "\<D> (Cast C e) A = \<D> e A"
| "\<D> (e instanceof T) = \<D> e"
| "\<D> (Val v) A = True"
| "\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (Var V) A = (V \<in>\<in> A)"
| "\<D> (LAss V e) A = \<D> e A"
| "\<D> (a\<lfloor>i\<rceil>) A = (\<D> a A \<and> \<D> i (A \<squnion> \ a))"
| "\<D> (a\<lfloor>i\<rceil> := e) A = (\<D> a A \<and> \<D> i (A \<squnion> \ a) \<and> \<D> e (A \<squnion> \ a \<squnion> \ i))"
| "\<D> (a\<bullet>length) A = \<D> a A"
| "\<D> (e\<bullet>F{D}) A = \<D> e A"
| "\<D> (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (e1\<bullet>compareAndSwap(D\<bullet>F, e2, e3)) A = (\<D> e1 A \<and> \<D> e2 (A \<squnion> \ e1) \<and> \<D> e3 (A \<squnion> \ e1 \<squnion> \ e2))"
| "\<D> (e\<bullet>M(es)) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"
| "\<D> ({V:T=vo; e}) A = (if vo = None then \<D> e (A \<ominus> V) else \<D> e (A \<squnion> \<lfloor>{V}\<rfloor>))"
| "\<D> (sync\<^bsub>V\<^esub> (o') e) A = (\<D> o' A \<and> \<D> e (A \<squnion> \ o'))"
| "\<D> (insync\<^bsub>V\<^esub> (a) e) A = \<D> e A"
| "\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (if (e) e\<^sub>1 else e\<^sub>2) A = (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))"
| "\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))"
| "\<D> (throw e) A = \<D> e A"
| "\<D> (try e\<^sub>1 catch(C V) e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \<lfloor>{V}\<rfloor>))"

| "\<D>s ([]) A = True"
| "\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
(*<*)by (induct vs) simp_all(*>*)

lemma As_append [simp]: "\s (xs @ ys) = (\s xs) \<squnion> (\s ys)"
by(induct xs, auto simp add: hyperset_defs)

lemma Ds_map_Val[simp]: "\<D>s (map Val vs) A"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)

lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
  and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"
apply(induct e and es rule: \.induct \s.induct)
apply (simp_all add:hyperset_defs)
apply fast+
done

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> e A'"
  and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s es A'"
(*<*)
apply(induct e and es rule: \<D>.induct \<D>s.induct)
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by(fastforce simp add:hyperset_defs)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest: sqUn_lem)
subgoal
  apply(clarsimp split: if_split_asm)
  apply (iprover dest:diff_lem)
  apply(iprover dest: sqUn_lem)
  done
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
done
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

declare hyperUn_comm [simp]
declare hyperUn_leftComm [simp]

end


section "Solution to Day 8 of AoC 2020"

theory day8
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils natural_utils list_utils HOL.Option
begin

text "This is a solution to the puzzle for day 8"

subsection "Input parsing"

datatype instr =
  Nop integer
  |Acc integer
  |Jmp integer

type_synonym program = "instr list"

definition parse_instr
  where "parse_instr s = (
    case hd s of
      CHR ''n'' \<Rightarrow> Nop (str_to_int (drop 4 s))
      |CHR ''j'' \<Rightarrow> Jmp (str_to_int (drop 4 s))
      |CHR ''a'' \<Rightarrow> Acc (str_to_int (drop 4 s))
  )"

lemma "parse_instr ''acc +7'' = Acc 7"
  by eval

lemma "parse_instr ''jmp -4'' = Jmp (- 4)"
  by eval

definition parse_program :: "string \<Rightarrow> program"
  where "parse_program p = map parse_instr (split CHR ''\<newline>'' (trim p))"

subsection "Solution Algorithm"

definition exec_instr :: "instr \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
  where "exec_instr instr acc = (
    case instr of
      Nop n \<Rightarrow> (acc, 1)
      | Acc n \<Rightarrow> (acc + n, 1)
      | Jmp n \<Rightarrow> (acc, n)
  )"

definition replace
  where "replace n l new = (take_natural n l) @ [new] @ (drop (n + 1) l)"

fun exec_program_until_loop :: "natural \<Rightarrow> _"
  where
    "exec_program_until_loop limit p flags acc pc = (
    if limit = 0 then undefined else (
      if nth pc flags then
        acc
      else
        (let (new_acc, pc_change) = (exec_instr (nth pc p) acc) in
          let new_flags = replace pc flags True in
          exec_program_until_loop (limit - 1) p new_flags new_acc (natural_of_integer ((integer_of_natural pc) + pc_change))
        )
      )
    )
  "

definition find_loop
  where "find_loop p = (let flags = map (\<lambda> a . False) p in
    exec_program_until_loop 9999 p flags 0 0
  )"

definition part1 :: "string \<Rightarrow> integer"
  where "part1 s = find_loop (parse_program (trim s))"

fun fix_error
  where "fix_error (Nop n) = (Jmp n)"
  |"fix_error (Jmp n) = (Nop n)"
  |"fix_error other = other"

fun exec_program_to_exit :: "natural \<Rightarrow> _"
  where
    "exec_program_to_exit limit error_pc proglen p flags acc pc = (
    if limit = 0 then undefined else (
      if pc \<ge> proglen then
        ((Some error_pc), acc)
      else
        if nth pc flags then
          (None, acc)
        else
          (let (new_acc, pc_change) = (exec_instr (if (error_pc = pc) then (fix_error (nth pc p)) else (nth pc p)) acc) in
            let new_flags = replace pc flags True in
            exec_program_to_exit (limit - 1) error_pc proglen p new_flags new_acc (natural_of_integer ((integer_of_natural pc) + pc_change))
          )
        )

    )
  "

fun first_some :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'a option" where
  "first_some [] f = None"
  |"first_some (Cons h t) f = (if Option.is_none (f h) then first_some t f else Some h)"

definition part2 :: "string \<Rightarrow> integer"
  where "part2 s = (let program = parse_program (trim s) in
    (let proglen = natural_len program in
      (let flags = map (\<lambda> a . False) program in
        (let result = first_some (map (\<lambda> n . exec_program_to_exit 9999 n proglen program flags 0 0) (naturals_to proglen)) (fst) in
          (case (map_option (snd) result) of
            None \<Rightarrow> 0
            |Some (acc) \<Rightarrow> acc
          )
        )
      )
    )
  )"

subsection "Testing"

definition example_input::string where "example_input = ''
nop +0
acc +1
jmp +4
acc +3
jmp -3
acc -99
acc +1
jmp -4
acc +6
''"

lemma "part1 example_input = 5"
  by eval

lemma "part2 example_input = 8"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


(*  Title:       CoreC++
    Author:      Tobias Nipkow, Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

header {* \isaheader{Definite assignment} *}

theory DefAss
imports BigStep
begin

section {*Hypersets*}

type_synonym hyperset = "vname set option"

definition hyperUn :: "hyperset \<Rightarrow> hyperset \<Rightarrow> hyperset"   (infixl "\<squnion>" 65) where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "hyperset \<Rightarrow> hyperset \<Rightarrow> hyperset"   (infixl "\<sqinter>" 70) where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "hyperset \<Rightarrow> vname \<Rightarrow> hyperset"   (infixl "\<ominus>" 65) where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "vname \<Rightarrow> hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50) where
"a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "hyperset \<Rightarrow> hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50) where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
by(simp add:hyperset_defs)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
by(simp add:hyperset_defs)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
by(simp add:hyperset_defs)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
by(simp add:hyperset_defs Un_assoc)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
by(simp add:hyperset_defs)

section {*Definite assignment*}

primrec \ :: "expr \<Rightarrow> hyperset" and \s :: "expr list \<Rightarrow> hyperset" where
"\ (new C) = \<lfloor>{}\<rfloor>" |
"\ (Cast C e) = \ e" |
"\ (\<lparr>C\<rparr>e) = \ e" |
"\ (Val v) = \<lfloor>{}\<rfloor>" |
"\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (Var V) = \<lfloor>{}\<rfloor>" |
"\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e" |
"\ (e\<bullet>F{Cs}) = \ e" |
"\ (e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (Call e Copt M es) = \ e \<squnion> \s es" |
"\ ({V:T; e}) = \ e \<ominus> V" |
"\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)" |
"\ (while (b) e) = \ b" |
"\ (throw e) = None" |

"\s ([]) = \<lfloor>{}\<rfloor>" |
"\s (e#es) = \ e \<squnion> \s es"

primrec \<D> :: "expr \<Rightarrow> hyperset \<Rightarrow> bool" and \<D>s :: "expr list \<Rightarrow> hyperset \<Rightarrow> bool" where
"\<D> (new C) A = True" |
"\<D> (Cast C e) A = \<D> e A" |
"\<D> (\<lparr>C\<rparr>e) A = \<D> e A" |
"\<D> (Val v) A = True" |
"\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (Var V) A = (V \<in>\<in> A)" |
"\<D> (LAss V e) A = \<D> e A" |
"\<D> (e\<bullet>F{Cs}) A = \<D> e A" |
"\<D> (e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (Call e Copt M es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))" |
"\<D> ({V:T; e}) A = \<D> e (A \<ominus> V)" |
"\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (if (e) e\<^sub>1 else e\<^sub>2) A =
  (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))" |
"\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))" |
"\<D> (throw e) A = \<D> e A" |

"\<D>s ([]) A = True" |
"\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
by (induct vs) simp_all

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
by (induct es type:list) (auto simp:hyperUn_assoc)

lemma A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"

apply(induct e and es rule: \.induct \s.induct)
apply (simp_all add:hyperset_defs)
apply blast+
done

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
by(simp add:hyperset_defs) blast

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
by(simp add:hyperset_defs) blast

(* This order of the premises avoids looping of the simplifier *)
lemma D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> (e::expr) A'"
and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s (es::expr list) A'"

apply(induct e and es rule: \<D>.induct \<D>s.induct)
apply simp
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:diff_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp
apply simp
apply (iprover dest:sqUn_lem)
done

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
by(blast intro:D_mono, blast intro:Ds_mono)

end


theory prop_24
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun max2 :: "Nat => Nat => Nat" where
  "max2 (Z) y = y"
  | "max2 (S z) (Z) = S z"
  | "max2 (S z) (S x2) = S (max2 z x2)"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  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"
  (*hipster max2 le equal2 *)
(*hipster equal2*)
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes prop_24.equal2.simps)

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

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

  theorem x0 :
    "(equal2 (max2 a b) a) = (le b a)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end