theory Mod_Plus_Minus

imports Kyber_spec

begin
section \<open>Re-centered Modulo Operation\<close>
text \<open>To define the compress and decompress functions,
  we need some special form of modulo. It returns the
  representation of the equivalence class in \<open>(-q div 2, q div 2]\<close>.
  Using these representatives, we ensure that the norm of the
  representative is as small as possible.\<close>

definition mod_plus_minus :: "int \<Rightarrow> int \<Rightarrow> int"
  (infixl "mod+-" 70) where
"m mod+- b =
  ((m + \<lfloor> real_of_int b / 2 \<rfloor>) mod b) - \<lfloor> real_of_int b / 2 \<rfloor>"

lemma mod_range: "b>0 \<Longrightarrow> (a::int) mod (b::int) \<in> {0..b-1}"
using range_mod by auto

lemma mod_rangeE:
  assumes "(a::int)\<in>{0..<b}"
  shows "a = a mod b"
using assms by auto

lemma mod_plus_minus_range:
  assumes "b>0"
  shows "y mod+- b \<in> {-\<lfloor>b/2\<rfloor>..\<lfloor>b/2\<rfloor>}"
unfolding mod_plus_minus_def
using mod_range[OF assms, of "(y + \<lfloor>real_of_int b / 2\<rfloor>)"]
by (auto)(linarith)

lemma odd_smaller_b:
  assumes "odd b"
  shows "\<lfloor> real_of_int b / 2 \<rfloor> + \<lfloor> real_of_int b / 2 \<rfloor> < b"
using assms
by (smt (z3) floor_divide_of_int_eq odd_two_times_div_two_succ
  of_int_hom.hom_add of_int_hom.hom_one)

lemma mod_plus_minus_rangeE:
  assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..<\<lfloor>real_of_int b/2\<rfloor>}"
          "odd b"
  shows "y = y mod+- b"
proof -
  have "(y + \<lfloor> real_of_int b / 2 \<rfloor>) \<in> {0..<b}"
    using assms(1) odd_smaller_b[OF assms(2)] by auto
  then have "(y + \<lfloor> real_of_int b / 2 \<rfloor>) mod b =
    (y + \<lfloor> real_of_int b / 2 \<rfloor>)"
    using mod_rangeE by auto
  then show ?thesis unfolding mod_plus_minus_def by auto
qed

lemma mod_plus_minus_rangeE':
  assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
          "odd b"
  shows "y = y mod+- b"
proof -
  have "(y + \<lfloor> real_of_int b / 2 \<rfloor>) \<in> {0..<b}"
    using assms(1) odd_smaller_b[OF assms(2)] by auto
  then have "(y + \<lfloor> real_of_int b / 2 \<rfloor>) mod b =
    (y + \<lfloor> real_of_int b / 2 \<rfloor>)"
    using mod_rangeE by auto
  then show ?thesis unfolding mod_plus_minus_def by auto
qed

lemma mod_plus_minus_zero:
  assumes "x mod+- b = 0"
  shows "x mod b = 0"
using assms unfolding mod_plus_minus_def
by (metis add.commute add.right_neutral bits_mod_0
  diff_add_cancel group_cancel.add1 mod_add_left_eq)

lemma mod_plus_minus_zero':
  assumes "b>0" "odd b"
  shows "0 mod+- b = (0::int)"
using mod_plus_minus_rangeE[of 0]
by (smt (verit, best) assms(1) assms(2) atLeastAtMost_iff
  atLeastLessThan_iff mod_plus_minus_range)

lemma neg_mod_plus_minus:
  assumes "odd b"
          "b>0"
  shows "(- x) mod+- b = - (x mod+- b)"
proof -
  obtain k :: int where k_def: "(-x) mod+- b = (-x)+ k* b"
  using mod_plus_minus_def
  proof -
    assume a1: "\<And>k. - x mod+- b = - x + k * b \<Longrightarrow> thesis"
    have "\<exists>i. i mod b + - (x + i) = - x mod+- b"
      by (metis (no_types) add.commute diff_add_cancel diff_minus_eq_add
        floor_divide_of_int_eq mod_plus_minus_def of_int_numeral)
    then show ?thesis
      using a1 by (metis (no_types) diff_add_cancel diff_diff_add
      diff_minus_eq_add minus_diff_eq minus_mult_div_eq_mod
      mult.commute mult_minus_left)
  qed
  then have "(-x) mod+- b = -(x - k*b)" using k_def by auto
  also have "\<dots> = - ((x-k*b) mod+- b)"
  proof -
    have range_xkb:"x - k * b \<in>
      {- \<lfloor>real_of_int b / 2\<rfloor>..\<lfloor>real_of_int b / 2\<rfloor>}"
      using k_def mod_plus_minus_range[OF assms(2)]
      by (smt (verit, ccfv_SIG) atLeastAtMost_iff)
    have "x - k*b = (x - k*b) mod+- b"
      using mod_plus_minus_rangeE'[OF range_xkb assms(1)] by auto
    then show ?thesis by auto
  qed
  also have "-((x - k*b) mod+- b) = -(x mod+- b)"
    unfolding mod_plus_minus_def
    by (smt (verit, best) mod_mult_self1)
  finally show ?thesis by auto
qed

lemma mod_plus_minus_rep:
  obtains k where "x = k*b + x mod+- b"
unfolding mod_plus_minus_def
by (metis add.commute add_diff_eq diff_eq_eq
  minus_mult_div_eq_mod mult.commute)

end


theory AbiDecode imports AbiTypes Hex Ok
begin

(* An decoder for the Solidity ABI.
   It supports decoding from all byte-strings representing
   valid Solidity-ABI encoded data
   (not limited to canonical encodings) *)

(* Functions for decoding basic data-types.*)
fun decode_uint :: "8 word list \<Rightarrow> int" where
"decode_uint l =
  (Word.uint (Word.word_rcat (take 32 l) :: 256 word))"

fun decode_sint :: "8 word list \<Rightarrow> int" where
"decode_sint l =
  (Word.sint (Word.word_rcat (take 32 l) :: 256 word))"

fun decode_bool :: "8 word list \<Rightarrow> bool option" where
"decode_bool l =
  (let i = decode_uint l in
   (if i = 0 then Some False
              else if i = 1 then Some True
              else None))"

fun decode_ufixed :: "nat \<Rightarrow> 8 word list \<Rightarrow> rat" where
"decode_ufixed n l =
  (let i = decode_uint l in (Rat.of_int i / (10 ^ n)))"

fun decode_fixed :: "nat \<Rightarrow> 8 word list \<Rightarrow> rat" where
"decode_fixed n l =
  (let i = decode_sint l in (Rat.of_int i / (10 ^ n)))"

(* bytes, fbytes, and strings will be padded to multiples of
   32 bytes. skip_padding skips this padding. *)
fun skip_padding :: "nat \<Rightarrow> nat" where
"skip_padding n =
  (case divmod_nat n 32 of
    (_, 0) \<Rightarrow> n
    | (_, rem) \<Rightarrow> n + 32 - rem)"

(* Ensure padding is zeroes.
   This is necessary for static encoder and static
   decoder to be inverses. *)
fun check_padding :: "nat \<Rightarrow> 8 word list \<Rightarrow> bool" where
"check_padding n l =
  (let p = skip_padding n in
  ((p \<le> length l) \<and> (drop n (take p l) = replicate (p - n) (word_of_int 0))))"

(* Extract byte strings of known length *)
fun decode_fbytes :: "nat \<Rightarrow> 8 word list \<Rightarrow> 8 word list option" where
"decode_fbytes n l =
  (if check_padding n l then Some (take n l)
   else None)"

fun decode_function_sel :: "8 word list \<Rightarrow> (int * int) option" where
"decode_function_sel bs =
  (if check_padding 24 bs then
      Some (Word.uint (Word.word_rcat (take 20 bs) :: 160 word),
            Word.uint (Word.word_rcat (take 4 (drop 20 bs)) :: 32 word))
   else None)"

fun bytes_to_string :: "8 word list \<Rightarrow> char list" where
"bytes_to_string bs =
  List.map (\<lambda> b . char_of_integer (integer_of_int (Word.uint b))) bs"

(* Lemma for decoder termination *)
lemma abi_type_list_measure_replicate :
  "\<And> t . abi_type_list_measure (replicate n t)
           =  1 + n + (n * abi_type_measure t)"
proof(induction n)
  case 0
  then show ?case
    by(simp)
next
  case (Suc n)
  then show ?case
    by(simp)
qed

(* Construct decoder error messages *)
fun decode_err :: "char list \<Rightarrow> (int * 8 word list) \<Rightarrow> char list"
  where
"decode_err s (ix, l) =
  s @ '' at byte '' @ decwrite (nat ix) @ '' of '' @ decwrite (length l) @ ''.''"

(* Decoder for static data *)
function (sequential) decode_static :: "abi_type \<Rightarrow> (int * 8 word list) \<Rightarrow> abi_value orerror"
and decode_static_tup :: "abi_type list \<Rightarrow> (int * 8 word list) \<Rightarrow> abi_value list orerror" where
"decode_static (Tuint n) (ix, l) =
   (let l' = drop (nat ix) l in
   (let res = decode_uint l' in
    (if uint_value_valid n res then Ok (Vuint n res)
     else Err (decode_err ''Invalid uint'' (ix, l)))))"
| "decode_static (Tsint n) (ix, l) =
   (let l' = drop (nat ix) l in
   (let res = decode_sint l' in
    (if sint_value_valid n res then Ok (Vsint n res)
     else Err (decode_err ''Invalid sint'' (ix, l)))))"
| "decode_static Taddr (ix, l) =
  (let l' = drop (nat ix) l in
   (let res = decode_uint l' in
    (if addr_value_valid res then Ok (Vaddr res)
     else Err (decode_err ''Invalid address'' (ix, l)))))"
| "decode_static Tbool (ix, l) =
  (let l' = drop (nat ix) l in
   (case decode_bool l' of
      None \<Rightarrow> Err (decode_err ''Invalid bool'' (ix, l))
      | Some b \<Rightarrow> Ok (Vbool b)))"
| "decode_static (Tfixed m n) (ix, l) =
  (let l' = drop (nat ix) l in
   (let res = decode_fixed n l' in
    (if fixed_value_valid m n res then Ok (Vfixed m n res)
     else Err (decode_err ''Invalid fixed'' (ix, l)))))"
| "decode_static (Tufixed m n) (ix, l) =
  (let l' = drop (nat ix) l in
   (let res = decode_ufixed n l' in
    (if ufixed_value_valid m n res then Ok (Vufixed m n res)
     else Err (decode_err ''Invalid ufixed'' (ix, l)))))"
| "decode_static (Tfbytes n) (ix, l) =
  (let l' = drop (nat ix) l in
   (case decode_fbytes n l' of
      Some res \<Rightarrow> (if fbytes_value_valid n res then Ok (Vfbytes n res)
                    else Err (decode_err ''Invalid fbytes'' (ix, l)))
      | None \<Rightarrow> Err (decode_err ''invalid fbytes padding'' (ix, l))))"

| "decode_static (Tfunction) (ix, l) =
    (let l' = drop (nat ix) l in
      (case decode_function_sel l' of
        Some (i, j) \<Rightarrow> (if function_value_valid i j then Ok (Vfunction i j)
                        else Err (decode_err ''Invalid function'' (ix, l)))
        | None \<Rightarrow> Err (decode_err ''invalid function padding'' (ix, l))))"

| "decode_static (Tfarray t n) (ix, l) =
  (case decode_static_tup (List.replicate n t) (ix, l) of
    Err s \<Rightarrow> Err s
    | Ok vs \<Rightarrow>
        (if farray_value_valid_aux t n vs then Ok (Vfarray t n vs)
         else Err (decode_err ''Invalid farray'' (ix, l))))"
| "decode_static (Ttuple ts) (ix, l) =
  (case decode_static_tup ts (ix, l) of
    Err s \<Rightarrow> Err s
    | Ok vs \<Rightarrow>
      (if tuple_value_valid_aux ts vs then Ok (Vtuple ts vs)
       else Err (decode_err ''Invalid tuple'' (ix, l))))"
| "decode_static _ (ix, l) = Err (decode_err ''Ran static parser on dynamic array'' (ix, l))"
| "decode_static_tup [] (ix, l) = Ok []"
| "decode_static_tup (t#ts) (ix, l) =
    (case decode_static t (ix, l) of
      Err s \<Rightarrow> Err s
      | Ok v \<Rightarrow> (case decode_static_tup ts
                       (ix + (abi_static_size t), l) of
          Err s \<Rightarrow> Err s
          | Ok vs \<Rightarrow> Ok (v#vs)))"
  by pat_completeness auto

termination
proof(relation
"measure (\<lambda> x .
    (case x of
      Inl (t, l) \<Rightarrow> 1 + abi_type_measure t
      | Inr (ts, l) \<Rightarrow> abi_type_list_measure ts))"; (auto; fail)?)
  show "\<And>t n ix l.
       (Inr (replicate n t, ix, l), Inl (Tfarray t n, ix, l))
       \<in> measure (\<lambda>x. case x of Inl (t, l) \<Rightarrow> 1 + abi_type_measure t
                              | Inr (ts, l) \<Rightarrow> abi_type_list_measure ts)"
    by(auto simp add:abi_type_list_measure_replicate)
next
  fix t ts
  show "\<And> ix l.
       (Inl (t, ix, l), Inr (t # ts, ix, l))
       \<in> measure (\<lambda>x. case x of Inl (t, l) \<Rightarrow> 1 + abi_type_measure t
                              | Inr (ts, l) \<Rightarrow> abi_type_list_measure ts)"
    by(cases ts; auto)
qed

(* Another measure for termination *)
fun tails_measure :: "(abi_value + (abi_type * nat)) list \<Rightarrow> nat" where
"tails_measure [] = 1"
| "tails_measure ((Inl _)#ts) = 1 + tails_measure ts"
| "tails_measure ((Inr (t, _))#ts) =
    abi_type_measure t + tails_measure ts"

fun abi_size_lower_bound :: "abi_type \<Rightarrow> int" where
"abi_size_lower_bound t =
 (if abi_type_isstatic t then abi_static_size t
  else 32)"

(* Implementation of the core decoder
   End-users should call decode instead (see below), which implements
   top-level validity checks
*)
function (sequential) decode' :: "abi_type \<Rightarrow> (int * 8 word list) \<Rightarrow> (abi_value * int) orerror"

(* first returned nat is the length of all the heads (used for computing offsets);
   second returned nat is number of bytes consumed;
   input nat is running count of head length. *)
and decode'_dyn_tuple_heads :: "abi_type list \<Rightarrow> int \<Rightarrow> (int * 8 word list) \<Rightarrow>
                (abi_value option list *  (int option) list * int * int) orerror"
(* list parameter gives an offset for each field that still needs to be parsed
   the int parameter is an index of how many bytes into our overall tuple encoding we are *)
and decode'_dyn_tuple_tails :: "(int option) list \<Rightarrow> abi_type list \<Rightarrow> abi_value option list \<Rightarrow>
                                int \<Rightarrow> (int * 8 word list) \<Rightarrow>
                (abi_value list * int) orerror"
where
"decode' t (ix, l) =
(if ix < 0 then Err (decode_err ''Tried to decode at a negative index'' (ix, l))
 else (if (ix > length l) then Err (decode_err ''Tried to decode at an index out of range'' (ix, l))
 else
 (let l' = drop (nat ix) l in

  (if abi_type_isstatic t
    then
      if int (length l) < (abi_static_size t) + ix
      then Err (decode_err ''Too few bytes for given static type'' (ix, l))
      else (case decode_static t (ix, l) of
            Err s \<Rightarrow> Err s
            | Ok v \<Rightarrow> Ok (v, (abi_static_size t)))
   else
    (case t of
      Tfarray t n \<Rightarrow>
        (let ts = List.replicate (nat n) t in
        (case decode'_dyn_tuple_heads ts 0 (ix, l) of
          Err s \<Rightarrow> Err s
          | Ok (vos, idxs, byteoffset, bytes_parsed) \<Rightarrow>
            (case decode'_dyn_tuple_tails idxs ts vos byteoffset (ix, l) of
              Err s \<Rightarrow> Err s
              | Ok (vs, bytes_parsed') \<Rightarrow> Ok (Vfarray t n vs, bytes_parsed + bytes_parsed'))))
      | Tarray t \<Rightarrow>
       if int (length l) < 32 + ix
       then Err (decode_err ''Too few bytes; could not read array size'' (ix, l))
       else
         (let n = (decode_uint (take 32 l')) in
          \<comment> \<open>check data length against a lower bound for size of encoded data \<close>
          if int (length l) < 32 + (n * abi_size_lower_bound t) + ix
          then Err (decode_err ''Bytes remaining less than lower bound on array size'' (ix, l))
          else
          (let ts = List.replicate (nat n) t in
          (case decode'_dyn_tuple_heads ts 0 (ix + 32, l) of
            Err s \<Rightarrow> Err s
            | Ok (vos, idxs, byteoffset, bytes_parsed) \<Rightarrow>
              (case decode'_dyn_tuple_tails idxs ts vos byteoffset (ix + 32, l) of
                Err s \<Rightarrow> Err s
                | Ok (vs, bytes_parsed') \<Rightarrow> Ok (Varray t vs, bytes_parsed + bytes_parsed' + 32)))))
      | Ttuple ts \<Rightarrow>
        (case decode'_dyn_tuple_heads ts 0 (ix, l) of
          Err s \<Rightarrow> Err s
          | Ok (vos, idxs, byteoffset, bytes_parsed) \<Rightarrow>
            (case decode'_dyn_tuple_tails idxs ts vos byteoffset (ix, l) of
              Err s \<Rightarrow> Err s
              | Ok (vs, bytes_parsed') \<Rightarrow> Ok (Vtuple ts vs, bytes_parsed + bytes_parsed')))
      | Tbytes \<Rightarrow>
        if int (length l) < 32 + ix
        then Err (decode_err ''Too few bytes; could not read bytestream size'' (ix, l))
        else let sz = (decode_uint (take 32 l')) in
             if int (length l) < sz + 32 + ix
             then Err (decode_err ''Fewer bytes remaining than bytestream size'' (ix, l))
             else (if check_padding (nat sz) (drop 32 l')
                   then Ok (Vbytes (take (nat sz) (drop 32 l')), int(skip_padding (nat sz)) + 32)
                   else Err (decode_err ''Invalid bytes padding'' (ix, l)))
      | Tstring \<Rightarrow>
        if int(length l) < 32 + ix
        then Err (decode_err ''Too few bytes; could not read string size'' (ix, l))
        else let sz = (decode_uint (take 32 l')) in
             if int (length l) < sz + 32 + ix
             then Err (decode_err ''Fewer bytes remaining than string size'' (ix, l))
             else (if check_padding (nat sz) (drop 32 l')
             then Ok (Vstring (bytes_to_string (take (nat sz) (drop 32 l')))
                     , int (skip_padding (nat sz)) + 32)
                   else Err (decode_err ''Invalid string padding'' (ix, l)))
      | _ \<Rightarrow> Err (decode_err ''This should be dead code'' (ix, l)))))))"

(* indices ix are the index of the start of the overall tuple we are encoding *)
| "decode'_dyn_tuple_heads [] n (ix, l) = Ok ([], [], n, 0)"
| "decode'_dyn_tuple_heads (th#tt) n (ix, l) =
  (let l' = drop (nat (ix + n)) l in
    (if abi_type_isstatic th
      then (case decode' th (ix + n, l) of
        Err s \<Rightarrow> Err s
        | Ok (v, bytes_parsed) \<Rightarrow>
          (case decode'_dyn_tuple_heads tt (n + nat (abi_static_size th)) (ix, l) of
            Err s \<Rightarrow> Err s
            | Ok (vos, idxs, n', bytes_parsed') \<Rightarrow>
                Ok (Some v # vos, None#idxs, n', bytes_parsed + bytes_parsed')))
    else
      (if length l' < 32 then Err (decode_err ''Too few bytes; could not read tuple head'' (ix, l))
       else let sz = (decode_sint (take 32 l')) in
            (case decode'_dyn_tuple_heads tt (n + 32) (ix, l) of
              Err s \<Rightarrow> Err s
              | Ok (vos, idxs, n', bytes_parsed) \<Rightarrow>
                  Ok (None # vos, (Some (ix + sz))#idxs, n', bytes_parsed + 32)))))"

| "decode'_dyn_tuple_tails [] [] []  _ (ix, l) = Ok ([], 0)"
| "decode'_dyn_tuple_tails (None#t) (th#tt) (Some vh#vt) offset (ix, l) =
   (case decode'_dyn_tuple_tails t tt vt offset (ix, l) of
    Err s \<Rightarrow> Err s
    | Ok (vs, bytes_parsed) \<Rightarrow> Ok (vh#vs, bytes_parsed))"

| "decode'_dyn_tuple_tails ((Some toffset)#t) (th#tt) (None#vt) offset (ix, l) =
   (let ix' = toffset in
       (case decode' th (ix', l) of
              Err s \<Rightarrow> Err s
              | Ok (v, bytes_parsed) \<Rightarrow>
                     let offset' = offset + bytes_parsed in
                     (case decode'_dyn_tuple_tails t tt vt offset' (ix, l) of
                           Err s \<Rightarrow> Err s
                           | Ok (vs, bytes_parsed') \<Rightarrow>
                              Ok (v#vs, bytes_parsed + bytes_parsed'))))
      "

| "decode'_dyn_tuple_tails _ _ _ _ (ix, l) = Err (decode_err ''Should be dead code'' (ix, l))"

  by pat_completeness auto

fun somes :: "'a option list \<Rightarrow> 'a list" where
"somes [] = []"
| "somes (None#t) = somes t"
| "somes (Some h#t) = h # somes t"

lemma abi_type_measure_nonzero :
  "abi_type_measure t > 0"
  by(induction t; auto)

(* Termination proof for decoder
   (Automation fails to prove termination in a reasonable amount of time)
*)
termination decode'
proof(relation
"measure (\<lambda> x .
    (case x of
       Inl (t, (ix, l)) \<Rightarrow> 1 + abi_type_measure t
      | Inr (Inl (ts,  n, (ix, l))) \<Rightarrow> abi_type_list_measure ts
      | Inr (Inr (idxs, ts, vs, n, (ix, l))) \<Rightarrow> abi_type_list_measure ts))";
      (auto simp add:abi_type_list_measure_replicate; fail)?)

  fix t ix l x x13
  show
    "\<And> xa xb.
       \<not> ix < 0 \<Longrightarrow>
       \<not> int (length l) < ix \<Longrightarrow>
       x = drop (nat ix) l \<Longrightarrow>
       \<not> abi_type_isstatic t \<Longrightarrow>
       t = Tarray x13 \<Longrightarrow>
       \<not> int (length l) < 32 + ix \<Longrightarrow>
       xa = decode_uint (take 32 x) \<Longrightarrow>
       xb = replicate (nat xa) x13 \<Longrightarrow>
       (Inr (Inl (xb, 0, ix + 32, l)), Inl (t, ix, l))
       \<in> measure
           (\<lambda>x. case x of Inl (t, ix, l) \<Rightarrow> 1 + abi_type_measure t
                        | Inr (Inl (ts, n, ix, l)) \<Rightarrow> abi_type_list_measure ts
                        | Inr (Inr (idxs, ts, vs, n, ix, l)) \<Rightarrow> abi_type_list_measure ts)"

    using abi_type_measure_nonzero[of x13]
          Word.uint_lt[of "(word_rcat (take 32 (drop (nat ix) l)) :: 256 word)"]
    by(auto simp add: abi_type_list_measure_replicate max_u256_def intro:Nat.add_less_mono)
next
  fix t ix l x x13
  show
    "\<And> xa xb a xc y xd ya xe yb.
       \<not> ix < 0 \<Longrightarrow>
       \<not> int (length l) < ix \<Longrightarrow>
       x = drop (nat ix) l \<Longrightarrow>
       \<not> abi_type_isstatic t \<Longrightarrow>
       t = Tarray x13 \<Longrightarrow>
       \<not> int (length l) < 32 + ix \<Longrightarrow>
       xa = decode_uint (take 32 x) \<Longrightarrow>
       xb = replicate (nat xa) x13 \<Longrightarrow>
       decode'_dyn_tuple_heads xb 0 (ix + 32, l) = Ok a \<Longrightarrow>
       (xc, y) = a \<Longrightarrow>
       (xd, ya) = y \<Longrightarrow>
       (xe, yb) = ya \<Longrightarrow>
       decode'_decode'_dyn_tuple_heads_decode'_dyn_tuple_tails_dom
          (Inr (Inl (xb, 0, ix + 32, l))) \<Longrightarrow>
       (Inr (Inr (xd, xb, xc, xe, ix + 32, l)), Inl (t, ix, l))
       \<in> measure (\<lambda>x. case x of Inl (t, ix, l) \<Rightarrow> 1 + abi_type_measure t
                              | Inr (Inl (ts, n, ix, l)) \<Rightarrow> abi_type_list_measure ts
                              | Inr (Inr (idxs, ts, vs, n, ix, l)) \<Rightarrow> abi_type_list_measure ts)"
   using abi_type_measure_nonzero[of x13]
          Word.uint_lt[of "(word_rcat (take 32 (drop (nat ix) l)) :: 256 word)"]
   by(auto simp add: abi_type_list_measure_replicate max_u256_def intro:Nat.add_less_mono)
next
  fix th tt
  show
    "\<And> n ix l x.
       x = drop (nat (ix + n)) l \<Longrightarrow>
       abi_type_isstatic th \<Longrightarrow>
       (Inl (th, ix + n, l), Inr (Inl (th # tt, n, ix, l)))
       \<in> measure (\<lambda>x. case x of Inl (t, ix, l) \<Rightarrow> 1 + abi_type_measure t
                              | Inr (Inl (ts, n, ix, l)) \<Rightarrow> abi_type_list_measure ts
                              | Inr (Inr (idxs, ts, vs, n, ix, l)) \<Rightarrow> abi_type_list_measure ts)"
    by(cases tt; auto)
next
  fix tt
  show
    "\<And> toffset t th vt offset ix l x.
       x = toffset \<Longrightarrow>
       (Inl (th, x, l), Inr (Inr (Some toffset # t, th # tt, None # vt, offset, ix, l)))
       \<in> measure (\<lambda>x. case x of Inl (t, ix, l) \<Rightarrow> 1 + abi_type_measure t
                              | Inr (Inl (ts, n, ix, l)) \<Rightarrow> abi_type_list_measure ts
                              | Inr (Inr (idxs, ts, vs, n, ix, l)) \<Rightarrow> abi_type_list_measure ts)"
    by(cases tt; auto)
qed

fun decode :: "abi_type \<Rightarrow> 8 word list \<Rightarrow> abi_value orerror" where
"decode t l =
  (if abi_type_valid t then
    (case decode' t (0, l) of
      Err s \<Rightarrow> Err s
      | Ok (v, _) \<Rightarrow> Ok v)
   else Err ''Invalid ABI type'')"

end


(* Title:      Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Semirings\<close>

text \<open>
This theory develops a hierarchy of idempotent semirings.
All kinds of semiring considered here are bounded semilattices, but many lack additional properties typically assumed for semirings.
In particular, we consider the variants of semirings, in which
\begin{itemize}
\item multiplication is not required to be associative;
\item a right zero and unit of multiplication need not exist;
\item multiplication has a left residual;
\item multiplication from the left is not required to distribute over addition;
\item the semilattice order has a greatest element.
\end{itemize}
We have applied results from this theory a number of papers for unifying computation models.
For example, see \cite{Guttmann2012c} for various relational and matrix-based computation models and \cite{BerghammerGuttmann2015b} for multirelational models.

The main results in this theory relate different ways of defining reflexive-transitive closures as discussed in \cite{BerghammerGuttmann2015b}.
\<close>

theory Semirings

imports Fixpoints

begin

subsection \<open>Idempotent Semirings\<close>

text \<open>
The following definitions are standard for relations.
Putting them into a general class that depends only on the signature facilitates reuse.
Coreflexives are sometimes called partial identities, subidentities, monotypes or tests.
\<close>

class times_one_ord = times + one + ord
begin

abbreviation reflexive   :: "'a \<Rightarrow> bool" where "reflexive x   \<equiv> 1 \<le> x"
abbreviation coreflexive :: "'a \<Rightarrow> bool" where "coreflexive x \<equiv> x \<le> 1"

abbreviation transitive  :: "'a \<Rightarrow> bool" where "transitive x  \<equiv> x * x \<le> x"
abbreviation dense_rel   :: "'a \<Rightarrow> bool" where "dense_rel x   \<equiv> x \<le> x * x"
abbreviation idempotent  :: "'a \<Rightarrow> bool" where "idempotent x  \<equiv> x * x = x"

abbreviation preorder    :: "'a \<Rightarrow> bool" where "preorder x    \<equiv> reflexive x \<and> transitive x"

abbreviation "coreflexives \<equiv> { x . coreflexive x }"

end

text \<open>
The first algebra is a very weak idempotent semiring, in which multiplication is not necessarily associative.
\<close>

class non_associative_left_semiring = bounded_semilattice_sup_bot + times + one +
  assumes mult_left_sub_dist_sup: "x * y \<squnion> x * z \<le> x * (y \<squnion> z)"
  assumes mult_right_dist_sup: "(x \<squnion> y) * z = x * z \<squnion> y * z"
  assumes mult_left_zero [simp]: "bot * x = bot"
  assumes mult_left_one [simp]: "1 * x = x"
  assumes mult_sub_right_one: "x \<le> x * 1"
begin

subclass times_one_ord .

text \<open>
We first show basic isotonicity and subdistributivity properties of multiplication.
\<close>

lemma mult_left_isotone:
  "x \<le> y \<Longrightarrow> x * z \<le> y * z"
  using mult_right_dist_sup sup_right_divisibility by auto

lemma mult_right_isotone:
  "x \<le> y \<Longrightarrow> z * x \<le> z * y"
  using mult_left_sub_dist_sup sup.bounded_iff sup_right_divisibility by auto

lemma mult_isotone:
  "w \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> w * x \<le> y * z"
  using order_trans mult_left_isotone mult_right_isotone by blast

lemma affine_isotone:
  "isotone (\<lambda>x . y * x \<squnion> z)"
  using isotone_def mult_right_isotone sup_left_isotone by auto

lemma mult_left_sub_dist_sup_left:
  "x * y \<le> x * (y \<squnion> z)"
  by (simp add: mult_right_isotone)

lemma mult_left_sub_dist_sup_right:
  "x * z \<le> x * (y \<squnion> z)"
  by (simp add: mult_right_isotone)

lemma mult_right_sub_dist_sup_left:
  "x * z \<le> (x \<squnion> y) * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_sup_right:
  "y * z \<le> (x \<squnion> y) * z"
  by (simp add: mult_left_isotone)

lemma case_split_left:
  assumes "1 \<le> w \<squnion> z"
      and "w * x \<le> y"
      and "z * x \<le> y"
    shows "x \<le> y"
proof -
  have "(w \<squnion> z) * x \<le> y"
    by (simp add: assms(2-3) mult_right_dist_sup)
  thus ?thesis
    by (metis assms(1) dual_order.trans mult_left_one mult_left_isotone)
qed

lemma case_split_left_equal:
  "w \<squnion> z = 1 \<Longrightarrow> w * x = w * y \<Longrightarrow> z * x = z * y \<Longrightarrow> x = y"
  by (metis mult_left_one mult_right_dist_sup)

text \<open>
Next we consider under which semiring operations the above properties are closed.
\<close>

lemma reflexive_one_closed:
  "reflexive 1"
  by simp

lemma reflexive_sup_closed:
  "reflexive x \<Longrightarrow> reflexive (x \<squnion> y)"
  by (simp add: le_supI1)

lemma reflexive_mult_closed:
  "reflexive x \<Longrightarrow> reflexive y \<Longrightarrow> reflexive (x * y)"
  using mult_isotone by fastforce

lemma coreflexive_bot_closed:
  "coreflexive bot"
  by simp

lemma coreflexive_one_closed:
  "coreflexive 1"
  by simp

lemma coreflexive_sup_closed:
  "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> coreflexive (x \<squnion> y)"
  by simp

lemma coreflexive_mult_closed:
  "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> coreflexive (x * y)"
  using mult_isotone by fastforce

lemma transitive_bot_closed:
  "transitive bot"
  by simp

lemma transitive_one_closed:
  "transitive 1"
  by simp

lemma dense_one_closed:
  "dense_rel 1"
  by simp

lemma dense_sup_closed:
  "dense_rel x \<Longrightarrow> dense_rel y \<Longrightarrow> dense_rel (x \<squnion> y)"
  by (metis mult_right_dist_sup order_lesseq_imp sup.mono mult_left_sub_dist_sup_left mult_left_sub_dist_sup_right)

lemma idempotent_bot_closed:
  "idempotent bot"
  by simp

lemma idempotent_one_closed:
  "idempotent 1"
  by simp

lemma preorder_one_closed:
  "preorder 1"
  by simp

lemma coreflexive_transitive:
  "coreflexive x \<Longrightarrow> transitive x"
  using mult_left_isotone by fastforce

lemma preorder_idempotent:
  "preorder x \<Longrightarrow> idempotent x"
  using antisym mult_isotone by fastforce

text \<open>
We study the following three ways of defining reflexive-transitive closures.
Each of them is given as a least prefixpoint, but the underlying functions are different.
They implement left recursion, right recursion and symmetric recursion, respectively.
\<close>

abbreviation Lf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Lf y \<equiv> (\<lambda>x . 1 \<squnion> x * y)"
abbreviation Rf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Rf y \<equiv> (\<lambda>x . 1 \<squnion> y * x)"
abbreviation Sf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Sf y \<equiv> (\<lambda>x . 1 \<squnion> y \<squnion> x * x)"

abbreviation lstar :: "'a \<Rightarrow> 'a" where "lstar y \<equiv> p\<mu> (Lf y)"
abbreviation rstar :: "'a \<Rightarrow> 'a" where "rstar y \<equiv> p\<mu> (Rf y)"
abbreviation sstar :: "'a \<Rightarrow> 'a" where "sstar y \<equiv> p\<mu> (Sf y)"

text \<open>
All functions are isotone and, therefore, if the prefixpoints exist they are also fixpoints.
\<close>

lemma lstar_rec_isotone:
  "isotone (Lf y)"
  using isotone_def sup_right_divisibility sup_right_isotone mult_right_sub_dist_sup_right by auto

lemma rstar_rec_isotone:
  "isotone (Rf y)"
  using isotone_def sup_right_divisibility sup_right_isotone mult_left_sub_dist_sup_right by auto

lemma sstar_rec_isotone:
  "isotone (Sf y)"
  using isotone_def sup_right_isotone mult_isotone by auto

lemma lstar_fixpoint:
  "has_least_prefixpoint (Lf y) \<Longrightarrow> lstar y = \<mu> (Lf y)"
  by (simp add: pmu_mu lstar_rec_isotone)

lemma rstar_fixpoint:
  "has_least_prefixpoint (Rf y) \<Longrightarrow> rstar y = \<mu> (Rf y)"
  by (simp add: pmu_mu rstar_rec_isotone)

lemma sstar_fixpoint:
  "has_least_prefixpoint (Sf y) \<Longrightarrow> sstar y = \<mu> (Sf y)"
  by (simp add: pmu_mu sstar_rec_isotone)

lemma sstar_increasing:
  "has_least_prefixpoint (Sf y) \<Longrightarrow> y \<le> sstar y"
  using order_trans pmu_unfold sup_ge1 sup_ge2 by blast

text \<open>
The fixpoint given by right recursion is always below the one given by symmetric recursion.
\<close>

lemma rstar_below_sstar:
  assumes "has_least_prefixpoint (Rf y)"
      and "has_least_prefixpoint (Sf y)"
    shows "rstar y \<le> sstar y"
proof -
  have "y \<le> sstar y"
    using assms(2) pmu_unfold by force
  hence "Rf y (sstar y) \<le> Sf y (sstar y)"
    by (meson sup.cobounded1 sup.mono mult_left_isotone)
  also have "... \<le> sstar y"
    using assms(2) pmu_unfold by blast
  finally show ?thesis
    using assms(1) is_least_prefixpoint_def least_prefixpoint by auto
qed

end

text \<open>
Our next structure adds one half of the associativity property.
This inequality holds, for example, for multirelations under the compositions defined by Parikh and Peleg \cite{Parikh1983,Peleg1987}.
The converse inequality requires up-closed multirelations for Parikh's composition.
\<close>

class pre_left_semiring = non_associative_left_semiring +
  assumes mult_semi_associative: "(x * y) * z \<le> x * (y * z)"
begin

lemma mult_one_associative [simp]:
  "x * 1 * y = x * y"
  by (metis dual_order.antisym mult_left_isotone mult_left_one mult_semi_associative mult_sub_right_one)

lemma mult_sup_associative_one:
  "(x * (y * 1)) * z \<le> x * (y * z)"
  by (metis mult_semi_associative mult_one_associative)

lemma rstar_increasing:
  assumes "has_least_prefixpoint (Rf y)"
    shows "y \<le> rstar y"
proof -
  have "Rf y (rstar y) \<le> rstar y"
    using assms pmu_unfold by blast
  thus ?thesis
    by (metis le_supE mult_right_isotone mult_sub_right_one sup.absorb_iff2)
qed

end

text \<open>
For the next structure we add a left residual operation.
Such a residual is available, for example, for multirelations.

The operator notation for binary division is introduced in a class that requires a unary inverse.
This is appropriate for fields, but too strong in the present context of semirings.
We therefore reintroduce it without requiring a unary inverse.
\<close>

no_notation
  inverse_divide (infixl "'/" 70)

notation
  divide (infixl "'/" 70)

class residuated_pre_left_semiring = pre_left_semiring + divide +
  assumes lres_galois: "x * y \<le> z \<longleftrightarrow> x \<le> z / y"
begin

text \<open>
We first derive basic properties of left residuals from the Galois connection.
\<close>

lemma lres_left_isotone:
  "x \<le> y \<Longrightarrow> x / z \<le> y / z"
  using dual_order.trans lres_galois by blast

lemma lres_right_antitone:
  "x \<le> y \<Longrightarrow> z / y \<le> z / x"
  using dual_order.trans lres_galois mult_right_isotone by blast

lemma lres_inverse:
  "(x / y) * y \<le> x"
  by (simp add: lres_galois)

lemma lres_one:
  "x / 1 \<le> x"
  using mult_sub_right_one order_trans lres_inverse by blast

lemma lres_mult_sub_lres_lres:
  "x / (z * y) \<le> (x / y) / z"
  using lres_galois mult_semi_associative order.trans by blast

lemma mult_lres_sub_assoc:
  "x * (y / z) \<le> (x * y) / z"
  by (meson dual_order.trans lres_galois mult_right_isotone lres_inverse lres_mult_sub_lres_lres)

text \<open>
With the help of a left residual, it follows that left recursion is below right recursion.
\<close>

lemma lstar_below_rstar:
  assumes "has_least_prefixpoint (Lf y)"
      and "has_least_prefixpoint (Rf y)"
    shows "lstar y \<le> rstar y"
proof -
  have "y * (rstar y / y) * y \<le> y * rstar y"
    using lres_galois mult_lres_sub_assoc by auto
  also have "... \<le> rstar y"
    using assms(2) le_supE pmu_unfold by blast
  finally have "y * (rstar y / y) \<le> rstar y / y"
    by (simp add: lres_galois)
  hence "Rf y (rstar y / y) \<le> rstar y / y"
    using assms(2) lres_galois rstar_increasing by fastforce
  hence "rstar y \<le> rstar y / y"
    using assms(2) is_least_prefixpoint_def least_prefixpoint by auto
  hence "Lf y (rstar y) \<le> rstar y"
    using assms(2) lres_galois pmu_unfold by fastforce
  thus ?thesis
    using assms(1) is_least_prefixpoint_def least_prefixpoint by auto
qed

text \<open>
Moreover, right recursion gives the same result as symmetric recursion.
The next proof follows an argument of \cite[Satz 10.1.5]{Berghammer2012}.
\<close>

lemma rstar_sstar:
  assumes "has_least_prefixpoint (Rf y)"
      and "has_least_prefixpoint (Sf y)"
    shows "rstar y = sstar y"
proof -
  have "Rf y (rstar y / rstar y) * rstar y \<le> rstar y \<squnion> y * ((rstar y / rstar y) * rstar y)"
    using mult_right_dist_sup mult_semi_associative sup_right_isotone by auto
  also have "... \<le> rstar y \<squnion> y * rstar y"
    using mult_right_isotone sup_right_isotone lres_inverse by blast
  also have "... \<le> rstar y"
    using assms(1) pmu_unfold by fastforce
  finally have "Rf y (rstar y / rstar y) \<le> rstar y / rstar y"
    by (simp add: lres_galois)
  hence "rstar y * rstar y \<le> rstar y"
    using assms(1) is_least_prefixpoint_def least_prefixpoint lres_galois by auto
  hence "y \<squnion> rstar y * rstar y \<le> rstar y"
    by (simp add: assms(1) rstar_increasing)
  hence "Sf y (rstar y) \<le> rstar y"
    using assms(1) pmu_unfold by force
  hence "sstar y \<le> rstar y"
    using assms(2) is_least_prefixpoint_def least_prefixpoint by auto
  thus ?thesis
    by (simp add: assms antisym rstar_below_sstar)
qed

end

text \<open>
In the next structure we add full associativity of multiplication, as well as a right unit.
Still, multiplication does not need to have a right zero and does not need to distribute over addition from the left.
\<close>

class idempotent_left_semiring = non_associative_left_semiring + monoid_mult
begin

subclass pre_left_semiring
  by unfold_locales (simp add: mult_assoc)

lemma zero_right_mult_decreasing:
  "x * bot \<le> x"
  by (metis bot_least mult_1_right mult_right_isotone)

text \<open>
The following result shows that for dense coreflexives there are two equivalent ways to express that a property is preserved.
In the setting of Kleene algebras, this is well known for tests, which form a Boolean subalgebra.
The point here is that only very few properties of tests are needed to show the equivalence.
\<close>

end

text \<open>
The next structure has both distributivity properties of multiplication.
Only a right zero is missing from full semirings.
This is important as many computation models do not have a right zero of sequential composition.
\<close>

class idempotent_left_zero_semiring = idempotent_left_semiring +
  assumes mult_left_dist_sup: "x * (y \<squnion> z) = x * y \<squnion> x * z"
begin

lemma case_split_right:
  assumes "1 \<le> w \<squnion> z"
      and "x * w \<le> y"
      and "x * z \<le> y"
    shows "x \<le> y"
proof -
  have "x * (w \<squnion> z) \<le> y"
    by (simp add: assms(2-3) mult_left_dist_sup)
  thus ?thesis
    by (metis assms(1) dual_order.trans mult_1_right mult_right_isotone)
qed

lemma case_split_right_equal:
  "w \<squnion> z = 1 \<Longrightarrow> x * w = y * w \<Longrightarrow> x * z = y * z \<Longrightarrow> x = y"
  by (metis mult_1_right mult_left_dist_sup)

text \<open>
This is the first structure we can connect to the semirings provided by Isabelle/HOL.
\<close>

sublocale semiring: ordered_semiring sup bot less_eq less times
  apply unfold_locales
  using sup_right_isotone apply blast
  apply (simp add: mult_right_dist_sup)
  apply (simp add: mult_left_dist_sup)
  apply (simp add: mult_right_isotone)
  by (simp add: mult_left_isotone)

sublocale semiring: semiring_numeral 1 times sup ..

end

text \<open>
Completing this part of the hierarchy, we obtain idempotent semirings by adding a right zero of multiplication.
\<close>

class idempotent_semiring = idempotent_left_zero_semiring +
  assumes mult_right_zero [simp]: "x * bot = bot"
begin

sublocale semiring: semiring_0 sup bot times
  by unfold_locales simp_all

end

subsection \<open>Bounded Idempotent Semirings\<close>

text \<open>
All of the following semirings have a greatest element in the underlying semilattice order.
With this element, we can express further standard properties of relations.
We extend each class in the above hierarchy in turn.
\<close>

class times_top = times + top
begin

abbreviation vector     :: "'a \<Rightarrow> bool" where "vector x     \<equiv> x * top = x"
abbreviation covector   :: "'a \<Rightarrow> bool" where "covector x   \<equiv> top * x = x"
abbreviation total      :: "'a \<Rightarrow> bool" where "total x      \<equiv> x * top = top"
abbreviation surjective :: "'a \<Rightarrow> bool" where "surjective x \<equiv> top * x = top"

abbreviation "vectors   \<equiv> { x . vector x }"
abbreviation "covectors \<equiv> { x . covector x }"

end

class bounded_non_associative_left_semiring = non_associative_left_semiring + top +
  assumes sup_right_top [simp]: "x \<squnion> top = top"
begin

subclass times_top .

text \<open>
We first give basic properties of the greatest element.
\<close>

lemma sup_left_top [simp]:
  "top \<squnion> x = top"
  using sup_right_top sup.commute by fastforce

lemma top_greatest [simp]:
  "x \<le> top"
  by (simp add: le_iff_sup)

lemma top_left_mult_increasing:
  "x \<le> top * x"
  by (metis mult_left_isotone mult_left_one top_greatest)

lemma top_right_mult_increasing:
  "x \<le> x * top"
  using mult_right_isotone mult_sub_right_one order_trans top_greatest by blast

lemma top_mult_top [simp]:
  "top * top = top"
  by (simp add: antisym top_left_mult_increasing)

text \<open>
Closure of the above properties under the semiring operations is considered next.
\<close>

lemma vector_bot_closed:
  "vector bot"
  by simp

lemma vector_top_closed:
  "vector top"
  by simp

lemma vector_sup_closed:
  "vector x \<Longrightarrow> vector y \<Longrightarrow> vector (x \<squnion> y)"
  by (simp add: mult_right_dist_sup)

lemma covector_top_closed:
  "covector top"
  by simp

lemma total_one_closed:
  "total 1"
  by simp

lemma total_top_closed:
  "total top"
  by simp

lemma surjective_one_closed:
  "surjective 1"
  by (simp add: antisym mult_sub_right_one)

lemma surjective_top_closed:
  "surjective top"
  by simp

lemma surjective_sup_closed:
  "surjective x \<Longrightarrow> surjective (x \<squnion> y)"
  by (metis le_iff_sup mult_left_sub_dist_sup_left sup_left_top)

lemma reflexive_top_closed:
  "reflexive top"
  by simp

lemma transitive_top_closed:
  "transitive top"
  by simp

lemma dense_top_closed:
  "dense_rel top"
  by simp

lemma idempotent_top_closed:
  "idempotent top"
  by simp

lemma preorder_top_closed:
  "preorder top"
  by simp

end

text \<open>
Some closure properties require at least half of associativity.
\<close>

class bounded_pre_left_semiring = pre_left_semiring + bounded_non_associative_left_semiring
begin

lemma vector_mult_closed:
  "vector y \<Longrightarrow> vector (x * y)"
  by (metis antisym mult_semi_associative top_right_mult_increasing)

lemma surjective_mult_closed:
  "surjective x \<Longrightarrow> surjective y \<Longrightarrow> surjective (x * y)"
  by (metis antisym mult_semi_associative top_greatest)

end

text \<open>
We next consider residuals with the greatest element.
\<close>

class bounded_residuated_pre_left_semiring = residuated_pre_left_semiring + bounded_pre_left_semiring
begin

lemma lres_top_decreasing:
  "x / top \<le> x"
  using lres_inverse order.trans top_right_mult_increasing by blast

lemma top_lres_absorb [simp]:
  "top / x = top"
  using antisym lres_galois top_greatest by blast

lemma covector_lres_closed:
  "covector x \<Longrightarrow> covector (x / y)"
  by (metis antisym mult_lres_sub_assoc top_left_mult_increasing)

end

text \<open>
Some closure properties require full associativity.
\<close>

class bounded_idempotent_left_semiring = bounded_pre_left_semiring + idempotent_left_semiring
begin

lemma covector_mult_closed:
  "covector x \<Longrightarrow> covector (x * y)"
  by (metis mult_assoc)

lemma total_mult_closed:
  "total x \<Longrightarrow> total y \<Longrightarrow> total (x * y)"
  by (simp add: mult_assoc)

end

text \<open>
Some closure properties require distributivity from the left.
\<close>

class bounded_idempotent_left_zero_semiring = bounded_idempotent_left_semiring + idempotent_left_zero_semiring
begin

lemma covector_sup_closed:
  "covector x \<Longrightarrow> covector y \<Longrightarrow> covector (x \<squnion> y)"
  by (simp add: mult_left_dist_sup)

end

text \<open>
Our final structure is an idempotent semiring with a greatest element.
\<close>

class bounded_idempotent_semiring = bounded_idempotent_left_zero_semiring + idempotent_semiring
begin

lemma covector_bot_closed:
  "covector bot"
  by simp

end

end


(*  Title:      IPv4.thy
    Authors:    Cornelius Diekmann, Julius Michaelis
*)
theory IPv4
imports IP_Address
        NumberWang_IPv4
        (* include "HOL-Library.Code_Target_Nat" if you need to work with actual numbers.*)
begin

section \<open>IPv4 Adresses\<close>
  text\<open>An IPv4 address is basically a 32 bit unsigned integer.\<close>
  type_synonym ipv4addr = "32 word"

  text\<open>Conversion between natural numbers and IPv4 adresses\<close>
  definition nat_of_ipv4addr :: "ipv4addr \<Rightarrow> nat" where
    "nat_of_ipv4addr a = unat a"
  definition ipv4addr_of_nat :: "nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_nat n =  of_nat n"

  text\<open>The maximum IPv4 addres\<close>
  definition max_ipv4_addr :: "ipv4addr" where
    "max_ipv4_addr \<equiv> ipv4addr_of_nat ((2^32) - 1)"

  lemma max_ipv4_addr_number: "max_ipv4_addr = 4294967295"
    unfolding max_ipv4_addr_def ipv4addr_of_nat_def by(simp)
  lemma "max_ipv4_addr = 0b11111111111111111111111111111111"
    by(fact max_ipv4_addr_number)
  lemma max_ipv4_addr_max_word: "max_ipv4_addr = max_word"
    by(simp add: max_ipv4_addr_number max_word_def)
  lemma max_ipv4_addr_max[simp]: "\<forall>a. a \<le> max_ipv4_addr"
    by(simp add: max_ipv4_addr_max_word)
  lemma UNIV_ipv4addrset: "UNIV = {0 .. max_ipv4_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ipv4_addr_max_word) fastforce

  text\<open>identity functions\<close>
  lemma nat_of_ipv4addr_ipv4addr_of_nat:
    "\<lbrakk> n \<le> nat_of_ipv4addr max_ipv4_addr \<rbrakk> \<Longrightarrow> nat_of_ipv4addr (ipv4addr_of_nat n) = n"
    by (simp add: ipv4addr_of_nat_def le_unat_uoi nat_of_ipv4addr_def)
  lemma nat_of_ipv4addr_ipv4addr_of_nat_mod: "nat_of_ipv4addr (ipv4addr_of_nat n) = n mod 2^32"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def unat_of_nat)
  lemma ipv4addr_of_nat_nat_of_ipv4addr: "ipv4addr_of_nat (nat_of_ipv4addr addr) = addr"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)

subsection\<open>Representing IPv4 Adresses (Syntax)\<close>
  fun ipv4addr_of_dotdecimal :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a )"

  fun dotdecimal_of_ipv4addr :: "ipv4addr \<Rightarrow> nat \<times> nat \<times> nat \<times> nat" where
    "dotdecimal_of_ipv4addr a = (nat_of_ipv4addr ((a >> 24) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 16) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 8) AND 0xFF),
                                    nat_of_ipv4addr (a AND 0xff))"

  declare ipv4addr_of_dotdecimal.simps[simp del]
  declare dotdecimal_of_ipv4addr.simps[simp del]

  text\<open>Examples:\<close>
  lemma "ipv4addr_of_dotdecimal (192, 168, 0, 1) = 3232235521"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
    (*could be solved by eval, but needs "HOL-Library.Code_Target_Nat"*)
  lemma "dotdecimal_of_ipv4addr 3232235521 = (192, 168, 0, 1)"
    by(simp add: dotdecimal_of_ipv4addr.simps nat_of_ipv4addr_def)

  text\<open>a different notation for @{term ipv4addr_of_dotdecimal}\<close>
  lemma ipv4addr_of_dotdecimal_bit:
    "ipv4addr_of_dotdecimal (a,b,c,d) =
      (ipv4addr_of_nat a << 24) + (ipv4addr_of_nat b << 16) +
       (ipv4addr_of_nat c << 8) + ipv4addr_of_nat d"
  proof -
    have a: "(ipv4addr_of_nat a) << 24 = ipv4addr_of_nat (a * 16777216)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have b: "(ipv4addr_of_nat b) << 16 = ipv4addr_of_nat (b * 65536)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have c: "(ipv4addr_of_nat c) << 8 = ipv4addr_of_nat (c * 256)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have ipv4addr_of_nat_suc: "\<And>x. ipv4addr_of_nat (Suc x) = word_succ (ipv4addr_of_nat (x))"
      by(simp add: ipv4addr_of_nat_def, metis Abs_fnat_hom_Suc of_nat_Suc)
    { fix x y
      have "ipv4addr_of_nat x + ipv4addr_of_nat y = ipv4addr_of_nat (x+y)"
        apply(induction x arbitrary: y)
         apply(simp add: ipv4addr_of_nat_def; fail)
        by(simp add: ipv4addr_of_nat_suc word_succ_p1)
    } from this a b c
    show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps)
      apply(rule arg_cong[where f=ipv4addr_of_nat])
      apply(thin_tac _)+
      by presburger
  qed

  lemma size_ipv4addr: "size (x::ipv4addr) = 32" by(simp add:word_size)

  lemma dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal:
  "\<lbrakk> a < 256; b < 256; c < 256; d < 256 \<rbrakk> \<Longrightarrow>
    dotdecimal_of_ipv4addr (ipv4addr_of_dotdecimal (a,b,c,d)) = (a,b,c,d)"
  proof -
    assume  "a < 256" and "b < 256" and "c < 256" and "d < 256"
    note assms= \<open>a < 256\<close> \<open>b < 256\<close> \<open>c < 256\<close> \<open>d < 256\<close>
    hence a:  "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 24) AND mask 8) = a"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      done
    have ipv4addr_of_nat_AND_mask8: "(ipv4addr_of_nat a) AND mask 8 = (ipv4addr_of_nat (a mod 256))"
      for a
      apply(simp add: ipv4addr_of_nat_def and_mask_mod_2p)
      apply(simp add: word_of_nat) (*use this to get rid of of_nat. All thm are with word_of_int*)
      apply(simp add: uint_word_of_int)
      apply(subst mod_mod_cancel)
       apply(simp; fail)
      apply(simp add: zmod_int)
      done
    from assms have b:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 16) AND mask 8) = b"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      apply(simp add: NumberWang_IPv4.div65536[simplified])
      (*The [simplified] is needed because Word_Lib adds some additional simp rules*)
      done
      \<comment> \<open>When @{file \<open>../Word_Lib/Word_Lemmas.thy\<close>} is imported,
         some @{file \<open>NumberWang_IPv4.thy\<close>} lemmas need the
         [simplified] attribute because @{text Word_Lib} adds some simp rules.
         This theory should also work without @{file \<open>../Word_Lib/Word_Lemmas.thy\<close>}\<close>
    from assms have c:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 8) AND mask 8) = c"
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def unat_def)
      apply(simp add: and_mask_mod_2p)
      apply(simp add: shiftr_div_2n)
      apply(simp add: uint_word_of_int)
      apply(simp add: NumberWang_IPv4.div256[simplified])
      done
    from \<open>d < 256\<close> have d: "nat_of_ipv4addr (ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) AND mask 8) = d"
      apply(simp add: ipv4addr_of_nat_AND_mask8)
      apply(simp add: ipv4addr_of_nat_def word_of_nat)
      apply(simp add: nat_of_ipv4addr_def)
      apply(subgoal_tac "(d + 256 * c + 65536 * b + 16777216 * a) mod 256 = d")
       apply(simp add: unat_def uint_word_of_int; fail)
      apply(simp add: NumberWang_IPv4.mod256)
      done
    from a b c d show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps dotdecimal_of_ipv4addr.simps)
      apply(simp add: mask_def)
      done
  qed

  lemma ipv4addr_of_dotdecimal_dotdecimal_of_ipv4addr:
    "(ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip)) = ip"
  proof -
    have ip_and_mask8_bl_drop24: "(ip::ipv4addr) AND mask 8 = of_bl (drop 24 (to_bl ip))"
      by(simp add: Word_Lemmas.of_drop_to_bl size_ipv4addr)
    have List_rev_drop_geqn: "length x \<ge> n \<Longrightarrow> (take n (rev x)) = rev (drop (length x - n) x)"
      for x :: "'a list" and n by(simp add: List.rev_drop)
    have and_mask_bl_take: "length x \<ge> n \<Longrightarrow> ((of_bl x) AND mask n) = (of_bl (rev (take n (rev (x)))))"
      for x n by(simp add: List_rev_drop_geqn of_bl_drop)
    have ipv4addr_and_255: "x AND 255 = x AND mask 8" for x :: ipv4addr
      by(simp add: mask_def)
    have bit_equality:
      "((ip >> 24) AND 0xFF << 24) + ((ip >> 16) AND 0xFF << 16) + ((ip >> 8) AND 0xFF << 8) + (ip AND 0xFF) =
       of_bl (take 8 (to_bl ip) @ take 8 (drop 8 (to_bl ip)) @ take 8 (drop 16 (to_bl ip)) @ drop 24 (to_bl ip))"
      apply(simp add: ipv4addr_and_255)
      apply(simp add: shiftr_slice)
      apply(simp add: Word.slice_take' size_ipv4addr)
      apply(simp add: and_mask_bl_take)
      apply(simp add: List_rev_drop_geqn)
      apply(simp add: drop_take)
      apply(simp add: Word.shiftl_of_bl)
      apply(simp add: of_bl_append)
      apply(simp add: ip_and_mask8_bl_drop24)
      done
    have blip_split: "\<And> blip. length blip = 32 \<Longrightarrow>
      blip = (take 8 blip) @ (take 8 (drop 8 blip)) @ (take 8 (drop 16 blip)) @ (take 8 (drop 24 blip))"
      by(rename_tac blip,case_tac blip,simp_all)+ (*I'm so sorry for this ...*)
    have "ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip) = of_bl (to_bl ip)"
      apply(subst blip_split)
       apply(simp; fail)
      apply(simp add: ipv4addr_of_dotdecimal_bit dotdecimal_of_ipv4addr.simps)
      apply(simp add: ipv4addr_of_nat_nat_of_ipv4addr)
      apply(simp add: bit_equality)
      done
    thus ?thesis using Word.word_bl.Rep_inverse[symmetric] by simp
  qed

  lemma ipv4addr_of_dotdecimal_eqE:
    "\<lbrakk> ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_dotdecimal (e,f,g,h);
       a < 256; b < 256; c < 256; d < 256; e < 256; f < 256; g < 256; h < 256 \<rbrakk> \<Longrightarrow>
         a = e \<and> b = f \<and> c = g \<and> d = h"
     by (metis Pair_inject dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal)

subsection\<open>IP Ranges: Examples\<close>
  lemma "(UNIV :: ipv4addr set) = {0 .. max_ipv4_addr}" by(simp add: UNIV_ipv4addrset)
  lemma "(42::ipv4addr) \<in> UNIV" by(simp)

  (*Warning, not executable!*)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (255,255,0,0)) =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_netmask_def ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (0,0,0,0)) = UNIV"
    by(simp add: UNIV_ipv4addrset ipset_from_netmask_def ipv4addr_of_dotdecimal.simps
                 ipv4addr_of_nat_def max_ipv4_addr_max_word)

  text\<open>192.168.0.0/24\<close>

  lemma fixes addr :: ipv4addr
    shows "ipset_from_cidr addr pflength =
            ipset_from_netmask addr ((mask pflength) << (32 - pflength))"
    by(simp add: ipset_from_cidr_def)

  lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,42)) 16 =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_cidr_alt mask_def  ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ip \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 0)"
    by(simp add: ipset_from_cidr_0)

  lemma ipv4set_from_cidr_32: fixes addr :: ipv4addr
    shows "ipset_from_cidr addr 32 = {addr}"
    by(simp add: ipset_from_cidr_alt mask_def)

  lemma  fixes pre :: ipv4addr
    shows "ipset_from_cidr pre len = {(pre AND ((mask len) << (32 - len))) .. pre OR (mask (32 - len))}"
    by (simp add: ipset_from_cidr_alt ipset_from_cidr_def)

  text\<open>making element check executable\<close>
  lemma addr_in_ipv4set_from_netmask_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
            (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by (simp add: addr_in_ipset_from_netmask_code)
  lemma addr_in_ipv4set_from_cidr_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
              (pre AND ((mask len) << (32 - len))) \<le> addr \<and> addr \<le> pre OR (mask (32 - len))"
    by(simp add: addr_in_ipset_from_cidr_code)

  (*small numbers because we didn't load Code_Target_Nat. Should work by eval*)
  lemma "ipv4addr_of_dotdecimal (192,168,42,8) \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,0)) 16)"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_def
                    ipset_from_netmask_def mask_def)

  definition ipv4range_UNIV :: "32 wordinterval" where "ipv4range_UNIV \<equiv> wordinterval_UNIV"

  lemma ipv4range_UNIV_set_eq: "wordinterval_to_set ipv4range_UNIV = UNIV"
    by(simp only: ipv4range_UNIV_def wordinterval_UNIV_set_eq)

  thm iffD1[OF wordinterval_eq_set_eq]
  (*TODO: probably the following is a good idea?*)
  (*
  declare iffD1[OF wordinterval_eq_set_eq, cong]
  *)

  text\<open>This \<open>LENGTH('a)\<close> is 32 for IPv4 addresses.\<close>
  lemma ipv4cidr_to_interval_simps[code_unfold]: "ipcidr_to_interval ((pre::ipv4addr), len) = (
      let netmask = (mask len) << (32 - len);
          network_prefix = (pre AND netmask)
      in (network_prefix, network_prefix OR (NOT netmask)))"
  by(simp add: ipcidr_to_interval_def Let_def ipcidr_to_interval_start.simps ipcidr_to_interval_end.simps)

end


theory Overtaking_Aux
  imports Analysis "Affine_Arithmetic/Polygon"
begin

type_synonym real2 = "real \<times> real"

definition min2D :: "real2 \<Rightarrow> real2 \<Rightarrow> real2" where
  "min2D z1 z2 = (let x1 = fst z1; x2 = fst z2; y1 = snd z1; y2 = snd z2 in
                    if x1 < x2 then z1 else
                    if x1 = x2 then (if y1 \<le> y2 then z1 else z2) else
                    (* x1 > x2 *)   z2)"

theorem min2D_D:
  assumes "min2D x y = z"
  shows "fst z \<le> fst x \<and> fst z \<le> fst y"
  using assms unfolding min2D_def by smt

theorem min2D_D2:
  assumes "min2D x y = z"
  shows "z = x \<or> z = y"
  using assms unfolding min2D_def by presburger

theorem min2D_D3:
  assumes "min2D x y = x"
  shows "fst x < fst y \<or> (fst x = fst y \<and> snd x \<le> snd y)"
  using assms unfolding min2D_def by smt

theorem min2D_D4:
  assumes "min2D x y = y"
  shows "fst y < fst x \<or> (fst x = fst y \<and> snd y \<le> snd x)"
  using assms unfolding min2D_def by smt

section "Rectangle"

record rectangle =
  Xcoord :: real
  Ycoord :: real
  Orient :: real
  Length :: real
  Width  :: real

definition rotation_matrix' :: "real \<Rightarrow> real2 \<Rightarrow> real2" where
  "rotation_matrix' theta \<equiv>  (\<lambda>p :: real2. (cos theta * fst p - sin theta * snd p,
                                             sin theta * fst p + cos theta * snd p))"
(*
definition rotate_rect :: "rectangle \<Rightarrow> real2 \<Rightarrow> real2" where
  "rotate_rect rect \<equiv> (let centre = (Xcoord rect, Ycoord rect); ori = Orient rect in
                              (\<lambda>p. p + centre) \<circ> (rotation_matrix' ori) \<circ> (\<lambda>p. p - centre))"   *)

definition rotate_rect :: "rectangle \<Rightarrow> real2 \<Rightarrow> real2" where
  "rotate_rect rect \<equiv> (let centre = (Xcoord rect, Ycoord rect); ori = Orient rect in
                                                                            (rotation_matrix' ori))"

(* the vertices are sorted in counter-clockwise manner *)
definition get_vertices :: "rectangle \<Rightarrow> real2 list" where
  "get_vertices rect \<equiv> (let x = Xcoord rect; y = Ycoord rect; l = Length rect; w = Width rect in
                          [(x - l / 2, y + w / 2),
                           (x - l / 2, y - w / 2),
                           (x + l / 2, y - w / 2),
                           (x + l / 2, y + w / 2)])"

definition get_vertices_zero :: "rectangle \<Rightarrow> real2 list" where
  "get_vertices_zero rect \<equiv> (let l = Length rect; w = Width rect in
                          [(- l / 2,   w / 2),
                           (- l / 2, - w / 2),
                           (  l / 2, - w / 2),
                           (  l / 2,   w / 2)])"

theorem
  assumes "vertices = get_vertices rect"
  assumes "0 < Length rect" and "0 < Width rect"
  shows "ccw' (vertices ! 0) (vertices ! 1) (vertices ! 2)"
proof -
  define x where "x \<equiv> Xcoord rect"
  define y where "y \<equiv> Ycoord rect"
  define l where "l \<equiv> Length rect"
  define w where "w \<equiv> Width rect"
  note params = x_def y_def l_def w_def
  from assms(2-3) have "0 < l" and "0 < w" unfolding params by auto
  from assms have 0: "vertices ! 0 = (x - l / 2, y + w / 2)" and 1: "vertices ! 1 = (x - l/2, y - w/2)"
      and 2: "vertices ! 2 = (x + l /2, y - w / 2)"
    unfolding get_vertices_def Let_def params by auto
  have "ccw' (vertices ! 0) (vertices ! 1) (vertices ! 2) =
        ccw' 0 (vertices ! 1 - vertices ! 0) (vertices ! 2 - vertices ! 0)"
    unfolding ccw'_def using det3_translate_origin by auto
  also have "... = ccw' 0 (0, -w) (l, -w)" unfolding 0 1 2 by auto
  finally have *: "ccw' (vertices ! 0) (vertices ! 1) (vertices ! 2) = ccw' 0 (0,-w) (l,-w)" by auto
  have "det3 0 (0,-w) (l,-w) =  w * l" unfolding det3_def'  by (auto simp add:algebra_simps)
  with `0 < w` `0 < l` have "0 < det3 0 (0,-w) (l,-w)" by auto
  hence "ccw' 0 (0,-w) (l,-w)" unfolding ccw'_def by auto
  with * show ?thesis by auto
qed

theorem nbr_of_vertex:
  "length (get_vertices rect) = 4"
  unfolding get_vertices_def Let_def by auto

theorem nbr_of_vertex_zero:
  "length (get_vertices_zero rect) = 4"
  unfolding get_vertices_zero_def Let_def by auto

definition get_vertices_rotated :: "rectangle \<Rightarrow> real2 list" where
  "get_vertices_rotated rect \<equiv> map (rotation_matrix' (Orient rect)) (get_vertices_zero rect)"

theorem nbr_of_vertex_rotated:
  "length (get_vertices_rotated rect) = 4"
  unfolding get_vertices_rotated_def using length_map nbr_of_vertex_zero by auto

definition get_vertices_rotated_translated :: "rectangle \<Rightarrow> real2 list" where
  "get_vertices_rotated_translated rect \<equiv>
                               map (\<lambda>p. p + (Xcoord rect, Ycoord rect)) (get_vertices_rotated rect)"

theorem nbr_of_vertex_rotated_translated:
  "length (get_vertices_rotated_translated rect) = 4"
  unfolding get_vertices_rotated_translated_def using length_map nbr_of_vertex_rotated by auto

definition get_lines :: "rectangle \<Rightarrow> (real2 \<times> real2) list" where
  "get_lines rect \<equiv> (let vertices = get_vertices_rotated_translated rect;
                         zero = vertices ! 0; one = vertices ! 1;
                         two = vertices ! 2; three = vertices ! 3
                      in
                        [(zero, one), (one, two), (two, three), (three, zero)])"

theorem nbr_of_lines:
  "length (get_lines rect) = 4"
  unfolding get_lines_def unfolding Let_def by auto

(* Definition of point inside a rectangle *)
definition inside_rectangle :: "real2 \<Rightarrow> rectangle \<Rightarrow> bool" where
  "inside_rectangle p rect \<equiv> (let lines = get_lines rect;
                                line0 = lines ! 0; line1 = lines ! 1; line2 = lines ! 2; line3 = lines ! 3
                              in
                                ccw' p (fst line0) (snd line0) \<and> ccw' p (fst line1) (snd line1) \<and>
                                ccw' p (fst line2) (snd line2) \<and> ccw' p (fst line3) (snd line3))"

theorem centre_point_inside:
  assumes "0 < Length rect" and "0 < Width rect"
  shows "inside_rectangle (Xcoord rect, Ycoord rect) rect"
proof -
  define x where "x \<equiv> Xcoord rect"
  define y where "y \<equiv> Ycoord rect"
  define l where "l \<equiv> Length rect"
  define w where "w \<equiv> Width rect"
  note params = x_def y_def l_def w_def
  from assms have "0 < l" and "0 < w" unfolding params by auto

  define zero where "zero \<equiv> get_vertices_rotated_translated rect ! 0"
  define one where "one \<equiv> get_vertices_rotated_translated rect ! 1"
  define two where "two \<equiv> get_vertices_rotated_translated rect ! 2"
  define three where "three \<equiv> get_vertices_rotated_translated rect ! 3"
  note vertices_def = zero_def one_def two_def three_def
  have "zero = rotation_matrix' (Orient rect) (- l / 2, w / 2) + (x,y)" and
       "one = rotation_matrix' (Orient rect) (- l / 2, - w / 2) + (x,y)" and
       "two = rotation_matrix' (Orient rect) (l / 2, - w / 2) + (x,y)" and
       "three = rotation_matrix' (Orient rect) (l / 2, w / 2) + (x,y)"
    unfolding vertices_def get_vertices_rotated_translated_def get_vertices_rotated_def
      get_vertices_zero_def Let_def params by auto
  define line0 where "line0 \<equiv> get_lines rect ! 0"
  define line1 where "line1 \<equiv> get_lines rect ! 1"
  define line2 where "line2 \<equiv> get_lines rect ! 2"
  define line3 where "line3 \<equiv> get_lines rect ! 3"
  note lines_def = line0_def line1_def line2_def line3_def
  have "line0 = (zero,one)" "line1 = (one,two)" "line2 = (two, three)" "line3 = (three, zero)"
    unfolding lines_def get_lines_def Let_def vertices_def by auto

  have "ccw' (x,y) (fst line0) (snd line0)" sorry
  moreover
  have "ccw' (x,y) (fst line1) (snd line1)" sorry
  moreover
  have "ccw' (x,y) (fst line2) (snd line2)" sorry
  moreover
  have "ccw' (x,y) (fst line3) (snd line3)" sorry
  ultimately show ?thesis unfolding inside_rectangle_def Let_def params lines_def by auto
qed

end


theory PPL_Summer_School_2017
  imports Main
begin

(* Pure *)

lemma name: "\<And>P. P \<Longrightarrow> P"
proof-
  fix P
  assume 1: "P"
  show "P" by (rule 1)
qed

lemma name2:
  fixes P shows "P \<Longrightarrow> P"
proof-
  assume 1: "P"
  show "P" by (rule 1)
qed

lemma name3:
  fixes P assumes 1: "P" shows "P"
  by (rule 1)

lemma mp_Pure:
  "\<And> P Q. P \<Longrightarrow> (P \<Longrightarrow> Q) \<Longrightarrow> Q"
proof-
  fix P Q
  assume 1: "P"
  assume 2: "P \<Longrightarrow> Q"
  show "Q"
    (* by (rule 2, rule 1) *)
  proof (rule 2)
    show "P" by (rule 1)
  qed
qed

lemma mp_Pure_short:
  fixes P Q
  assumes 1: "P"
  assumes 2: "P \<Longrightarrow> Q" shows "Q" by (rule 2, rule 1)

(* HOL *)

term "True"
term "False"
term "~ x"
term "x \<longrightarrow> y"
term "x \<and> y"
term "\<forall>x :: nat. P x \<or> ~ P x"

lemma True_HOL: "True" by (rule HOL.TrueI)

lemma "~ False"
  find_theorems "(_ \<Longrightarrow> False) \<Longrightarrow> ~ _"
(* by (rule HOL.notI) *)
proof (rule notI)
  assume 1: "False"
  show "False" by (rule 1)
qed

lemma "\<forall>p. p \<longrightarrow> p"
  find_theorems "(\<And>_. _) \<Longrightarrow> \<forall>_. _"
proof (rule allI) (* by (intro allI impI) *)
  fix p
  show "p \<longrightarrow> p"
  by (rule impI)
qed

lemma "\<forall>p q. p \<longrightarrow> (p \<longrightarrow> q) \<longrightarrow> q"
proof (intro allI impI)
  find_theorems "PROP _ \<Longrightarrow> (_ \<longrightarrow> _)"
  fix p q
  assume 1: "p"
  assume 2: "p \<longrightarrow> q"
    have 3: "p \<Longrightarrow> q" using 2 by (elim impE)
    show "q" by (rule 3, rule 1)
qed

term my_True

definition my_True where "my_True = True"

term my_True

lemma "my_True = True"
  by (rule my_True_def)

lemma "my_True"
  unfolding my_True_def by (rule TrueI)

definition my_id where "my_id x = x"

lemma "my_id x = x" by (rule my_id_def)

lemma "my_id (my_id x) = x"
  unfolding my_id_def by (rule refl)

lemma "my_id (my_id x) = x" by (simp add: my_id_def)

declare my_id_def[simp]

definition my_id2 where "my_id2 = (\<lambda>x. x)"

declare my_id2_def[simp]

(* lemma "my_id = my_id2"
  unfolding my_id_def my_id2_def by (rule refl) *)

lemma "my_id = my_id2"
  by auto

(* List *)

term "[]"
term "x#xs"

value "[1::int, 2, 3, 4] ! 6"

definition my_sorted (* :: "int list \<Rightarrow> bool" *)
  where "my_sorted xs = (
    \<forall> i j. i < j \<longrightarrow>  j < length xs
    \<longrightarrow> ~ (xs!i > xs!j))"

lemma my_sortedI [intro]:
  (* fixes xs *)
  assumes 1: "\<And> i j. i < j \<Longrightarrow> j < length xs \<Longrightarrow>
     ~ (xs!i > xs!j)"
  shows "my_sorted xs"
  unfolding my_sorted_def
  using 1 by auto

lemma my_sortedD [dest]:
  fixes xs
  assumes 1: "my_sorted xs"
  shows "\<And>i j. i < j \<Longrightarrow> j < length xs \<Longrightarrow>
        ~ (xs!i > xs!j)"
  using 1 unfolding my_sorted_def by auto

lemma my_sortedE [elim]:
  fixes xs
  assumes 1: "my_sorted xs"
  assumes 2: "(\<And>i j. i < j \<Longrightarrow> j < length xs \<Longrightarrow>
              ~ (xs!i > xs!j)) \<Longrightarrow> P"
  shows "P"
  using 1 2 unfolding my_sorted_def by auto

fun my_insert (* :: "int \<Rightarrow> int list \<Rightarrow> int list" *)
  where "my_insert x [] = [x]"
  |     "my_insert x (y#ys) =
        (if x \<le> y then x # y # ys
         else y # my_insert x ys)"

fun my_sort (* :: "int list \<Rightarrow> int list" *)
  where "my_sort [] = []"
  |     "my_sort (x#xs) = my_insert x (my_sort xs)"

value "my_sort [1::int,5,3,8]"

value "my_sort [1,5,8,3::int]"

value "my_sort [3,7,5,1,9]"

term "set xs"

lemma my_sorted_Cons' [simp]:
  assumes 1: "my_sorted xs"
  assumes 2: "\<And>y. y \<in> set xs \<Longrightarrow> ~ (x > y)"
  shows "my_sorted (x#xs)"
proof (rule my_sortedI)
  fix i j :: "nat"
  assume 3: "i < j"
  assume 4: "j < length (x#xs)"
  show "~ ((x # xs) ! i > (x # xs) ! j)"

  proof (cases i)
    case 0
    then show ?thesis using 1 2 3 4 by auto
  next
    case (Suc nat)
    then show ?thesis using 1 2 3 4 by auto
  qed
qed

lemma my_sorted_Cons [simp]:
  "my_sorted (x#xs) \<longleftrightarrow>
   my_sorted xs \<and> (\<forall>y \<in> set xs. ~ (x > y))"
proof (intro iffI)
  assume 1: "my_sorted xs \<and> (\<forall>y \<in> set xs. ~ (x > y))"
  show "my_sorted (x#xs)"
    using 1 by (intro my_sorted_Cons', auto)
next
  assume 1: "my_sorted (x#xs)"
  show "my_sorted xs \<and> (\<forall>y \<in> set xs. ~ (x > y))"
  proof (intro conjI)
    show "my_sorted xs" (* using 1 by blast *)
      apply (intro my_sortedI)
      using "1" sorted_nth_monoI by auto
  next
    show "\<forall>y \<in> set xs. ~ (x > y)"
    proof (intro ballI)
      fix y
      assume 2: "y \<in> set xs"
      obtain i where 3: "xs ! i = y" and 4: "i < length xs"
        by (meson "2" in_set_conv_nth)

      show "~ (x > y)"
        using 1 2 3 4 by auto
    qed
  qed
qed

lemma set_my_insert [simp]:
  "set (my_insert x xs) = set xs \<union> {x}"
by (induct xs, auto)

lemma my_sorted_my_insert [intro]:
  fixes xs :: "('a ::preorder) list"
  assumes 1: "my_sorted xs"
  shows "my_sorted (my_insert x xs)"
  using 1
  apply (induct xs, auto)
  apply (simp add: less_le_not_le)
  apply (meson less_le_trans)
  by (simp add: less_imp_le)

theorem my_sorted_my_sort:
  fixes xs :: "('a :: preorder) list"
  shows "my_sorted (my_sort xs)"
by (induct xs, auto)

corollary
  fixes xs :: "int list"
  shows "my_sorted (my_sort xs)"
  by (rule my_sorted_my_sort)

export_code my_sort in OCaml
export_code my_sort in Haskell

definition my_sort_integer ::
  "integer list \<Rightarrow> integer list"
  where "my_sort_integer = my_sort"

export_code my_sort_integer in OCaml
export_code my_sort_integer in Haskell

instantiation char :: ord
begin
definition less_eq_char where
  "less_eq_char a b = (nat_of_char a \<le> nat_of_char b)"
definition less_char where
  "less_char a b = (nat_of_char a < nat_of_char b)"
instance by (intro_classes)
end

declare less_eq_char_def [simp]
declare less_char_def [simp]

value "my_sort [CHR ''r'', CHR ''a'', CHR ''b'']

instance char :: lineorder
by (intro_classes, auto)

corollary
fixes xs :: "char list"
shows "my_sorted (my_sort xs)"
by (rule my_sorted_my_sort)

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Constructing Minimal Bad Sequences\<close>

theory Minimal_Bad_Sequences
imports
  Almost_Full
  Minimal_Elements
begin

text \<open>
  A locale capturing the construction of minimal bad sequences over values from @{term "A"}. Where
  minimality is to be understood w.r.t.\ @{term size} of an element.
\<close>
locale mbs =
  fixes A :: "('a :: size) set"
begin

text \<open>
  Since the @{term size} is a well-founded measure, whenever some element satisfies a property
  @{term P}, then there is a size-minimal such element.
\<close>
lemma minimal:
  assumes "x \<in> A" and "P x"
  shows "\<exists>y \<in> A. size y \<le> size x \<and> P y \<and> (\<forall>z \<in> A. size z < size y \<longrightarrow> \<not> P z)"
using assms
proof (induction x taking: size rule: measure_induct)
  case (1 x)
  then show ?case
  proof (cases "\<forall>y \<in> A. size y < size x \<longrightarrow> \<not> P y")
    case True
    with 1 show ?thesis by blast
  next
    case False
    then obtain y where "y \<in> A" and "size y < size x" and "P y" by blast
    with "1.IH" show ?thesis by (fastforce elim!: order_trans)
  qed
qed

lemma less_not_eq [simp]:
  "x \<in> A \<Longrightarrow> size x < size y \<Longrightarrow> x = y \<Longrightarrow> False"
  by simp

text \<open>
  The set of all bad sequences over @{term A}.
\<close>
definition "BAD P = {f \<in> SEQ A. bad P f}"

lemma BAD_iff [iff]:
  "f \<in> BAD P \<longleftrightarrow> (\<forall>i. f i \<in> A) \<and> bad P f"
  by (auto simp: BAD_def)

text \<open>
  A partial order on infinite bad sequences.
\<close>
definition geseq :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set"
where
  "geseq =
    {(f, g). f \<in> SEQ A \<and> g \<in> SEQ A \<and> (f = g \<or> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j)))}"

text \<open>
  The strict part of the above order.
\<close>
definition gseq :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set" where
  "gseq = {(f, g). f \<in> SEQ A \<and> g \<in> SEQ A \<and> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j))}"

lemma geseq_iff:
  "(f, g) \<in> geseq \<longleftrightarrow>
    f \<in> SEQ A \<and> g \<in> SEQ A \<and> (f = g \<or> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j)))"
  by (auto simp: geseq_def)

lemma gseq_iff:
  "(f, g) \<in> gseq \<longleftrightarrow> f \<in> SEQ A \<and> g \<in> SEQ A \<and> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j))"
  by (auto simp: gseq_def)

lemma geseqE:
  assumes "(f, g) \<in> geseq"
    and "\<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; f = g\<rbrakk> \<Longrightarrow> Q"
    and "\<And>i. \<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; size (g i) < size (f i); \<forall>j < i. f j = g j\<rbrakk> \<Longrightarrow> Q"
  shows "Q"
  using assms by (auto simp: geseq_iff)

lemma gseqE:
  assumes "(f, g) \<in> gseq"
    and "\<And>i. \<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; size (g i) < size (f i); \<forall>j < i. f j = g j\<rbrakk> \<Longrightarrow> Q"
  shows "Q"
  using assms by (auto simp: gseq_iff)

sublocale min_elt_size?: minimal_element "measure_on size UNIV" A
rewrites "measure_on size UNIV \<equiv> \<lambda>x y. size x < size y"
apply (unfold_locales)
apply (auto simp: po_on_def irreflp_on_def transp_on_def simp del: wfp_on_UNIV intro: wfp_on_subset)
apply (auto simp: measure_on_def inv_image_betw_def)
done

context
  fixes P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

text \<open>
  A lower bound to all sequences in a set of sequences @{term B}.
\<close>
abbreviation "lb \<equiv> lexmin (BAD P)"

lemma eq_upto_BAD_mem:
  assumes "f \<in> eq_upto (BAD P) g i"
  shows "f j \<in> A"
  using assms by (auto)

text \<open>
  Assume that there is some infinite bad sequence @{term h}.
\<close>
context
  fixes h :: "nat \<Rightarrow> 'a"
  assumes BAD_ex: "h \<in> BAD P"
begin

text \<open>
  When there is a bad sequence, then filtering @{term "BAD P"} w.r.t.~positions in @{term lb} never
  yields an empty set of sequences.
\<close>
lemma eq_upto_BAD_non_empty:
  "eq_upto (BAD P) lb i \<noteq> {}"
using eq_upto_lexmin_non_empty [of "BAD P"] and BAD_ex by auto

lemma non_empty_ith:
  shows "ith (eq_upto (BAD P) lb i) i \<subseteq> A"
  and "ith (eq_upto (BAD P) lb i) i \<noteq> {}"
  using eq_upto_BAD_non_empty [of i] by auto

lemmas
  lb_minimal = min_elt_minimal [OF non_empty_ith, folded lexmin] and
  lb_mem = min_elt_mem [OF non_empty_ith, folded lexmin]

text \<open>
  @{term "lb"} is a infinite bad sequence.
\<close>
lemma lb_BAD:
  "lb \<in> BAD P"
proof -
  have *: "\<And>j. lb j \<in> ith (eq_upto (BAD P) lb j) j" by (rule lb_mem)
  then have "\<forall>i. lb i \<in> A" by (auto simp: ith_conv) (metis eq_upto_BAD_mem)
  moreover
  { assume "good P lb"
    then obtain i j where "i < j" and "P (lb i) (lb j)" by (auto simp: good_def)
    from * have "lb j \<in> ith (eq_upto (BAD P) lb j) j" by (auto)
    then obtain g where "g \<in> eq_upto (BAD P) lb j" and "g j = lb j" by force
    then have "\<forall>k \<le> j. g k = lb k" by (auto simp: order_le_less)
    with \<open>i < j\<close> and \<open>P (lb i) (lb j)\<close> have "P (g i) (g j)" by auto
    with \<open>i < j\<close> have "good P g" by (auto simp: good_def)
    with \<open>g \<in> eq_upto (BAD P) lb j\<close> have False by auto }
  ultimately show ?thesis by blast
qed

text \<open>
  There is no infinite bad sequence that is strictly smaller than @{term lb}.
\<close>
lemma lb_lower_bound:
  "\<forall>g. (lb, g) \<in> gseq \<longrightarrow> g \<notin> BAD P"
proof (intro allI impI)
  fix g
  assume "(lb, g) \<in> gseq"
  then obtain i where "g i \<in> A" and "size (g i) < size (lb i)"
    and "\<forall>j < i. lb j = g j" by (auto simp: gseq_iff)
  moreover with lb_minimal
    have "g i \<notin> ith (eq_upto (BAD P) lb i) i" by auto
  ultimately show "g \<notin> BAD P" by blast
qed

text \<open>
  If there is at least one bad sequence, then there is also a minimal one.
\<close>
lemma lower_bound_ex:
  "\<exists>f \<in> BAD P. \<forall>g. (f, g) \<in> gseq \<longrightarrow> g \<notin> BAD P"
  using lb_BAD and lb_lower_bound by blast

lemma gseq_conv:
  "(f, g) \<in> gseq \<longleftrightarrow> f \<noteq> g \<and> (f, g) \<in> geseq"
  by (auto simp: gseq_def geseq_def dest: less_not_eq)

text \<open>There is a minimal bad sequence.\<close>
lemma mbs:
  "\<exists>f \<in> BAD P. \<forall>g. (f, g) \<in> gseq \<longrightarrow> good P g"
  using lower_bound_ex by (auto simp: gseq_conv geseq_iff)

end

end

end

end


(* Author: Tobias Nipkow *)

subsection "Interval Analysis"

theory Abs_Int2_ivl
imports Abs_Int2
begin

type_synonym eint = "int extended"
type_synonym eint2 = "eint * eint"

definition \<gamma>_rep :: "eint2 \<Rightarrow> int set" where
"\<gamma>_rep p = (let (l,h) = p in {i. l \<le> Fin i \<and> Fin i \<le> h})"

definition eq_ivl :: "eint2 \<Rightarrow> eint2 \<Rightarrow> bool" where
"eq_ivl p1 p2 = (\<gamma>_rep p1 = \<gamma>_rep p2)"

lemma refl_eq_ivl[simp]: "eq_ivl p p"
by(auto simp: eq_ivl_def)

quotient_type ivl = eint2 / eq_ivl
by(rule equivpI)(auto simp: reflp_def symp_def transp_def eq_ivl_def)

abbreviation ivl_abbr :: "eint \<Rightarrow> eint \<Rightarrow> ivl" ("[_, _]") where
"[l,h] == abs_ivl(l,h)"

lift_definition \<gamma>_ivl :: "ivl \<Rightarrow> int set" is \<gamma>_rep
by(simp add: eq_ivl_def)

lemma \<gamma>_ivl_nice: "\<gamma>_ivl[l,h] = {i. l \<le> Fin i \<and> Fin i \<le> h}"
by transfer (simp add: \<gamma>_rep_def)

lift_definition num_ivl :: "int \<Rightarrow> ivl" is "\<lambda>i. (Fin i, Fin i)" .

lift_definition in_ivl :: "int \<Rightarrow> ivl \<Rightarrow> bool"
  is "\<lambda>i (l,h). l \<le> Fin i \<and> Fin i \<le> h"
by(auto simp: eq_ivl_def \<gamma>_rep_def)

lemma in_ivl_nice: "in_ivl i [l,h] = (l \<le> Fin i \<and> Fin i \<le> h)"
by transfer simp

definition is_empty_rep :: "eint2 \<Rightarrow> bool" where
"is_empty_rep p = (let (l,h) = p in l>h | l=Pinf & h=Pinf | l=Minf & h=Minf)"

lemma \<gamma>_rep_cases: "\<gamma>_rep p = (case p of (Fin i,Fin j) => {i..j} | (Fin i,Pinf) => {i..} |
  (Minf,Fin i) \<Rightarrow> {..i} | (Minf,Pinf) \<Rightarrow> UNIV | _ \<Rightarrow> {})"
by(auto simp add: \<gamma>_rep_def split: prod.splits extended.splits)

lift_definition  is_empty_ivl :: "ivl \<Rightarrow> bool" is is_empty_rep
apply(auto simp: eq_ivl_def \<gamma>_rep_cases is_empty_rep_def)
apply(auto simp: not_less less_eq_extended_case split: extended.splits)
done

lemma eq_ivl_iff: "eq_ivl p1 p2 = (is_empty_rep p1 & is_empty_rep p2 | p1 = p2)"
by(auto simp: eq_ivl_def is_empty_rep_def \<gamma>_rep_cases Icc_eq_Icc split: prod.splits extended.splits)

definition empty_rep :: eint2 where "empty_rep = (Pinf,Minf)"

lift_definition empty_ivl :: ivl is empty_rep .

lemma is_empty_empty_rep[simp]: "is_empty_rep empty_rep"
by(auto simp add: is_empty_rep_def empty_rep_def)

lemma is_empty_rep_iff: "is_empty_rep p = (\<gamma>_rep p = {})"
by(auto simp add: \<gamma>_rep_cases is_empty_rep_def split: prod.splits extended.splits)

declare is_empty_rep_iff[THEN iffD1, simp]

instantiation ivl :: semilattice_sup_top
begin

definition le_rep :: "eint2 \<Rightarrow> eint2 \<Rightarrow> bool" where
"le_rep p1 p2 = (let (l1,h1) = p1; (l2,h2) = p2 in
  if is_empty_rep(l1,h1) then True else
  if is_empty_rep(l2,h2) then False else l1 \<ge> l2 & h1 \<le> h2)"

lemma le_iff_subset: "le_rep p1 p2 \<longleftrightarrow> \<gamma>_rep p1 \<subseteq> \<gamma>_rep p2"
apply rule
apply(auto simp: is_empty_rep_def le_rep_def \<gamma>_rep_def split: if_splits prod.splits)[1]
apply(auto simp: is_empty_rep_def \<gamma>_rep_cases le_rep_def)
apply(auto simp: not_less split: extended.splits)
done

lift_definition less_eq_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> bool" is le_rep
by(auto simp: eq_ivl_def le_iff_subset)

definition less_ivl where "i1 < i2 = (i1 \<le> i2 \<and> \<not> i2 \<le> (i1::ivl))"

lemma le_ivl_iff_subset: "iv1 \<le> iv2 \<longleftrightarrow> \<gamma>_ivl iv1 \<subseteq> \<gamma>_ivl iv2"
by transfer (rule le_iff_subset)

definition sup_rep :: "eint2 \<Rightarrow> eint2 \<Rightarrow> eint2" where
"sup_rep p1 p2 = (if is_empty_rep p1 then p2 else if is_empty_rep p2 then p1
  else let (l1,h1) = p1; (l2,h2) = p2 in  (min l1 l2, max h1 h2))"

lift_definition sup_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is sup_rep
by(auto simp: eq_ivl_iff sup_rep_def)

lift_definition top_ivl :: ivl is "(Minf,Pinf)" .

lemma is_empty_min_max:
  "\<not> is_empty_rep (l1,h1) \<Longrightarrow> \<not> is_empty_rep (l2, h2) \<Longrightarrow> \<not> is_empty_rep (min l1 l2, max h1 h2)"
by(auto simp add: is_empty_rep_def max_def min_def split: if_splits)

instance
proof (standard, goal_cases)
  case 1 show ?case by (rule less_ivl_def)
next
  case 2 show ?case by transfer (simp add: le_rep_def split: prod.splits)
next
  case 3 thus ?case by transfer (auto simp: le_rep_def split: if_splits)
next
  case 4 thus ?case by transfer (auto simp: le_rep_def eq_ivl_iff split: if_splits)
next
  case 5 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max)
next
  case 6 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max)
next
  case 7 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def)
next
  case 8 show ?case by transfer (simp add: le_rep_def is_empty_rep_def)
qed

end

text\<open>Implement (naive) executable equality:\<close>
instantiation ivl :: equal
begin

definition equal_ivl where
"equal_ivl i1 (i2::ivl) = (i1\<le>i2 \<and> i2 \<le> i1)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(simp add: equal_ivl_def eq_iff)
qed

end

instantiation ivl :: bounded_lattice
begin

definition inf_rep :: "eint2 \<Rightarrow> eint2 \<Rightarrow> eint2" where
"inf_rep p1 p2 = (let (l1,h1) = p1; (l2,h2) = p2 in (max l1 l2, min h1 h2))"

lemma \<gamma>_inf_rep: "\<gamma>_rep(inf_rep p1 p2) = \<gamma>_rep p1 \<inter> \<gamma>_rep p2"
by(auto simp:inf_rep_def \<gamma>_rep_cases split: prod.splits extended.splits)

lift_definition inf_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is inf_rep
by(auto simp: \<gamma>_inf_rep eq_ivl_def)

lemma \<gamma>_inf: "\<gamma>_ivl (iv1 \<sqinter> iv2) = \<gamma>_ivl iv1 \<inter> \<gamma>_ivl iv2"
by transfer (rule \<gamma>_inf_rep)

definition "\<bottom> = empty_ivl"

instance
proof (standard, goal_cases)
  case 1 thus ?case by (simp add: \<gamma>_inf le_ivl_iff_subset)
next
  case 2 thus ?case by (simp add: \<gamma>_inf le_ivl_iff_subset)
next
  case 3 thus ?case by (simp add: \<gamma>_inf le_ivl_iff_subset)
next
  case 4 show ?case
    unfolding bot_ivl_def by transfer (auto simp: le_iff_subset)
qed

end

lemma eq_ivl_empty: "eq_ivl p empty_rep = is_empty_rep p"
by (metis eq_ivl_iff is_empty_empty_rep)

lemma le_ivl_nice: "[l1,h1] \<le> [l2,h2] \<longleftrightarrow>
  (if [l1,h1] = \<bottom> then True else
   if [l2,h2] = \<bottom> then False else l1 \<ge> l2 & h1 \<le> h2)"
unfolding bot_ivl_def by transfer (simp add: le_rep_def eq_ivl_empty)

lemma sup_ivl_nice: "[l1,h1] \<squnion> [l2,h2] =
  (if [l1,h1] = \<bottom> then [l2,h2] else
   if [l2,h2] = \<bottom> then [l1,h1] else [min l1 l2,max h1 h2])"
unfolding bot_ivl_def by transfer (simp add: sup_rep_def eq_ivl_empty)

lemma inf_ivl_nice: "[l1,h1] \<sqinter> [l2,h2] = [max l1 l2,min h1 h2]"
by transfer (simp add: inf_rep_def)

lemma top_ivl_nice: "\<top> = [-\<infinity>,\<infinity>]"
by (simp add: top_ivl_def)

instantiation ivl :: plus
begin

definition plus_rep :: "eint2 \<Rightarrow> eint2 \<Rightarrow> eint2" where
"plus_rep p1 p2 =
  (if is_empty_rep p1 \<or> is_empty_rep p2 then empty_rep else
   let (l1,h1) = p1; (l2,h2) = p2 in (l1+l2, h1+h2))"

lift_definition plus_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is plus_rep
by(auto simp: plus_rep_def eq_ivl_iff)

instance ..
end

lemma plus_ivl_nice: "[l1,h1] + [l2,h2] =
  (if [l1,h1] = \<bottom> \<or> [l2,h2] = \<bottom> then \<bottom> else [l1+l2 , h1+h2])"
unfolding bot_ivl_def by transfer (auto simp: plus_rep_def eq_ivl_empty)

lemma uminus_eq_Minf[simp]: "-x = Minf \<longleftrightarrow> x = Pinf"
by(cases x) auto
lemma uminus_eq_Pinf[simp]: "-x = Pinf \<longleftrightarrow> x = Minf"
by(cases x) auto

lemma uminus_le_Fin_iff: "- x \<le> Fin(-y) \<longleftrightarrow> Fin y \<le> (x::'a::ordered_ab_group_add extended)"
by(cases x) auto
lemma Fin_uminus_le_iff: "Fin(-y) \<le> -x \<longleftrightarrow> x \<le> ((Fin y)::'a::ordered_ab_group_add extended)"
by(cases x) auto

instantiation ivl :: uminus
begin

definition uminus_rep :: "eint2 \<Rightarrow> eint2" where
"uminus_rep p = (let (l,h) = p in (-h, -l))"

lemma \<gamma>_uminus_rep: "i \<in> \<gamma>_rep p \<Longrightarrow> -i \<in> \<gamma>_rep(uminus_rep p)"
by(auto simp: uminus_rep_def \<gamma>_rep_def image_def uminus_le_Fin_iff Fin_uminus_le_iff
        split: prod.split)

lift_definition uminus_ivl :: "ivl \<Rightarrow> ivl" is uminus_rep
by (auto simp: uminus_rep_def eq_ivl_def \<gamma>_rep_cases)
   (auto simp: Icc_eq_Icc split: extended.splits)

instance ..
end

lemma \<gamma>_uminus: "i \<in> \<gamma>_ivl iv \<Longrightarrow> -i \<in> \<gamma>_ivl(- iv)"
by transfer (rule \<gamma>_uminus_rep)

lemma uminus_nice: "-[l,h] = [-h,-l]"
by transfer (simp add: uminus_rep_def)

instantiation ivl :: minus
begin

definition minus_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" where
"(iv1::ivl) - iv2 = iv1 + -iv2"

instance ..
end

definition inv_plus_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl \<Rightarrow> ivl*ivl" where
"inv_plus_ivl iv iv1 iv2 = (iv1 \<sqinter> (iv - iv2), iv2 \<sqinter> (iv - iv1))"

definition above_rep :: "eint2 \<Rightarrow> eint2" where
"above_rep p = (if is_empty_rep p then empty_rep else let (l,h) = p in (l,\<infinity>))"

definition below_rep :: "eint2 \<Rightarrow> eint2" where
"below_rep p = (if is_empty_rep p then empty_rep else let (l,h) = p in (-\<infinity>,h))"

lift_definition above :: "ivl \<Rightarrow> ivl" is above_rep
by(auto simp: above_rep_def eq_ivl_iff)

lift_definition below :: "ivl \<Rightarrow> ivl" is below_rep
by(auto simp: below_rep_def eq_ivl_iff)

lemma \<gamma>_aboveI: "i \<in> \<gamma>_ivl iv \<Longrightarrow> i \<le> j \<Longrightarrow> j \<in> \<gamma>_ivl(above iv)"
by transfer
   (auto simp add: above_rep_def \<gamma>_rep_cases is_empty_rep_def
         split: extended.splits)

lemma \<gamma>_belowI: "i \<in> \<gamma>_ivl iv \<Longrightarrow> j \<le> i \<Longrightarrow> j \<in> \<gamma>_ivl(below iv)"
by transfer
   (auto simp add: below_rep_def \<gamma>_rep_cases is_empty_rep_def
         split: extended.splits)

definition inv_less_ivl :: "bool \<Rightarrow> ivl \<Rightarrow> ivl \<Rightarrow> ivl * ivl" where
"inv_less_ivl res iv1 iv2 =
  (if res
   then (iv1 \<sqinter> (below iv2 - [1,1]),
         iv2 \<sqinter> (above iv1 + [1,1]))
   else (iv1 \<sqinter> above iv2, iv2 \<sqinter> below iv1))"

lemma above_nice: "above[l,h] = (if [l,h] = \<bottom> then \<bottom> else [l,\<infinity>])"
unfolding bot_ivl_def by transfer (simp add: above_rep_def eq_ivl_empty)

lemma below_nice: "below[l,h] = (if [l,h] = \<bottom> then \<bottom> else [-\<infinity>,h])"
unfolding bot_ivl_def by transfer (simp add: below_rep_def eq_ivl_empty)

lemma add_mono_le_Fin:
  "\<lbrakk>x1 \<le> Fin y1; x2 \<le> Fin y2\<rbrakk> \<Longrightarrow> x1 + x2 \<le> Fin (y1 + (y2::'a::ordered_ab_group_add))"
by(drule (1) add_mono) simp

lemma add_mono_Fin_le:
  "\<lbrakk>Fin y1 \<le> x1; Fin y2 \<le> x2\<rbrakk> \<Longrightarrow> Fin(y1 + y2::'a::ordered_ab_group_add) \<le> x1 + x2"
by(drule (1) add_mono) simp

global_interpretation Val_semilattice
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
proof (standard, goal_cases)
  case 1 thus ?case by transfer (simp add: le_iff_subset)
next
  case 2 show ?case by transfer (simp add: \<gamma>_rep_def)
next
  case 3 show ?case by transfer (simp add: \<gamma>_rep_def)
next
  case 4 thus ?case
    apply transfer
    apply(auto simp: \<gamma>_rep_def plus_rep_def add_mono_le_Fin add_mono_Fin_le)
    by(auto simp: empty_rep_def is_empty_rep_def)
qed

global_interpretation Val_lattice_gamma
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
defines aval_ivl = aval'
proof (standard, goal_cases)
  case 1 show ?case by(simp add: \<gamma>_inf)
next
  case 2 show ?case unfolding bot_ivl_def by transfer simp
qed

global_interpretation Val_inv
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
proof (standard, goal_cases)
  case 1 thus ?case by transfer (auto simp: \<gamma>_rep_def)
next
  case (2 _ _ _ _ _ i1 i2) thus ?case
    unfolding inv_plus_ivl_def minus_ivl_def
    apply(clarsimp simp add: \<gamma>_inf)
    using gamma_plus'[of "i1+i2" _ "-i1"] gamma_plus'[of "i1+i2" _ "-i2"]
    by(simp add:  \<gamma>_uminus)
next
  case (3 i1 i2) thus ?case
    unfolding inv_less_ivl_def minus_ivl_def one_extended_def
    apply(clarsimp simp add: \<gamma>_inf split: if_splits)
    using gamma_plus'[of "i1+1" _ "-1"] gamma_plus'[of "i2 - 1" _ "1"]
    apply(simp add: \<gamma>_belowI[of i2] \<gamma>_aboveI[of i1]
      uminus_ivl.abs_eq uminus_rep_def \<gamma>_ivl_nice)
    apply(simp add: \<gamma>_aboveI[of i2] \<gamma>_belowI[of i1])
    done
qed

global_interpretation Abs_Int_inv
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
defines inv_aval_ivl = inv_aval'
and inv_bval_ivl = inv_bval'
and step_ivl = step'
and AI_ivl = AI
and aval_ivl' = aval''
..

text\<open>Monotonicity:\<close>

lemma mono_plus_ivl: "iv1 \<le> iv2 \<Longrightarrow> iv3 \<le> iv4 \<Longrightarrow> iv1+iv3 \<le> iv2+(iv4::ivl)"
apply transfer
apply(auto simp: plus_rep_def le_iff_subset split: if_splits)
by(auto simp: is_empty_rep_iff \<gamma>_rep_cases split: extended.splits)

lemma mono_minus_ivl: "iv1 \<le> iv2 \<Longrightarrow> -iv1 \<le> -(iv2::ivl)"
apply transfer
apply(auto simp: uminus_rep_def le_iff_subset split: if_splits prod.split)
by(auto simp: \<gamma>_rep_cases split: extended.splits)

lemma mono_above: "iv1 \<le> iv2 \<Longrightarrow> above iv1 \<le> above iv2"
apply transfer
apply(auto simp: above_rep_def le_iff_subset split: if_splits prod.split)
by(auto simp: is_empty_rep_iff \<gamma>_rep_cases split: extended.splits)

lemma mono_below: "iv1 \<le> iv2 \<Longrightarrow> below iv1 \<le> below iv2"
apply transfer
apply(auto simp: below_rep_def le_iff_subset split: if_splits prod.split)
by(auto simp: is_empty_rep_iff \<gamma>_rep_cases split: extended.splits)

global_interpretation Abs_Int_inv_mono
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
proof (standard, goal_cases)
  case 1 thus ?case by (rule mono_plus_ivl)
next
  case 2 thus ?case
    unfolding inv_plus_ivl_def minus_ivl_def less_eq_prod_def
    by (auto simp: le_infI1 le_infI2 mono_plus_ivl mono_minus_ivl)
next
  case 3 thus ?case
    unfolding less_eq_prod_def inv_less_ivl_def minus_ivl_def
    by (auto simp: le_infI1 le_infI2 mono_plus_ivl mono_above mono_below)
qed

subsubsection "Tests"

value "show_acom_opt (AI_ivl test1_ivl)"

text\<open>Better than \<open>AI_const\<close>:\<close>
value "show_acom_opt (AI_ivl test3_const)"
value "show_acom_opt (AI_ivl test4_const)"
value "show_acom_opt (AI_ivl test6_const)"

definition "steps c i = (step_ivl \<top> ^^ i) (bot c)"

value "show_acom_opt (AI_ivl test2_ivl)"
value "show_acom (steps test2_ivl 0)"
value "show_acom (steps test2_ivl 1)"
value "show_acom (steps test2_ivl 2)"
value "show_acom (steps test2_ivl 3)"

text\<open>Fixed point reached in 2 steps.
 Not so if the start value of x is known:\<close>

value "show_acom_opt (AI_ivl test3_ivl)"
value "show_acom (steps test3_ivl 0)"
value "show_acom (steps test3_ivl 1)"
value "show_acom (steps test3_ivl 2)"
value "show_acom (steps test3_ivl 3)"
value "show_acom (steps test3_ivl 4)"
value "show_acom (steps test3_ivl 5)"

text\<open>Takes as many iterations as the actual execution. Would diverge if
loop did not terminate. Worse still, as the following example shows: even if
the actual execution terminates, the analysis may not. The value of y keeps
increasing as the analysis is iterated, no matter how long:\<close>

value "show_acom (steps test4_ivl 50)"

text\<open>Relationships between variables are NOT captured:\<close>
value "show_acom_opt (AI_ivl test5_ivl)"

text\<open>Again, the analysis would not terminate:\<close>
value "show_acom (steps test6_ivl 50)"

end