theory Result
  imports
    Main
    "HOL-Library.Monad_Syntax"
begin

datatype ('err, 'a) result =
  is_err: Error 'err |
  is_ok: Ok 'a

section \<open>Monadic bind\<close>

context begin

qualified fun bind :: "('a, 'b) result \<Rightarrow> ('b \<Rightarrow> ('a, 'c) result) \<Rightarrow> ('a, 'c) result" where
  "bind (Error x) _ = Error x" |
  "bind (Ok x) f = f x"

end

adhoc_overloading
  bind Result.bind

context begin

qualified lemma bind_Ok[simp]: "x \<bind> Ok = x"
  by (cases x) simp_all

qualified lemma bind_eq_Ok_conv: "(x \<bind> f = Ok z) = (\<exists>y. x = Ok y \<and> f y = Ok z)"
  by (cases x) simp_all

qualified lemmas bind_eq_OkD[dest!] = bind_eq_Ok_conv[THEN iffD1]
qualified lemmas bind_eq_OkE = bind_eq_OkD[THEN exE]
qualified lemmas bind_eq_OkI[intro] = conjI[THEN exI[THEN bind_eq_Ok_conv[THEN iffD2]]]

qualified lemma bind_eq_Error_conv:
  "x \<bind> f = Error z \<longleftrightarrow> x = Error z \<or> (\<exists>y. x = Ok y \<and> f y = Error z)"
  by (cases x) simp_all

qualified lemmas bind_eq_ErrorD[dest!] = bind_eq_Error_conv[THEN iffD1]
qualified lemmas bind_eq_ErrorE = bind_eq_ErrorD[THEN disjE]
qualified lemmas bind_eq_ErrorI =
  disjI1[THEN bind_eq_Error_conv[THEN iffD2]]
  conjI[THEN exI[THEN disjI2[THEN bind_eq_Error_conv[THEN iffD2]]]]

lemma if_then_else_Ok[simp]:
  "(if a then b else Error c) = Ok d \<longleftrightarrow> a \<and> b = Ok d"
  "(if a then Error c else b) = Ok d \<longleftrightarrow> \<not> a \<and> b = Ok d"
  by (cases a) simp_all

qualified lemma if_then_else_Error[simp]:
  "(if a then Ok b else c) = Error d \<longleftrightarrow> \<not> a \<and> c = Error d"
  "(if a then c else Ok b) = Error d \<longleftrightarrow> a \<and> c = Error d"
  by (cases a) simp_all

qualified lemma map_eq_Ok_conv: "map_result f g x = Ok y \<longleftrightarrow> (\<exists>x'. x = Ok x' \<and> y = g x')"
  by (cases x; auto)

qualified lemma map_eq_Error_conv: "map_result f g x = Error y \<longleftrightarrow> (\<exists>x'. x = Error x' \<and> y = f x')"
  by (cases x; auto)

qualified lemmas map_eq_OkD[dest!] = iffD1[OF map_eq_Ok_conv]
qualified lemmas map_eq_ErrorD[dest!] = iffD1[OF map_eq_Error_conv]

end

section \<open>Conversion functions\<close>

context begin

qualified fun of_option where
  "of_option e None = Error e" |
  "of_option e (Some x) = Ok x"

qualified lemma of_option_injective[simp]: "(of_option e x = of_option e y) = (x = y)"
  by (cases x; cases y; simp)

qualified lemma of_option_eq_Ok[simp]: "(of_option x y = Ok z) = (y = Some z)"
  by (cases y) simp_all

qualified fun to_option where
  "to_option (Error _) = None" |
  "to_option (Ok x) = Some x"

qualified lemma to_option_Some[simp]: "(to_option r = Some x) = (r = Ok x)"
  by (cases r) simp_all

qualified fun those :: "('err, 'ok) result list \<Rightarrow> ('err, 'ok list) result" where
  "those [] = Ok []" |
  "those (x # xs) = do {
    y \<leftarrow> x;
    ys \<leftarrow> those xs;
    Ok (y # ys)
  }"

qualified lemma those_Cons_OkD: "those (x # xs) = Ok ys \<Longrightarrow> \<exists>y ys'. ys = y # ys' \<and> x = Ok y \<and> those xs = Ok ys'"
  by auto

end

end


section \<open>Prefixpoints\<close>

theory Ex4
imports "../LCF"
begin

lemma example:
  assumes asms: "f(p) << p"  "\<And>q. f(q) << q \<Longrightarrow> p << q"
  shows "FIX(f)=p"
  apply (unfold eq_def)
  apply (rule conjI)
  apply (induct f)
  apply (rule minimal)
  apply (intro strip)
  apply (rule less_trans)
  prefer 2
  apply (rule asms)
  apply (erule less_ap_term)
  apply (rule asms)
  apply (rule FIX_eq [THEN eq_imp_less1])
  done

end


section {* Alphabetised Predicates *}

theory utp_pred
imports
  utp_expr
  utp_subst
  utp_tactics
begin

text {* An alphabetised predicate is a simply a boolean valued expression *}

type_synonym '\<alpha> upred = "(bool, '\<alpha>) uexpr"

translations
  (type) "'\<alpha> upred" <= (type) "(bool, '\<alpha>) uexpr"

subsection {* Predicate syntax *}

text {* We want to remain as close as possible to the mathematical UTP syntax, but also
        want to be conservative with HOL. For this reason we chose not to steal syntax
        from HOL, but where possible use polymorphism to allow selection of the appropriate
        operator (UTP vs. HOL). Thus we will first remove the standard syntax for conjunction,
        disjunction, and negation, and replace these with adhoc overloaded definitions. *}

purge_notation
  conj (infixr "\<and>" 35) and
  disj (infixr "\<or>" 30) and
  Not ("\<not> _" [40] 40)

consts
  utrue  :: "'a" ("true")
  ufalse :: "'a" ("false")
  uconj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<and>" 35)
  udisj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<or>" 30)
  uimpl  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Rightarrow>" 25)
  uiff   :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Leftrightarrow>" 25)
  unot   :: "'a \<Rightarrow> 'a" ("\<not> _" [40] 40)
  uex    :: "('a, '\<alpha>) uvar \<Rightarrow> 'p \<Rightarrow> 'p"
  uall   :: "('a, '\<alpha>) uvar \<Rightarrow> 'p \<Rightarrow> 'p"
  ushEx  :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"
  ushAll :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"

adhoc_overloading
  uconj conj and
  udisj disj and
  unot Not

text {* We set up two versions of each of the quantifiers: @{const uex} / @{const uall} and
        @{const ushEx} / @{const ushAll}. The former pair allows quantification of UTP variables,
        whilst the latter allows quantification of HOL variables. Both varieties will be
        needed at various points. Syntactically they are distinguish by a boldface quantifier
        for the HOL versions (achieved by the "bold" escape in Isabelle). *}

nonterminal idt_list

syntax
  "_idt_el"  :: "idt \<Rightarrow> idt_list" ("_")
  "_idt_list" :: "idt \<Rightarrow> idt_list \<Rightarrow> idt_list" ("(_,/ _)" [0, 1])
  "_uex"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<exists> _ \<bullet> _" [0, 10] 10)
  "_uall"    :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushEx"   :: "idt_list \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<bullet> _" [0, 10] 10)
  "_ushAll"  :: "idt_list \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushBEx"  :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushBAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushGAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_ushGtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ > _ \<bullet> _" [0, 0, 10] 10)
  "_ushLtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ < _ \<bullet> _" [0, 0, 10] 10)

translations
  "_uex x P"                   == "CONST uex x P"
  "_uall x P"                  == "CONST uall x P"
  "_ushEx (_idt_el x) P"       == "CONST ushEx (\<lambda> x. P)"
  "_ushEx (_idt_list x y) P"   => "CONST ushEx (\<lambda> x. (_ushEx y P))"
  "\<^bold>\<exists> x \<in> A \<bullet> P"                => "\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<and> P"
  "_ushAll (_idt_el x) P"      == "CONST ushAll (\<lambda> x. P)"
  "_ushAll (_idt_list x y) P"  => "CONST ushAll (\<lambda> x. (_ushAll y P))"
  "\<^bold>\<forall> x \<in> A \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<Rightarrow> P"
  "\<^bold>\<forall> x | P \<bullet> Q"                => "\<^bold>\<forall> x \<bullet> P \<Rightarrow> Q"
  "\<^bold>\<forall> x > y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> >\<^sub>u y \<Rightarrow> P"
  "\<^bold>\<forall> x < y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> <\<^sub>u y \<Rightarrow> P"

subsection {* Predicate operators *}

text {* We chose to maximally reuse definitions and laws built into HOL. For this reason,
        when introducing the core operators we proceed by lifting operators from the
        polymorphic algebraic hiearchy of HOL. Thus the initial definitions take
        place in the context of type class instantiations. We first introduce our own
        class called \emph{refine} that will add the refinement operator syntax to
        the HOL partial order class. *}

class refine = order

abbreviation refineBy :: "'a::refine \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubseteq>" 50) where
"P \<sqsubseteq> Q \<equiv> less_eq Q P"

text {* Since, on the whole, lattices in UTP are the opposite way up to the standard definitions
        in HOL, we syntactically invert the lattice operators. This is the one exception where
        we do steal HOL syntax, but I think it makes sense for UTP. *}

purge_notation inf (infixl "\<sqinter>" 70)
notation inf (infixl "\<squnion>" 70)
purge_notation sup (infixl "\<squnion>" 65)
notation sup (infixl "\<sqinter>" 65)

purge_notation Inf ("\<Sqinter>_" [900] 900)
notation Inf ("\<Squnion>_" [900] 900)
purge_notation Sup ("\<Squnion>_" [900] 900)
notation Sup ("\<Sqinter>_" [900] 900)

purge_notation bot ("\<bottom>")
notation bot ("\<top>")
purge_notation top ("\<top>")
notation top ("\<bottom>")

purge_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)

text {* We trivially instantiate our refinement class *}

instance uexpr :: (order, type) refine ..

-- {* Configure transfer law for refinement for the fast relational tactics. *}

theorem upred_ref_iff [uexpr_transfer_laws]:
"(P \<sqsubseteq> Q) = (\<forall>b. \<lbrakk>Q\<rbrakk>\<^sub>e b \<longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e b)"
apply (transfer)
apply (clarsimp)
done

text {* Next we introduce the lattice operators, which is again done by lifting. *}

instantiation uexpr :: (lattice, type) lattice
begin
  lift_definition sup_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. sup (P A) (Q A)" .
  lift_definition inf_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. inf (P A) (Q A)" .
instance
  by (intro_classes) (transfer, auto)+
end

instantiation uexpr :: (bounded_lattice, type) bounded_lattice
begin
  lift_definition bot_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. bot" .
  lift_definition top_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. top" .
instance
  by (intro_classes) (transfer, auto)+
end

instance uexpr :: (distrib_lattice, type) distrib_lattice
  by (intro_classes) (transfer, rule ext, auto simp add: sup_inf_distrib1)

text {* Finally we show that predicates form a Boolean algebra (under the lattice operators). *}

instance uexpr :: (boolean_algebra, type) boolean_algebra
apply (intro_classes, unfold uexpr_defs; transfer, rule ext)
apply (simp_all add: sup_inf_distrib1 diff_eq)
done

instantiation uexpr :: (complete_lattice, type) complete_lattice
begin
  lift_definition Inf_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. INF P:PS. P(A)" .
  lift_definition Sup_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. SUP P:PS. P(A)" .
instance
  by (intro_classes)
     (transfer, auto intro: INF_lower SUP_upper simp add: INF_greatest SUP_least)+
end

syntax
  "_mu" :: "idt \<Rightarrow> logic \<Rightarrow> logic" ("\<mu> _ \<bullet> _" [0, 10] 10)
  "_nu" :: "idt \<Rightarrow> logic \<Rightarrow> logic" ("\<nu> _ \<bullet> _" [0, 10] 10)

translations
  "\<nu> X \<bullet> P" == "CONST lfp (\<lambda> X. P)"
  "\<mu> X \<bullet> P" == "CONST gfp (\<lambda> X. P)"

instance uexpr :: (complete_distrib_lattice, type) complete_distrib_lattice
  apply (intro_classes)
  unfolding INF_def
  apply (transfer, rule ext, auto)
  using sup_INF apply fastforce
  unfolding SUP_def
  apply (transfer, rule ext, auto)
  using inf_SUP apply fastforce
done

instance uexpr :: (complete_boolean_algebra, type) complete_boolean_algebra ..

text {* With the lattice operators defined, we can proceed to give definitions for the
        standard predicate operators in terms of them. *}

definition "true_upred  = (top :: '\<alpha> upred)"
definition "false_upred = (bot :: '\<alpha> upred)"
definition "conj_upred  = (inf :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "disj_upred  = (sup :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "not_upred   = (uminus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "diff_upred  = (minus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"

abbreviation Conj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<And>_" [900] 900) where
"\<And> A \<equiv> \<Squnion> A"

abbreviation Disj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<Or>_" [900] 900) where
"\<Or> A \<equiv> \<Sqinter> A"

notation
  conj_upred (infixr "\<and>\<^sub>p" 35) and
  disj_upred (infixr "\<or>\<^sub>p" 30)

lift_definition USUP :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Sup {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

lift_definition UINF :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Inf {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

declare USUP_def [upred_defs]
declare UINF_def [upred_defs]

syntax
  "_USup"     :: "idt \<Rightarrow> logic \<Rightarrow> logic"            ("\<Sqinter> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_USUP"     :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_UInf"     :: "idt \<Rightarrow> logic \<Rightarrow> logic"            ("\<Squnion> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_UINF"     :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ | _ \<bullet> _" [0, 10] 10)

translations
  "\<Sqinter> x | P \<bullet> F" => "CONST USUP (\<lambda> x. P) (\<lambda> x. F)"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<in> A \<bullet> F" => "\<Sqinter> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Sqinter> x | P \<bullet> F" <= "CONST USUP (\<lambda> x. P) (\<lambda> y. F)"
  "\<Sqinter> x | P \<bullet> F(x)" <= "CONST USUP (\<lambda> x. P) F"
  "\<Squnion> x | P \<bullet> F" => "CONST UINF (\<lambda> x. P) (\<lambda> x. F)"
  "\<Squnion> x \<bullet> F"     == "\<Squnion> x | true \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" => "\<Squnion> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Squnion> x | P \<bullet> F" <= "CONST UINF (\<lambda> x. P) (\<lambda> y. F)"
  "\<Squnion> x | P \<bullet> F(x)" <= "CONST UINF (\<lambda> x. P) F"

text {* We also define the other predicate operators *}

lift_definition impl::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longrightarrow> Q A" .

lift_definition iff_upred ::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longleftrightarrow> Q A" .

lift_definition ex :: "('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<exists> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shEx ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<exists> x. (P x) A" .

lift_definition all :: "('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<forall> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shAll ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<forall> x. (P x) A" .

text {* We have to add a u subscript to the closure operator as I don't want to override the syntax
        for HOL lists (we'll be using them later). *}

lift_definition closure::"'\<alpha> upred \<Rightarrow> '\<alpha> upred" ("[_]\<^sub>u") is
"\<lambda> P A. \<forall>A'. P A'" .

lift_definition taut :: "'\<alpha> upred \<Rightarrow> bool" ("`_`")
is "\<lambda> P. \<forall> A. P A" .

-- {* Configuration for UTP tactics (see @{theory utp_tactics}). *}

update_uexpr_rep_eq_thms -- {* Reread @{text rep_eq} theorems. *}

declare utp_pred.taut.rep_eq [upred_defs]

adhoc_overloading
  utrue "true_upred" and
  ufalse "false_upred" and
  unot "not_upred" and
  uconj "conj_upred" and
  udisj "disj_upred" and
  uimpl impl and
  uiff iff_upred and
  uex ex and
  uall all and
  ushEx shEx and
  ushAll shAll

syntax
  "_uneq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<noteq>\<^sub>u" 50)
  "_unmem"      :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<notin>\<^sub>u" 50)

translations
  "x \<noteq>\<^sub>u y" == "CONST unot (x =\<^sub>u y)"
  "x \<notin>\<^sub>u A" == "CONST unot (CONST bop (op \<in>) x A)"

declare true_upred_def [upred_defs]
declare false_upred_def [upred_defs]
declare conj_upred_def [upred_defs]
declare disj_upred_def [upred_defs]
declare not_upred_def [upred_defs]
declare diff_upred_def [upred_defs]
declare subst_upd_uvar_def [upred_defs]
declare unrest_usubst_def [upred_defs]
declare uexpr_defs [upred_defs]

lemma true_alt_def: "true = \<guillemotleft>True\<guillemotright>"
  by (pred_auto)

declare true_alt_def[THEN sym,lit_simps]
declare false_alt_def[THEN sym,lit_simps]

abbreviation cond ::
  "('a,'\<alpha>) uexpr \<Rightarrow> '\<alpha> upred \<Rightarrow> ('a,'\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr"
  ("(3_ \<triangleleft> _ \<triangleright>/ _)" [52,0,53] 52)
where "P \<triangleleft> b \<triangleright> Q \<equiv> trop If b P Q"

subsection {* Unrestriction Laws *}

lemma unrest_true [unrest]: "x \<sharp> true"
  by (pred_auto)

lemma unrest_false [unrest]: "x \<sharp> false"
  by (pred_auto)

lemma unrest_conj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<and> Q"
  by (pred_auto)

lemma unrest_disj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<or> Q"
  by (pred_auto)

lemma unrest_USUP [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_UINF [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_impl [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Rightarrow> Q"
  by (pred_auto)

lemma unrest_iff [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Leftrightarrow> Q"
  by (pred_auto)

lemma unrest_not [unrest]: "x \<sharp> (P :: '\<alpha> upred) \<Longrightarrow> x \<sharp> (\<not> P)"
  by (pred_auto)

text {* The sublens proviso can be thought of as membership below. *}

lemma unrest_ex_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<exists> y \<bullet> P)"
  by (pred_auto)

declare sublens_refl [simp]
declare lens_plus_ub [simp]
declare lens_plus_right_sublens [simp]
declare comp_wb_lens [simp]
declare comp_mwb_lens [simp]
declare plus_mwb_lens [simp]

lemma unrest_ex_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<exists> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma unrest_all_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma unrest_all_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<forall> x \<bullet> P)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma unrest_shEx [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<exists> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_shAll [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<forall> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_closure [unrest]:
  "x \<sharp> [P]\<^sub>u"
  by (pred_auto)

subsection {* Substitution Laws *}

text {* Substitution is monotone *}

lemma subst_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<sigma> \<dagger> P) \<sqsubseteq> (\<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_true [usubst]: "\<sigma> \<dagger> true = true"
  by (pred_auto)

lemma subst_not [usubst]: "\<sigma> \<dagger> (\<not> P) = (\<not> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_impl [usubst]: "\<sigma> \<dagger> (P \<Rightarrow> Q) = (\<sigma> \<dagger> P \<Rightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_iff [usubst]: "\<sigma> \<dagger> (P \<Leftrightarrow> Q) = (\<sigma> \<dagger> P \<Leftrightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_disj [usubst]: "\<sigma> \<dagger> (P \<or> Q) = (\<sigma> \<dagger> P \<or> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_conj [usubst]: "\<sigma> \<dagger> (P \<and> Q) = (\<sigma> \<dagger> P \<and> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_sup [usubst]: "\<sigma> \<dagger> (P \<sqinter> Q) = (\<sigma> \<dagger> P \<sqinter> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_inf [usubst]: "\<sigma> \<dagger> (P \<squnion> Q) = (\<sigma> \<dagger> P \<squnion> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_USUP [usubst]: "\<sigma> \<dagger> (\<Sqinter> i | P(i) \<bullet> Q(i)) = (\<Sqinter> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_UINF [usubst]: "\<sigma> \<dagger> (\<Squnion> i | P(i) \<bullet> Q(i)) = (\<Squnion> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_closure [usubst]: "\<sigma> \<dagger> [P]\<^sub>u = [P]\<^sub>u"
  by (pred_auto)

lemma subst_shEx [usubst]: "\<sigma> \<dagger> (\<^bold>\<exists> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

lemma subst_shAll [usubst]: "\<sigma> \<dagger> (\<^bold>\<forall> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

text {* TODO: Generalise the quantifier substitution laws to n-ary substitutions *}

lemma subst_ex_same [usubst]:
  assumes "mwb_lens x"
  shows "(\<exists> x \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<exists> x \<bullet> P)"
  by (simp add: assms id_subst subst_unrest unrest_ex_in)

lemma subst_ex_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<exists> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<exists> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma subst_all_same [usubst]:
  assumes "mwb_lens x"
  shows "(\<forall> x \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<forall> x \<bullet> P)"
  by (simp add: assms id_subst subst_unrest unrest_all_in)

lemma subst_all_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<forall> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<forall> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

subsection {* Predicate Laws *}

text {* Showing that predicates form a Boolean Algebra (under the predicate operators) gives us
        many useful laws. *}

interpretation boolean_algebra diff_upred not_upred conj_upred "op \<le>" "op <"
  disj_upred false_upred true_upred
  by (unfold_locales; pred_auto)

lemma taut_true [simp]: "`true`"
  by (pred_auto)

lemma refBy_order: "P \<sqsubseteq> Q = `Q \<Rightarrow> P`"
  by (pred_auto)

lemma conj_idem [simp]: "((P::'\<alpha> upred) \<and> P) = P"
  by (pred_auto)

lemma disj_idem [simp]: "((P::'\<alpha> upred) \<or> P) = P"
  by (pred_auto)

lemma conj_comm: "((P::'\<alpha> upred) \<and> Q) = (Q \<and> P)"
  by (pred_auto)

lemma disj_comm: "((P::'\<alpha> upred) \<or> Q) = (Q \<or> P)"
  by (pred_auto)

lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> upred) \<and> Q) = (R \<and> Q)"
  by (pred_auto)

lemma conj_assoc:"(((P::'\<alpha> upred) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
  by (pred_auto)

lemma disj_assoc:"(((P::'\<alpha> upred) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
  by (pred_auto)

lemma conj_disj_abs:"((P::'\<alpha> upred) \<and> (P \<or> Q)) = P"
  by (pred_auto)

lemma disj_conj_abs:"((P::'\<alpha> upred) \<or> (P \<and> Q)) = P"
  by (pred_auto)

lemma conj_disj_distr:"((P::'\<alpha> upred) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
  by (pred_auto)

lemma disj_conj_distr:"((P::'\<alpha> upred) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
  by (pred_auto)

lemma true_disj_zero [simp]:
  "(P \<or> true) = true" "(true \<or> P) = true"
  by (pred_auto)+

lemma true_conj_zero [simp]:
  "(P \<and> false) = false" "(false \<and> P) = false"
  by (pred_auto)+

lemma imp_vacuous [simp]: "(false \<Rightarrow> u) = true"
  by (pred_auto)

lemma imp_true [simp]: "(p \<Rightarrow> true) = true"
  by (pred_auto)

lemma true_imp [simp]: "(true \<Rightarrow> p) = p"
  by (pred_auto)

lemma p_and_not_p [simp]: "(P \<and> \<not> P) = false"
  by (pred_auto)

lemma p_or_not_p [simp]: "(P \<or> \<not> P) = true"
  by (pred_auto)

lemma p_imp_p [simp]: "(P \<Rightarrow> P) = true"
  by (pred_auto)

lemma p_iff_p [simp]: "(P \<Leftrightarrow> P) = true"
  by (pred_auto)

lemma p_imp_false [simp]: "(P \<Rightarrow> false) = (\<not> P)"
  by (pred_auto)

lemma not_conj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
  by (pred_auto)

lemma not_disj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
  by (pred_auto)

lemma conj_disj_not_abs [simp]: "((P::'\<alpha> upred) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
  by (pred_auto)

lemma subsumption1:
  "`P \<Rightarrow> Q` \<Longrightarrow> (P \<or> Q) = Q"
  by (pred_auto)

lemma subsumption2:
  "`Q \<Rightarrow> P` \<Longrightarrow> (P \<or> Q) = P"
  by (pred_auto)

lemma neg_conj_cancel1: "(\<not> P \<and> (P \<or> Q)) = (\<not> P \<and> Q :: '\<alpha> upred)"
  by (pred_auto)

lemma neg_conj_cancel2: "(\<not> Q \<and> (P \<or> Q)) = (\<not> Q \<and> P :: '\<alpha> upred)"
  by (pred_auto)

lemma double_negation [simp]: "(\<not> \<not> (P::'\<alpha> upred)) = P"
  by (pred_auto)

lemma true_not_false [simp]: "true \<noteq> false" "false \<noteq> true"
  by (pred_auto)+

lemma closure_conj_distr: "([P]\<^sub>u \<and> [Q]\<^sub>u) = [P \<and> Q]\<^sub>u"
  by (pred_auto)

lemma closure_imp_distr: "`[P \<Rightarrow> Q]\<^sub>u \<Rightarrow> [P]\<^sub>u \<Rightarrow> [Q]\<^sub>u`"
  by (pred_auto)

lemma uinf_or:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<sqinter> Q) = (P \<or> Q)"
  by (pred_auto)

lemma usup_and:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<squnion> Q) = (P \<and> Q)"
  by (pred_auto)

lemma USUP_cong_eq:
  "\<lbrakk> \<And> x. P\<^sub>1(x) = P\<^sub>2(x); \<And> x. `P\<^sub>1(x) \<Rightarrow> Q\<^sub>1(x) =\<^sub>u Q\<^sub>2(x)` \<rbrakk> \<Longrightarrow>
        (\<Sqinter> x | P\<^sub>1(x) \<bullet> Q\<^sub>1(x)) = (\<Sqinter> x | P\<^sub>2(x) \<bullet> Q\<^sub>2(x))"
 by (unfold USUP_def, pred_simp, metis)

lemma USUP_as_Sup: "(\<Sqinter> P \<in> \<P> \<bullet> P) = \<Sqinter> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: setcompr_eq_image)
done

lemma USUP_as_Sup_collect: "(\<Sqinter>P\<in>A \<bullet> f(P)) = (\<Sqinter>P\<in>A. f(P))"

  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def )
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image )
  unfolding SUP_def apply transfer apply auto
done

lemma USUP_as_Sup_image: "(\<Sqinter> P | \<guillemotleft>P\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> f(P)) = \<Sqinter> (f ` A)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image )
done

lemma UINF_as_Inf: "(\<Squnion> P \<in> \<P> \<bullet> P) = \<Squnion> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image )
done

lemma UINF_as_Inf_collect: "(\<Squnion>P\<in>A \<bullet> f(P)) = (\<Squnion>P\<in>A. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
  unfolding INF_def apply transfer apply auto
done

lemma UINF_as_Inf_image: "(\<Squnion> P \<in> \<P> \<bullet> f(P)) = \<Squnion> (f ` \<P>)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
done

lemma USUP_image_eq [simp]: "USUP (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Sqinter> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Sup Sup], auto)

lemma UINF_image_eq [simp]: "UINF (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Squnion> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Inf Inf], auto)

lemma not_USUP: "(\<not> (\<Sqinter> i\<in>A\<bullet> P(i))) = (\<Squnion> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma not_UINF: "(\<not> (\<Squnion> i\<in>A\<bullet> P(i))) = (\<Sqinter> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma USUP_empty [simp]: "(\<Sqinter> i \<in> {} \<bullet> P(i)) = false"
  by (pred_auto)

lemma USUP_insert [simp]: "(\<Sqinter> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<sqinter> (\<Sqinter> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Sup_insert[THEN sym])
  apply (rule_tac cong[of Sup Sup])
  apply (auto)
done

lemma UINF_empty [simp]: "(\<Squnion> i \<in> {} \<bullet> P(i)) = true"
  by (pred_auto)

lemma UINF_insert [simp]: "(\<Squnion> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<squnion> (\<Squnion> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Inf_insert[THEN sym])
  apply (rule_tac cong[of Inf Inf])
  apply (auto)
done

lemma conj_USUP_dist:
  "(P \<and> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<and> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma disj_USUP_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<or> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<or> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma conj_UINF_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<and> (\<Squnion> Q\<in>S \<bullet> F(Q))) = (\<Squnion> Q\<in>S \<bullet> P \<and> F(Q))"
  by (subst uexpr_eq_iff, auto simp add: conj_upred_def UINF.rep_eq inf_uexpr.rep_eq bop.rep_eq lit.rep_eq)

lemma UINF_conj_UINF: "((\<Squnion> P \<in> A \<bullet> F(P)) \<and> (\<Squnion> P \<in> A \<bullet> G(P))) = (\<Squnion> P \<in> A \<bullet> F(P) \<and> G(P))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma UINF_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> G(P))"
  by (simp add: USUP_as_Sup_collect assms)

lemma USUP_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> G(P))"
  by (simp add: UINF_as_Inf_collect assms)

lemma UINF_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Sqinter> P\<in>B \<bullet> F(P)) \<sqsubseteq> (\<Sqinter> P\<in>A \<bullet> F(P))"
  by (simp add: SUP_subset_mono USUP_as_Sup_collect)

lemma USUP_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) \<sqsubseteq> (\<Squnion> P\<in>B \<bullet> F(P))"
  by (simp add: INF_superset_mono UINF_as_Inf_collect)

lemma mu_id: "(\<mu> X \<bullet> X) = true"
  by (simp add: antisym gfp_upperbound)

lemma mu_const: "(\<mu> X \<bullet> P) = P"
  by (simp add: gfp_unfold mono_def)

lemma nu_id: "(\<nu> X \<bullet> X) = false"
  by (simp add: lfp_lowerbound utp_pred.bot.extremum_uniqueI)

lemma nu_const: "(\<nu> X \<bullet> P) = P"
  by (simp add: lfp_const)

lemma true_iff [simp]: "(P \<Leftrightarrow> true) = P"
  by (pred_auto)

lemma impl_alt_def: "(P \<Rightarrow> Q) = (\<not> P \<or> Q)"
  by (pred_auto)

lemma eq_upred_refl [simp]: "(x =\<^sub>u x) = true"
  by (pred_auto)

lemma eq_upred_sym: "(x =\<^sub>u y) = (y =\<^sub>u x)"
  by (pred_auto)

lemma eq_cong_left:
  assumes "vwb_lens x" "$x \<sharp> Q" "$x\<acute> \<sharp> Q" "$x \<sharp> R" "$x\<acute> \<sharp> R"
  shows "(($x\<acute> =\<^sub>u $x \<and> Q) = ($x\<acute> =\<^sub>u $x \<and> R)) \<longleftrightarrow> (Q = R)"
  using assms
  by (pred_simp, (meson mwb_lens_def vwb_lens_mwb weak_lens_def)+)

lemma conj_eq_in_var_subst:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "vwb_lens x"
  shows "(P \<and> $x =\<^sub>u v) = (P\<lbrakk>v/$x\<rbrakk> \<and> $x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_eq_out_var_subst:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "vwb_lens x"
  shows "(P \<and> $x\<acute> =\<^sub>u v) = (P\<lbrakk>v/$x\<acute>\<rbrakk> \<and> $x\<acute> =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_pos_var_subst:
  assumes "vwb_lens x"
  shows "($x \<and> Q) = ($x \<and> Q\<lbrakk>true/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma conj_neg_var_subst:
  assumes "vwb_lens x"
  shows "(\<not> $x \<and> Q) = (\<not> $x \<and> Q\<lbrakk>false/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma le_pred_refl [simp]:
  fixes x :: "('a::preorder, '\<alpha>) uexpr"
  shows "(x \<le>\<^sub>u x) = true"
  by (pred_auto)

lemma shEx_unbound [simp]: "(\<^bold>\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma shEx_bool [simp]: "shEx P = (P True \<or> P False)"
  by (pred_simp, metis (full_types))

lemma shEx_commute: "(\<^bold>\<exists> x \<bullet> \<^bold>\<exists> y \<bullet> P x y) = (\<^bold>\<exists> y \<bullet> \<^bold>\<exists> x \<bullet> P x y)"
  by (pred_auto)

lemma shEx_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shEx P = shEx Q"
  by (pred_auto)

lemma shAll_unbound [simp]: "(\<^bold>\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma shAll_bool [simp]: "shAll P = (P True \<and> P False)"
  by (pred_simp, metis (full_types))

lemma shAll_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shAll P = shAll Q"
  by (pred_auto)

lemma upred_eq_true [simp]: "(p =\<^sub>u true) = p"
  by (pred_auto)

lemma upred_eq_false [simp]: "(p =\<^sub>u false) = (\<not> p)"
  by (pred_auto)

lemma conj_var_subst:
  assumes "vwb_lens x"
  shows "(P \<and> var x =\<^sub>u v) = (P\<lbrakk>v/x\<rbrakk> \<and> var x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis (full_types) vwb_lens_def wb_lens.get_put)+)

lemma uvar_assign_exists:
  "vwb_lens x \<Longrightarrow> \<exists> v. b = put\<^bsub>x\<^esub> b v"
  by (rule_tac x="get\<^bsub>x\<^esub> b" in exI, simp)

lemma uvar_obtain_assign:
  assumes "vwb_lens x"
  obtains v where "b = put\<^bsub>x\<^esub> b v"
  using assms
  by (drule_tac uvar_assign_exists[of _ b], auto)

lemma eq_split_subst:
  assumes "vwb_lens x"
  shows "(P = Q) \<longleftrightarrow> (\<forall> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
  using assms
  by (pred_simp, metis uvar_assign_exists)

lemma eq_split_substI:
  assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
  shows "P = Q"
  using assms(1) assms(2) eq_split_subst by blast

lemma taut_split_subst:
  assumes "vwb_lens x"
  shows "`P` \<longleftrightarrow> (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
  using assms
  by (pred_simp, metis uvar_assign_exists)

lemma eq_split:
  assumes "`P \<Rightarrow> Q`" "`Q \<Rightarrow> P`"
  shows "P = Q"
  using assms
  by (pred_auto)

lemma subst_bool_split:
  assumes "vwb_lens x"
  shows "`P` = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
proof -
  from assms have "`P` = (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
    by (subst taut_split_subst[of x], auto)
  also have "... = (`P\<lbrakk>\<guillemotleft>True\<guillemotright>/x\<rbrakk>` \<and> `P\<lbrakk>\<guillemotleft>False\<guillemotright>/x\<rbrakk>`)"
    by (metis (mono_tags, lifting))
  also have "... = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
    by (pred_auto)
  finally show ?thesis .
qed

lemma taut_iff_eq:
  "`P \<Leftrightarrow> Q` \<longleftrightarrow> (P = Q)"
  by (pred_auto)

lemma subst_eq_replace:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "(p\<lbrakk>u/x\<rbrakk> \<and> u =\<^sub>u v) = (p\<lbrakk>v/x\<rbrakk> \<and> u =\<^sub>u v)"
  by (pred_auto)

lemma exists_twice: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> \<exists> x \<bullet> P) = (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma all_twice: "mwb_lens x \<Longrightarrow> (\<forall> x \<bullet> \<forall> x \<bullet> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

lemma exists_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma ex_commute:
  assumes "x \<bowtie> y"
  shows "(\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma all_commute:
  assumes "x \<bowtie> y"
  shows "(\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> \<forall> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma ex_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<exists> x \<bullet> P) = (\<exists> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma all_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<forall> x \<bullet> P) = (\<forall> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma ex_zero:
  "(\<exists> &\<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma all_zero:
  "(\<forall> &\<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma ex_plus:
  "(\<exists> y;x \<bullet> P) = (\<exists> x \<bullet> \<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_plus:
  "(\<forall> y;x \<bullet> P) = (\<forall> x \<bullet> \<forall> y \<bullet> P)"
  by (pred_auto)

lemma closure_all:
  "[P]\<^sub>u = (\<forall> &\<Sigma> \<bullet> P)"
  by (pred_auto)

lemma unrest_as_exists:
  "vwb_lens x \<Longrightarrow> (x \<sharp> P) \<longleftrightarrow> ((\<exists> x \<bullet> P) = P)"
  by (pred_simp, metis vwb_lens.put_eq)

lemma ex_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> (\<exists> x \<bullet> Q)"
  by (pred_auto)

lemma ex_weakens: "wb_lens x \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> P"
  by (pred_simp, metis wb_lens.get_put)

lemma all_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<forall> x \<bullet> P) \<sqsubseteq> (\<forall> x \<bullet> Q)"
  by (pred_auto)

lemma all_strengthens: "wb_lens x \<Longrightarrow> P \<sqsubseteq> (\<forall> x \<bullet> P)"
  by (pred_simp, metis wb_lens.get_put)

lemma ex_unrest: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma all_unrest: "x \<sharp> P \<Longrightarrow> (\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma not_ex_not: "\<not> (\<exists> x \<bullet> \<not> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

subsection {* Conditional laws *}

lemma cond_def:
  "(P \<triangleleft> b \<triangleright> Q) = ((b \<and> P) \<or> ((\<not> b) \<and> Q))"
  by (pred_auto)

lemma cond_idem:"(P \<triangleleft> b \<triangleright> P) = P" by (pred_auto)

lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)" by (pred_auto)

lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))" by (pred_auto)

lemma cond_unit_T [simp]:"(P \<triangleleft> true \<triangleright> Q) = P" by (pred_auto)

lemma cond_unit_F [simp]:"(P \<triangleleft> false \<triangleright> Q) = Q" by (pred_auto)

lemma cond_and_T_integrate:
  "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
  by (pred_auto)

lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" by (pred_auto)

lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)" by (pred_auto)

lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_imp_distr:
"((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_eq_distr:
"((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_conj_distr:"(P \<and> (Q \<triangleleft> b \<triangleright> S)) = ((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S))" by (pred_auto)

lemma cond_disj_distr:"(P \<or> (Q \<triangleleft> b \<triangleright> S)) = ((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S))" by (pred_auto)

lemma cond_neg: "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))" by (pred_auto)

lemma cond_conj: "P \<triangleleft> b \<and> c \<triangleright> Q = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
  by (pred_auto)

lemma cond_USUP_dist: "(\<Squnion> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Squnion> P\<in>S \<bullet> G(P)) = (\<Squnion> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_UINF_dist: "(\<Sqinter> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Sqinter> P\<in>S \<bullet> G(P)) = (\<Sqinter> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_var_subst_left:
  assumes "vwb_lens x"
  shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> Q) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma cond_var_subst_right:
  assumes "vwb_lens x"
  shows "(P \<triangleleft> var x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens.put_eq)

lemma cond_var_split:
  "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
  by (rel_simp, (metis (full_types) vwb_lens.put_eq)+)

subsection {* Cylindric algebra *}

lemma C1: "(\<exists> x \<bullet> false) = false"
  by (pred_auto)

lemma C2: "wb_lens x \<Longrightarrow> `P \<Rightarrow> (\<exists> x \<bullet> P)`"
  by (pred_simp, metis wb_lens.get_put)

lemma C3: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> (P \<and> (\<exists> x \<bullet> Q))) = ((\<exists> x \<bullet> P) \<and> (\<exists> x \<bullet> Q))"
  by (pred_auto)

lemma C4a: "x \<approx>\<^sub>L y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))+

lemma C4b: "x \<bowtie> y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using ex_commute by blast

lemma C5:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "(&x =\<^sub>u &x) = true"
  by (pred_auto)

lemma C6:
  assumes "wb_lens x" "x \<bowtie> y" "x \<bowtie> z"
  shows "(&y =\<^sub>u &z) = (\<exists> x \<bullet> &y =\<^sub>u &x \<and> &x =\<^sub>u &z)"
  using assms
  by (pred_simp, (metis lens_indep_def)+)

lemma C7:
  assumes "weak_lens x" "x \<bowtie> y"
  shows "((\<exists> x \<bullet> &x =\<^sub>u &y \<and> P) \<and> (\<exists> x \<bullet> &x =\<^sub>u &y \<and> \<not> P)) = false"
  using assms
  by (pred_simp, simp add: lens_indep_sym)

subsection {* Quantifier lifting *}

named_theorems uquant_lift

lemma shEx_lift_conj_1 [uquant_lift]:
  "((\<^bold>\<exists> x \<bullet> P(x)) \<and> Q) = (\<^bold>\<exists> x \<bullet> P(x) \<and> Q)"
  by (pred_auto)

lemma shEx_lift_conj_2 [uquant_lift]:
  "(P \<and> (\<^bold>\<exists> x \<bullet> Q(x))) = (\<^bold>\<exists> x \<bullet> P \<and> Q(x))"
  by (pred_auto)

end


theory CanonicalizationSyntax
  imports
    OptimizationDSL.Canonicalization
    CanonicalizationTreeProofs
begin

(* TODO: rename this to a more general name now it is not 32-bit specific. *)
typedef i32exp = "{e . (\<forall>m p v . ([m,p] \<turnstile> e \<mapsto> v) \<longrightarrow> (is_IntVal v))}"
  by auto

lemma i32e_eval:
  "\<forall>v. \<exists>b vv. ([m, p] \<turnstile> (Rep_i32exp e) \<mapsto> v) \<longrightarrow> ([m, p] \<turnstile> (Rep_i32exp e) \<mapsto> IntVal b vv)"
  using Rep_i32exp is_IntVal_def by fastforce

lemma int32_binary:
  assumes "[m, p] \<turnstile> BinaryExpr op (Rep_i32exp x) (Rep_i32exp y) \<mapsto> v"
  shows "\<exists>b xv yv. v = bin_eval op (IntVal b xv) (IntVal b yv)"
  using assms apply auto using Rep_i32exp is_IntVal_def
  sorry
(* WAS:
  by (metis (mono_tags, lifting) mem_Collect_eq)
*)

typedef intexp = "{e . (\<forall>m p v . ([m,p] \<turnstile> e \<mapsto> v) \<longrightarrow> is_IntVal v)}"
  by auto

declare
  [[coercion_enabled]]
  [[coercion Rep_intexp, coercion Rep_i32exp]]

fun size :: "IRExpr \<Rightarrow> nat" where
  "size (UnaryExpr op e) = (size e) + 1" |
  "size (BinaryExpr BinAdd x y) = (size x) + (2 * (size y))" |
  "size (BinaryExpr op x y) = (size x) + (size y)" |
  "size (ConditionalExpr cond t f) = (size cond) + (size t) + (size f) + 2" |
  "size (ConstantExpr c) = 1" |
  "size (ParameterExpr ind s) = 2" |
  "size (LeafExpr nid s) = 2" |
  "size (ConstantVar c) = 2" |
  "size (VariableExpr x s) = 2"

lemma size_gt_0: "size e > 0"
proof (induction e)
case (UnaryExpr x1 e)
  then show ?case by auto
next
case (BinaryExpr x1 e1 e2)
then show ?case by (cases x1; auto)
next
  case (ConditionalExpr e1 e2 e3)
  then show ?case by auto
next
  case (ParameterExpr x1 x2)
then show ?case by auto
next
  case (LeafExpr x1 x2)
  then show ?case by auto
next
  case (ConstantExpr x)
  then show ?case by auto
next
  case (ConstantVar x)
  then show ?case by auto
next
  case (VariableExpr x1 x2)
  then show ?case by auto
qed

lemma binary_expr_size_gte_2: "size (BinaryExpr op x y) \<ge> 2"
  apply (induction "BinaryExpr op x y") apply auto apply (cases op; auto) using size_gt_0
  apply (simp add: Suc_leI trans_le_add2)
  by (metis Suc_leI add_2_eq_Suc' add_Suc_shift add_mono numeral_2_eq_2 size_gt_0)+

lemma size_eq_1: "(size e = 1) = is_ConstantExpr e"
  apply (cases e; auto) using size_gt_0
  apply (metis) using size_gt_0
  by (metis binary_expr_size_gte_2 lessI not_less numeral_2_eq_2)

lemma nonconstants_gt_one: "\<not> (is_ConstantExpr e) \<Longrightarrow> size e > 1"
  apply (cases e; auto) using size_gt_0
  apply simp using size_gt_0
  using Suc_le_eq binary_expr_size_gte_2 numeral_2_eq_2 by auto

lemma size_det: "x = y \<Longrightarrow> size x = size y"
  by auto

lemma size_non_add: "op \<noteq> BinAdd \<Longrightarrow> size (BinaryExpr op a b) = size a + size b"
  by (induction op; auto)

value "exp[abs e]"
ML_val \<open>@{term "abs e"}\<close>
ML_val \<open>@{term "x & x"}\<close>
ML_val \<open>@{term "cond ? tv : fv"}\<close>
ML_val \<open>@{term "x < y"}\<close>
ML_val \<open>@{term "c < y"}\<close>
ML_val \<open>@{term "a \<Longrightarrow> c < y"}\<close>
ML_val \<open>@{term "x << y"}\<close>

value "exp[(const v1) + y]"

datatype Type =
  Integer |
  Float |
  Object |
  Unknown

definition type :: "IRExpr \<Rightarrow> Type" where
  "type e = (case (stamp_expr e) of
    IntegerStamp _ _ _ \<Rightarrow> Integer
    | ObjectStamp _ _ _ _ \<Rightarrow> Object
    | _ \<Rightarrow> Unknown)"

lemma unfold_type[simp]:
  "(type x = Integer) = is_IntegerStamp (stamp_expr x)"
  unfolding type_def using is_IntegerStamp_def
  using Stamp.case_eq_if Stamp.disc(1) Type.distinct(1) Type.distinct(3)
  by (simp add: Stamp.case_eq_if)

definition type_safe :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" where
  "type_safe e1 e2 =
    ((type e1 = type e2)
    \<and> (is_IntegerStamp (stamp_expr e1)
        \<longrightarrow> (stp_bits (stamp_expr e1) = stp_bits (stamp_expr e2))))"

fun int_and_equal_bits :: "Value \<Rightarrow> Value \<Rightarrow> bool" where
  "int_and_equal_bits (IntVal b1 e1) (IntVal b2 e2) = (b1 = b2 \<and> 0 < b1 \<and> b1 \<le> 64)" |
  "int_and_equal_bits _ _ = False"

lemma unfold_int_typesafe[simp]:
  assumes "type e1 = Integer"
  shows "type_safe e1 e2 =
    ((type e1 = type e2) \<and>
    (stp_bits (stamp_expr e1) = stp_bits (stamp_expr e2)))"
proof -
  have "is_IntegerStamp (stamp_expr e1)"
    using assms unfold_type by simp
  then show ?thesis unfolding type_safe_def
    by simp
qed

lemma uminus_intstamp_prop:
  assumes "type x = Integer"
  shows "type exp[-x] = Integer"
proof -
  obtain b lo hi where "stamp_expr x = IntegerStamp b lo hi"
    using assms is_IntegerStamp_def by auto
  then show ?thesis
    using assms unfolding type_def type_safe_def
    by simp
qed

lemma "(size exp[x + (-y)]) > (size exp[x - y])"
  using size.simps(1,2)
  by force

datatype RewriteResult =
  success IRExpr |
  fail

ML_val \<open>@{term "(case n of
    (BinaryExpr BinAdd (ConstantExpr c_val) e) \<Rightarrow>
      if (\<not>(is_ConstantExpr e) \<and> type e = Integer) then
        success (BinaryExpr BinAdd e (ConstantExpr c_val))
      else
        fail |
    _ \<Rightarrow> fail)"}\<close>

(*(app "_case_syntax"
            (Ast.Variable "x",
             foldr1 (app \<^syntax_const>\<open>_case2\<close>) (map_index (case1 constraint authentic) spec)),
           capp (capps (case_constant, map_index arg1 spec), Ast.Variable "x"))*)

ML \<open>
val test = Conditional
            (@{term \<open>BinaryExpr BinAdd (ConstantExpr c_val) e\<close>},
            @{term \<open>BinaryExpr BinAdd e (ConstantExpr c_val)\<close>},
            @{term \<open>\<not>(is_ConstantExpr e) \<and> type e = Integer\<close>})

fun generate_cases p e ctxt =
  let
  val x =
    Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);

  val NilC = Syntax.const @{const_name "Nil"};
  val ConsC = Syntax.const @{const_name "Cons"};
  val dummyC = Syntax.const @{const_name "Pure.dummy_pattern"};

  fun single x = ConsC $ x $ NilC;

  val case1 = Syntax.const \<^syntax_const>\<open>_case1\<close> $ p $ single e;
  val case2 =
    Syntax.const \<^syntax_const>\<open>_case1\<close> $ dummyC $ NilC;
  val cs = Syntax.const \<^syntax_const>\<open>_case2\<close> $ case1 $ case2;

  val res = Case_Translation.case_tr false ctxt [x, cs];
  val _ = @{print} res;

  val plz = Syntax.const @{syntax_const "_case_syntax"}
  in
    single e $ dummyC
  end;

fun rewrite_to_code bind rewrite ctxt =
  case rewrite of
    Conditional (pre, post, cond) =>
        @{const Trueprop} $
        (Const ("HOL.eq", @{typ "(IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> (IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> bool"})
        $ (Free (bind ^ "_code", @{typ "IRExpr \<Rightarrow> RewriteResult"}))
        $ (Const ("IRTreeEval.IRExpr.case_IRExpr",
          @{typ \<open>(IRUnaryOp \<Rightarrow> IRExpr \<Rightarrow> RewriteResult)
           \<Rightarrow> (IRBinaryOp \<Rightarrow> IRExpr \<Rightarrow> IRExpr \<Rightarrow> RewriteResult)
              \<Rightarrow> (IRExpr \<Rightarrow> IRExpr \<Rightarrow> IRExpr \<Rightarrow> RewriteResult)
                 \<Rightarrow> (nat \<Rightarrow> Stamp \<Rightarrow> RewriteResult)
                    \<Rightarrow> (nat \<Rightarrow> Stamp \<Rightarrow> RewriteResult)
                       \<Rightarrow> (Value \<Rightarrow> RewriteResult)
                          \<Rightarrow> (char list \<Rightarrow> RewriteResult)
                             \<Rightarrow> (char list \<Rightarrow> Stamp \<Rightarrow> RewriteResult)
                                \<Rightarrow> IRExpr \<Rightarrow> RewriteResult\<close>})
        $ @{term "(\<lambda> (_::IRUnaryOp) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::IRBinaryOp) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::nat) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::ID) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::Value) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::string) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::string) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}))
 |
   (* Transform (pre, post) =>
        @{const Trueprop}
        $ (Const ("HOL.eq", @{typ "(IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> (IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> bool"})
           $ Free (bind ^ "_code", @{typ "IRExpr \<Rightarrow> RewriteResult"})
           $ generate_cases pre post ctxt
          )
 | *)
    _ => @{const Trueprop} $
        (Const ("HOL.eq", @{typ "(IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> (IRExpr \<Rightarrow> RewriteResult) \<Rightarrow> bool"})
        $ (Free (bind ^ "_code", @{typ "IRExpr \<Rightarrow> RewriteResult"}))
        $ @{term \<open>\<lambda> (x::IRExpr) \<Rightarrow> fail\<close>});
\<close>

fun bad_trm :: "IRExpr \<Rightarrow> nat" where
  "bad_trm x = 0"

definition test where
  "test n = (case n of
    (BinaryExpr BinAdd (ConstantExpr c_val) e) \<Rightarrow>
      if (\<not>(is_ConstantExpr e) \<and> type e = Integer) then
        success (BinaryExpr BinAdd e (ConstantExpr c_val))
      else
        fail |
    _ \<Rightarrow> fail)"

ML_val \<open>@{term "(case n of
    (BinaryExpr BinAdd (ConstantExpr c_val) e) \<Rightarrow>
      if (\<not>(is_ConstantExpr e) \<and> type e = Integer) then
        success (BinaryExpr BinAdd e (ConstantExpr c_val))
      else
        fail |
    _ \<Rightarrow> fail)"}\<close>

print_phases

ML_val \<open>@{term "case_IRExpr"}
        $ @{term "(\<lambda> (_::IRUnaryOp) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::IRBinaryOp) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> \<lambda> (_::IRExpr) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::nat) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::ID) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::Value) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::string) \<Rightarrow> fail)"}
        $ @{term "(\<lambda> (_::string) \<Rightarrow> \<lambda> (_::Stamp) \<Rightarrow> fail)"}\<close>

ML_val \<open>@{term "hello = case_IRExpr
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> fail)
    (\<lambda> _ \<Rightarrow> \<lambda> _ \<Rightarrow> fail)"}\<close>

phase Canonicalization
  terminating size
begin

(*
optimization constant_fold:
  "(const(c\<^sub>1) \<oplus>\<^sub>x const(c\<^sub>2)) \<mapsto> (bin_eval c\<^sub>1 x c\<^sub>2)"

optimization constant_add:
  "(e1 + e2) \<mapsto> r when (e1 = ConstantExpr v1 \<and> e2 = ConstantExpr v2 \<and> r = ConstantExpr (intval_add v1 v2))"
  unfolding le_expr_def apply (cases; auto) using evaltree.ConstantExpr defer
   apply simp
  sorry
*)

(*
value "constant_add_code (BinaryExpr BinAdd (ConstantExpr (IntVal32 0)) (ConstantExpr (IntVal32 0)))"
*)

print_context

optimization constant_shift:
  "((const c) + (e::intexp)) \<longmapsto> (e + (const c)) when (\<not>(is_ConstantExpr e))"
  using nonconstants_gt_one apply fastforce
  sorry
(* WAS:
   by (smt (verit, ccfv_SIG) BinaryExprE add.commute bin_eval.simps(1) evaltree.intros(5) le_expr_def)
*)

print_context

thm constant_shift

optimization neutral_zero:
  "((e::i32exp) + const(IntVal b 0)) \<longmapsto> e"
   apply simp+
  using Rep_i32exp is_IntVal_def
  sorry
(* WAS: by fastforce *)

ML_val \<open>@{term "(e1 - e2) + e2 \<longmapsto> e1"}\<close>

lemma neutral_left_add_sub_val:
  assumes "val[(e1 - e2) + e2] \<noteq> UndefVal"
  shows "val[(e1 - e2) + e2] = e1"
  using assms apply (cases e1; cases e2; auto)
  sorry
(* TODO: need to derive information about the values being well-formed? *)

optimization neutral_left_add_sub:
  "((e1::intexp) - (e2::intexp)) + e2 \<longmapsto> e1"
   defer apply simp
  using neutral_left_add_sub_val
  apply (smt (verit, del_insts) bin_eval.simps(1) bin_eval.simps(3) evalDet unfold_binary)
  by (simp add: size_gt_0)

lemma neutral_right_add_sub_val:
  assumes "val[e1 + (e2 - e1)] \<noteq> UndefVal"
  shows "val[e1 + (e2 - e1)] = e2"
  using assms apply (cases e1; cases e2; auto)
  sorry
(* TODO: need to derive information about the values being well-formed? *)

optimization neutral_right_add_sub:
  "(e1::intexp) + ((e2::intexp) - e1) \<longmapsto> e2"
   defer apply simp
  using neutral_right_add_sub_val
  apply (smt (verit) BinaryExprE bin_eval.simps(1) bin_eval.simps(3) evalDet)
  using size_gt_0 by auto

optimization add_ynegate:
  "((x::i32exp) + (-(y::i32exp))) \<longmapsto> (x - y)"
  defer apply simp
  using Groups.group_add_class.add_uminus_conv_diff sorry
  (*by (metis BinaryExpr bin_eval.simps(3) evalDet i32e_eval intval_add.simps(1) intval_negate.simps(1) intval_sub.simps(1))*)

print_context

end

print_context

phase DirectTranslationTest
  terminating size
begin

(*
value "intval_abs (IntVal32 (0))"
value "intval_abs (intval_abs (IntVal32 (0)))"
value "intval_abs (IntVal32 (2147483648))"
value "intval_abs (intval_abs (IntVal32 (2147483648)))"
value "intval_abs (IntVal32 (-2147483648))"
value "intval_abs (intval_abs (IntVal32 (-2147483648)))"
value "intval_abs (IntVal32 (4294967295))"
value "intval_abs (intval_abs (IntVal32 (4294967295)))"

lemma helper: "intval_abs (IntVal32 e) = intval_abs (intval_abs (IntVal32 e))" (is ?thesis)
  sorry

optimization AbsIdempotence: "abs(abs(Rep_int32 e)) \<mapsto> abs(Rep_int32 e)"
  apply auto using helper
  using Rep_int32
  by (metis UnaryExpr evalDet int32_eval unary_eval.simps(1))

optimization AbsNegate: "abs(-e) \<mapsto> abs(e) when is_IntegerStamp (stamp_expr e)"
  apply auto
  by (metis UnaryExpr abs_neg_is_neg stamp_implies_valid_value is_IntegerStamp_def unary_eval.simps(1))
*)

(* NOTE: I had to add assms 2-3 to this.  It is similar to validDefIntConst. *)
lemma int_constants_valid:
  assumes "is_IntVal val"
  assumes "0 < intval_bits val \<and> intval_bits val \<le> 64"
  assumes "take_bit (intval_bits val) (intval_word val) = (intval_word val)"
  shows "valid_value val (constantAsStamp val)"
proof -
  obtain ival where ival: "val = IntVal (intval_bits val) ival"
    using assms is_IntVal_def by fastforce
  then show ?thesis
    using assms validStampIntConst
    by (metis intval_word.simps validDefIntConst)
qed

(*
lemma unary_eval_preserves_validity:
  assumes "is_int_val c"
  shows "valid_value (unary_eval op c) (constantAsStamp (unary_eval op c))"
  using assms apply (cases c) apply simp
     defer defer apply simp+
  apply (cases op)
  using int_constants_valid intval_abs.simps(1) is_int_val.simps(1) unary_eval.simps(1) apply presburger
  using int_constants_valid intval_negate.simps(1) is_int_val.simps(1) unary_eval.simps(2) apply presburger
  using int_constants_valid intval_not.simps(1) is_int_val.simps(1) unary_eval.simps(3) apply presburger
  using int_constants_valid intval_logic_negation.simps(1) is_int_val.simps(1) unary_eval.simps(4) apply presburger
     defer defer defer
     apply (cases op)
  using int_constants_valid intval_abs.simps(2) is_int_val.simps(2) unary_eval.simps(1) apply presburger
  using int_constants_valid intval_negate.simps(2) is_int_val.simps(2) unary_eval.simps(2) apply presburger
  using int_constants_valid intval_not.simps(2) is_int_val.simps(2) unary_eval.simps(3) apply presburger
  sorry (* WARNING: TODO: WARNING: a whole bunch of unary operations aren't implemented making this false *)

optimization UnaryConstantFold: "UnaryExpr op c \<mapsto> ConstantExpr (unary_eval op val_c) when is_int_val val_c"
  apply (auto simp: int_constants_valid)
  using evaltree.ConstantExpr int_constants_valid unary_eval_preserves_validity by simp
*)

optimization AndEqual: "((x::intexp) & x) \<longmapsto> x"
  sorry
(* WAS:
   defer apply auto
  using evalDet int_constants_valid demorgans_rewrites_helper(3)
  apply (metis constantAsStamp.elims intval_and.simps)
  by (simp add: size_gt_0)
*)

optimization AndShiftConstantRight: "((const x) + y) \<longmapsto> y + (const x) when ~(is_ConstantExpr y)"
  defer apply simp
   apply (smt (verit, ccfv_threshold) BinaryExprE bin_eval.simps(1) evaltree.simps intval_add_sym)
  unfolding size.simps using nonconstants_gt_one by auto

(*
optimization AndRightFallthrough: "x & y \<mapsto> y when (canBeZero x.stamp & canBeOne y.stamp) = 0" sorry
optimization AndLeftFallthrough: "x & y \<mapsto> x when (canBeZero y.stamp & canBeOne x.stamp) = 0" sorry
*)

lemma neutral_and:
  assumes "valid_value x (IntegerStamp 32 lox hix)"
  shows "bin_eval BinAnd x (IntVal 32 (neg_one 32)) = x"
  using assms bin_eval.simps(4) valid_int_gives apply (cases x; auto)
   apply (metis take_bit_eq_mask)
  by presburger

context
  includes bit_operations_syntax
begin
optimization AndNeutral: "((x::i32exp) & (const (IntVal 32 (neg_one 32)))) \<longmapsto> x"
   apply auto
  using unrestricted_stamp_valid_value neutral_and
  sorry
(* WAS:
  by (smt (z3) Value.distinct(9) bin_eval.simps(4) intval_and.elims neutral_and unrestricted_stamp_valid_value unrestricted_stamp.simps(2))
*)
end

optimization ConditionalEqualBranches: "(b ? v : v) \<longmapsto> v" .

optimization ConditionalEqualIsRHS: "((x eq y) ? x : y) \<longmapsto> y when (type x = Integer \<and> type_safe x y)"
   apply auto
  sorry
(* WAS:
  by (smt (z3) bool_to_val.simps(2) evalDet intval_equals.elims val_to_bool.simps(1))
*)

(*
optimization ConditionalEliminateKnownLess: "(x < y ? x : y) \<mapsto> x when (x.stamp.upper <= y.stamp.lower)" sorry
optimization ConditionalEliminateKnownLess: "(x < y ? y : x) \<mapsto> y when (x.stamp.upper <= y.stamp.lower)" sorry
*)

lemma bool_is_int_val:
  "is_IntVal (bool_to_val x)"
  using bool_to_val.simps is_IntVal_def by (metis (full_types))

text \<open>Not all binary operators require equal bits, but these results hold for those that do.\<close>

lemma bin_eval_defined:
  assumes "int_and_equal_bits c1 c2"
  assumes "val = bin_eval op c1 c2"
  shows "val \<noteq> UndefVal \<and> is_IntVal val"
  using assms apply (cases c1; cases c2; cases op; simp)
  using bool_is_int_val apply blast
  apply (smt (verit) Value.disc(2) Value.distinct(1) new_int.simps)
    using bool_is_int_val by blast+

(* TODO: this needs refining, as there are three groups of binary operators,
  each with different resulting bit widths.  Maybe we need lemmas about the
  result size for each group?
*)
lemma bin_eval_preserves_validity:
  assumes "int_and_equal_bits c1 c2"
  assumes "val = bin_eval op c1 c2"
  shows "valid_value val (constantAsStamp val)"
proof -
  obtain b ival where "val = IntVal b ival"
    using bin_eval_defined assms is_IntVal_def by force
  then have "valid_stamp (constantAsStamp val)"
    using assms validStampIntConst
    sorry
  then show ?thesis
    sorry
qed

optimization BinaryFoldConstant: "BinaryExpr op (const e1) (const e2) \<longmapsto> ConstantExpr (bin_eval op e1 e2) when int_and_equal_bits e1 e2 "
   defer apply auto
   apply (simp add: wf_value_def ConstantExpr bin_eval_preserves_validity)
  using nonconstants_gt_one by simp

optimization AddShiftConstantRight: "((const c) + y) \<longmapsto> y + (const c) when ~(is_ConstantExpr y)"
  defer apply simp
   apply (smt (verit, del_insts) BinaryExprE bin_eval.simps(1) evaltree.simps intval_add_sym)
  unfolding size.simps using nonconstants_gt_one by simp
(*
optimization RedundantSubAdd: "isAssociative + => (a - b) + b \<mapsto> a" sorry
optimization RedundantAddSub: "isAssociative + => (b + a) - b \<mapsto> a" sorry
*)
lemma neutral_add:
  assumes "valid_value x (IntegerStamp 32 lox hix)"
  shows "bin_eval BinAdd x (IntVal 32 (0)) = x"
  using assms bin_eval.simps(4) by (cases x; auto; presburger)

(* TODO: this one can be false if e is malformed.  E.g. 32-bits but with upper bits set. *)
lemma AddNeutralVal:
  assumes "val[e + const 0] \<noteq> UndefVal"
  shows "val[e + const 0] = e"
  using assms apply (cases e; auto)
  sorry

optimization AddNeutral: "(e + (const (IntVal 32 0))) \<longmapsto> e when (stamp_expr e = IntegerStamp 32 l u)"
   apply simp+ apply (rule impI) apply (rule allI)+ apply (rule impI) using AddNeutralVal
  by fastforce

lemma intval_negateadd_equals_sub_left: "bin_eval BinAdd (unary_eval UnaryNeg e) y = bin_eval BinSub y e"
  by (cases e; auto; cases y; auto)

lemma intval_negateadd_equals_sub_right: "bin_eval BinAdd x (unary_eval UnaryNeg e) = bin_eval BinSub x e"
  by (cases e; auto; cases x; auto)

optimization AddLeftNegateToSub: "-e + y \<longmapsto> y - e"
  defer apply simp using intval_negateadd_equals_sub_left
  by (metis BinaryExpr BinaryExprE UnaryExprE)

optimization AddRightNegateToSub: "x + -e \<longmapsto> x - e"
  defer apply simp using intval_negateadd_equals_sub_right
  by (metis BinaryExpr BinaryExprE UnaryExprE)

optimization MulEliminator: "((x::i32exp) * const(IntVal 32 0)) \<longmapsto> const(IntVal 32 0)"
   defer apply auto
  using Rings.mult_zero_class.mult_zero_right
  sorry
(* WAS:
  apply (metis (no_types, opaque_lifting) ConstantExpr bin_eval.simps(3) bin_eval_preserves_validity cancel_comm_monoid_add_class.diff_cancel evalDet i32e_eval int_and_equal_bits.simps(1) intval_mul.simps(1) intval_sub.simps(1))
    unfolding size.simps
    by (simp add: size_gt_0)
*)

lemma "(x::('a::len) word) * 1 = x"
  by simp

optimization MulNeutral: "(x * const(IntVal 32 1)) \<longmapsto> x"
   apply auto
  using Groups.comm_monoid_mult_class.mult.comm_neutral
  sorry
(* WAS:
  by (smt (z3) Value.distinct(9) intval_mul.elims neutral_rewrite_helper(1) unrestricted_stamp_valid_value unrestricted_stamp.simps(2))
*)

(*
optimization MulNegate: "(x * const (-1) ) \<mapsto> -x when (stamp_expr x = IntegerStamp 32 l u)"
  apply simp
  apply (metis BinaryExprE ConstantExprE bin_eval.simps(2) neutral_rewrite_helper(1) stamp_implies_valid_value)
  unfolding size.simps by simp
*)
end

(*
experiment begin
value "(3::32 word) mod 32"

lemma "(x::nat) \<ge> 0 \<and> x < base \<Longrightarrow> x mod base = x"
  by simp

lemma word_mod_less: "(x::('a::len) word) < base \<Longrightarrow> x mod base = x"
  by (metis mod_less not_le unat_arith_simps(2) unat_arith_simps(7) unat_mono word_le_less_eq)

value "4294967298::32 word"

lemma shift_equality: "((v1::32 word) << unat ((v2::32 word) mod 32)) = v1 * ((2 ^ (unat v2))::32 word)"
proof -
  have "size_class.size (2 ^ (unat v2)) = 32" sorry
  then have "(2 ^ (unat v2)) < 2 ^ 32"
    using uint_range_size sorry
  then have "unat v2 < 32"
    using nat_power_less_imp_less zero_less_numeral by blast
  then show ?thesis
    using \<open>2 ^ unat v2 < 2 ^ 32\<close> numeral_Bit0 power2_eq_square power_add sorry
qed
end
*)

end