(*
  File: Lists_Ex.thy
  Author: Bohua Zhan
*)

section \<open>Lists\<close>

theory Lists_Ex
  imports Mapping_Str
begin

text \<open>
  Examples on lists. The itrev example comes from
  \<^cite>\<open>\<open>Section 2.4\<close> in "prog-prove"\<close>.

  The development here of insertion and deletion on lists is
  essential for verifying functional binary search trees and
  red-black trees. The idea, following Nipkow~\<^cite>\<open>"nipkow16"\<close>,
  is that showing sorted-ness and preservation of multisets for trees
  should be done on the in-order traversal of the tree.
\<close>

subsection \<open>Linear time version of rev\<close>

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev []       ys = ys"
| "itrev (x # xs) ys = itrev xs (x # ys)"
setup \<open>fold add_rewrite_rule @{thms itrev.simps}\<close>

lemma itrev_eq_rev: "itrev x [] = rev x"
@proof
  @induct x for "\<forall>y. itrev x y = rev x @ y" arbitrary y
@qed

subsection \<open>Strict sorted\<close>

fun strict_sorted :: "'a::linorder list \<Rightarrow> bool" where
  "strict_sorted [] = True"
| "strict_sorted (x # ys) = ((\<forall>y\<in>set ys. x < y) \<and> strict_sorted ys)"
setup \<open>fold add_rewrite_rule @{thms strict_sorted.simps}\<close>

lemma strict_sorted_appendI [backward]:
  "strict_sorted xs \<and> strict_sorted ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x < y) \<Longrightarrow> strict_sorted (xs @ ys)"
@proof @induct xs @qed

lemma strict_sorted_appendE1 [forward]:
  "strict_sorted (xs @ ys) \<Longrightarrow> strict_sorted xs \<and> strict_sorted ys"
@proof @induct xs @qed

lemma strict_sorted_appendE2 [forward]:
  "strict_sorted (xs @ ys) \<Longrightarrow> x \<in> set xs \<Longrightarrow> \<forall>y\<in>set ys. x < y"
@proof @induct xs @qed

lemma strict_sorted_distinct [forward]: "strict_sorted l \<Longrightarrow> distinct l"
@proof @induct l @qed

subsection \<open>Ordered insert\<close>

fun ordered_insert :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "ordered_insert x [] = [x]"
| "ordered_insert x (y # ys) = (
    if x = y then (y # ys)
    else if x < y then x # (y # ys)
    else y # ordered_insert x ys)"
setup \<open>fold add_rewrite_rule @{thms ordered_insert.simps}\<close>

lemma ordered_insert_set [rewrite]:
  "set (ordered_insert x ys) = {x} \<union> set ys"
@proof @induct ys @qed

lemma ordered_insert_sorted [forward]:
  "strict_sorted ys \<Longrightarrow> strict_sorted (ordered_insert x ys)"
@proof @induct ys @qed

lemma ordered_insert_binary [rewrite]:
  "strict_sorted (xs @ a # ys) \<Longrightarrow> ordered_insert x (xs @ a # ys) =
    (if x < a then ordered_insert x xs @ a # ys
     else if x > a then xs @ a # ordered_insert x ys
     else xs @ a # ys)"
@proof @induct xs @qed

subsection \<open>Deleting an element\<close>

fun remove_elt_list :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "remove_elt_list x [] = []"
| "remove_elt_list x (y # ys) = (if y = x then remove_elt_list x ys else y # remove_elt_list x ys)"
setup \<open>fold add_rewrite_rule @{thms remove_elt_list.simps}\<close>

lemma remove_elt_list_set [rewrite]:
  "set (remove_elt_list x ys) = set ys - {x}"
@proof @induct ys @qed

lemma remove_elt_list_sorted [forward]:
  "strict_sorted ys \<Longrightarrow> strict_sorted (remove_elt_list x ys)"
@proof @induct ys @qed

lemma remove_elt_idem [rewrite]:
  "x \<notin> set ys \<Longrightarrow> remove_elt_list x ys = ys"
@proof @induct ys @qed

lemma remove_elt_list_binary [rewrite]:
  "strict_sorted (xs @ a # ys) \<Longrightarrow> remove_elt_list x (xs @ a # ys) =
    (if x < a then remove_elt_list x xs @ a # ys
     else if x > a then xs @ a # remove_elt_list x ys else xs @ ys)"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x < a" @with @have "x \<notin> set ys" @end
  @endgoal @end
@qed

subsection \<open>Ordered insertion into list of pairs\<close>

fun ordered_insert_pairs :: "'a::ord \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "ordered_insert_pairs x v [] = [(x, v)]"
| "ordered_insert_pairs x v (y # ys) = (
    if x = fst y then ((x, v) # ys)
    else if x < fst y then (x, v) # (y # ys)
    else y # ordered_insert_pairs x v ys)"
setup \<open>fold add_rewrite_rule @{thms ordered_insert_pairs.simps}\<close>

lemma ordered_insert_pairs_map [rewrite]:
  "map_of_alist (ordered_insert_pairs x v ys) = update_map (map_of_alist ys) x v"
@proof @induct ys @qed

lemma ordered_insert_pairs_set [rewrite]:
  "set (map fst (ordered_insert_pairs x v ys)) = {x} \<union> set (map fst ys)"
@proof @induct ys @qed

lemma ordered_insert_pairs_sorted [backward]:
  "strict_sorted (map fst ys) \<Longrightarrow> strict_sorted (map fst (ordered_insert_pairs x v ys))"
@proof @induct ys @qed

lemma ordered_insert_pairs_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> ordered_insert_pairs x v (xs @ a # ys) =
    (if x < fst a then ordered_insert_pairs x v xs @ a # ys
     else if x > fst a then xs @ a # ordered_insert_pairs x v ys
     else xs @ (x, v) # ys)"
@proof @induct xs @qed

subsection \<open>Deleting from a list of pairs\<close>

fun remove_elt_pairs :: "'a \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "remove_elt_pairs x [] = []"
| "remove_elt_pairs x (y # ys) = (if fst y = x then ys else y # remove_elt_pairs x ys)"
setup \<open>fold add_rewrite_rule @{thms remove_elt_pairs.simps}\<close>

lemma remove_elt_pairs_map [rewrite]:
  "strict_sorted (map fst ys) \<Longrightarrow> map_of_alist (remove_elt_pairs x ys) = delete_map x (map_of_alist ys)"
@proof @induct ys @with
  @subgoal "ys = y # ys'"
    @case "fst y = x" @with @have "x \<notin> set (map fst ys')" @end
  @endgoal @end
@qed

lemma remove_elt_pairs_on_set [rewrite]:
  "strict_sorted (map fst ys) \<Longrightarrow> set (map fst (remove_elt_pairs x ys)) = set (map fst ys) - {x}"
@proof @induct ys @qed

lemma remove_elt_pairs_sorted [backward]:
  "strict_sorted (map fst ys) \<Longrightarrow> strict_sorted (map fst (remove_elt_pairs x ys))"
@proof @induct ys @qed

lemma remove_elt_pairs_idem [rewrite]:
  "x \<notin> set (map fst ys) \<Longrightarrow> remove_elt_pairs x ys = ys"
@proof @induct ys @qed

lemma remove_elt_pairs_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> remove_elt_pairs x (xs @ a # ys) =
    (if x < fst a then remove_elt_pairs x xs @ a # ys
     else if x > fst a then xs @ a # remove_elt_pairs x ys else xs @ ys)"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x < fst a" @with @have "x \<notin> set (map fst ys)" @end
  @endgoal @end
@qed

subsection \<open>Search in a list of pairs\<close>

lemma map_of_alist_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> (map_of_alist (xs @ a # ys))\<langle>x\<rangle> =
   (if x < fst a then (map_of_alist xs)\<langle>x\<rangle>
    else if x > fst a then (map_of_alist ys)\<langle>x\<rangle> else Some (snd a))"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x \<notin> set (map fst ys)"
  @endgoal @end
@qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory WordAbstract
imports L2Defs ExecConcrete
begin

definition [simplified]: "INT_MAX \<equiv> (2 :: int) ^ 31 - 1"
definition [simplified]: "INT_MIN \<equiv> - ((2 :: int) ^ 31)"
definition [simplified]: "UINT_MAX \<equiv> (2 :: nat) ^ 32 - 1"

definition [simplified]: "SHORT_MAX \<equiv> (2 :: int) ^ 15 - 1"
definition [simplified]: "SHORT_MIN \<equiv> - ((2 :: int) ^ 15)"
definition [simplified]: "USHORT_MAX \<equiv> (2 :: nat) ^ 16 - 1"

definition [simplified]: "CHAR_MAX \<equiv> (2 :: int) ^ 7 - 1"
definition [simplified]: "CHAR_MIN \<equiv> - ((2 :: int) ^ 7)"
definition [simplified]: "UCHAR_MAX \<equiv> (2 :: nat) ^ 8 - 1"

definition "WORD_MAX x \<equiv> ((2 ^ (len_of x - 1) - 1) :: int)"
definition "WORD_MIN x \<equiv> (- (2 ^ (len_of x - 1)) :: int)"
definition "UWORD_MAX x \<equiv> ((2 ^ (len_of x)) - 1 :: nat)"

lemma WORD_values [simplified]:
  "WORD_MAX (TYPE(8 signed)) = (2 ^ 7 - 1)"
  "WORD_MAX (TYPE(16 signed)) = (2 ^ 15 - 1)"
  "WORD_MAX (TYPE(32 signed)) = (2 ^ 31 - 1)"

  "WORD_MIN (TYPE(8 signed)) = - (2 ^ 7)"
  "WORD_MIN (TYPE(16 signed)) = - (2 ^ 15)"
  "WORD_MIN (TYPE(32 signed)) = - (2 ^ 31)"

  "UWORD_MAX (TYPE(8)) = (2 ^ 8 - 1)"
  "UWORD_MAX (TYPE(16)) = (2 ^ 16 - 1)"
  "UWORD_MAX (TYPE(32)) = (2 ^ 32 - 1)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

lemmas WORD_values_add1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x + 1"],
    simplified semiring_norm, simplified numeral_One]

lemmas WORD_values_minus1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x - 1"],
    simplified semiring_norm, simplified numeral_One nat_numeral]

lemmas [L1unfold] =
  WORD_values [symmetric]
  WORD_values_add1 [symmetric]
  WORD_values_minus1 [symmetric]

lemma WORD_MAX_simps [polish]:
   "WORD_MAX TYPE(32) = INT_MAX"
   "WORD_MAX TYPE(16) = SHORT_MAX"
   "WORD_MAX TYPE(8) = CHAR_MAX"
  by (auto simp: INT_MAX_def SHORT_MAX_def CHAR_MAX_def WORD_MAX_def)

lemma WORD_MIN_simps [polish]:
   "WORD_MIN TYPE(32) = INT_MIN"
   "WORD_MIN TYPE(16) = SHORT_MIN"
   "WORD_MIN TYPE(8) = CHAR_MIN"
  by (auto simp: INT_MIN_def SHORT_MIN_def CHAR_MIN_def WORD_MIN_def)

lemma UWORD_MAX_simps [polish]:
   "UWORD_MAX TYPE(32) = UINT_MAX"
   "UWORD_MAX TYPE(16) = USHORT_MAX"
   "UWORD_MAX TYPE(8) = UCHAR_MAX"
  by (auto simp: UINT_MAX_def USHORT_MAX_def UCHAR_MAX_def UWORD_MAX_def)

lemma WORD_signed_to_unsigned [polish, simp]:
   "WORD_MAX TYPE('a signed) = WORD_MAX TYPE('a::len)"
   "WORD_MIN TYPE('a signed) = WORD_MIN TYPE('a::len)"
   "UWORD_MAX TYPE('a signed) = UWORD_MAX TYPE('a::len)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

lemma INT_MIN_MAX_lemmas [simp, polish]:
  "unat (u :: word32) \<le> UINT_MAX"
  "sint (s :: sword32) \<le> INT_MAX"
  "INT_MIN \<le> sint (s :: sword32)"
  "INT_MIN \<le> INT_MAX"
  "INT_MIN \<le> sint (s :: sword32)"
  "INT_MIN \<le> INT_MAX"
  "INT_MIN \<le> 0"
  "0 \<le> INT_MAX"

  "\<not> (sint (s :: sword32) > INT_MAX)"
  "\<not> (INT_MIN > sint (s :: sword32))"
  "\<not> (unat (u :: word32) > UINT_MAX)"

  unfolding UINT_MAX_def INT_MAX_def INT_MIN_def
  using sint_range_size [where w=s, simplified word_size, simplified]
        unat_lt2p [where 'a=32, simplified]
        zle_add1_eq_le [where z=INT_MAX, symmetric]
        less_eq_Suc_le not_less_eq_eq
        unat_lt2p [where x=u]
  by auto

(*
 * The following set of theorems allow us to discharge simple
 * equalities involving INT_MIN, INT_MAX and UINT_MAX without
 * the constants being unfolded in the final output.
 *
 * For example:
 *
 *    (4 < INT_MAX)  becomes  True
 *    (x < INT_MAX)  remains  (x < INT_MAX)
 *)

lemma INT_MIN_comparisons [simp]:
  "\<lbrakk> a \<le> - (2 ^ (len_of TYPE('a) - 1)) \<rbrakk> \<Longrightarrow> a \<le> WORD_MIN (TYPE('a::len))"
  "a < - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a < WORD_MIN (TYPE('a::len))"
  "a \<ge> - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  "a > - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  by (auto simp: WORD_MIN_def)

lemma INT_MAX_comparisons [simp]:
  "a \<le> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<le> WORD_MAX (TYPE('a::len))"
  "a < (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a < WORD_MAX (TYPE('a::len))"
  "a \<ge> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  "a > (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  by (auto simp: WORD_MAX_def)

lemma UINT_MAX_comparisons [simp]:
  "x \<le> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x < (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x \<ge> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<ge> UWORD_MAX (TYPE('a::len))"
  "x > (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x > UWORD_MAX (TYPE('a::len))"
  by (auto simp: UWORD_MAX_def)

(*
 * This definition is used when we are trying to introduce a new type
 * in the program text: it simply states that introducing a given
 * abstraction is desired in the current context.
 *)
definition "introduce_typ_abs_fn f \<equiv> True"

declare introduce_typ_abs_fn_def [simp]

lemma introduce_typ_abs_fn:
  "introduce_typ_abs_fn f"
  by simp

(*
 * Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> bool") is an
 * abstraction (over function f) of "X'".
 *
 * For example, (a \<le>\<^sub>i\<^sub>n\<^sub>t b) could be an abstraction of (a \<le>\<^sub>w\<^sub>3\<^sub>2 b)
 * over the abstraction function "unat".
 *)
definition
  abstract_bool_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
where
  "abstract_bool_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (X' a b = X (f a) (f b))"

(* Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> 'b") abstracts "X'". *)
definition
  abstract_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> bool"
where
   "abstract_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (f (X' a b) = X (f a) (f b))"

(* The value "a" is the abstract version of "b" under precondition "P". *)
definition "abstract_val P a f b \<equiv> P \<longrightarrow> (a = f b)"

(* The variable "a" is the abstracted version of the variable "b". *)
definition "abs_var a f b \<equiv> abstract_val True a f b"

declare abstract_bool_binop_def [simp]
declare abstract_binop_def [simp]
declare abstract_val_def [simp]
declare abs_var_def [simp]

lemma abstract_val_trivial:
  "abstract_val True (f b) f b"
  by simp

lemma abstract_binop_is_abstract_val:
    "abstract_binop P f X X' = (\<forall>a b. abstract_val (P (f a) (f b)) (X (f a) (f b)) f (X' a b))"
  by auto

lemma abstract_expr_bool_binop:
  "\<lbrakk> abstract_bool_binop E f X X';
     introduce_typ_abs_fn f;
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) id (X' a' b')"
  by clarsimp

lemma abstract_expr_binop:
  "\<lbrakk> abstract_binop E f X X';
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) f (X' a' b')"
  by clarsimp

lemma unat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op <) (op <)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op \<le>) (op \<le>)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op =) (op =)"
  by (auto simp:  word_less_nat_alt word_le_nat_alt eq_iff)

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [unfolded word_bits_len_of]]

lemma le_to_less_plus_one:
    "((a::nat) \<le> b) = (a < b + 1)"
  by arith

lemma unat_abstract_binops:
  "abstract_binop (\<lambda>a b. a + b \<le> UWORD_MAX TYPE('a::len)) (unat :: 'a word \<Rightarrow> nat) (op +) (op +)"
  "abstract_binop (\<lambda>a b. a * b \<le> UWORD_MAX TYPE('a)) (unat :: 'a word \<Rightarrow> nat) (op * ) (op * )"
  "abstract_binop (\<lambda>a b. a \<ge> b) (unat :: 'a word \<Rightarrow> nat) (op -) (op -)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (op div) (op div)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (op mod) (op mod)"
  by (auto simp: unat_plus_if' unat_div unat_mod UWORD_MAX_def le_to_less_plus_one
              WordAbstract.unat_mult_simple word_bits_def unat_sub word_le_nat_alt)

lemma snat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: ('a::len) signed word \<Rightarrow> int) (op <) (word_sless)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (op \<le>) (word_sle)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (op =) (op =)"
  by (auto simp: word_sless_def word_sle_def less_le)

lemma snat_abstract_binops:
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a::len) \<le> a + b \<and> a + b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op +) (op +)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a * b \<and> a * b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op *) (op *)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a - b \<and> a - b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op -) (op -)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a sdiv b \<and> a sdiv b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op sdiv) (op sdiv)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a smod b \<and> a smod b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op smod) (op smod)"
  by (auto simp: signed_arith_sint word_size WORD_MIN_def WORD_MAX_def)

lemma abstract_val_signed_unary_minus:
  "\<lbrakk> abstract_val P r sint r' \<rbrakk> \<Longrightarrow>
       abstract_val (P \<and> (- r) \<le> WORD_MAX TYPE('a)) (- r) sint ( - (r' :: ('a :: len) signed word))"
  apply clarsimp
  using sint_range_size [where w=r']
  apply -
  apply (subst signed_arith_sint)
   apply (clarsimp simp: word_size WORD_MAX_def)
  apply simp
  done

lemma abstract_val_unsigned_unary_minus:
  "\<lbrakk> abstract_val P r unat r' \<rbrakk> \<Longrightarrow>
       abstract_val P (if r = 0 then 0 else UWORD_MAX TYPE('a::len) + 1 - r) unat ( - (r' :: 'a word))"
  by (clarsimp simp: unat_minus word_size unat_eq_zero UWORD_MAX_def)

lemmas abstract_val_signed_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(1)]
  abstract_expr_binop [OF snat_abstract_binops(2)]
  abstract_expr_binop [OF snat_abstract_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(4)]
  abstract_expr_binop [OF snat_abstract_binops(5)]
  abstract_val_signed_unary_minus

lemmas abstract_val_unsigned_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(1)]
  abstract_expr_binop [OF unat_abstract_binops(2)]
  abstract_expr_binop [OF unat_abstract_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(4)]
  abstract_expr_binop [OF unat_abstract_binops(5)]
  abstract_val_unsigned_unary_minus

lemma mod_less:
  "(a :: nat) < c \<Longrightarrow> a mod b < c"
  by (metis less_trans mod_less_eq_dividend order_leE)

lemma abstract_val_ucast:
    "\<lbrakk> introduce_typ_abs_fn (unat :: ('a::len) word \<Rightarrow> nat);
       abstract_val P v unat v' \<rbrakk>
       \<Longrightarrow>  abstract_val (P \<and> v \<le> nat (WORD_MAX TYPE('a)))
                  (int v) sint (ucast (v' :: 'a word) :: 'a signed word)"
  apply (clarsimp simp: uint_nat [symmetric])
  apply (subst sint_eq_uint)
   apply (rule not_msb_from_less)
   apply (clarsimp simp: word_less_nat_alt unat_ucast WORD_MAX_def le_to_less_plus_one)
   apply (subst (asm) nat_diff_distrib)
     apply simp
    apply clarsimp
   apply clarsimp
   apply (metis int_numeral nat_numeral nat_power_eq zero_zle_int)
  apply (clarsimp simp: uint_up_ucast is_up)
  done

lemma abstract_val_scast:
    "\<lbrakk> introduce_typ_abs_fn (sint :: ('a::len) signed word \<Rightarrow> int);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val (P \<and> 0 \<le> C') (nat C') unat (scast (C :: ('a::len) signed word) :: ('a::len) word)"
  apply (clarsimp simp: down_cast_same [symmetric] is_down unat_ucast)
  apply (subst sint_eq_uint)
   apply (clarsimp simp: word_msb_sint)
  apply (clarsimp simp: unat_def [symmetric])
  apply (subst word_unat.norm_Rep [symmetric])
  apply clarsimp
  done

lemma abstract_val_scast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  by (clarsimp simp: down_cast_same [symmetric] sint_up_scast is_up)

lemma abstract_val_scast_downcast:
    "\<lbrakk> len_of TYPE('b) < len_of TYPE('a::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (sbintrunc ((len_of TYPE('b::len) - 1)) C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint bintrunc_mod2p [symmetric])
  apply (subst bintrunc_sbintrunc_le)
   apply clarsimp
  apply (subst Abs_word_inverse)
   apply (metis len_signed uint word_ubin.eq_norm)
  apply clarsimp
  done

lemma abstract_val_ucast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') unat (ucast (C :: 'a word) :: 'b word)"
  by (clarsimp simp: is_up unat_ucast_upcast)

lemma abstract_val_ucast_downcast:
    "\<lbrakk> len_of TYPE('b::len) < len_of TYPE('a::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C' mod (UWORD_MAX TYPE('b) + 1)) unat (ucast (C :: 'a word) :: 'b word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint UWORD_MAX_def)
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (metis (hide_lams, mono_tags) uint_mod uint_power_lower
      unat_def unat_mod unat_power_lower)
  done

(*
 * The pair A/C are a valid abstraction/concrete-isation function pair,
 * under the precondition's P and Q.
 *)
definition
 "valid_typ_abs_fn (P :: 'a \<Rightarrow> bool) (Q :: 'a \<Rightarrow> bool) (A :: 'c \<Rightarrow> 'a) (C :: 'a \<Rightarrow> 'c) \<equiv>
     (\<forall>v. P v \<longrightarrow> A (C v) = v) \<and> (\<forall>v. Q (A v) \<longrightarrow> C (A v) = v)"

declare valid_typ_abs_fn_def [simp]

lemma valid_typ_abs_fn_id:
  "valid_typ_abs_fn \<top> \<top> id id"
  by clarsimp

lemma valid_typ_abs_fn_unit:
  "valid_typ_abs_fn \<top> \<top> id (id :: unit \<Rightarrow> unit)"
  by clarsimp

lemma valid_typ_abs_fn_unat:
  "valid_typ_abs_fn (\<lambda>v. v \<le> UWORD_MAX TYPE('a::len)) \<top> (unat :: 'a word \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma valid_typ_abs_fn_sint:
  "valid_typ_abs_fn (\<lambda>v. WORD_MIN TYPE('a::len) \<le> v \<and> v \<le> WORD_MAX TYPE('a)) \<top> (sint :: 'a signed word \<Rightarrow> int) (of_int :: int \<Rightarrow> 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma valid_typ_abs_fn_tuple:
  "\<lbrakk> valid_typ_abs_fn P_a Q_a abs_a conc_a; valid_typ_abs_fn P_b Q_b abs_b conc_b \<rbrakk> \<Longrightarrow>
          valid_typ_abs_fn (\<lambda>(a, b). P_a a \<and> P_b b) (\<lambda>(a, b). Q_a a \<and> Q_b b) (map_prod abs_a abs_b) (map_prod conc_a conc_b)"
  by clarsimp

lemma introduce_typ_abs_fn_tuple:
  "\<lbrakk> introduce_typ_abs_fn abs_a; introduce_typ_abs_fn abs_b \<rbrakk> \<Longrightarrow>
         introduce_typ_abs_fn (map_prod abs_a abs_b)"
  by clarsimp

definition [simp]:
  "corresTA P rx ex A C \<equiv> corresXF (\<lambda>s. s) (\<lambda>r s. rx r) (\<lambda>r s. ex r) P A C"

lemma corresTA_L2_gets:
  "\<lbrakk> \<And>s. abstract_val (Q s) (C s) rx (C' s) \<rbrakk> \<Longrightarrow>
     corresTA Q rx ex (L2_gets (\<lambda>s. C s) n) (L2_gets (\<lambda>s. C' s) n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_modify:
    "\<lbrakk> \<And>s. abstract_val (P s) (m s) id (m' s) \<rbrakk> \<Longrightarrow>
            corresTA P rx ex (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s))"
  by (monad_eq simp: L2_modify_def corresXF_def)

lemma corresTA_L2_throw:
  "\<lbrakk> abstract_val Q C ex C' \<rbrakk> \<Longrightarrow>
     corresTA (\<lambda>_. Q) rx ex (L2_throw C n) (L2_throw C' n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_skip:
  "corresTA \<top> rx ex L2_skip L2_skip"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_fail:
  "corresTA \<top> rx ex L2_fail L2_fail"
  by (clarsimp simp: L2_defs corresXF_def)

lemma corresTA_L2_seq':
  fixes L' :: "('s, 'e + 'c1) nondet_monad"
  fixes R' :: "'c1 \<Rightarrow> ('s, 'e + 'c2) nondet_monad"
  fixes L :: "('s, 'ea + 'a1) nondet_monad"
  fixes R :: "'a1 \<Rightarrow> ('s, 'ea + 'a2) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx1 ex L L';
     \<And>r. corresTA (Q (rx1 r)) rx2 ex (R (rx1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx2 ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r)))
       (L2_seq L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_guard_def)
  apply (erule corresXF_join [where P'="\<lambda>x y s. rx1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_seq:
  "\<lbrakk> introduce_typ_abs_fn rx1;
    corresTA P (rx1 :: 'a \<Rightarrow> 'b) ex L L';
     \<And>r r'. abs_var r rx1 r' \<Longrightarrow> corresTA (\<lambda>s. Q r s) rx2 ex (\<lambda>s. R r s) (\<lambda>s. R' r' s) \<rbrakk> \<Longrightarrow>
       corresTA P rx2 ex (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_ s. R r s))) (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_seq_unit:
  fixes L' :: "('s, 'e + unit) nondet_monad"
  fixes R' :: "unit \<Rightarrow> ('s, 'e + 'r) nondet_monad"
  fixes L :: "('s, 'ea + unit) nondet_monad"
  fixes R :: "('s, 'ea + 'ra) nondet_monad"
  shows
  "\<lbrakk> corresTA P id ex L L';
     corresTA Q rx ex (\<lambda>s. R s) (\<lambda>s. R' () s) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard Q) (\<lambda>r s. R s)))
       (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_catch':
  fixes L' :: "('s, 'e1 + 'c) nondet_monad"
  fixes R' :: "'e1 \<Rightarrow> ('s, 'e2 + 'c) nondet_monad"
  fixes L :: "('s, 'e1a + 'ca) nondet_monad"
  fixes R :: "'e1a \<Rightarrow> ('s, 'e2a + 'ca) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx ex1 L L';
     \<And>r. corresTA (Q (ex1 r)) rx ex2 (R (ex1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_catch_def L2_guard_def)
  apply (erule corresXF_except [where P'="\<lambda>x y s. ex1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits cong: rev_conj_cong)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_catch:
  "\<lbrakk> introduce_typ_abs_fn ex1;
     corresTA P rx ex1 L L';
     \<And>r r'. abs_var r ex1 r' \<Longrightarrow> corresTA (Q r) rx ex2 (R r) (R' r') \<rbrakk> \<Longrightarrow>
       corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  by (rule corresTA_L2_catch', simp+)

lemma corresTA_L2_while:
  assumes init_corres: "abstract_val Q i rx i'"
  and cond_corres: "\<And>r r' s. abs_var r rx r'
                           \<Longrightarrow> abstract_val (G r s) (C r s) id (C' r' s)"
  and body_corres: "\<And>r r'. abs_var r rx r'
                           \<Longrightarrow> corresTA (P r) rx ex (B r) (B' r')"
  shows "corresTA (\<lambda>_. Q) rx ex
       (L2_guarded_while (\<lambda>r s. G r s) (\<lambda>r s. C r s) (\<lambda>r. L2_seq (L2_guard (\<lambda>s. P r s)) (\<lambda>_. B r)) i x)
       (L2_while (\<lambda>r s. C' r s) B' i' x)"
proof -
  note body_corres' =
       corresXF_guarded_while_body [OF body_corres [unfolded corresTA_def]]

  have init_corres':
    "Q \<Longrightarrow> i = rx i'"
    using init_corres
    by simp

  show ?thesis
    apply (clarsimp simp: L2_defs guardE_def [symmetric] returnOk_liftE [symmetric])
    apply (rule corresXF_assume_pre)
    apply (rule corresXF_guarded_while [where P="\<lambda>r s. G (rx r) s"])
        apply (cut_tac r'=x in body_corres, simp)
        apply (monad_eq simp: guardE_def corresXF_def split: sum.splits)
       apply (insert cond_corres)[1]
       apply clarsimp
      apply clarsimp
      apply (rule hoareE_TrueI)
     apply (clarsimp simp: init_corres)
     apply (insert init_corres)[1]
     apply (clarsimp)
    apply (clarsimp simp: init_corres')
  done
qed

lemma corresTA_L2_guard:
  "\<lbrakk> \<And>s. abstract_val (Q s) (G s) id (G' s) \<rbrakk>
           \<Longrightarrow> corresTA \<top> rx ex (L2_guard (\<lambda>s. G s \<and> Q s)) (L2_guard (\<lambda>s. G' s))"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_condition:
  "\<lbrakk> corresTA P rx ex L L';
     corresTA Q rx ex R R';
     \<And>s. abstract_val (T s) (C s) id (C' s)  \<rbrakk>
   \<Longrightarrow> corresTA T rx ex
          (L2_condition (\<lambda>s. C s)
            (L2_seq (L2_guard P) (\<lambda>_. L))
            (L2_seq (L2_guard Q) (\<lambda>_. R))
           ) (L2_condition (\<lambda>s. C' s) L' R')"
  apply atomize
  apply (monad_eq simp: L2_defs corresXF_def Ball_def split: sum.splits)
  apply force
  done

(* Backup rule to corresTA_L2_call. Converts the return type of the function call. *)
lemma corresTA_L2_call':
  "\<lbrakk> \<And>s. corresTA P f1 x1 A B;
               valid_typ_abs_fn Q1 Q1' f1 f1';
               valid_typ_abs_fn Q2 Q2' f2 f2'
        \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. P s) f2 x2
           (L2_seq (L2_call A) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
           (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply metis
  apply clarsimp
  apply blast
  done

lemma corresTA_L2_call:
  "\<lbrakk> corresTA P rx ex A B \<rbrakk> \<Longrightarrow>
        corresTA P rx ex' (L2_call A) (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_measure_call:
  "\<lbrakk> monad_mono B; \<And>m. corresTA P rx id (A m) (B m) \<rbrakk> \<Longrightarrow>
        corresTA P rx id (measure_call A) (measure_call B)"
  by (simp add: corresTA_def corresXF_measure_call)

lemma corresTA_L2_unknown:
  "corresTA \<top> rx ex (L2_unknown x) (L2_unknown x)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_call_exec_concrete:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. \<forall>s'. s = st s' \<longrightarrow> P s') rx id
               (exec_concrete st (L2_call A))
               (exec_concrete st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_L2_call_exec_abstract:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. P (st s)) rx id
               (exec_abstract st (L2_call A))
               (exec_abstract st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma abstract_val_fun_app:
   "\<lbrakk> abstract_val Q b id b'; abstract_val P a id a' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q) (f $ (a $ b)) f (a' $ b')"
  by simp

lemma corresTA_precond_to_guard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A)) A'"
  apply (monad_eq simp: corresXF_def L2_defs split: sum.splits)
  done

lemma corresTA_precond_to_asm:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> corresTA \<top> rx ex A A' \<rbrakk> \<Longrightarrow> corresTA P rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma L2_guard_true: "L2_seq (L2_guard \<top>) A = A ()"
  by (monad_eq simp: L2_defs)
lemma corresTA_simp_trivial_guard:
  "corresTA P rx ex (L2_seq (L2_guard \<top>) A) C \<equiv> corresTA P rx ex (A ()) C"
  by (simp add: L2_guard_true)

definition "L2_assume P \<equiv> condition P (returnOk ()) (selectE {})"

lemma L2_assume_alt_def:
  "L2_assume P = (\<lambda>s. (if P s then {(Inr (), s)} else {}, False))"
  by (monad_eq simp: L2_assume_def selectE_def)

lemma corresTA_assume_values:
  "\<lbrakk> abstract_val P a f a'; corresTA \<top> rx ex X X' \<rbrakk>
              \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_assume (\<lambda>s. P \<longrightarrow> (\<exists>a'. a = f a'))) (\<lambda>_. X)) X'"
  apply (monad_eq simp: corresXF_def L2_defs L2_assume_alt_def split: sum.splits)
  apply force
  done

lemma corresTA_extract_preconds_of_call_init:
  "\<lbrakk> corresTA (\<lambda>s. P) rx ex A A' \<rbrakk> \<Longrightarrow> corresTA (\<lambda>s. P \<and> True) rx ex A A'"
  by simp

lemma corresTA_extract_preconds_of_call_step:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a' \<and> R) \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. R \<and> (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a') \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final':
  "\<lbrakk> corresTA (\<lambda>s. True \<and> C) rx ex A A' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. C) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_case_prod:
 "\<lbrakk> introduce_typ_abs_fn rx1;
    introduce_typ_abs_fn rx2;
    abstract_val (Q x) x (map_prod rx1 rx2) x';
      \<And>a b a' b'. \<lbrakk> abs_var a rx1 a'; abs_var  b rx2 b' \<rbrakk>
                      \<Longrightarrow>  corresTA (P a b) rx ex (M a b) (M' a' b') \<rbrakk>  \<Longrightarrow>
    corresTA (\<lambda>s. case x of (a, b) \<Rightarrow> P a b s \<and> Q (a, b)) rx ex (case x of (a, b) \<Rightarrow> M a b) (case x' of (a, b) \<Rightarrow> M' a b)"
  apply clarsimp
  apply (rule corresXF_assume_pre)
  apply (clarsimp simp: split_def map_prod_def)
  done

lemma abstract_val_case_prod:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var  b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b) h (M' a' b') \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            (case r of (a, b) \<Rightarrow> M a b) h
            (case r' of (a, b) \<Rightarrow> M' a b)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_case_prod_fun_app:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b s) h (M' a' b' s) \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            ((case r of (a, b) \<Rightarrow> M a b) s) h
            ((case r' of (a, b) \<Rightarrow> M' a b) s)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_of_nat:
  "abstract_val (r \<le> UWORD_MAX TYPE('a::len)) r unat (of_nat r :: 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma abstract_val_of_int:
  "abstract_val (WORD_MIN TYPE('a::len) \<le> r \<and> r \<le> WORD_MAX TYPE('a)) r sint (of_int r :: 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma abstract_val_tuple:
  "\<lbrakk> abstract_val P a absL a';
     abstract_val Q b absR b' \<rbrakk> \<Longrightarrow>
         abstract_val (P \<and> Q) (a, b) (map_prod absL absR) (a', b')"
  by clarsimp

lemma abstract_val_func:
   "\<lbrakk> abstract_val P a id a'; abstract_val Q b id b' \<rbrakk>
        \<Longrightarrow>  abstract_val (P \<and> Q) (f a b) id (f a' b')"
  by simp

lemma abstract_val_conj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (a \<longrightarrow> Q)) (a \<and> b) id (a' \<and> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_disj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (\<not> a \<longrightarrow> Q)) (a \<or> b) id (a' \<or> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_unwrap:
  "\<lbrakk> introduce_typ_abs_fn f; abstract_val P a f b \<rbrakk>
        \<Longrightarrow> abstract_val P a id (f b)"
  by simp

lemma abstract_val_uint:
  "\<lbrakk> introduce_typ_abs_fn unat; abstract_val P x unat x' \<rbrakk>
      \<Longrightarrow> abstract_val P (int x) id (uint x')"
  by (clarsimp simp: uint_nat)

lemma corresTA_L2_recguard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow>
        corresTA \<top> rx ex (L2_recguard m (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A))) (L2_recguard m A')"
  by (monad_eq simp: corresXF_def L2_defs split: sum.splits)

lemma corresTA_recguard_0:
    "corresTA st rx ex (L2_recguard 0 A) C"
  by (clarsimp simp: L2_recguard_def corresXF_def)

lemma abstract_val_lambda:
   "\<lbrakk> \<And>v. abstract_val (P v) (a v) id (a' v) \<rbrakk> \<Longrightarrow>
           abstract_val (\<forall>v. P v) (\<lambda>v. a v) id (\<lambda>v. a' v)"
  by auto

(* Variable abstraction *)

lemma abstract_val_abs_var [consumes 1]:
  "\<lbrakk> abs_var a f a' \<rbrakk> \<Longrightarrow> abstract_val True a f a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_concretise  [consumes 1]:
  "\<lbrakk> abs_var a A a'; introduce_typ_abs_fn A; valid_typ_abs_fn PA PC A (C :: 'a \<Rightarrow> 'c)  \<rbrakk>
      \<Longrightarrow> abstract_val (PC a) (C a) id a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_give_up [consumes 1]:
  "\<lbrakk> abs_var a id a' \<rbrakk> \<Longrightarrow> abstract_val True (A a) A a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

(* Misc *)

lemma len_of_word_comparisons [word_abs, L2opt]:
  "len_of TYPE(32) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(32)"
  "len_of TYPE( 8) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE( 8)"
  "len_of TYPE(16) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(16)"

  "len_of TYPE('a::len signed) = len_of TYPE('a)"
  "(len_of TYPE('a) = len_of TYPE('a)) = True"
  by auto

lemma scast_ucast_simps [simp, L2opt]:
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
        (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  by (auto simp: is_up is_down
      scast_ucast_1 scast_ucast_3 scast_ucast_4
      ucast_scast_1 ucast_scast_3 ucast_scast_4
      scast_scast_a scast_scast_b
      ucast_ucast_a ucast_ucast_b)

declare len_signed [L2opt]

lemmas [L2opt, polish] = zero_sle_ucast_up

lemma zero_sle_ucast_WORD_MAX [L2opt, polish]:
  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                = (uint b \<le> WORD_MAX (TYPE('a)))"
  by (clarsimp simp: WORD_MAX_def zero_sle_ucast)

lemmas [L2opt, polish] =
    is_up is_down unat_ucast_upcast sint_ucast_eq_uint

lemmas [L2opt, polish] =
    ucast_down_add scast_down_add
    ucast_down_minus scast_down_minus
    ucast_down_mult scast_down_mult

(*
 * Setup word abstraction rules.
 *)

(* Common word abstraction rules. *)

lemmas [word_abs] =
  corresTA_L2_gets
  corresTA_L2_modify
  corresTA_L2_throw
  corresTA_L2_skip
  corresTA_L2_fail
  corresTA_L2_seq
  corresTA_L2_seq_unit
  corresTA_L2_catch
  corresTA_L2_while
  corresTA_L2_guard
  corresTA_L2_condition
  corresTA_L2_unknown
  corresTA_L2_recguard
  corresTA_case_prod
  corresTA_L2_call_exec_concrete
  corresTA_L2_call_exec_abstract
  corresTA_L2_call'
  corresTA_L2_call
  corresTA_measure_call

lemmas [word_abs] =
  abstract_val_tuple
  abstract_val_conj
  abstract_val_disj
  abstract_val_case_prod
  abstract_val_trivial
  abstract_val_of_int
  abstract_val_of_nat

  abstract_val_abs_var_give_up
  abstract_val_abs_var_concretise
  abstract_val_abs_var

lemmas word_abs_base [word_abs] =
  valid_typ_abs_fn_id [where 'a="'a::c_type"]
  valid_typ_abs_fn_id [where 'a="bool"]
  valid_typ_abs_fn_id [where 'a="c_exntype"]
  valid_typ_abs_fn_tuple
  valid_typ_abs_fn_unit
  valid_typ_abs_fn_sint
  valid_typ_abs_fn_unat

(*
 * Signed word abstraction rules: sword32 \<rightarrow> int
 *)

lemmas word_abs_sword32 =
  abstract_val_signed_ops
  abstract_val_scast
  abstract_val_scast_upcast
  abstract_val_scast_downcast
  abstract_val_unwrap [where f=sint]
  introduce_typ_abs_fn [where f="sint :: (sword32 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword16 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword8 \<Rightarrow> int)"]

(*
 * Unsigned word abstraction rules: word32 \<rightarrow> nat
 *)

lemmas word_abs_word32 =
  abstract_val_unsigned_ops
  abstract_val_uint
  abstract_val_ucast
  abstract_val_ucast_upcast
  abstract_val_ucast_downcast
  abstract_val_unwrap [where f=unat]
  introduce_typ_abs_fn [where f="unat :: (word32 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word16 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word8 \<Rightarrow> nat)"]

(* 'a \<rightarrow> 'a *)
lemmas word_abs_default =
  introduce_typ_abs_fn [where f="id :: ('a::c_type \<Rightarrow> 'a)"]
  introduce_typ_abs_fn [where f="id :: (bool \<Rightarrow> bool)"]
  introduce_typ_abs_fn [where f="id :: (c_exntype \<Rightarrow> c_exntype)"]
  introduce_typ_abs_fn [where f="id :: (unit \<Rightarrow> unit)"]
  introduce_typ_abs_fn_tuple

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Flow Graph\<close>
theory Flow_Graph
  imports Main Auxiliary
begin

paragraph \<open>Summary\<close>
text \<open>This theory implements the basic data structure used by the Flow Framework
@{cite krishna20}: flow graphs.\<close>

section \<open>Flow Graph\<close>

subsection \<open>Preliminary Flow Graphs\<close>

text \<open>We start with the definition of a preliminary type for flow graphs.
Preliminary flow graphs (N,e,f) consist of a set of nodes N, a function e representing directed
edges (e.g. e x y represents the edge from x to y), and a function f labeling all nodes with
their so-called flow.
As e and f both are only defined on N this representation is not unique.
We will lift this type to a quotient type to obtain a unique representation.\<close>

type_synonym ('n,'m) fg' = "'n set \<times> ('n \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> 'm) \<times> ('n \<Rightarrow> 'm)"

text \<open>We define the notion of equality for preliminary flow graphs.\<close>

definition fg'_eq :: "('n,'m) fg' \<Rightarrow> ('n,'m) fg' \<Rightarrow> bool" where
  "fg'_eq \<equiv> \<lambda>(N1,e1,f1) (N2,e2,f2). N1 = N2 \<and> (e1 = e2 on N1) \<and> (f1 = f2 on N1)"

lemma fg'_eqI:
  assumes "N1 = N2" "e1 = e2 on N1" "f1 = f2 on N1"
  shows "fg'_eq (N1,e1,f1) (N2,e2,f2)"
  using assms unfolding fg'_eq_def by simp

text \<open>The central ingredient to define valid flow graphs: the flow equation
(@{cite \<open>p. 313\<close> krishna20}).
The flow equation describes if a label function f is a solution to an equation system
induced by a graph (N,e). If there exists an i such that f is a solution to the flow equation
then (N,e,f) is a valid flow graph. Function i is called inflow.\<close>

definition
  flow_eq' :: "('n,'m) fg' \<Rightarrow> ('n \<Rightarrow> 'm::cancel_comm_monoid_add) \<Rightarrow> bool"
where
  "flow_eq' \<equiv> \<lambda>(N,e,f) i. \<forall>n \<in> N. f n = i n + (\<Sum>n' \<in> N. e n' n (f n'))"

lemma flow_eq'_eq: "fg'_eq h1 h2 \<Longrightarrow> flow_eq' h1 i \<longleftrightarrow> flow_eq' h2 i"
  unfolding fg'_eq_def flow_eq'_def
  by auto

text \<open>For historical reasons we also keep this notation for flow equations:\<close>

definition
  flow_eq2'
  :: "'n set \<Rightarrow> ('n \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> 'm) \<Rightarrow> ('n \<Rightarrow> 'm) \<Rightarrow> ('n \<Rightarrow> 'm::cancel_comm_monoid_add) \<Rightarrow> bool"
where
  "flow_eq2' N e f i = flow_eq' (N,e,f) i"

text \<open>A flow graph is valid iff. there is an inflow i such that f solves the flow equation.
Furthermore, the domain of the flow graph must be finite. (@{cite \<open>def. 3\<close> krishna20})\<close>

definition def_fg' :: "('n,'m::cancel_comm_monoid_add) fg' \<Rightarrow> bool" where
  "def_fg' \<equiv> \<lambda>(N,e,f). (\<exists>i. flow_eq' (N,e,f) i) \<and> finite N"

text \<open>Before we can define the final flow graph type using a quotient type,
we have to lift preliminary flow graphs to the option type in order to obtain a representation
for invalid flow graphs in the quotient type.\<close>

text \<open>The notion of equality for is lifted canonically:\<close>

definition fg'_option_eq
  :: "('n,'m) fg' option \<Rightarrow> ('n,'m::cancel_comm_monoid_add) fg' option \<Rightarrow> bool"
where
  "fg'_option_eq \<equiv> \<lambda>h1 h2.
    case (h1,h2) of
       (Some h1', Some h2') \<Rightarrow> if \<not>def_fg' h1' \<and> \<not>def_fg' h2' then True else
                               if def_fg' h1' \<and> def_fg' h2' then fg'_eq h1' h2' else
                               False
     | (None, None) \<Rightarrow> True
     | (Some h1', None) \<Rightarrow> \<not>def_fg' h1'
     | (None, Some h2') \<Rightarrow> \<not>def_fg' h2'"

subsection \<open>Flow Graph\<close>

text \<open>Defining the actual type for flow graphs using our notion of equality.
(@{cite \<open>def. 3\<close> krishna20})\<close>

quotient_type (overloaded) ('n,'m) fg =
  "('n,'m::cancel_comm_monoid_add) fg' option" / fg'_option_eq
    apply (rule equivpI)
  subgoal by (auto intro: reflpI simp: fg'_option_eq_def fg'_eq_def split: option.splits)
  subgoal by (auto intro: sympI simp: fg'_option_eq_def fg'_eq_def split: option.splits)
  subgoal by (rule transpI, auto simp: fg'_option_eq_def fg'_eq_def split: option.splits if_splits)
  done

text \<open>A constructor function that allows us to define flow graphs without mentioning Some.\<close>

lift_definition fg
  :: "'n set \<Rightarrow> ('n \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> 'm) \<Rightarrow> ('n \<Rightarrow> 'm) \<Rightarrow>
      ('n,'m::cancel_comm_monoid_add) fg"
  is "\<lambda>N e f. Some (N,e,f)" .

text \<open>Accessor functions that provide us with the components of flow graphs.
For invalid flow graphs we obtain default values. edge function and flow function are set to
default values outside the domain of their flow graph.\<close>

lift_definition dom_fg :: "('n,'m::cancel_comm_monoid_add) fg \<Rightarrow> 'n set"
  is "\<lambda>h. case h of Some (N,e,f) \<Rightarrow> if def_fg' (N,e,f) then N else {} | _ \<Rightarrow> {}"
  unfolding fg'_option_eq_def def_fg'_def fg'_eq_def
  by (auto split: option.splits if_splits)

lift_definition flow_fg :: "('n,'m::cancel_comm_monoid_add) fg \<Rightarrow> ('n \<Rightarrow> 'm)"
  is "\<lambda>h. case h of
    Some (N,e,f) \<Rightarrow> if def_fg' (N,e,f) then restrict N 0 f else (\<lambda>_. 0) |
    None \<Rightarrow> (\<lambda>_. 0)"
  unfolding fg'_option_eq_def fg'_eq_def
  by (auto split: option.splits)

lift_definition edge_fg :: "('n,'m::cancel_comm_monoid_add) fg \<Rightarrow> ('n \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> 'm)"
  is "\<lambda>h. case h of
    Some (N,e,f) \<Rightarrow> if def_fg' (N,e,f) then restrict N (\<lambda>_ _. 0) e else (\<lambda>_ _ _. 0) |
    None \<Rightarrow> (\<lambda>_ _ _. 0)"
  unfolding fg'_option_eq_def fg'_eq_def
  by (auto split: option.splits)

lemma dom_fg_finite[simp]: "finite (dom_fg h)"
  apply (transfer)
  unfolding def_fg'_def
  by (auto split: option.splits)

text \<open>Lift the flow equation to the actual flow graph type. (@{cite \<open>p. 313\<close> krishna20})\<close>

lift_definition flow_eq :: "('n,'m) fg \<Rightarrow> ('n \<Rightarrow> 'm :: cancel_comm_monoid_add) \<Rightarrow> bool" is
  "\<lambda>h i. case h of Some h' \<Rightarrow> if def_fg' h' then flow_eq' h' i else False | _ \<Rightarrow> False"
  unfolding fg'_option_eq_def fg'_eq_def
  apply (auto split: option.splits if_splits)
  subgoal for e1 f1 N1 e2 f2
    using flow_eq'_eq[OF fg'_eqI[of N1 N1 e1 e2 f1 f2]] by auto
  done

lemma flow_eq_outside_irrelevant:
  assumes "flow_eq h i"
  shows "flow_eq h (restrict (dom_fg h) 0 i)"
  using assms
  apply transfer
  by (auto split: option.splits if_splits simp: def_fg'_def flow_eq'_def)

text \<open>Notation for the invalid flow graph:\<close>

instantiation fg :: (type,type) bot
begin
lift_definition bot_fg :: "('n,'m::cancel_comm_monoid_add) fg" is None .
instance ..
end

lemma dom_fg_bot[simp]: "dom_fg bot = {}"
  apply transfer unfolding bot_fg_def dom_fg_def by simp

text \<open>Some simplification rules for accessor functions and constructor.\<close>

lemma dom_fg_fg[simp]:
  "fg N e f \<noteq> bot \<Longrightarrow> dom_fg (fg N e f) = N"
  apply transfer by (auto split: option.splits simp: fg'_option_eq_def)

lemma edge_fg_fg[simp]:
  "fg N e f \<noteq> bot \<Longrightarrow> edge_fg (fg N e f) = restrict N (\<lambda>_ _. 0) e"
  apply transfer by (auto split: option.splits simp: fg'_option_eq_def)

lemma flow_fg_fg[simp]:
  "fg N e f \<noteq> bot \<Longrightarrow> flow_fg (fg N e f) = restrict N 0 f"
  apply transfer by (auto split: option.splits simp: fg'_option_eq_def)

lemma fg_restrict_components[simp]:
  assumes "a \<noteq> bot"
  shows "fg (dom_fg a) (restrict (dom_fg a) x0 (edge_fg a)) (restrict (dom_fg a) x1 (flow_fg a)) = a"
  using assms
  apply transfer
  by (auto split: option.splits if_splits
      simp: fg'_option_eq_def def_fg'_def fg'_eq_def flow_eq'_def)

lemma fg_components[simp]:
  "a \<noteq> bot \<Longrightarrow> fg (dom_fg a) (edge_fg a) (flow_fg a) = a"
  apply transfer
  by (auto split: option.splits if_splits
      simp: fg'_option_eq_def def_fg'_def fg'_eq_def flow_eq'_def)

text \<open>Part 1 from @{cite \<open>lemma 1\<close> krishna20}: There exists an inflow for valid flow graphs.
As we extended the notion of flow graphs with validity of flow graphs we add the additional
assumption that h is valid.\<close>

lemma flow_eq_exists:
  assumes "h \<noteq> bot"
  shows "\<exists>i. flow_eq h i"
  using assms
  apply transfer by (auto simp: fg'_option_eq_def def_fg'_def split: option.splits if_splits)

text \<open>Part 2 from @{cite \<open>lemma 1\<close> krishna20}: The inflow of flow graphs is unique\<close>

lemma flow_eq_unique:
  assumes "flow_eq h i1" "flow_eq h i2"
  shows "i1 = i2 on (dom_fg h)"
  using assms
  apply transfer by (auto split: option.splits simp: flow_eq'_def)

lemma pos_flow_nbot:
  assumes "flow_fg h x \<noteq> 0"
  shows "h \<noteq> bot"
  using assms unfolding flow_fg_def bot_fg_def apply (auto split: option.splits if_splits)
  by (metis (no_types, lifting) assms flow_fg.abs_eq option.simps(4))

lemma pos_flow_dom:
  assumes "flow_fg h x \<noteq> 0"
  shows "x \<in> dom_fg h"
  using assms unfolding flow_fg_def bot_fg_def apply (auto split: option.splits if_splits)
  by (metis pos_flow_nbot assms fg_components flow_fg_fg)

text \<open>Determining the validity of constructed flow graphs:\<close>

lemma fgI:
  assumes "f = (\<lambda>n. i n + (\<Sum>n' \<in> N. e n' n (f n'))) on N" "finite N"
  shows "fg N e f \<noteq> bot"
  using assms
  apply transfer
  by (auto simp: fg'_option_eq_def def_fg'_def flow_eq'_def)

lemma fgI2:
  assumes "flow_eq (fg N e f) i" "finite N"
  shows "fg N e f \<noteq> bot"
  using assms
  apply transfer
  by (auto simp: fg'_option_eq_def def_fg'_def flow_eq'_def split: if_splits)

lemma flow_eqI:
  assumes "f = (\<lambda>n. i n + (\<Sum>n' \<in> N. e n' n (f n'))) on N" "finite N"
  shows "flow_eq (fg N e f) i"
  using assms
  apply transfer
  by (auto simp add: flow_eq'_def def_fg'_def)

text \<open>Gain access to flow equation for valid flow graphs:\<close>

lemma fgE:
  assumes "h \<noteq> bot"
  shows "(\<exists>i. finite (dom_fg h) \<and> flow_fg h =
    (\<lambda>n. i n + (\<Sum>n' \<in> dom_fg h. edge_fg h n' n (flow_fg h n'))) on dom_fg h)"
  using assms
  by (transfer, auto simp: fg'_option_eq_def def_fg'_def flow_eq'_def
      split: option.splits if_splits)

lemma fgE':
  "flow_eq h i \<Longrightarrow> \<forall>n \<in> dom_fg h.
    flow_fg h n = i n + (\<Sum>n' \<in> dom_fg h. edge_fg h n' n (flow_fg h n'))"
  by (transfer, auto simp: fg'_option_eq_def def_fg'_def flow_eq'_def
      split: option.splits if_splits)

lemma fgE'':
  "flow_eq (fg N e f) i \<Longrightarrow> N \<noteq> {} \<Longrightarrow> \<forall>n \<in> N. f n = i n + (\<Sum>n' \<in> N. e n' n (f n'))"
  by (transfer, auto split: option.splits if_splits simp: flow_eq'_def)

text \<open>Determine equality of flow graphs:\<close>

lemma fg_eqI:
  assumes "h1 \<noteq> bot" "h2 \<noteq> bot" "dom_fg h1 = dom_fg h2"
    "edge_fg h1 = edge_fg h2 on dom_fg h1" "flow_fg h1 = flow_fg h2 on dom_fg h2"
  shows "h1 = h2"
  using assms
  apply transfer
  by (auto split: option.splits simp: fg'_option_eq_def fg'_eq_def)

lemma fg_eqI2:
  assumes "h1 \<noteq> bot \<Longrightarrow> h1 = h2" "h2 \<noteq> bot \<Longrightarrow> h1 = h2"
  shows "h1 = h2"
  using assms by auto

lemma fg_cong:
  assumes "N1 = N2" "e1 = e2 on N1" "f1 = f2 on N1"
  shows "fg N1 e1 f1 = fg N2 e2 f2"
  using assms
  apply transfer
  by (auto simp: fg'_option_eq_def fg'_eq_def def_fg'_def flow_eq'_def)

lemma fg_eqD:
  assumes "h1 = h2"
  shows "dom_fg h1 = dom_fg h2 \<and> edge_fg h1 = edge_fg h2 on dom_fg h1 \<and>
    flow_fg h1 = flow_fg h2 on dom_fg h2"
  using assms
  unfolding edge_fg_def dom_fg_def flow_fg_def
  by auto

subsection \<open>Flow Graphs are Cancellative Monoids\<close>

instantiation fg :: (type,cancel_comm_monoid_add) comm_monoid_add
begin

text \<open>The unit flow graph is the flow graph consisting of no nodes. @{cite krishna20}\<close>

definition zero_fg where
  "zero_fg \<equiv> fg {} (\<lambda>_ _ _. 0) (\<lambda>_. 0)"

lemma zero_fg_nbot [simp]: "0 \<noteq> (bot :: ('n,'m :: cancel_comm_monoid_add) fg)"
  unfolding zero_fg_def bot_fg_def fg_def   apply (auto)
  by (auto simp: fg.abs_eq_iff fg'_option_eq_def def_fg'_def flow_eq'_def)

lemma dom_fg_zero_fg [simp]: "dom_fg 0 = {}"
  unfolding zero_fg_def using dom_fg_fg by force

text \<open>Addition for flow graphs @{cite \<open>def. 4\<close> krishna20} requires the summands to be disjoint.
The edge and flow functions are merely the combination of the two summand's functions.
We have to additionally take validity into account in our definition.\<close>

definition
  plus_fg :: "('n,'m) fg \<Rightarrow> ('n,'m) fg \<Rightarrow> ('n,'m :: cancel_comm_monoid_add) fg"
where
  "plus_fg h1 h2 \<equiv>
    let N = dom_fg h1 \<union> dom_fg h2;
        e = combine (dom_fg h1) (dom_fg h2) (\<lambda>_ _. 0) (edge_fg h1) (edge_fg h2);
        f = combine (dom_fg h1) (dom_fg h2)        0  (flow_fg h1) (flow_fg h2) in
    if h1 \<noteq> bot \<and> h2 \<noteq> bot \<and> dom_fg h1 \<inter> dom_fg h2 = {}
      then fg N e f
      else bot"

lemma plus_fg_fg:
  assumes "fg N1 e1 f1 \<noteq> bot" "fg N2 e2 f2 \<noteq> bot" "N1 \<inter> N2 = {}"
  shows "fg N1 e1 f1 + fg N2 e2 f2 =
    fg (N1 \<union> N2) (combined N1 N2 (\<lambda>_ _. 0) e1 e2) (combined N1 N2 0 f1 f2)"
proof -
  have *:
    "fg (N1 \<union> N2)
      (combined N1 (dom_fg (fg N2 e2 f2)) (\<lambda>_ _. 0) (edge_fg (fg N1 e1 f1)) (edge_fg (fg N2 e2 f2)))
      (combined N1 (dom_fg (fg N2 e2 f2)) 0 (flow_fg (fg N1 e1 f1)) (flow_fg (fg N2 e2 f2))) =
     fg (N1 \<union> N2) (combined N1 N2 (\<lambda>_ _. 0) e1 e2) (combined N1 N2 0 f1 f2)"
    unfolding combined_def
    by (rule fg_cong, auto simp: assms)
  show ?thesis
    using assms *
    unfolding plus_fg_def combined_def
    by (auto simp: Let_def)
qed

lemma plus_fg_fg':
  assumes "fg N1 e1 f1 \<noteq> bot" "fg N2 e2 f2 \<noteq> bot" "N1 \<inter> N2 = {}" "N1 \<union> N2 = N"
      "e = e1 on N1" "e = e2 on N2" "f = f1 on N1" "f = f2 on N2"
    shows "fg N1 e1 f1 + fg N2 e2 f2 = fg N e f"
proof -
  have "fg N1 e1 f1 + fg N2 e2 f2 =
    fg (N1 \<union> N2) (combined N1 N2 (\<lambda>_ _. 0) e1 e2) (combined N1 N2 0 f1 f2)"
    using plus_fg_fg assms by simp
  also have "... = fg N e f"
    apply (rule fg_cong) unfolding combined_def using assms by auto
  finally show ?thesis .
qed

lemma plus_fg_bot_bot[simp]: "bot + h = bot" "h + bot = (bot :: ('n,'m::cancel_comm_monoid_add) fg)"
  unfolding bot_fg_def plus_fg_def by (auto split: option.splits)

lemma def_fg_zero_fg[simp]:
  "0 \<noteq> (bot :: ('a,'b) fg)"
  by auto

lemma plus_fg_ops_exist:
  "h1 + h2 \<noteq> bot \<Longrightarrow> h1 \<noteq> bot \<and> h2 \<noteq> (bot :: ('n,'m :: cancel_comm_monoid_add) fg)"
  unfolding plus_fg_def
  by auto

lemma plus_fg_dom_un[simp]:
  "h1 + h2 \<noteq> bot \<Longrightarrow> dom_fg (h1 + h2) = dom_fg h1 \<union> dom_fg h2"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma plus_fg_dom_disj[simp]:
  "h1 + h2 \<noteq> bot \<Longrightarrow> dom_fg h1 \<inter> dom_fg h2 = {}"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma flow_fg_plus_fg_on1:
  "h1 + h2 \<noteq> bot \<Longrightarrow> flow_fg (h1 + h2) = flow_fg h1 on (dom_fg h1)"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma flow_fg_plus_fg_on2:
  "h1 + h2 \<noteq> bot \<Longrightarrow> flow_fg (h1 + h2) = flow_fg h2 on (dom_fg h2)"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma flow_fg_plus_fg_on1':
  "h1 + h2 \<noteq> bot \<Longrightarrow> x \<in> dom_fg h1 \<Longrightarrow> flow_fg (h1 + h2) x = flow_fg h1 x"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma flow_fg_plus_fg_on2':
  "h1 + h2 \<noteq> bot \<Longrightarrow> x \<in> dom_fg h2 \<Longrightarrow> flow_fg (h1 + h2) x = flow_fg h2 x"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma edge_fg_plus_fg_on1:
  "h1 + h2 \<noteq> bot \<Longrightarrow> edge_fg (h1 + h2) = edge_fg h1 on (dom_fg h1)"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma edge_fg_plus_fg_on2:
  "h1 + h2 \<noteq> bot \<Longrightarrow> edge_fg (h1 + h2) = edge_fg h2 on (dom_fg h2)"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma edge_fg_plus_fg_on1':
  "h1 + h2 \<noteq> bot \<Longrightarrow> x \<in> dom_fg h1 \<Longrightarrow> edge_fg (h1 + h2) x = edge_fg h1 x"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma edge_fg_plus_fg_on2':
  "h1 + h2 \<noteq> bot \<Longrightarrow> x \<in> dom_fg h2 \<Longrightarrow> edge_fg (h1 + h2) x = edge_fg h2 x"
  unfolding plus_fg_def
  by (auto simp: Let_def split: if_splits)

lemma flow_fg_zero_outside_dom:
  "flow_fg h = (\<lambda>_. 0) on (-dom_fg h)"
  unfolding plus_fg_def flow_fg_def dom_fg_def
  by (auto simp: Let_def split: option.splits)

lemma edge_fg_0_outside_dom:
  "x \<in> -dom_fg h \<Longrightarrow> h \<noteq> bot \<Longrightarrow> edge_fg h x = (\<lambda> _ _. 0)"
  by (transfer, auto split: option.splits)

lemma flow_fg_0_outside_dom:
  "x \<in> -dom_fg h \<Longrightarrow> h \<noteq> bot \<Longrightarrow> flow_fg h x = 0"
  by (transfer, auto split: option.splits)

text \<open>@{text split_fg} enables us to decompose a valid flow graph into a sum of valid flow graphs.
This lemma significantly simplifies the proof of @{text plus_fg_assoc} as we have to decompose
(a + b) + c there, this lemma and its existential quantification saves us from stating the
quite verbose decomposition terms manually.\<close>

lemma split_fg:
  assumes "h \<noteq> bot" "dom_fg h = N1 \<union> N2" "N1 \<inter> N2 = {}"
  shows "\<exists>h1 h2. h = h1 + h2 \<and> h1 \<noteq> bot \<and> h2 \<noteq> bot \<and>
    dom_fg h1 = N1 \<and> dom_fg h2 = N2 \<and>
    edge_fg h = edge_fg h1 on N1 \<and> edge_fg h = edge_fg h2 on N2 \<and>
    flow_fg h = flow_fg h1 on N1 \<and> flow_fg h = flow_fg h2 on N2"
proof -
  obtain i where *: "flow_eq h i" using assms(1) flow_eq_exists by auto
  have "finite (dom_fg h)" using assms(1) by simp
  hence **: "finite N1" "finite N2" using assms(2) by auto

  let ?i1 = "\<lambda>n. if n \<in> N1 then i n + (\<Sum>n'\<in>N2. edge_fg h n' n (flow_fg h n')) else 0"
  let ?i2 = "\<lambda>n. if n \<in> N2 then i n + (\<Sum>n'\<in>N1. edge_fg h n' n (flow_fg h n')) else 0"
  let ?f = "flow_fg h" let ?e = "edge_fg h"

  have X1: "fg N1 ?e ?f \<noteq> bot"
  proof (rule fgI)
    show "?f = \<lambda>x. ?i1 x + (\<Sum>n'\<in>N1. ?e n' x (?f n')) on N1"
    proof
      fix n assume "n\<in>N1"
      then have "?f n = i n + (\<Sum>n'\<in>dom_fg h. ?e n' n (?f n'))"
        using assms `n\<in>N1` * fgE'[of h i] by simp
      thus "?f n = ?i1 n + (\<Sum>n'\<in>N1. ?e n' n (?f n'))"
        using assms sum.union_disjoint  * ** \<open>n \<in> N1\<close>
        by (auto simp: Un_commute algebra_simps)
    qed
    show "finite N1" using ** by simp
  qed

  have X2: "fg N2 ?e ?f \<noteq> bot"
  proof (rule fgI)
    show "?f = \<lambda>x. ?i2 x + (\<Sum>n'\<in>N2. ?e n' x (?f n')) on N2"
    proof
      fix n assume "n\<in>N2"
      show "?f n = ?i2 n + (\<Sum>n'\<in>N2. ?e n' n (?f n'))"
      proof -
        have "?f n = i n + (\<Sum>n'\<in>dom_fg h. ?e n' n (?f n'))"
          using assms `n\<in>N2` * fgE'[of h i] by simp
        thus ?thesis
          using assms sum.union_disjoint[of N2 N1 "\<lambda>n'. ?e n' n (?f n')"] * ** \<open>n \<in> N2\<close>
          by (auto simp: Un_commute algebra_simps)
      qed
    qed

    show "finite N2"
      using ** by simp
  qed

  have *: "fg N1 ?e ?f + fg N2 ?e ?f = h"
    using plus_fg_fg' X1 X2 fg_components[of h] assms by metis

  show ?thesis
    apply (rule exI[where x="fg N1 ?e ?f"])
    apply (rule exI[where x="fg N2 ?e ?f"])
    using X1 X2 * assms by simp
qed

lemma plus_fg_assoc:
  fixes a b c :: "('a,'b :: cancel_comm_monoid_add) fg"
  assumes "a + b + c \<noteq> bot"
  shows "a + b + c = a + (b + c)"
proof -
  let ?h = "a + b + c"
  let ?Na = "dom_fg a"
  let ?Nb = "dom_fg b"
  let ?Nc = "dom_fg c"

  (* Exploit split_fg to obtain exactly the parts required by the proof and then
    show the equality between those parts and the actual parts. *)

  have nbot: "a + b + c \<noteq> bot" "a + b \<noteq> bot" "a \<noteq> bot" "b \<noteq> bot" "c \<noteq> bot"
    using assms by auto

  have dom: "dom_fg (a + b) \<inter> ?Nc = {}" "?Na \<inter> ?Nc = {}" "?Na \<inter> ?Nb = {}" "?Nb \<inter> ?Nc = {}"
    "dom_fg (a + b + c) = dom_fg (a + b) \<union> ?Nc" "dom_fg (a + b) = ?Na \<union> ?Nb"
    using nbot plus_fg_dom_disj[of "a + b" c] by auto

  then have "dom_fg (a + b + c) = ?Na \<union> (?Nb \<union> ?Nc)" "?Na \<inter> (?Nb \<union> ?Nc) = {}"
    using dom by blast+

  then obtain h1 h2 where *: "a + b + c = h1 + h2" "dom_fg h1 = ?Na" "dom_fg h2 = ?Nb \<union> ?Nc"
     "edge_fg ?h = edge_fg h1 on ?Na" "edge_fg ?h = edge_fg h2 on ?Nb \<union> ?Nc"
     "flow_fg ?h = flow_fg h1 on ?Na" "flow_fg ?h = flow_fg h2 on ?Nb \<union> ?Nc"
     "h1 \<noteq> bot" "h2 \<noteq> bot"
    using split_fg[of ?h ?Na "?Nb \<union> ?Nc"] assms by blast

  then obtain h21 h22 where **: "h2 = h21 + h22" "dom_fg h21 = ?Nb" "dom_fg h22 = ?Nc"
    "edge_fg h2 = edge_fg h21 on ?Nb" "edge_fg h2 = edge_fg h22 on ?Nc"
    "flow_fg h2 = flow_fg h21 on ?Nb" "flow_fg h2 = flow_fg h22 on ?Nc"
    "h21 \<noteq> bot" "h22 \<noteq> bot"
    using split_fg[of h2 ?Nb ?Nc] dom * by blast

  have ***: "edge_fg ?h = edge_fg a on ?Na" "flow_fg ?h = flow_fg a on ?Na"
      "edge_fg ?h = edge_fg b on ?Nb" "flow_fg ?h = flow_fg b on ?Nb"
      "edge_fg ?h = edge_fg c on ?Nc" "flow_fg ?h = flow_fg c on ?Nc"
    using edge_fg_plus_fg_on1 edge_fg_plus_fg_on2
          flow_fg_plus_fg_on1 flow_fg_plus_fg_on2 nbot by simp_all

  have "h1 = a"
    apply (rule fg_eqI) using nbot * ** *** by simp_all
  moreover have "h21 = b"
    apply (rule fg_eqI) using nbot * ** *** by simp_all
  moreover have "h22 = c"
    apply (rule fg_eqI) using nbot * ** *** by simp_all
  ultimately show ?thesis
    using * ** by simp
qed

lemma plus_fg_comm:
  fixes a b :: "('a,'b :: cancel_comm_monoid_add) fg"
  shows "a + b = b + a"
  unfolding plus_fg_def
  by (auto simp: Let_def Un_commute split: if_splits)

instance
proof (standard, goal_cases)
  case (1 a b c)
  then show ?case
  proof (rule fg_eqI2, goal_cases)
    case 1
    then show ?case
      using plus_fg_assoc by simp
  next
    case 2
    \<comment> \<open>derive second direction from first direction of associativity and commutativity\<close>
    then have "a + (b + c) = (b + c) + a" using plus_fg_comm by simp
    then have "a + (b + c) = b + (c + a)" using 2 plus_fg_assoc by simp
    then have "a + (b + c) = (c + a) + b" using plus_fg_comm by simp
    then have "a + (b + c) = c + (a + b)" using 2 plus_fg_assoc by simp
    then show ?case using plus_fg_comm by simp
  qed
next
  case (2 a b)
  then show ?case
    using plus_fg_comm by simp
next
  case (3 a)
  then show ?case
    unfolding plus_fg_def
    by (cases "a = bot", auto simp: Let_def split: if_splits)
qed

end

lemma split_sum:
  fixes f :: "'n \<Rightarrow> ('n,'m::cancel_comm_monoid_add) fg"
  assumes "sum f (xs \<union> ys) \<noteq> bot" "xs \<inter> ys = {}" "finite xs" "finite ys"
  shows "sum f (xs \<union> ys) = sum f xs + sum f ys \<and> sum f xs \<noteq> bot \<and> sum f ys \<noteq> bot"
proof -
  have "sum f (xs \<union> ys) = sum f xs + sum f ys"
    using assms by (smt disjoint_iff_not_equal sum.cong sum.union_disjoint)
  thus ?thesis
    using assms by auto
qed

text \<open>Cancellativity only holds for valid flow graphs,
therefore we can not instantiate @{text cancel_comm_monoid_add}.\<close>

lemma plus_fg_cancel_left:
  fixes h1 h2 h3 :: "('n,'m :: cancel_comm_monoid_add) fg"
  assumes "h1 + h2 \<noteq> bot"
    and "h1 + h2 = h1 + h3"
  shows "h2 = h3"
proof (rule fg_eqI)
  have "h1 \<noteq> bot" "h2 \<noteq> bot" "h3 \<noteq> bot"
    using assms plus_fg_ops_exist by auto

  thus "h2 \<noteq> bot" "h3 \<noteq> bot"
    by simp_all

  have "dom_fg h1 \<inter> dom_fg h2 = {}"
    "dom_fg h1 \<inter> dom_fg h3 = {}"
    "dom_fg (h1 + h2) = dom_fg h1 \<union> dom_fg h2"
    "dom_fg (h1 + h3) = dom_fg h1 \<union> dom_fg h3"
    using assms plus_fg_dom_un[of h1 h2] by auto
  thus *: "dom_fg h2 = dom_fg h3"
    using assms(2) by auto

  have "edge_fg (h1 + h2) = edge_fg h2 on (dom_fg h2)"
    "edge_fg (h1 + h3) = edge_fg h3 on (dom_fg h3)"
    using edge_fg_plus_fg_on2[of h1 h2] edge_fg_plus_fg_on2[of h1 h3] assms by simp_all
  thus "edge_fg h2 = edge_fg h3 on dom_fg h2"
    using assms(2) * by simp

  have "flow_fg (h1 + h2) = flow_fg h2 on (dom_fg h2)"
    "flow_fg (h1 + h3) = flow_fg h3 on (dom_fg h3)"
    using flow_fg_plus_fg_on2[of h1 h2] flow_fg_plus_fg_on2[of h1 h3] assms by simp_all
  thus "flow_fg h2 = flow_fg h3 on dom_fg h3"
    using assms(2) * by simp
qed

lemma plus_fg_cancel_right:
  assumes "a + c \<noteq> (bot :: (('n,'m :: cancel_comm_monoid_add) fg))" "a + c = b + c"
  shows "a = b"
  using assms plus_fg_cancel_left[of c a b] by (simp add: algebra_simps)

text \<open>Some results about validity of special cases of flow graphs\<close>

lemma def_fg_singleton[simp]:
  (* weird/seemingly circular, but can be used to show that fg {x} e f \<noteq> bot *)
  "dom_fg h = {n} \<Longrightarrow> edge_fg h n n = (\<lambda>_. 0) \<Longrightarrow> h \<noteq> bot"
  by (transfer, auto split: option.splits if_splits simp: fg'_option_eq_def)

lemma def_fg_singleton_id:
  (* also weird *)
  "dom_fg h = {n} \<Longrightarrow> edge_fg h n n = id \<Longrightarrow> h \<noteq> bot"
  by (transfer,
      auto split: option.splits if_splits simp: fg'_option_eq_def def_fg'_def flow_eq'_def)

lemma def_fg_singleton':
  "e x x = (\<lambda>_. 0) \<Longrightarrow> fg {x} e f \<noteq> bot"
  by (transfer,
      auto split: option.splits if_splits simp: fg'_option_eq_def def_fg'_def flow_eq'_def)

end


section \<open>Lens Algebraic Operators\<close>

theory Lens_Algebra
imports Lens_Laws
begin

subsection \<open>Lens Composition, Plus, Unit, and Identity\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Composition}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Composition}
  \label{fig:Comp}
  \end{figure}
  We introduce the algebraic lens operators; for more information please see our paper~\<^cite>\<open>"Foster16a"\<close>.
  Lens composition, illustrated in Figure~\ref{fig:Comp}, constructs a lens by composing the source
  of one lens with the view of another.\<close>

definition lens_comp :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> ('a \<Longrightarrow> 'c)" (infixl ";\<^sub>L" 80) where
[lens_defs]: "lens_comp Y X = \<lparr> lens_get = get\<^bsub>Y\<^esub> \<circ> lens_get X
                              , lens_put = (\<lambda> \<sigma> v. lens_put X \<sigma> (lens_put Y (lens_get X \<sigma>) v)) \<rparr>"

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Sum}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Sum}
  \label{fig:Sum}
  \end{figure}
  Lens plus, as illustrated in Figure~\ref{fig:Sum} parallel composes two independent lenses,
  resulting in a lens whose view is the product of the two underlying lens views.\<close>

definition lens_plus :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Longrightarrow> 'c" (infixr "+\<^sub>L" 75) where
[lens_defs]: "X +\<^sub>L Y = \<lparr> lens_get = (\<lambda> \<sigma>. (lens_get X \<sigma>, lens_get Y \<sigma>))
                       , lens_put = (\<lambda> \<sigma> (u, v). lens_put X (lens_put Y \<sigma> v) u) \<rparr>"

text \<open>The product functor lens similarly parallel composes two lenses, but in this case the lenses
  have different sources and so the resulting source is also a product.\<close>

definition lens_prod :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'd) \<Rightarrow> ('a \<times> 'b \<Longrightarrow> 'c \<times> 'd)" (infixr "\<times>\<^sub>L" 85) where
[lens_defs]: "lens_prod X Y = \<lparr> lens_get = map_prod get\<^bsub>X\<^esub> get\<^bsub>Y\<^esub>
                              , lens_put = \<lambda> (u, v) (x, y). (put\<^bsub>X\<^esub> u x, put\<^bsub>Y\<^esub> v y) \<rparr>"

text \<open>The $\lfst$ and $\lsnd$ lenses project the first and second elements, respectively, of a
  product source type.\<close>

definition fst_lens :: "'a \<Longrightarrow> 'a \<times> 'b" ("fst\<^sub>L") where
[lens_defs]: "fst\<^sub>L = \<lparr> lens_get = fst, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (u, \<rho>)) \<rparr>"

definition snd_lens :: "'b \<Longrightarrow> 'a \<times> 'b" ("snd\<^sub>L") where
[lens_defs]: "snd\<^sub>L = \<lparr> lens_get = snd, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (\<sigma>, u)) \<rparr>"

lemma get_fst_lens [simp]: "get\<^bsub>fst\<^sub>L\<^esub> (x, y) = x"
  by (simp add: fst_lens_def)

lemma get_snd_lens [simp]: "get\<^bsub>snd\<^sub>L\<^esub> (x, y) = y"
  by (simp add: snd_lens_def)

text \<open>The swap lens is a bijective lens which swaps over the elements of the product source type.\<close>

abbreviation swap_lens :: "'a \<times> 'b \<Longrightarrow> 'b \<times> 'a" ("swap\<^sub>L") where
"swap\<^sub>L \<equiv> snd\<^sub>L +\<^sub>L fst\<^sub>L"

text \<open>The zero lens is an ineffectual lens whose view is a unit type. This means the zero lens
  cannot distinguish or change the source type.\<close>

definition zero_lens :: "unit \<Longrightarrow> 'a" ("0\<^sub>L") where
[lens_defs]: "0\<^sub>L = \<lparr> lens_get = (\<lambda> _. ()), lens_put = (\<lambda> \<sigma> x. \<sigma>) \<rparr>"

text \<open>The identity lens is a bijective lens where the source and view type are the same.\<close>

definition id_lens :: "'a \<Longrightarrow> 'a" ("1\<^sub>L") where
[lens_defs]: "1\<^sub>L = \<lparr> lens_get = id, lens_put = (\<lambda> _. id) \<rparr>"

text \<open>The quotient operator $X \lquot Y$ shortens lens $X$ by cutting off $Y$ from the end. It is
  thus the dual of the composition operator.\<close>

definition lens_quotient :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<Longrightarrow> 'b" (infixr "'/\<^sub>L" 90) where
[lens_defs]: "X /\<^sub>L Y = \<lparr> lens_get = \<lambda> \<sigma>. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>)
                       , lens_put = \<lambda> \<sigma> v. get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>) v) \<rparr>"

text \<open>Lens inverse take a bijective lens and swaps the source and view types.\<close>

definition lens_inv :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'a)" ("inv\<^sub>L") where
[lens_defs]: "lens_inv x = \<lparr> lens_get = create\<^bsub>x\<^esub>, lens_put = \<lambda> \<sigma>. get\<^bsub>x\<^esub> \<rparr>"

subsection \<open>Closure Poperties\<close>

text \<open>We show that the core lenses combinators defined above are closed under the key lens classes.\<close>

lemma id_wb_lens: "wb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma source_id_lens: "\<S>\<^bsub>1\<^sub>L\<^esub> = UNIV"
  by (simp add: id_lens_def lens_source_def)

lemma unit_wb_lens: "wb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma source_zero_lens: "\<S>\<^bsub>0\<^sub>L\<^esub> = UNIV"
  by (simp_all add: zero_lens_def lens_source_def)

lemma comp_weak_lens: "\<lbrakk> weak_lens x; weak_lens y \<rbrakk> \<Longrightarrow> weak_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma comp_wb_lens: "\<lbrakk> wb_lens x; wb_lens y \<rbrakk> \<Longrightarrow> wb_lens (x ;\<^sub>L y)"
  by (unfold_locales, auto simp add: lens_comp_def wb_lens_def weak_lens.put_closure)

lemma comp_mwb_lens: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> mwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, auto simp add: lens_comp_def mwb_lens_def weak_lens.put_closure)

lemma source_lens_comp: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> \<S>\<^bsub>x ;\<^sub>L y\<^esub> = {s \<in> \<S>\<^bsub>y\<^esub>. get\<^bsub>y\<^esub> s \<in> \<S>\<^bsub>x\<^esub>}"
  by (auto simp add: lens_comp_def lens_source_def, blast, metis mwb_lens.put_put mwb_lens_def weak_lens.put_get)

lemma id_vwb_lens [simp]: "vwb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_vwb_lens [simp]: "vwb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_vwb_lens: "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> vwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def weak_lens.put_closure)

lemma unit_ief_lens: "ief_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

text \<open>Lens plus requires that the lenses be independent to show closure.\<close>

lemma plus_mwb_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "mwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales)
   apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym)
  apply (simp add: lens_indep_comm)
done

lemma plus_wb_lens:
  assumes "wb_lens x" "wb_lens y" "x \<bowtie> y"
  shows "wb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
done

lemma plus_vwb_lens [simp]:
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "vwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
   apply (simp add: lens_indep_sym prod.case_eq_if)
  apply (simp add: lens_indep_comm prod.case_eq_if)
done

lemma source_plus_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "\<S>\<^bsub>x +\<^sub>L y\<^esub> = \<S>\<^bsub>x\<^esub> \<inter> \<S>\<^bsub>y\<^esub>"
  apply (auto simp add: lens_source_def lens_plus_def)
  apply (meson assms(3) lens_indep_comm)
  apply (metis assms(1) mwb_lens.weak_get_put mwb_lens_weak weak_lens.put_closure)
done

lemma prod_mwb_lens:
  "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_wb_lens:
  "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_vwb_lens:
  "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_bij_lens:
  "\<lbrakk> bij_lens X; bij_lens Y \<rbrakk> \<Longrightarrow> bij_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma fst_vwb_lens: "vwb_lens fst\<^sub>L"
  by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

lemma snd_vwb_lens: "vwb_lens snd\<^sub>L"
  by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if)

lemma id_bij_lens: "bij_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma inv_id_lens: "inv\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_inv_def id_lens_def lens_create_def)

lemma inv_inv_lens: "bij_lens X \<Longrightarrow> inv\<^sub>L (inv\<^sub>L X) = X"
  apply (cases X)
  apply (auto simp add: lens_defs fun_eq_iff)
  apply (metis (no_types) bij_lens.strong_get_put bij_lens_def select_convs(2) weak_lens.put_get)
  done

lemma lens_inv_bij: "bij_lens X \<Longrightarrow> bij_lens (inv\<^sub>L X)"
  by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swap\<^sub>L"
  by (unfold_locales, simp_all add: lens_plus_def prod.case_eq_if fst_lens_def snd_lens_def)

subsection \<open>Composition Laws\<close>

text \<open>Lens composition is monoidal, with unit @{term "1\<^sub>L"}, as the following theorems demonstrate.
  It also has @{term "0\<^sub>L"} as a right annihilator. \<close>

lemma lens_comp_assoc: "X ;\<^sub>L (Y ;\<^sub>L Z) = (X ;\<^sub>L Y) ;\<^sub>L Z"
  by (auto simp add: lens_comp_def)

lemma lens_comp_left_id [simp]: "1\<^sub>L ;\<^sub>L X = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_right_id [simp]: "X ;\<^sub>L 1\<^sub>L = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_anhil [simp]: "wb_lens X \<Longrightarrow> 0\<^sub>L ;\<^sub>L X = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

lemma lens_comp_anhil_right [simp]: "wb_lens X \<Longrightarrow> X ;\<^sub>L 0\<^sub>L = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

subsection \<open>Independence Laws\<close>

text \<open>The zero lens @{term "0\<^sub>L"} is independent of any lens. This is because nothing can be observed
  or changed using @{term "0\<^sub>L"}. \<close>

lemma zero_lens_indep [simp]: "0\<^sub>L \<bowtie> X"
  by (auto simp add: zero_lens_def lens_indep_def)

lemma zero_lens_indep' [simp]: "X \<bowtie> 0\<^sub>L"
  by (auto simp add: zero_lens_def lens_indep_def)

text \<open>Lens independence is irreflexive, but only for effectual lenses as otherwise nothing can
  be observed.\<close>

lemma lens_indep_quasi_irrefl: "\<lbrakk> wb_lens x; eff_lens x \<rbrakk> \<Longrightarrow> \<not> (x \<bowtie> x)"
  unfolding lens_indep_def ief_lens_def ief_lens_axioms_def
  by (simp, metis (full_types) wb_lens.get_put)

text \<open>Lens independence is a congruence with respect to composition, as the following properties demonstrate.\<close>

lemma lens_indep_left_comp [simp]:
  "\<lbrakk> mwb_lens z; x \<bowtie> y \<rbrakk> \<Longrightarrow> (x ;\<^sub>L z) \<bowtie> (y ;\<^sub>L z)"
  apply (rule lens_indepI)
    apply (auto simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_comp:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> (x ;\<^sub>L z)"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
    using lens_indep_comm lens_indep_sym apply fastforce
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_left_ext [intro]:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> z"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_ext [intro]:
  "x \<bowtie> z \<Longrightarrow> x \<bowtie> (y ;\<^sub>L z)"
  by (simp add: lens_indep_left_ext lens_indep_sym)

lemma lens_comp_indep_cong_left:
  "\<lbrakk> mwb_lens Z; X ;\<^sub>L Z \<bowtie> Y ;\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y"
  apply (rule lens_indepI)
    apply (rename_tac u v \<sigma>)
    apply (drule_tac u=u and v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_comm)
    apply (simp add: lens_comp_def)
    apply (meson mwb_lens_weak weak_lens.view_determination)
   apply (rename_tac v \<sigma>)
   apply (drule_tac v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
   apply (simp add: lens_comp_def)
  apply (drule lens_indep_sym)
  apply (rename_tac u \<sigma>)
  apply (drule_tac v=u and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
  apply (simp add: lens_comp_def)
done

lemma lens_comp_indep_cong:
  "mwb_lens Z \<Longrightarrow> (X ;\<^sub>L Z) \<bowtie> (Y ;\<^sub>L Z) \<longleftrightarrow> X \<bowtie> Y"
  using lens_comp_indep_cong_left lens_indep_left_comp by blast

text \<open>The first and second lenses are independent since the view different parts of a product source.\<close>

lemma fst_snd_lens_indep [simp]:
  "fst\<^sub>L \<bowtie> snd\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma snd_fst_lens_indep [simp]:
  "snd\<^sub>L \<bowtie> fst\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
  assumes "mwb_lens X"
  shows "(fst\<^sub>L ;\<^sub>L X) \<bowtie> (snd\<^sub>L ;\<^sub>L X)"
  using assms fst_snd_lens_indep lens_indep_left_comp vwb_lens_mwb by blast

text \<open>Lens independence is preserved by summation.\<close>

lemma plus_pres_lens_indep [simp]: "\<lbrakk> X \<bowtie> Z; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<bowtie> Z"
  apply (rule lens_indepI)
    apply (simp_all add: lens_plus_def prod.case_eq_if)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma plus_pres_lens_indep' [simp]:
  "\<lbrakk> X \<bowtie> Y; X \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y +\<^sub>L Z"
  by (auto intro: lens_indep_sym plus_pres_lens_indep)

text \<open>Lens independence is preserved by product.\<close>

lemma lens_indep_prod:
  "\<lbrakk> X\<^sub>1 \<bowtie> X\<^sub>2; Y\<^sub>1 \<bowtie> Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 \<times>\<^sub>L Y\<^sub>1 \<bowtie> X\<^sub>2 \<times>\<^sub>L Y\<^sub>2"
  apply (rule lens_indepI)
    apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
   apply (simp_all add: lens_indep_sym)
  done

subsection \<open> Compatibility Laws \<close>

lemma zero_lens_compat [simp]: "0\<^sub>L ##\<^sub>L X"
  by (auto simp add: zero_lens_def lens_override_def lens_compat_def)

lemma id_lens_compat [simp]: "vwb_lens X \<Longrightarrow> 1\<^sub>L ##\<^sub>L X"
  by (auto simp add: id_lens_def lens_override_def lens_compat_def)

subsection \<open>Algebraic Laws\<close>

text \<open>Lens plus distributes to the right through composition.\<close>

lemma plus_lens_distr: "mwb_lens Z \<Longrightarrow> (X +\<^sub>L Y) ;\<^sub>L Z = (X ;\<^sub>L Z) +\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def lens_plus_def comp_def)

text \<open>The first lens projects the first part of a summation.\<close>

lemma fst_lens_plus:
  "wb_lens y \<Longrightarrow> fst\<^sub>L ;\<^sub>L (x +\<^sub>L y) = x"
  by (simp add: fst_lens_def lens_plus_def lens_comp_def comp_def)

text \<open>The second law requires independence as we have to apply x first, before y\<close>

lemma snd_lens_plus:
  "\<lbrakk> wb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> snd\<^sub>L ;\<^sub>L (x +\<^sub>L y) = y"
  apply (simp add: snd_lens_def lens_plus_def lens_comp_def comp_def)
  apply (subst lens_indep_comm)
   apply (simp_all)
done

text \<open>The swap lens switches over a summation.\<close>

lemma lens_plus_swap:
  "X \<bowtie> Y \<Longrightarrow> swap\<^sub>L ;\<^sub>L (X +\<^sub>L Y) = (Y +\<^sub>L X)"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def lens_comp_def lens_indep_comm)

text \<open>The first, second, and swap lenses are all closely related.\<close>

lemma fst_snd_id_lens: "fst\<^sub>L +\<^sub>L snd\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

lemma swap_lens_idem: "swap\<^sub>L ;\<^sub>L swap\<^sub>L = 1\<^sub>L"
  by (simp add: fst_snd_id_lens lens_indep_sym lens_plus_swap)

lemma swap_lens_fst: "fst\<^sub>L ;\<^sub>L swap\<^sub>L = snd\<^sub>L"
  by (simp add: fst_lens_plus fst_vwb_lens)

lemma swap_lens_snd: "snd\<^sub>L ;\<^sub>L swap\<^sub>L = fst\<^sub>L"
  by (simp add: lens_indep_sym snd_lens_plus snd_vwb_lens)

text \<open>The product lens can be rewritten as a sum lens.\<close>

lemma prod_as_plus: "X \<times>\<^sub>L Y = X ;\<^sub>L fst\<^sub>L +\<^sub>L Y ;\<^sub>L snd\<^sub>L"
  by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

lemma prod_lens_id_equiv:
  "1\<^sub>L \<times>\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_prod_def id_lens_def)

lemma prod_lens_comp_plus:
  "X\<^sub>2 \<bowtie> Y\<^sub>2 \<Longrightarrow> ((X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) ;\<^sub>L (X\<^sub>2 +\<^sub>L Y\<^sub>2)) = (X\<^sub>1 ;\<^sub>L X\<^sub>2) +\<^sub>L (Y\<^sub>1 ;\<^sub>L Y\<^sub>2)"
  by (auto simp add: lens_comp_def lens_plus_def lens_prod_def prod.case_eq_if fun_eq_iff)

text \<open>The following laws about quotient are similar to their arithmetic analogues. Lens quotient
  reverse the effect of a composition.\<close>

lemma lens_comp_quotient:
  "weak_lens Y \<Longrightarrow> (X ;\<^sub>L Y) /\<^sub>L Y = X"
  by (simp add: lens_quotient_def lens_comp_def)

lemma lens_quotient_id [simp]: "weak_lens X \<Longrightarrow> (X /\<^sub>L X) = 1\<^sub>L"
  by (force simp add: lens_quotient_def id_lens_def)

lemma lens_quotient_id_denom: "X /\<^sub>L 1\<^sub>L = X"
  by (simp add: lens_quotient_def id_lens_def lens_create_def)

lemma lens_quotient_unit: "weak_lens X \<Longrightarrow> (0\<^sub>L /\<^sub>L X) = 0\<^sub>L"
  by (simp add: lens_quotient_def zero_lens_def)

lemma lens_obs_eq_zero: "s\<^sub>1 \<simeq>\<^bsub>0\<^sub>L\<^esub> s\<^sub>2 = (s\<^sub>1 = s\<^sub>2)"
  by (simp add: lens_defs)

lemma lens_obs_eq_one: "s\<^sub>1 \<simeq>\<^bsub>1\<^sub>L\<^esub> s\<^sub>2"
  by (simp add: lens_defs)

lemma lens_obs_eq_as_override: "vwb_lens X \<Longrightarrow> s\<^sub>1 \<simeq>\<^bsub>X\<^esub> s\<^sub>2 \<longleftrightarrow> (s\<^sub>2 = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X)"
  by (auto simp add: lens_defs; metis vwb_lens.put_eq)

end