(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_25
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun even :: "Nat => bool" where
  "even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z2)) = even z2"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

theorem property0 :
  "((even (length (x y z))) = (even (t2 (length z) (length y))))"
  oops

end


(* Author: Tobias Nipkow *)

section \<open>2-3 Tree Implementation of Maps\<close>

theory Tree23_Map
imports
  Tree23_Set
  Map_by_Ordered
begin

fun lookup :: "('a::linorder * 'b) tree23 \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node2 l (a,b) r) x = (case cmp x a of
  LT \<Rightarrow> lookup l x |
  GT \<Rightarrow> lookup r x |
  EQ \<Rightarrow> Some b)" |
"lookup (Node3 l (a1,b1) m (a2,b2) r) x = (case cmp x a1 of
  LT \<Rightarrow> lookup l x |
  EQ \<Rightarrow> Some b1 |
  GT \<Rightarrow> (case cmp x a2 of
          LT \<Rightarrow> lookup m x |
          EQ \<Rightarrow> Some b2 |
          GT \<Rightarrow> lookup r x))"

fun upd :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) up\<^sub>i" where
"upd x y Leaf = Up\<^sub>i Leaf (x,y) Leaf" |
"upd x y (Node2 l ab r) = (case cmp x (fst ab) of
   LT \<Rightarrow> (case upd x y l of
           T\<^sub>i l' => T\<^sub>i (Node2 l' ab r)
         | Up\<^sub>i l1 ab' l2 => T\<^sub>i (Node3 l1 ab' l2 ab r)) |
   EQ \<Rightarrow> T\<^sub>i (Node2 l (x,y) r) |
   GT \<Rightarrow> (case upd x y r of
           T\<^sub>i r' => T\<^sub>i (Node2 l ab r')
         | Up\<^sub>i r1 ab' r2 => T\<^sub>i (Node3 l ab r1 ab' r2)))" |
"upd x y (Node3 l ab1 m ab2 r) = (case cmp x (fst ab1) of
   LT \<Rightarrow> (case upd x y l of
           T\<^sub>i l' => T\<^sub>i (Node3 l' ab1 m ab2 r)
         | Up\<^sub>i l1 ab' l2 => Up\<^sub>i (Node2 l1 ab' l2) ab1 (Node2 m ab2 r)) |
   EQ \<Rightarrow> T\<^sub>i (Node3 l (x,y) m ab2 r) |
   GT \<Rightarrow> (case cmp x (fst ab2) of
           LT \<Rightarrow> (case upd x y m of
                   T\<^sub>i m' => T\<^sub>i (Node3 l ab1 m' ab2 r)
                 | Up\<^sub>i m1 ab' m2 => Up\<^sub>i (Node2 l ab1 m1) ab' (Node2 m2 ab2 r)) |
           EQ \<Rightarrow> T\<^sub>i (Node3 l ab1 m (x,y) r) |
           GT \<Rightarrow> (case upd x y r of
                   T\<^sub>i r' => T\<^sub>i (Node3 l ab1 m ab2 r')
                 | Up\<^sub>i r1 ab' r2 => Up\<^sub>i (Node2 l ab1 m) ab2 (Node2 r1 ab' r2))))"

definition update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) tree23" where
"update a b t = tree\<^sub>i(upd a b t)"

fun del :: "'a::linorder \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) up\<^sub>d" where
"del x Leaf = T\<^sub>d Leaf" |
"del x (Node2 Leaf ab1 Leaf) = (if x=fst ab1 then Up\<^sub>d Leaf else T\<^sub>d(Node2 Leaf ab1 Leaf))" |
"del x (Node3 Leaf ab1 Leaf ab2 Leaf) = T\<^sub>d(if x=fst ab1 then Node2 Leaf ab2 Leaf
  else if x=fst ab2 then Node2 Leaf ab1 Leaf else Node3 Leaf ab1 Leaf ab2 Leaf)" |
"del x (Node2 l ab1 r) = (case cmp x (fst ab1) of
  LT \<Rightarrow> node21 (del x l) ab1 r |
  GT \<Rightarrow> node22 l ab1 (del x r) |
  EQ \<Rightarrow> let (ab1',t) = del_min r in node22 l ab1' t)" |
"del x (Node3 l ab1 m ab2 r) = (case cmp x (fst ab1) of
  LT \<Rightarrow> node31 (del x l) ab1 m ab2 r |
  EQ \<Rightarrow> let (ab1',m') = del_min m in node32 l ab1' m' ab2 r |
  GT \<Rightarrow> (case cmp x (fst ab2) of
           LT \<Rightarrow> node32 l ab1 (del x m) ab2 r |
           EQ \<Rightarrow> let (ab2',r') = del_min r in node33 l ab1 m ab2' r' |
           GT \<Rightarrow> node33 l ab1 m ab2 (del x r)))"

definition delete :: "'a::linorder \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) tree23" where
"delete x t = tree\<^sub>d(del x t)"

subsection \<open>Functional Correctness\<close>

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by (induction t) (auto simp: map_of_simps split: option.split)

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(tree\<^sub>i(upd x y t)) = upd_list x y (inorder t)"
by(induction t) (auto simp: upd_list_simps split: up\<^sub>i.splits)

corollary inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd)

lemma inorder_del: "\<lbrakk> bal t ; sorted1(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(tree\<^sub>d (del x t)) = del_list x (inorder t)"
by(induction t rule: del.induct)
  (auto simp: del_list_simps inorder_nodes del_minD split!: if_split prod.splits)

corollary inorder_delete: "\<lbrakk> bal t ; sorted1(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Balancedness\<close>

lemma bal_upd: "bal t \<Longrightarrow> bal (tree\<^sub>i(upd x y t)) \<and> height(upd x y t) = height t"
by (induct t) (auto split!: if_split up\<^sub>i.split)(* 16 secs in 2015 *)

corollary bal_update: "bal t \<Longrightarrow> bal (update x y t)"
by (simp add: update_def bal_upd)

lemma height_del: "bal t \<Longrightarrow> height(del x t) = height t"
by(induction x t rule: del.induct)
  (auto simp add: heights max_def height_del_min split: prod.split)

lemma bal_tree\<^sub>d_del: "bal t \<Longrightarrow> bal(tree\<^sub>d(del x t))"
by(induction x t rule: del.induct)
  (auto simp: bals bal_del_min height_del height_del_min split: prod.split)

corollary bal_delete: "bal t \<Longrightarrow> bal(delete x t)"
by(simp add: delete_def bal_tree\<^sub>d_del)

subsection \<open>Overall Correctness\<close>

interpretation Map_by_Ordered
where empty = Leaf and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = bal
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 6 thus ?case by(simp add: bal_update)
next
  case 7 thus ?case by(simp add: bal_delete)
qed simp+

end


(*
  Author:  Jeremy Dawson, NICTA
*)

section \<open>Useful Numerical Lemmas\<close>

theory Misc_Numeric
imports Main
begin

lemma mod_2_neq_1_eq_eq_0:
  fixes k :: int
  shows "k mod 2 \<noteq> 1 \<longleftrightarrow> k mod 2 = 0"
  by (fact not_mod_2_eq_1_eq_0)

lemma z1pmod2:
  fixes b :: int
  shows "(2 * b + 1) mod 2 = (1::int)"
  by arith

lemma diff_le_eq':
  "a - b \<le> c \<longleftrightarrow> a \<le> b + (c::int)"
  by arith

lemma emep1:
  fixes n d :: int
  shows "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (n + 1) mod d = (n mod d) + 1"
  by (auto simp add: pos_zmod_mult_2 add.commute dvd_def)

lemma int_mod_ge:
  "a < n \<Longrightarrow> 0 < (n :: int) \<Longrightarrow> a \<le> a mod n"
  by (metis dual_order.trans le_cases mod_pos_pos_trivial pos_mod_conj)

lemma int_mod_ge':
  "b < 0 \<Longrightarrow> 0 < (n :: int) \<Longrightarrow> b + n \<le> b mod n"
  by (metis add_less_same_cancel2 int_mod_ge mod_add_self2)

lemma int_mod_le':
  "(0::int) \<le> b - n \<Longrightarrow> b mod n \<le> b - n"
  by (metis minus_mod_self2 zmod_le_nonneg_dividend)

lemma zless2:
  "0 < (2 :: int)"
  by (fact zero_less_numeral)

lemma zless2p:
  "0 < (2 ^ n :: int)"
  by arith

lemma zle2p:
  "0 \<le> (2 ^ n :: int)"
  by arith

lemma m1mod2k:
  "- 1 mod 2 ^ n = (2 ^ n - 1 :: int)"
  using zless2p by (rule zmod_minus1)

lemma p1mod22k':
  fixes b :: int
  shows "(1 + 2 * b) mod (2 * 2 ^ n) = 1 + 2 * (b mod 2 ^ n)"
  using zle2p by (rule pos_zmod_mult_2)

lemma p1mod22k:
  fixes b :: int
  shows "(2 * b + 1) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n) + 1"
  by (simp add: p1mod22k' add.commute)

lemma int_mod_lem:
  "(0 :: int) < n ==> (0 <= b & b < n) = (b mod n = b)"
  apply safe
    apply (erule (1) mod_pos_pos_trivial)
   apply (erule_tac [!] subst)
   apply auto
  done

end


(*  Title:      IP_Address.thy
    Authors:    Cornelius Diekmann
*)
theory IP_Address
  imports
    Word_Lib.Word_Lemmas
    Word_Lib.Word_Syntax
    Word_Lib.Reversed_Bit_Lists
    Hs_Compat
    WordInterval
begin

section \<open>Modelling IP Adresses\<close>
  text\<open>An IP address is basically an unsigned integer.
    We model IP addresses of arbitrary lengths.

    We will write @{typ "'i::len word"} for IP addresses of length @{term "LENGTH('i::len)"}.
    We use the convention to write @{typ 'i} whenever we mean IP addresses instead of generic words.
    When we will later have theorems with several polymorphic types in it (e.g. arbitrarily
    extensible packets), this notation makes it easier to spot that type @{typ 'i} is for
    IP addresses.

    The files @{file \<open>IPv4.thy\<close>} @{file \<open>IPv6.thy\<close>} concrete this for IPv4 and IPv6.\<close>

  text\<open>The maximum IP address\<close>
  definition max_ip_addr :: "'i::len word" where
    "max_ip_addr \<equiv> of_nat ((2^(len_of(TYPE('i)))) - 1)"

  lemma max_ip_addr_max_word: "max_ip_addr = - 1"
    by (simp only: max_ip_addr_def of_nat_mask_eq flip: mask_eq_exp_minus_1) simp

  lemma max_ip_addr_max: "\<forall>a. a \<le> max_ip_addr"
    by(simp add: max_ip_addr_max_word)
  lemma range_0_max_UNIV: "UNIV = {0 .. max_ip_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ip_addr_max_word) fastforce

  lemma "size (x::'i::len word) = len_of(TYPE('i))" by(simp add:word_size)

subsection\<open>Sets of IP Addresses\<close>

  context
    includes bit_operations_syntax
  begin

  (*Warning, not executable!*)
  text\<open>Specifying sets with network masks: 192.168.0.0 255.255.255.0\<close>
  definition ipset_from_netmask::"'i::len word \<Rightarrow> 'i::len word \<Rightarrow> 'i::len word set" where
    "ipset_from_netmask addr netmask \<equiv>
      let
        network_prefix = (addr AND netmask)
      in
        {network_prefix .. network_prefix OR (NOT netmask)}"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_netmask} \<open>192.168.1.129  255.255.255.0\<close> =
        \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  text\<open>A network mask of all ones (i.e. @{term "(- 1)::'i::len word"}).\<close>
  lemma ipset_from_netmask_minusone:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)
  lemma ipset_from_netmask_maxword:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)

  lemma ipset_from_netmask_zero:
    "ipset_from_netmask ip 0 = UNIV" by (auto simp add: ipset_from_netmask_def)

  text\<open>Specifying sets in Classless Inter-domain Routing (CIDR) notation: 192.168.0.0/24\<close>
  definition ipset_from_cidr ::"'i::len word \<Rightarrow> nat \<Rightarrow> 'i::len word set" where
    "ipset_from_cidr addr pflength \<equiv>
       ipset_from_netmask addr ((mask pflength) << (len_of(TYPE('i)) - pflength))"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_cidr} \<open>192.168.1.129 24\<close> = \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  (*does this simplify stuff?*)
  lemma "(case ipcidr of (base, len) \<Rightarrow> ipset_from_cidr base len) = uncurry ipset_from_cidr ipcidr"
    by(simp add: uncurry_case_stmt)

  lemma ipset_from_cidr_0: "ipset_from_cidr ip 0 = UNIV"
    by(auto simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)

  text\<open>A prefix length of word size gives back the singleton set with the IP address.
       Example: \<open>192.168.1.2/32 = {192.168.1.2}\<close>\<close>
  lemma ipset_from_cidr_wordlength:
    fixes ip :: "'i::len word"
    shows "ipset_from_cidr ip (LENGTH('i)) = {ip}"
    by (simp add: ipset_from_cidr_def ipset_from_netmask_def)

  text\<open>Alternative definition: Considering words as bit lists:\<close>
  lemma ipset_from_cidr_bl:
    fixes addr :: "'i::len word"
    shows "ipset_from_cidr addr pflength \<equiv>
            ipset_from_netmask addr (of_bl ((replicate pflength True) @
                                            (replicate ((len_of(TYPE('i))) - pflength)) False))"
    by(simp add: ipset_from_cidr_def mask_bl shiftl_of_bl)

  lemma ipset_from_cidr_alt:
    fixes pre :: "'i::len word"
    shows "ipset_from_cidr pre len =
            {pre AND (mask len << LENGTH('i) - len)
             ..
             pre OR mask (LENGTH('i) - len)}"
    apply(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)
    apply(simp add: word_oa_dist)
    apply(simp add: NOT_mask_shifted_lenword)
    done

  lemma ipset_from_cidr_alt2:
    fixes base ::"'i::len word"
    shows "ipset_from_cidr base len =
           ipset_from_netmask base (NOT (mask (LENGTH('i) - len)))"
    apply(simp add: ipset_from_cidr_def)
    using NOT_mask_shifted_lenword by(metis word_not_not)

  text\<open>In CIDR notation, we cannot express the empty set.\<close>
  lemma ipset_from_cidr_not_empty: "ipset_from_cidr base len \<noteq> {}"
    by(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last)

  text\<open>Though we can write 192.168.1.2/24, we say that 192.168.0.0/24 is well-formed.\<close>
  lemma ipset_from_cidr_base_wellforemd: fixes base:: "'i::len word"
    assumes "mask (LENGTH('i) - l) AND base = 0"
      shows "ipset_from_cidr base l = {base .. base OR mask (LENGTH('i) - l)}"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask l << LENGTH('i) - l) :: 'i::len word) = NOT (mask (LENGTH('i) - l))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have *: "base AND NOT (mask (LENGTH('i) - l)) = base"
      unfolding mask_eq_0_eq_x[symmetric] using assms word_bw_comms(1)[of base] by simp
    hence **: "base AND NOT (mask (LENGTH('i) - l)) OR mask (LENGTH('i) - l) =
                base OR mask (LENGTH('i) - l)" by simp
    have "ipset_from_netmask base (NOT (mask (LENGTH('i) - l))) =
            {base .. base || mask (LENGTH('i) - l)}"
      by(simp add: ipset_from_netmask_def Let_def ** *)
    thus ?thesis by(simp add: ipset_from_cidr_def maskshift_eq_not_mask_generic)
  qed

  lemma ipset_from_cidr_large_pfxlen:
    fixes ip:: "'i::len word"
    assumes "n \<ge> LENGTH('i)"
    shows "ipset_from_cidr ip n = {ip}"
  proof -
    have obviously: "mask (LENGTH('i) - n) = 0" by (simp add: assms)
    show ?thesis
      apply(subst ipset_from_cidr_base_wellforemd)
       subgoal using assms by simp
      by (simp add: obviously)
  qed

  lemma ipset_from_netmask_base_mask_consume:
    fixes base :: "'i::len word"
    shows "ipset_from_netmask (base AND NOT (mask (LENGTH('i) - m)))
                              (NOT (mask (LENGTH('i) - m)))
            =
             ipset_from_netmask base (NOT (mask (LENGTH('i) - m)))"
    unfolding ipset_from_netmask_def by(simp)

  text\<open>Another definition of CIDR notation:
       All IP address which are equal on the first @{term "len - n"} bits\<close>
  definition ip_cidr_set :: "'i::len word \<Rightarrow> nat \<Rightarrow> 'i word set" where
    "ip_cidr_set i r \<equiv>
      {j . i AND NOT (mask (LENGTH('i) - r)) = j AND NOT (mask (LENGTH('i) - r))}"

  text\<open>The definitions are equal\<close>
  lemma ipset_from_cidr_eq_ip_cidr_set:
    fixes base::"'i::len word"
    shows "ipset_from_cidr base len = ip_cidr_set base len"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask len << LENGTH('a) - len) :: 'a::len word) = NOT (mask (LENGTH('a) - len))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have 1: "mask (len - m) AND base AND NOT (mask (len - m)) = 0"
      for len m and base::"'i::len word"
      by(simp add: word_bw_lcs)
    have 2: "mask (LENGTH('i) - len) AND pfxm_p = 0 \<Longrightarrow>
           (a \<in> ipset_from_netmask pfxm_p (NOT (mask (LENGTH('i) - len)))) \<longleftrightarrow>
           (pfxm_p = NOT (mask (LENGTH('i) - len)) AND a)" for a::"'i::len word" and pfxm_p
    apply(subst ipset_from_cidr_alt2[symmetric])
    apply(subst zero_base_lsb_imp_set_eq_as_bit_operation)
     apply(simp; fail)
    apply(subst ipset_from_cidr_base_wellforemd)
     apply(simp; fail)
    apply(simp)
    done
    from 2[OF 1, of _ base] have
      "(x \<in> ipset_from_netmask base (~~ (mask (LENGTH('i) - len)))) \<longleftrightarrow>
       (base && ~~ (mask (LENGTH('i) - len)) = x && ~~ (mask (LENGTH('i) - len)))" for x
    apply(simp add: ipset_from_netmask_base_mask_consume)
    unfolding word_bw_comms(1)[of _ " ~~ (mask (LENGTH('i) - len))"] by simp
    then show ?thesis
      unfolding ip_cidr_set_def ipset_from_cidr_def
      by(auto simp add:  maskshift_eq_not_mask_generic)
  qed

  lemma ip_cidr_set_change_base: "j \<in> ip_cidr_set i r \<Longrightarrow> ip_cidr_set j r = ip_cidr_set i r"
    by (auto simp: ip_cidr_set_def)

subsection\<open>IP Addresses as WordIntervals\<close>
  text\<open>The nice thing is: @{typ "'i wordinterval"}s are executable.\<close>

  definition iprange_single :: "'i::len word \<Rightarrow> 'i wordinterval" where
    "iprange_single ip \<equiv> WordInterval ip ip"

  fun iprange_interval :: "('i::len word \<times> 'i::len word) \<Rightarrow> 'i wordinterval" where
    "iprange_interval (ip_start, ip_end) = WordInterval ip_start ip_end"
  declare iprange_interval.simps[simp del]

  lemma iprange_interval_uncurry: "iprange_interval ipcidr = uncurry WordInterval ipcidr"
    by(cases ipcidr) (simp add: iprange_interval.simps)

  lemma "wordinterval_to_set (iprange_single ip) = {ip}"
    by(simp add: iprange_single_def)
  lemma "wordinterval_to_set (iprange_interval (ip1, ip2)) = {ip1 .. ip2}"
    by(simp add: iprange_interval.simps)

  text\<open>Now we can use the set operations on @{typ "'i::len wordinterval"}s\<close>
  term wordinterval_to_set
  term wordinterval_element
  term wordinterval_union
  term wordinterval_empty
  term wordinterval_setminus
  term wordinterval_UNIV
  term wordinterval_invert
  term wordinterval_intersection
  term wordinterval_subset
  term wordinterval_eq

subsection\<open>IP Addresses in CIDR Notation\<close>
  text\<open>We want to convert IP addresses in CIDR notation to intervals.
    We already have @{const ipset_from_cidr}, which gives back a non-executable set.
    We want to convert to something we can store in an @{typ "'i wordinterval"}.\<close>

  fun ipcidr_to_interval_start :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_start (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix)"
  fun ipcidr_to_interval_end :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_end (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix OR (NOT netmask))"
  definition ipcidr_to_interval :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> 'i word)" where
    "ipcidr_to_interval cidr \<equiv> (ipcidr_to_interval_start cidr, ipcidr_to_interval_end cidr)"

  lemma ipset_from_cidr_ipcidr_to_interval:
    "ipset_from_cidr base len =
      {ipcidr_to_interval_start (base,len) .. ipcidr_to_interval_end (base,len)}"
    by(simp add: Let_def ipcidr_to_interval_def ipset_from_cidr_def ipset_from_netmask_def)
  declare ipcidr_to_interval_start.simps[simp del] ipcidr_to_interval_end.simps[simp del]

  lemma ipcidr_to_interval:
    "ipcidr_to_interval (base, len) = (s,e) \<Longrightarrow> ipset_from_cidr base len = {s .. e}"
    by (simp add: ipcidr_to_interval_def ipset_from_cidr_ipcidr_to_interval)

  definition ipcidr_tuple_to_wordinterval :: "('i::len word \<times> nat) \<Rightarrow> 'i wordinterval" where
    "ipcidr_tuple_to_wordinterval iprng \<equiv> iprange_interval (ipcidr_to_interval iprng)"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval (b, m)) = ipset_from_cidr b m"
    unfolding ipcidr_tuple_to_wordinterval_def ipset_from_cidr_ipcidr_to_interval
              ipcidr_to_interval_def
    by(simp add: iprange_interval.simps)

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ipcidr) = uncurry ipset_from_cidr ipcidr"
    by(cases ipcidr, simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval)

  definition ipcidr_union_set :: "('i::len word \<times> nat) set \<Rightarrow> ('i word) set" where
    "ipcidr_union_set ips \<equiv> \<Union>(base, len) \<in> ips. ipset_from_cidr base len"

  lemma ipcidr_union_set_uncurry:
    "ipcidr_union_set ips = (\<Union> ipcidr \<in> ips. uncurry ipset_from_cidr ipcidr)"
    by(simp add: ipcidr_union_set_def uncurry_case_stmt)

subsection\<open>Clever Operations on IP Addresses in CIDR Notation\<close>
  text\<open>Intersecting two intervals may result in a new interval.
    Example: \<open>{1..10} \<inter> {5..20} = {5..10}\<close>

    Intersecting two IP address ranges represented as CIDR ranges results either in the empty set
    or the smaller of the two ranges. It will never create a new range.
    \<close>
  context
  begin
    (*contributed by Lars Noschinski*)
    private lemma less_and_not_mask_eq:
      fixes i :: "('a :: len) word"
      assumes "r2 \<le> r1" "i && ~~ (mask r2) = x && ~~ (mask r2)"
      shows "i && ~~ (mask r1) = x && ~~ (mask r1)"
    proof -
      have "i AND NOT (mask r1) = (i && ~~ (mask r2)) && ~~ (mask r1)" (is "_ = ?w && _")
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      also have "?w = x && ~~ (mask r2)" by fact
      also have "\<dots> && ~~ (mask r1) = x && ~~ (mask r1)"
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      finally show ?thesis .
    qed

    lemma ip_cidr_set_less:
      fixes i :: "'i::len word"
      shows "r1 \<le> r2 \<Longrightarrow> ip_cidr_set i r2 \<subseteq> ip_cidr_set i r1"
      unfolding ip_cidr_set_def
      apply auto
      apply (rule less_and_not_mask_eq[where ?r2.0="LENGTH('i) - r2"])
      apply auto
      done

    private lemma ip_cidr_set_intersect_subset_helper:
      fixes i1 r1 i2 r2
      assumes disj: "ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 \<noteq> {}" and  "r1 \<le> r2"
      shows "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof -
      from disj obtain j where "j \<in> ip_cidr_set i1 r1" "j \<in> ip_cidr_set i2 r2" by auto
      with \<open>r1 \<le> r2\<close> have "j \<in> ip_cidr_set j r1" "j \<in> ip_cidr_set j r1"
        using ip_cidr_set_change_base ip_cidr_set_less by blast+

      show "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof
        fix i assume "i \<in> ip_cidr_set i2 r2"
        with \<open>j \<in> ip_cidr_set i2 r2\<close> have "i \<in> ip_cidr_set j r2" using ip_cidr_set_change_base by auto
        also have "ip_cidr_set j r2 \<subseteq> ip_cidr_set j r1" using \<open>r1 \<le> r2\<close> ip_cidr_set_less by blast
        also have "\<dots> = ip_cidr_set i1 r1" using \<open>j \<in> ip_cidr_set i1 r1\<close> ip_cidr_set_change_base by blast
        finally show "i \<in> ip_cidr_set i1 r1" .
      qed
    qed

    lemma ip_cidr_set_notsubset_empty_inter:
      "\<not> ip_cidr_set i1 r1 \<subseteq> ip_cidr_set i2 r2 \<Longrightarrow>
       \<not> ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1 \<Longrightarrow>
       ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 = {}"
      apply(cases "r1 \<le> r2")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      apply(cases "r2 \<le> r1")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      by(simp)
  end

  lemma ip_cidr_intersect:
     "\<not> ipset_from_cidr b2 m2 \<subseteq> ipset_from_cidr b1 m1 \<Longrightarrow>
      \<not> ipset_from_cidr b1 m1 \<subseteq> ipset_from_cidr b2 m2 \<Longrightarrow>
      ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2 = {}"
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set)
    using ip_cidr_set_notsubset_empty_inter by blast

  text\<open>Computing the intersection of two IP address ranges in CIDR notation\<close>
  fun ipcidr_conjunct :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> nat) \<Rightarrow> ('i word \<times> nat) option" where
    "ipcidr_conjunct (base1, m1) (base2, m2) = (
       if
         ipset_from_cidr base1 m1 \<inter> ipset_from_cidr base2 m2 = {}
       then
         None
       else if
         ipset_from_cidr base1 m1 \<subseteq> ipset_from_cidr base2 m2
       then
         Some (base1, m1)
       else
         Some (base2, m2)
      )"

  text\<open>Intersecting with an address with prefix length zero always yields a non-empty result.\<close>
  lemma ipcidr_conjunct_any: "ipcidr_conjunct a (x,0) \<noteq> None" "ipcidr_conjunct (y,0) b \<noteq> None"
     apply(cases a, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)
    by(cases b, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)

  lemma ipcidr_conjunct_correct: "(case ipcidr_conjunct (b1, m1) (b2, m2)
                                          of Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx
                                          |  None \<Rightarrow> {}) =
                                   (ipset_from_cidr b1 m1) \<inter> (ipset_from_cidr b2 m2)"
    apply(simp split: if_split_asm)
    using ip_cidr_intersect by fast
  declare ipcidr_conjunct.simps[simp del]

subsection\<open>Code Equations\<close>
  text\<open>Executable definition using word intervals\<close>
  lemma ipcidr_conjunct_word[code_unfold]:
  "ipcidr_conjunct ips1 ips2 = (
     if
      wordinterval_empty (wordinterval_intersection
                            (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2))
     then
       None
     else if
       wordinterval_subset (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2)
     then
       Some ips1
     else
       Some ips2
     )"
  apply(simp)
  apply(cases ips1, cases ips2, rename_tac b1 m1 b2 m2, simp)
  apply(auto simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval ipcidr_conjunct.simps
             split: if_split_asm)
  done

  (*with the code_unfold lemma before, this works!*)
  lemma "ipcidr_conjunct (0::32 word,0) (8,1) = Some (8, 1)" by eval
  export_code ipcidr_conjunct checking SML

  text\<open>making element check executable\<close>
  lemma addr_in_ipset_from_netmask_code[code_unfold]:
    "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: ipset_from_netmask_def Let_def)
  lemma addr_in_ipset_from_cidr_code[code_unfold]:
    "(addr::'i::len word) \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
       (pre AND ((mask len) << (LENGTH('i) - len))) \<le> addr \<and>
        addr \<le> pre OR (mask (LENGTH('i) - len))"
  unfolding ipset_from_cidr_alt by simp

  end

end


section \<open> Counter in CSP \<close>

theory utp_csp_counter
  imports "UTP-Circus.utp_circus"
begin

utp_lift_notation csp_enable
utp_lift_notation csp_do
utp_const chan_apply (0)

chantype ch_counter =
  count :: nat

alphabet st_counter =
  ctr :: nat

lemma get_val_count [simp]: "un_count_C \<circ> count_C = id"
  by (auto)

text \<open> This one of the simplest possible stateful CSP processes. It starts from a given number
  and keeps outputting the next number when asked. \<close>

abbreviation "CtrBdy \<equiv> (count.(&ctr) \<^bold>\<rightarrow> ctr :=\<^sub>C (&ctr + 1))"

definition "Counter(n) = (ctr :=\<^sub>C \<guillemotleft>n\<guillemotright> ;; (\<mu>\<^sub>C X \<bullet> CtrBdy ;; X))"

text \<open> We calculate the pre, peri-, and postconditions of @{term "CtrBdy"} below. \<close>

lemma CtrBdy_contract:
  "CtrBdy =
    \<^bold>R\<^sub>s(true\<^sub>r
       \<turnstile> \<E>(true,[], {(count\<cdot>&ctr)\<^sub>u})
       \<diamondop> \<Phi>(true,[&ctr \<mapsto>\<^sub>s &ctr + 1],[(count\<cdot>&ctr)\<^sub>u]))"
  by (rdes_simp)

text \<open> The precondition is simply true because there is no possibility of divergence.
  The pericondition states that in all initial states (true), and after doing no events
  (trace is empty), the count event is not being refused. The postcondition states that
  the counter is incremented by one, and the trace is increased
  by the count event. \<close>

    text \<open> The recursive case is a little more interesting. \<close>

lemma preR_Counter [rdes]: "pre\<^sub>R(Counter(n)) = true\<^sub>r"
  by (simp add: Counter_def rdes closure rpred unrest wp usubst)

text \<open> The pericondition consists of three sequential composed parts. The first part sets up the initial
  value for @{term ctr}. The second and third parts are within an internal choice of a natural
  number $i$. The second states that the trace is extended by count and the state
  variable is updated $i \<ge> 0$ times. The power operator corresponds to iteration. The third part
  states that after this the next count communication is not being refused. \<close>

lemma periR_Counter':
  "peri\<^sub>R(Counter(n)) =
    \<Phi>(true,[ctr \<mapsto>\<^sub>s \<guillemotleft>n\<guillemotright>],\<langle>\<rangle>) ;; (\<Sqinter> i \<bullet> \<Phi>(true,[ctr \<mapsto>\<^sub>s &ctr + 1], \<langle>(count\<cdot>&ctr)\<^sub>u\<rangle>) \<^bold>^ i ;; \<E>(true,\<langle>\<rangle>, {(count\<cdot>&ctr)\<^sub>u}\<^sub>u))"
  by (simp add: Counter_def rdes rpred alpha closure usubst unrest wp seq_UINF_distr)

text \<open> This pericondition can be substantially simplified by an inductive proof. We show below
  that it is really the second part is really equivalent to stating that the trace is updated
  by all the count communications between $ctr$ and $ctr+k$, and then next count is not being
  refused. \<close>

lemma tr_count_prop:
  "(\<Phi>(true, [ctr \<mapsto>\<^sub>s &ctr + 1], \<langle>(count\<cdot>&ctr)\<^sub>u\<rangle>)) \<^bold>^ k ;; \<E>(true,\<langle>\<rangle>,{(count\<cdot>&ctr)\<^sub>u}\<^sub>u) =
    \<E>(true,map\<^sub>u \<guillemotleft>count\<guillemotright> \<langle>&ctr..<&ctr+\<guillemotleft>k\<guillemotright>\<rangle>,{(count\<cdot>&ctr+\<guillemotleft>k\<guillemotright>)\<^sub>u}\<^sub>u)"
  apply (induct k)
   apply (rel_auto)
  apply (simp)
  apply (subst seqr_assoc[THEN sym])
  apply (simp add:usubst unrest closure)
  apply (rel_auto)
   apply (simp add: upt_conv_Cons)
  apply (simp add: upt_rec)
done

text \<open> Thus we can simplify the pericondition as follows. Effectively we have eliminated
  the iteration (the power operator is gone). \<close>

lemma periR_Counter [rdes]:
  "peri\<^sub>R(Counter(n)) = (\<Sqinter> i \<bullet> \<E>(true,map\<^sub>u \<guillemotleft>count\<guillemotright> \<langle>\<guillemotleft>n\<guillemotright>..<\<guillemotleft>n\<guillemotright> + \<guillemotleft>i\<guillemotright>\<rangle>, {(count\<cdot>\<guillemotleft>n\<guillemotright> + \<guillemotleft>i\<guillemotright>)\<^sub>u}\<^sub>u))"
  by (simp add: Counter_def rdes rpred alpha closure usubst unrest wp seq_UINF_distr tr_count_prop[simplified])

text \<open> Like many reactive systems the postcondition is @{term false}, as it never terminates. \<close>

lemma postR_Counter [rdes]:
  "post\<^sub>R(Counter(n)) = false"
  by (simp add: Counter_def rdes rpred closure unrest usubst wp)

text \<open> From these calculations we can prove a simple property of the counter -- any output
  on count must hold a number greater than the starting value. \<close>

lemma Counter_property_1:
  "[true \<turnstile> \<^bold>\<forall> i \<bullet> (count\<cdot>\<guillemotleft>i\<guillemotright>)\<^sub>u \<in>\<^sub>u elems\<^sub>u(\<guillemotleft>trace\<guillemotright>) \<Rightarrow> \<guillemotleft>i\<guillemotright> \<ge>\<^sub>u &ctr | false]\<^sub>C \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> CtrBdy ;; X)"
  apply (rule CRD_mu_basic_refine)
  apply (simp_all add: closure rdes usubst rpred alpha unrest)
  apply (rel_simp)
    apply (simp add: zero_list_def)
   apply (rel_simp)
  apply (smt Suc_leD append.assoc append_Cons append_Nil append_minus ch_counter.inject less_eq_list_def order_refl prefix_concat_minus set_ConsD)
done

lemma Counter_property_2:
  "[true \<turnstile> \<Sqinter> i \<bullet> \<guillemotleft>i\<guillemotright> \<ge>\<^sub>u &ctr \<and> \<guillemotleft>trace\<guillemotright> =\<^sub>u map\<^sub>u \<guillemotleft>count\<guillemotright> \<langle>&ctr..<\<guillemotleft>i\<guillemotright>\<rangle> | false ]\<^sub>C \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> CtrBdy ;; X)"
  apply (rule CRD_mu_basic_refine)
  apply (simp_all add: closure rdes rpred usubst alpha unrest)
  apply (rel_simp, simp add: zero_list_def)
  apply auto[1]
  apply (rel_simp)
  apply (metis Prefix_Order.prefixE Suc_leD Suc_le_lessD append_Cons append_Nil append_assoc append_minus list.simps(9) upt_rec)
done

lemma Counter_property_3:
  "[true \<turnstile> sorted\<^sub>u(map\<^sub>u \<guillemotleft>get_val\<guillemotright> \<guillemotleft>trace\<guillemotright>) | false ]\<^sub>C \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> CtrBdy ;; X)"
  (is "?lhs \<sqsubseteq> ?rhs")
proof -
  have "?lhs \<sqsubseteq> [true \<turnstile> \<Sqinter> i \<bullet> \<guillemotleft>i\<guillemotright> \<ge>\<^sub>u &ctr \<and> \<guillemotleft>trace\<guillemotright> =\<^sub>u map\<^sub>u \<guillemotleft>count\<guillemotright> \<langle>&ctr..<\<guillemotleft>i\<guillemotright>\<rangle> | false ]\<^sub>C"
    by (rule CRD_refine_CRD, simp_all add: alpha, rel_simp)
  thus ?thesis
    using Counter_property_2 dual_order.trans by blast
qed

end


(*  Title:      HOL/Library/Z2.thy
    Author:     Brian Huffman
*)

section \<open>The Field of Integers mod 2\<close>

theory Z2
imports Main
begin

text \<open>
  Note that in most cases \<^typ>\<open>bool\<close> is appropriate when a binary type is needed; the
  type provided here, for historical reasons named \<^text>\<open>bit\<close>, is only needed if proper
  field operations are required.
\<close>

typedef bit = \<open>UNIV :: bool set\<close> ..

instantiation bit :: zero_neq_one
begin

definition zero_bit :: bit
  where \<open>0 = Abs_bit False\<close>

definition one_bit :: bit
  where \<open>1 = Abs_bit True\<close>

instance
  by standard (simp add: zero_bit_def one_bit_def Abs_bit_inject)

end

free_constructors case_bit for \<open>0::bit\<close> | \<open>1::bit\<close>
proof -
  fix P :: bool
  fix a :: bit
  assume \<open>a = 0 \<Longrightarrow> P\<close> and \<open>a = 1 \<Longrightarrow> P\<close>
  then show P
    by (cases a) (auto simp add: zero_bit_def one_bit_def Abs_bit_inject)
qed simp

lemma bit_not_zero_iff [simp]:
  \<open>a \<noteq> 0 \<longleftrightarrow> a = 1\<close> for a :: bit
  by (cases a) simp_all

lemma bit_not_one_iff [simp]:
  \<open>a \<noteq> 1 \<longleftrightarrow> a = 0\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: semidom_modulo
begin

definition plus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a + b = Abs_bit (Rep_bit a \<noteq> Rep_bit b)\<close>

definition minus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>minus_bit = plus\<close>

definition times_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a * b = Abs_bit (Rep_bit a \<and> Rep_bit b)\<close>

definition divide_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>divide_bit = times\<close>

definition modulo_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a mod b = Abs_bit (Rep_bit a \<and> \<not> Rep_bit b)\<close>

instance
  by standard
    (auto simp flip: Rep_bit_inject
    simp add: zero_bit_def one_bit_def plus_bit_def times_bit_def modulo_bit_def Abs_bit_inverse Rep_bit_inverse)

end

lemma bit_2_eq_0 [simp]:
  \<open>2 = (0::bit)\<close>
  by (simp flip: one_add_one add: zero_bit_def plus_bit_def)

instance bit :: semiring_parity
  apply standard
    apply (auto simp flip: Rep_bit_inject simp add: modulo_bit_def Abs_bit_inverse Rep_bit_inverse)
         apply (auto simp add: zero_bit_def one_bit_def Abs_bit_inverse Rep_bit_inverse)
  done

lemma Abs_bit_eq_of_bool [code_abbrev]:
  \<open>Abs_bit = of_bool\<close>
  by (simp add: fun_eq_iff zero_bit_def one_bit_def)

lemma Rep_bit_eq_odd:
  \<open>Rep_bit = odd\<close>
proof -
  have \<open>\<not> Rep_bit 0\<close>
    by (simp only: zero_bit_def) (subst Abs_bit_inverse, auto)
  then show ?thesis
    by (auto simp flip: Rep_bit_inject simp add: fun_eq_iff)
qed

lemma Rep_bit_iff_odd [code_abbrev]:
  \<open>Rep_bit b \<longleftrightarrow> odd b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Rep_bit_iff_even [code_abbrev]:
  \<open>\<not> Rep_bit b \<longleftrightarrow> even b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Not_Rep_bit [code_unfold]:
  \<open>\<not> \<not> Rep_bit b \<longleftrightarrow> Rep_bit b\<close>
  by simp

code_datatype \<open>0::bit\<close> \<open>1::bit\<close>

lemma Abs_bit_code [code]:
  \<open>Abs_bit False = 0\<close>
  \<open>Abs_bit True = 1\<close>
  by (simp_all add: Abs_bit_eq_of_bool)

lemma Rep_bit_code [code]:
  \<open>Rep_bit 0 \<longleftrightarrow> False\<close>
  \<open>Rep_bit 1 \<longleftrightarrow> True\<close>
  by (simp_all add: Rep_bit_eq_odd)

context zero_neq_one
begin

abbreviation of_bit :: \<open>bit \<Rightarrow> 'a\<close>
  where \<open>of_bit b \<equiv> of_bool (odd b)\<close>

end

context
begin

qualified lemma bit_eq_iff:
  \<open>a = b \<longleftrightarrow> (even a \<longleftrightarrow> even b)\<close> for a b :: bit
  by (cases a; cases b) simp_all

end

lemma modulo_bit_unfold [simp, code]:
  \<open>a mod b = of_bool (odd a \<and> even b)\<close> for a b :: bit
  by (simp add: modulo_bit_def Abs_bit_eq_of_bool Rep_bit_eq_odd)

lemma power_bit_unfold [simp]:
  \<open>a ^ n = of_bool (odd a \<or> n = 0)\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: field
begin

definition uminus_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>uminus_bit = id\<close>

definition inverse_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>inverse_bit = id\<close>

instance
  apply standard
  apply simp_all
  apply (simp only: Z2.bit_eq_iff even_add)
  apply simp
  done

end

instantiation bit :: semiring_bits
begin

definition bit_bit :: \<open>bit \<Rightarrow> nat \<Rightarrow> bool\<close>
  where [simp]: \<open>bit_bit b n \<longleftrightarrow> odd b \<and> n = 0\<close>

instance
  apply standard
              apply auto
  apply (metis bit.exhaust of_bool_eq(2))
  done

end

instantiation bit :: ring_bit_operations
begin

context
  includes bit_operations_syntax
begin

definition not_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>NOT b = of_bool (even b)\<close> for b :: bit

definition and_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b AND c = of_bool (odd b \<and> odd c)\<close> for b c :: bit

definition or_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b OR c = of_bool (odd b \<or> odd c)\<close> for b c :: bit

definition xor_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b XOR c = of_bool (odd b \<noteq> odd c)\<close> for b c :: bit

definition mask_bit :: \<open>nat \<Rightarrow> bit\<close>
  where [simp]: \<open>mask n = (of_bool (n > 0) :: bit)\<close>

definition set_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>set_bit n b = of_bool (n = 0 \<or> odd b)\<close> for b :: bit

definition unset_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>unset_bit n b = of_bool (n > 0 \<and> odd b)\<close> for b :: bit

definition flip_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>flip_bit n b = of_bool ((n = 0) \<noteq> odd b)\<close> for b :: bit

definition push_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>push_bit n b = of_bool (odd b \<and> n = 0)\<close> for b :: bit

definition drop_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>drop_bit n b = of_bool (odd b \<and> n = 0)\<close> for b :: bit

definition take_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>take_bit n b = of_bool (odd b \<and> n > 0)\<close> for b :: bit

end

instance
  apply standard
             apply auto
  apply (simp only: Z2.bit_eq_iff even_add even_zero)
  done

end

lemma add_bit_eq_xor [simp, code]:
  \<open>(+) = (Bit_Operations.xor :: bit \<Rightarrow> _)\<close>
  by (auto simp add: fun_eq_iff)

lemma mult_bit_eq_and [simp, code]:
  \<open>(*) = (Bit_Operations.and :: bit \<Rightarrow> _)\<close>
  by (simp add: fun_eq_iff)

lemma bit_numeral_even [simp]:
  \<open>numeral (Num.Bit0 n) = (0 :: bit)\<close>
  by (simp only: Z2.bit_eq_iff even_numeral) simp

lemma bit_numeral_odd [simp]:
  \<open>numeral (Num.Bit1 n) = (1 :: bit)\<close>
  by (simp only: Z2.bit_eq_iff odd_numeral)  simp

end


(* Author: Jaime Mendizabal Roche *)

theory Euler_Criterion
imports Residues
begin

context
  fixes p :: "nat"
  fixes a :: "int"

  assumes p_prime: "prime p"
  assumes p_ge_2: "2 < p"
  assumes p_a_relprime: "[a \<noteq> 0](mod p)"
begin

private lemma odd_p: "odd p" using p_ge_2 p_prime prime_odd_nat by blast

private lemma p_minus_1_int: "int (p - 1) = int p - 1" using p_prime prime_ge_1_nat by force

private lemma E_1: assumes "QuadRes p a"
  shows "[a ^ ((p - 1) div 2) = 1] (mod (int p))"
proof -
  from assms obtain b where b: "[b ^ 2 = a] (mod p)" unfolding QuadRes_def by blast
  hence "[a ^ ((p - 1) div 2) = b ^ (2 * ((p - 1) div 2))] (mod p)"
    by (simp add: cong_exp_int cong_sym_int power_mult)
  hence "[a ^ ((p - 1) div 2) = b ^ (p - 1)] (mod p)" using odd_p by force
  moreover have "~ p dvd b"
    using b cong_altdef_int[of a 0 p] cong_dvd_eq_int[of "b ^ 2" a "int p"] p_a_relprime p_prime
    by (auto simp: prime_dvd_power_int_iff)
  ultimately show ?thesis using fermat_theorem[of p b] p_prime
    by (auto intro: cong_trans_int)
qed

private definition S1 :: "int set" where "S1 = {0 <.. int p - 1}"

private definition P :: "int \<Rightarrow> int \<Rightarrow> bool" where
  "P x y \<longleftrightarrow> [x * y = a] (mod p) \<and> y \<in> S1"

private definition f_1 :: "int \<Rightarrow> int" where
  "f_1 x = (THE y. P x y)"

private definition f :: "int \<Rightarrow> int set" where
  "f x = {x, f_1 x}"

private definition S2 :: "int set set" where "S2 = f ` S1"

private lemma P_lemma: assumes "x \<in> S1"
  shows "\<exists>! y. P x y"
proof -
  have "~ p dvd x" using assms zdvd_not_zless S1_def by auto
  hence co_xp: "coprime x p" using p_prime prime_imp_coprime_int[of p x]
    by (simp add: gcd.commute)
  then obtain y' where y': "[x * y' = 1] (mod p)" using cong_solve_coprime_int by blast
  moreover define y where "y = y' * a mod p"
  ultimately have "[x * y = a] (mod p)" using mod_mult_right_eq[of x "y' * a" p]
    cong_scalar_int[of "x * y'"] unfolding cong_int_def mult.assoc by auto
  moreover have "y \<in> {0 .. int p - 1}" unfolding y_def using p_ge_2 by auto
  hence "y \<in> S1" using calculation cong_altdef_int p_a_relprime S1_def by auto
  ultimately have "P x y" unfolding P_def by blast
  moreover {
    fix y1 y2
    assume "P x y1" "P x y2"
    moreover hence "[y1 = y2] (mod p)" unfolding P_def
      using co_xp cong_mult_lcancel_int[of x p y1 y2] cong_sym_int cong_trans_int by blast
    ultimately have "y1 = y2" unfolding P_def S1_def using cong_less_imp_eq_int by auto
  }
  ultimately show ?thesis by blast
qed

private lemma f_1_lemma_1: assumes "x \<in> S1"
  shows "P x (f_1 x)" using assms P_lemma theI'[of "P x"] f_1_def by presburger

private lemma f_1_lemma_2: assumes "x \<in> S1"
  shows "f_1 (f_1 x) = x"
  using assms f_1_lemma_1[of x] f_1_def P_lemma[of "f_1 x"] P_def by (auto simp: mult.commute)

private lemma f_lemma_1: assumes "x \<in> S1"
  shows "f x = f (f_1 x)" using f_def f_1_lemma_2[of x] assms by auto

private lemma l1: assumes "~ QuadRes p a" "x \<in> S1"
  shows "x \<noteq> f_1 x"
  using f_1_lemma_1[of x] assms unfolding P_def QuadRes_def power2_eq_square by fastforce

private lemma l2: assumes "~ QuadRes p a" "x \<in> S1"
  shows "[\<Prod> (f x) = a] (mod p)"
  using assms l1 f_1_lemma_1 P_def f_def by auto

private lemma l3: assumes "x \<in> S2"
  shows "finite x" using assms f_def S2_def by auto

private lemma l4: "S1 = \<Union> S2" using f_1_lemma_1 P_def f_def S2_def by auto

private lemma l5: assumes "x \<in> S2" "y \<in> S2" "x \<noteq> y"
  shows "x \<inter> y = {}"
proof -
  obtain a b where ab: "x = f a" "a \<in> S1" "y = f b" "b \<in> S1" using assms S2_def by auto
  hence "a \<noteq> b" "a \<noteq> f_1 b" "f_1 a \<noteq> b" using assms(3) f_lemma_1 by blast+
  moreover hence "f_1 a \<noteq> f_1 b" using f_1_lemma_2[of a] f_1_lemma_2[of b] ab by force
  ultimately show ?thesis using f_def ab by fastforce
qed

private lemma l6: "prod Prod S2 = \<Prod> S1"
  using prod.Union_disjoint[of S2 "\<lambda>x. x"] l3 l4 l5 unfolding comp_def by auto

private lemma l7: "fact n = \<Prod> {0 <.. int n}"
proof (induction n)
case (Suc n)
  have "int (Suc n) = int n + 1" by simp
  hence "insert (int (Suc n)) {0<..int n} = {0<..int (Suc n)}" by auto
  thus ?case using prod.insert[of "{0<..int n}" "int (Suc n)" "\<lambda>x. x"] Suc fact_Suc by auto
qed simp

private lemma l8: "fact (p - 1) = \<Prod> S1" using l7[of "p - 1"] S1_def p_minus_1_int by presburger

private lemma l9: "[prod Prod S2 = -1] (mod p)"
  using l6 l8 wilson_theorem[of p] p_prime by presburger

private lemma l10: assumes "card S = n" "\<And>x. x \<in> S \<Longrightarrow> [g x = a] (mod p)"
  shows "[prod g S = a ^ n] (mod p)" using assms
proof (induction n arbitrary: S)
case 0
  thus ?case using card_0_eq[of S] prod.empty prod.infinite by fastforce
next
case (Suc n)
  then obtain x where x: "x \<in> S" by force
  define S' where "S' = S - {x}"
  hence "[prod g S' = a ^ n] (mod int p)"
    using x Suc(1)[of S'] Suc(2) Suc(3) by (simp add: card_ge_0_finite)
  moreover have "prod g S = g x * prod g S'"
    using x S'_def Suc(2) prod.remove[of S x g] by fastforce
  ultimately show ?case using x Suc(3) cong_mult_int by simp
qed

private lemma l11: assumes "~ QuadRes p a"
  shows "card S2 = (p - 1) div 2"
proof -
  have "sum card S2 = 2 * card S2"
    using sum.cong[of S2 S2 card "\<lambda>x. 2"] l1 f_def S2_def assms by fastforce
  moreover have "p - 1 = sum card S2"
    using l4 card_UN_disjoint[of S2 "\<lambda>x. x"] l3 l5 S1_def S2_def by auto
  ultimately show ?thesis by linarith
qed

private lemma l12: assumes "~ QuadRes p a"
  shows "[prod Prod S2 = a ^ ((p - 1) div 2)] (mod p)"
  using assms l2 l10 l11 unfolding S2_def by blast

private lemma E_2: assumes "~ QuadRes p a"
  shows "[a ^ ((p - 1) div 2) = -1] (mod p)" using l9 l12 cong_trans_int cong_sym_int assms by blast

lemma euler_criterion_aux: "[(Legendre a p) = a ^ ((p - 1) div 2)] (mod p)"
  using E_1 E_2 Legendre_def cong_sym_int p_a_relprime by presburger

end

theorem euler_criterion: assumes "prime p" "2 < p"
  shows "[(Legendre a p) = a ^ ((p - 1) div 2)] (mod p)"
proof (cases "[a = 0] (mod p)")
case True
  hence "[a ^ ((p - 1) div 2) = 0 ^ ((p - 1) div 2)] (mod p)" using cong_exp_int by blast
  moreover have "(0::int) ^ ((p - 1) div 2) = 0" using zero_power[of "(p - 1) div 2"] assms(2) by simp
  ultimately have "[a ^ ((p - 1) div 2) = 0] (mod p)" using cong_trans_int cong_refl_int by presburger
  thus ?thesis unfolding Legendre_def using True cong_sym_int by presburger
next
case False
  thus ?thesis using euler_criterion_aux assms by presburger
qed

hide_fact euler_criterion_aux

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_pow_times
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
"times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun formulapow3 :: "Nat => Nat => Nat" where
"formulapow3 x (Z) = S Z"
| "formulapow3 x (S z) = times x (formulapow3 x z)"

fun formulapow2 :: "Nat => Nat => Nat" where
"formulapow2 x (Z) = S Z"
| "formulapow2 x (S z) = times x (formulapow2 x z)"

fun formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

theorem property0 :
  "((formulapow x (plus y z)) =
      (times (formulapow2 x y) (formulapow3 x z)))"
  oops

end


(*  File:       Elimination_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Elimination Module\<close>

theory Elimination_Module
  imports Evaluation_Function
          Electoral_Module
begin

text
\<open>This is the elimination module. It rejects a set of alternatives only if these
are not all alternatives. The alternatives potentially to be rejected are put
in a so-called elimination set. These are all alternatives that score below
a preset threshold value that depends on the specific voting rule.\<close>

subsection \<open>Definition\<close>

type_synonym Threshold_Value = nat

type_synonym Threshold_Relation = "nat \<Rightarrow> nat \<Rightarrow> bool"

type_synonym 'a Electoral_Set = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a set"

fun elimination_set :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Set" where
 "elimination_set e t r A p vs = {a \<in> A . r (e a A p vs) t }"

fun elimination_module :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Module" where
  "elimination_module e t r A p vs =
      (if (elimination_set e t r A p vs) \<noteq> A
        then ({}, (elimination_set e t r A p vs), A - (elimination_set e t r A p vs))
        else ({},{},A))"

subsection \<open>Common Eliminators\<close>

fun less_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "less_eliminator e t A p vs = elimination_module e t (<) A p vs"

fun max_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "max_eliminator e A p vs =
    less_eliminator e (Max {e x A p vs | x. x \<in> A}) A p vs"

fun leq_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "leq_eliminator e t A p vs = elimination_module e t (\<le>) A p vs"

fun min_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "min_eliminator e A p vs =
    leq_eliminator e (Min {e x A p vs | x. x \<in> A}) A p vs"

fun average :: "'a Evaluation_Function \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow>
                    Threshold_Value" where
  "average e A p vs = (\<Sum>x \<in> A. e x A p vs) div (card A)"

fun less_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "less_average_eliminator e A p vs = less_eliminator e (average e A p vs) A p vs"

fun leq_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "leq_average_eliminator e A p vs = leq_eliminator e (average e A p vs) A p vs"

subsection \<open>Soundness\<close>

lemma elim_mod_sound[simp]: "electoral_module (elimination_module e t r)"
proof (unfold electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  have "set_equals_partition A (elimination_module e t r A p vs)"
    by auto
  thus "well_formed A (elimination_module e t r A p vs)"
    by simp
qed

lemma less_elim_sound[simp]: "electoral_module (less_eliminator e t)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs < t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs < t} \<union> A = A"
    by safe
qed

lemma leq_elim_sound[simp]: "electoral_module (leq_eliminator e t)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs \<le> t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs \<le> t} \<union> A = A"
    by safe
qed

lemma max_elim_sound[simp]: "electoral_module (max_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs < Max {e x A p vs |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs < Max {e x A p vs |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma min_elim_sound[simp]: "electoral_module (min_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs \<le> Min {e x A p vs |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs \<le> Min {e x A p vs |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma less_avg_elim_sound[simp]: "electoral_module (less_average_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs < (\<Sum>x\<in>A. e x A p vs) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs < (\<Sum>x\<in>A. e x A p vs) div card A} \<union> A = A"
    by safe
qed

lemma leq_avg_elim_sound[simp]: "electoral_module (leq_average_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors"
  show
    "{a \<in> A. e a A p vs\<le> (\<Sum>x\<in>A. e x A p vs) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p vs\<le> (\<Sum>x\<in>A. e x A p vs) div card A} \<union> A = A"
    by safe
qed

subsection \<open>Non-Electing\<close>

lemma elim_mod_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (elimination_module e t r )"
  by (simp add: non_electing_def)

lemma less_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (less_eliminator e t)"
  using elim_mod_non_electing profile less_elim_sound
  by (simp add: non_electing_def)

lemma leq_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (leq_eliminator e t)"
proof -
  have "non_electing (elimination_module e t (\<le>))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma max_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (max_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma min_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (min_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma less_avg_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (less_average_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma leq_avg_elim_non_electing:
  assumes profile: "finite_profile A p" and vectors: "finite_pair_vectors A vs"
  shows "non_electing (leq_average_eliminator e)"
proof -
  have "non_electing (elimination_module e t (\<le>))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

subsection \<open>Inference Rules\<close>

(*** If the used evaluation function is Condorcet rating,
     max-eliminator is Condorcet compatible. ***)
theorem cr_eval_imp_ccomp_max_elim[simp]:
  assumes
    profile: "finite_profile A p" and
    rating: "condorcet_rating e"
  shows
    "condorcet_compatibility (max_eliminator e)"
  unfolding condorcet_compatibility_def
proof (auto)
  have f1:
    "\<And>A p w x vs. condorcet_winner A p w \<Longrightarrow>
      finite A \<Longrightarrow> w \<in> A \<Longrightarrow> e w A p vs < Max {e x A p vs |x. x \<in> A} \<Longrightarrow>
        x \<in> A \<Longrightarrow> e x A p vs < Max {e x A p vs |x. x \<in> A}"
    using rating
    by (simp add: cond_winner_imp_max_eval_val)
  thus
    "\<And>A p w x vs.
      profile A p \<Longrightarrow> w \<in> A \<Longrightarrow>
        \<forall>x\<in>A - {w}.
          card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)} \<Longrightarrow>
              finite A \<Longrightarrow> e w A p vs< Max {e x A p vs| x. x \<in> A} \<Longrightarrow>
                x \<in> A \<Longrightarrow> e x A p vs< Max {e x A p vs| x. x \<in> A}"
    by simp
qed

lemma cr_eval_imp_dcc_max_elim_helper1:
  assumes
    f_prof: "finite_profile A p" and
    rating: "condorcet_rating e" and
    winner: "condorcet_winner A p w" and
    vectors: "finite_pair_vectors A vs"
  shows "elimination_set e (Max {e x A p vs | x. x \<in> A}) (<) A p vs = A - {w}"
proof (safe, simp_all, safe)
  assume
    w_in_A: "w \<in> A" and
    max: "e w A p vs< Max {e x A p vs|x. x \<in> A}"
  show "False"
    using cond_winner_imp_max_eval_val
          rating winner f_prof max
    by fastforce
next
  fix
    x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    not_max: "\<not> e x A p vs< Max {e y A p vs|y. y \<in> A}"
  show "x = w"
    using non_cond_winner_not_max_eval x_in_A
          rating winner f_prof not_max vectors
    by (metis (mono_tags, lifting))
qed

(*
  If the used evaluation function is Condorcet rating, max-eliminator
  is defer-Condorcet-consistent.
*)
theorem cr_eval_imp_dcc_max_elim[simp]:
  assumes rating: "condorcet_rating e"
  shows "defer_condorcet_consistency (max_eliminator e)"
  unfolding defer_condorcet_consistency_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    w :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    finite: "finite A" and
    vectors: "vector_pair A vs"
  let ?trsh = "(Max {e y A p vs| y. y \<in> A})"
  show
    "max_eliminator e A p vs=
      ({},
        A - defer (max_eliminator e) A p vs,
        {a \<in> A. condorcet_winner A p a})"
  proof (cases "elimination_set e (?trsh) (<) A p vs \<noteq> A")
    case True
    have profile: "finite_profile A p"
      using winner
      by simp
    with rating winner have 0:
      "(elimination_set e ?trsh (<) A p vs) = A - {w}"
      using cr_eval_imp_dcc_max_elim_helper1 profile vectors
      by (metis (mono_tags, lifting))
    have
      "max_eliminator e A p vs=
        ({},
          (elimination_set e ?trsh (<) A p vs),
          A - (elimination_set e ?trsh (<) A p vs))"
      using True
      by simp
    also have "... = ({}, A - {w}, A - (A - {w}))"
      using "0"
      by presburger
    also have "... = ({}, A - {w}, {w})"
      using winner
      by auto
    also have "... = ({},A - defer (max_eliminator e) A p vs, {w})"
      using calculation
      by auto
    also have
      "... =
        ({},
          A - defer (max_eliminator e) A p vs,
          {d \<in> A. condorcet_winner A p d})"
      using cond_winner_unique3 winner Collect_cong
      by (metis (no_types, lifting))
    finally show ?thesis
      using finite winner
      by metis
  next
    case False
    thus ?thesis
    proof -
      have f1:
        "finite A \<and> profile A p \<and> w \<in> A \<and> (\<forall>a. a \<notin> A - {w} \<or> wins w p a)"
        using winner
        by auto
      hence
        "?trsh = e w A p vs"
        using rating winner
        by (simp add: cond_winner_imp_max_eval_val)
      hence False
        using f1 False
        by auto
      thus ?thesis
        by simp
    qed
  qed
qed

end


(*  Author:     Tobias Nipkow, 2007

A simple certificate based checker for q-free dlo formulae.
Certificate is cycle.
*)

theory CertDlo
imports QEdlo
begin

fun cyclerec :: "nat \<Rightarrow> nat \<Rightarrow> atom list \<Rightarrow> bool" where
"cyclerec i j [] = (i=j)" |
"cyclerec i j (Less m n # fs) = (j=m \<and> cyclerec i n fs)" |
"cyclerec i j (Eq m n # fs) = (if j=m then cyclerec i n fs
                               else if j=n then cyclerec i m fs else False)"

definition cycle :: "atom list \<Rightarrow> nat list \<Rightarrow> bool" where
"cycle fs is =
 ((\<forall>i\<in>set is. i < length fs) \<and>
  (case map (nth fs) is of Less i j # fs' \<Rightarrow> cyclerec i j fs' | _ \<Rightarrow> False))"

definition
"cyclic_dnf ass = (\<exists>iss. list_all2 cycle ass iss)"

lemma refute_I:
  "\<not> Logic.interpret h (Neg f) e \<Longrightarrow> Logic.interpret h f e"
by simp

lemma cyclerecD: fixes xs :: "'a :: dlo list" shows
 "\<lbrakk> cyclerec i j as; xs!i < xs!j\<rbrakk> \<Longrightarrow> \<exists>a\<in>set as. \<not> I\<^sub>d\<^sub>l\<^sub>o a xs"
apply(induct as arbitrary: j)
 apply (simp)
apply(case_tac a)
apply(auto split:if_split_asm)
done

lemma cycleD: fixes xs :: "'a :: dlo list" shows
 "cycle as is \<Longrightarrow> \<not> DLO.I (list_conj (map Atom as)) xs"
apply rule
apply (simp add:cycle_def map_eq_Cons_conv split:list.splits atom.splits)
apply auto
apply(drule_tac xs = xs in cyclerecD)
apply(drule_tac x = "as!z" in bspec)
apply (erule nth_mem)
apply fastforce
apply fastforce
done

lemma cyclic_dnfD: "qfree f \<Longrightarrow> cyclic_dnf (dnf(DLO.nnf f)) \<Longrightarrow> \<not>DLO.I f xs"
apply(subst DLO.I_nnf[unfolded nnf_def, symmetric])
apply(subst DLO.I_dnf[symmetric])
apply(erule DLO.nqfree_nnf[unfolded nnf_def])
apply(auto simp add:cyclic_dnf_def list_all2_iff in_set_conv_nth)
apply(drule_tac x="(dnf(DLO.nnf f) ! i, iss!i)" in bspec)
apply (auto simp:set_zip)
apply(drule_tac xs=xs in cycleD)
apply auto
done

end


(*<*)
theory Basis
imports
  Main
  "HOL-Library.While_Combinator"
begin

(*>*)
section\<open> Preliminaries \<close>

(*>*)(*<*)

subsection\<open> HOL Detritus \<close>

lemma Above_union:
  shows "x \<in> Above r (X \<union> Y) \<longleftrightarrow> x \<in> Above r X \<and> x \<in> Above r Y"
unfolding Above_def by blast

lemma Above_Field:
  assumes "x \<in> Above r X"
  shows "x \<in> Field r"
using assms unfolding Above_def by blast

lemma AboveS_Field:
  assumes "x \<in> AboveS r X"
  shows "x \<in> Field r"
using assms unfolding AboveS_def by blast

lemma Above_Linear_singleton:
  assumes "x \<in> Field r"
  assumes "Linear_order r"
  shows "x \<in> Above r {x}"
using assms unfolding Above_def order_on_defs by (force dest: refl_onD)

lemma subseqs_set:
  assumes "y \<in> set (subseqs xs)"
  shows "set y \<subseteq> set xs"
using assms by (metis Pow_iff image_eqI subseqs_powset)

primrec map_of_default :: "'v \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> 'k \<Rightarrow> 'v" where
  "map_of_default v0 [] k = v0"
| "map_of_default v0 (kv # kvs) k = (if k = fst kv then snd kv else map_of_default v0 kvs k)"

lemmas set_elem_equalityI = Set.equalityI[OF Set.subsetI Set.subsetI]

lemmas total_onI = iffD2[OF total_on_def, rule_format]

lemma partial_order_on_acyclic:
  assumes "partial_order_on A r"
  shows "acyclic (r - Id)"
by (metis acyclic_irrefl assms irrefl_diff_Id partial_order_on_def preorder_on_def trancl_id trans_diff_Id)

lemma finite_Linear_order_induct[consumes 3, case_names step]:
  assumes "Linear_order r"
  assumes "x \<in> Field r"
  assumes "finite r"
  assumes step: "\<And>x. \<lbrakk>x \<in> Field r; \<And>y. y \<in> aboveS r x \<Longrightarrow> P y\<rbrakk> \<Longrightarrow> P x"
  shows "P x"
using assms(2)
proof(induct rule: wf_induct[of "r\<inverse> - Id"])
  from assms(1,3) show "wf (r\<inverse> - Id)"
    using linear_order_on_well_order_on linear_order_on_converse
    unfolding well_order_on_def by blast
next
  case (2 x) then show ?case
    by - (rule step; auto simp: aboveS_def intro: FieldI2)
qed

text\<open>

We sometimes want a notion of monotonicity over some set.

\<close>

definition mono_on :: "'a::order set \<Rightarrow> ('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "mono_on A f = (\<forall>x\<in>A. \<forall>y\<in>A. x \<le> y \<longrightarrow> f x \<le> f y)"

lemmas mono_onI = iffD2[OF mono_on_def, rule_format]
lemmas mono_onD = iffD1[OF mono_on_def, rule_format]

lemma mono_onE:
  "\<lbrakk>mono_on A f; x \<in> A; y \<in> A; x \<le> y; f x \<le> f y \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis"
using mono_onD by blast

lemma mono_on_mono:
  "mono_on UNIV = mono"
by (clarsimp simp: mono_on_def mono_def fun_eq_iff)

(*>*)
subsection\<open> MaxR: maximum elements of linear orders \<close>

text\<open>

We generalize the existing @{const "max"} and @{const "Max"} functions
to work on orders defined over sets. See \S\ref{sec:cf-linear} for
choice-function related lemmas.

\<close>

locale MaxR =
  fixes r :: "'a::finite rel"
  assumes r_Linear_order: "Linear_order r"
begin

text\<open>

The basic function chooses the largest of two elements:

\<close>

definition maxR :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "maxR x y = (if (x, y) \<in> r then y else x)"
(*<*)

lemma maxR_domain:
  shows "{x, y} \<subseteq> A \<Longrightarrow> maxR x y \<in> A"
unfolding maxR_def by simp

lemma maxR_range:
  shows "maxR x y \<in> {x, y}"
unfolding maxR_def by simp

lemma maxR_rangeD:
  "maxR x y \<noteq> x \<Longrightarrow> maxR x y = y"
  "maxR x y \<noteq> y \<Longrightarrow> maxR x y = x"
unfolding maxR_def by auto

lemma maxR_idem:
  shows "maxR x x = x"
unfolding maxR_def by simp

lemma maxR_absorb2:
  shows "(x, y) \<in> r \<Longrightarrow> maxR x y = y"
unfolding maxR_def by simp

lemma maxR_absorb1:
  shows "(y, x) \<in> r \<Longrightarrow> maxR x y = x"
using r_Linear_order unfolding maxR_def by (simp add: order_on_defs antisym_def)

lemma maxR_assoc:
  shows "{x,y,z} \<subseteq> Field r \<Longrightarrow> maxR (maxR x y) z = maxR x (maxR y z)"
using r_Linear_order unfolding maxR_def by simp (metis order_on_defs(1-3) total_on_def trans_def)

lemma maxR_commute:
  shows "{x,y} \<subseteq> Field r \<Longrightarrow> maxR x y = maxR y x"
using r_Linear_order unfolding maxR_def by (fastforce simp: order_on_defs antisym_def total_on_def)

lemmas maxR_simps =
  maxR_idem
  maxR_absorb1
  maxR_absorb2

(*>*)
text\<open>

We hoist this to finite sets using the @{const "Finite_Set.fold"}
combinator. For code generation purposes it seems inevitable that we
need to fuse the fold and filter into a single total recursive
definition.

\<close>

definition MaxR_f :: "'a \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "MaxR_f x acc = (if x \<in> Field r then Some (case acc of None \<Rightarrow> x | Some y \<Rightarrow> maxR x y) else acc)"

interpretation MaxR_f: comp_fun_idem MaxR_f
using %invisible r_Linear_order
by unfold_locales (fastforce simp: fun_eq_iff maxR_def MaxR_f_def order_on_defs total_on_def antisymD elim: transE split: option.splits)+

definition MaxR_opt :: "'a set \<Rightarrow> 'a option" where
  MaxR_opt_eq_fold': "MaxR_opt A = Finite_Set.fold MaxR_f None A"
(*<*)

lemma empty [simp]:
  shows "MaxR_opt {} = None"
by (simp add: MaxR_opt_eq_fold')

lemma
  shows insert: "MaxR_opt (insert x A) = (if x \<in> Field r then Some (case MaxR_opt A of None \<Rightarrow> x | Some y \<Rightarrow> maxR x y) else MaxR_opt A)"
    and range_Some[rule_format]: "MaxR_opt A = Some a \<longrightarrow> a \<in> A \<inter> Field r"
using finite[of A] by induct (auto simp: MaxR_opt_eq_fold' maxR_def MaxR_f_def split: option.splits)

lemma range_None:
  assumes "MaxR_opt A = None"
  shows "A \<inter> Field r = {}"
using assms by (metis Int_iff insert all_not_in_conv insert_absorb option.simps(3))

lemma domain_empty:
  assumes "A \<inter> Field r = {}"
  shows "MaxR_opt A = None"
using assms by (metis empty_iff option.exhaust range_Some)

lemma domain:
  shows "MaxR_opt (A \<inter> Field r) = MaxR_opt A"
using finite[of A] by induct (simp_all add: insert)

lemmas MaxR_opt_code = MaxR_opt_eq_fold'[where A="set A", unfolded MaxR_f.fold_set_fold] for A

lemma range:
  shows "MaxR_opt A \<in> Some ` (A \<inter> Field r) \<union> {None}"
using range_Some notin_range_Some by fastforce

lemma union:
  shows "MaxR_opt (A \<union> B) = (case MaxR_opt A of None \<Rightarrow> MaxR_opt B | Some mA \<Rightarrow> Some (case MaxR_opt B of None \<Rightarrow> mA | Some mB \<Rightarrow> maxR mA mB))"
using finite[of A] by induct (auto simp: maxR_assoc insert dest!: range_Some split: option.splits)

lemma mono:
  assumes "MaxR_opt A = Some x"
  shows "\<exists>y. MaxR_opt (A \<union> B) = Some y \<and> (x, y) \<in> r"
using finite[of B]
proof induct
  case empty with assms show ?case
    using range_Some underS_incl_iff[OF r_Linear_order] by fastforce
next
  note ins = insert
  case (insert b B) with assms r_Linear_order show ?case
    unfolding order_on_defs total_on_def by (fastforce simp: ins maxR_def elim: transE intro: FieldI1)
qed

lemma MaxR_opt_is_greatest:
  assumes "MaxR_opt A = Some x"
  assumes "y \<in> A \<inter> Field r"
  shows "(y, x) \<in> r"
using finite[of A] assms
proof(induct arbitrary: x)
  note ins = insert
  case (insert a A) then show ?case
    using r_Linear_order unfolding order_on_defs refl_on_def total_on_def
    by (auto 10 0 simp: maxR_def ins dest!: range_None range_Some split: if_splits option.splits elim: transE)
qed simp

lemma greatest_is_MaxR_opt:
  assumes "x \<in> A \<inter> Field r"
  assumes "\<forall>y \<in> A \<inter> Field r. (y, x) \<in> r"
  shows "MaxR_opt A = Some x"
using finite[of A] assms
proof(induct arbitrary: x)
  note ins = insert
  case (insert a A) then show ?case
    using maxR_absorb1 maxR_absorb2
    by (fastforce simp: maxR_def ins dest: range_None range_Some split: option.splits)
qed simp

(*>*)

end

interpretation MaxR_empty: MaxR "{}"
by unfold_locales simp

interpretation MaxR_singleton: MaxR "{(x,x)}" for x
by unfold_locales simp

lemma MaxR_r_domain [iff]:
  assumes "MaxR r"
  shows "MaxR (Restr r A)"
using assms Linear_order_Restr unfolding MaxR_def by blast

subsection\<open> Linear orders from lists \<close>

text\<open>

Often the easiest way to specify a concrete linear order is with a
list. Here these run from greatest to least.

\<close>

primrec linord_of_listP :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "linord_of_listP x y [] \<longleftrightarrow> False"
| "linord_of_listP x y (z # zs) \<longleftrightarrow> (z = y \<and> x \<in> set (z # zs)) \<or> linord_of_listP x y zs"

definition linord_of_list :: "'a list \<Rightarrow> 'a rel" where
  "linord_of_list xs \<equiv> {(x, y). linord_of_listP x y xs}"

(*<*)

lemma linord_of_list_linord_of_listP:
  shows "xy \<in> linord_of_list xs \<longleftrightarrow> linord_of_listP (fst xy) (snd xy) xs"
unfolding linord_of_list_def split_def by simp

lemma linord_of_listP_linord_of_list:
  shows "linord_of_listP x y xs \<longleftrightarrow> (x, y) \<in> linord_of_list xs"
unfolding linord_of_list_def by simp

lemma linord_of_listP_empty:
  shows "(\<forall>x y. \<not>linord_of_listP x y xs) \<longleftrightarrow> xs = []"
by (metis linord_of_listP.simps list.exhaust list.set_intros(1))

lemma linord_of_listP_domain:
  assumes "linord_of_listP x y xs"
  shows "x \<in> set xs \<and> y \<in> set xs"
using assms by (induct xs) auto

lemma linord_of_list_empty[iff]:
  "linord_of_list [] = {}"
  "linord_of_list xs = {} \<longleftrightarrow> xs = []"
unfolding linord_of_list_def by (simp_all add: linord_of_listP_empty)

lemma linord_of_list_singleton:
  "(x, y) \<in> linord_of_list [z] \<longleftrightarrow> x = z \<and> y = z"
by (force simp: linord_of_list_linord_of_listP)

lemma linord_of_list_range:
  "linord_of_list xs \<subseteq> set xs \<times> set xs"
unfolding linord_of_list_def by (induct xs) auto

lemma linord_of_list_Field [simp]:
  "Field (linord_of_list xs) = set xs"
unfolding linord_of_list_def by (induct xs) (auto simp: Field_def)

lemma linord_of_listP_append:
  "linord_of_listP x y (xs @ ys) \<longleftrightarrow> linord_of_listP x y xs \<or> linord_of_listP x y ys \<or> (y \<in> set xs \<and> x \<in> set ys)"
by (induct xs) auto

lemma linord_of_list_append:
  "(x, y) \<in> linord_of_list (xs @ ys) \<longleftrightarrow> (x, y) \<in> linord_of_list xs \<or> (x, y) \<in> linord_of_list ys \<or> (y \<in> set xs \<and> x \<in> set ys)"
unfolding linord_of_list_def by (simp add: linord_of_listP_append)

lemma linord_of_list_refl_on:
  shows "refl_on (set xs) (linord_of_list xs)"
unfolding linord_of_list_def
by (induct xs) (auto intro!: refl_onI simp: refl_onD1 refl_onD2 dest: refl_onD subsetD[OF linord_of_list_range])

lemma linord_of_list_trans:
  assumes "distinct xs"
  shows "trans (linord_of_list xs)"
using assms unfolding linord_of_list_def
by (induct xs) (auto intro!: transI dest: linord_of_listP_domain elim: transE)

lemma linord_of_list_antisym:
  assumes "distinct xs"
  shows "antisym (linord_of_list xs)"
using assms unfolding linord_of_list_def
by (induct xs) (auto intro!: antisymI dest: linord_of_listP_domain simp: antisymD)

lemma linord_of_list_total_on:
  shows "total_on (set xs) (linord_of_list xs)"
unfolding total_on_def linord_of_list_def by (induct xs) auto

lemma linord_of_list_Restr:
  assumes "x \<notin> C"
  notes in_set_remove1[simp del] (* suppress warning *)
  shows "Restr (linord_of_list (remove1 x xs)) C = Restr (linord_of_list xs) C"
using assms unfolding linord_of_list_def by (induct xs) (auto iff: in_set_remove1)

lemma linord_of_list_nth:
  assumes "(xs ! i, xs ! j) \<in> linord_of_list xs"
  assumes "i < length xs" "j < length xs"
  assumes "distinct xs"
  shows "j \<le> i"
using %invisible assms
proof(induct xs arbitrary: i j)
  case (Cons x xs i j) show ?case
  proof(cases "i < length xs")
    case True with Cons show ?thesis
      by (auto simp: linord_of_list_linord_of_listP nth_equal_first_eq less_Suc_eq_0_disj linord_of_listP_domain)
  next
    case False with Cons show ?thesis by fastforce
  qed
qed simp

(*>*)
text\<open>\<close>

lemma linord_of_list_Linear_order:
  assumes "distinct xs"
  assumes "ys = set xs"
  shows "linear_order_on ys (linord_of_list xs)"
using %invisible assms linord_of_list_range linord_of_list_refl_on linord_of_list_trans linord_of_list_antisym linord_of_list_total_on
unfolding order_on_defs by force

text\<open>

Every finite linear order is generated by a list.

\<close>

(*<*)

inductive sorted_on :: "'a rel \<Rightarrow> 'a list \<Rightarrow> bool" where
  Nil [iff]: "sorted_on r []"
| Cons [intro!]: "\<lbrakk>x \<in> Field r; \<forall>y\<in>set xs. (x, y) \<in> r; sorted_on r xs\<rbrakk> \<Longrightarrow> sorted_on r (x # xs)"

inductive_cases sorted_on_inv[elim!]:
  "sorted_on r []"
  "sorted_on r (x # xs)"

primrec insort_key_on :: "'a rel \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "insort_key_on r f x [] = [x]"
| "insort_key_on r f x (y # ys) =
    (if (f x, f y) \<in> r then (x # y # ys) else y # insort_key_on r f x ys)"

definition sort_key_on :: "'a rel \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "sort_key_on r f xs = foldr (insort_key_on r f) xs []"

definition insort_insert_key_on :: "'a rel \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "insort_insert_key_on r f x xs =
    (if f x \<in> f ` set xs then xs else insort_key_on r f x xs)"

abbreviation "sort_on r \<equiv> sort_key_on r (\<lambda>x. x)"
abbreviation "insort_on r \<equiv> insort_key_on r (\<lambda>x. x)"
abbreviation "insort_insert_on r \<equiv> insort_insert_key_on r (\<lambda>x. x)"

context
  fixes r :: "'a rel"
  assumes "Linear_order r"
begin

lemma sorted_on_single [iff]:
  shows "sorted_on r [x] \<longleftrightarrow> x \<in> Field r"
by (metis empty_iff list.distinct(1) list.set(1) nth_Cons_0 sorted_on.simps)

lemma sorted_on_many:
  assumes "(x, y) \<in> r"
  assumes "sorted_on r (y # zs)"
  shows "sorted_on r (x # y # zs)"
using assms \<open>Linear_order r\<close> unfolding order_on_defs by (auto elim: transE intro: FieldI1)

lemma sorted_on_Cons:
  shows "sorted_on r (x # xs) \<longleftrightarrow> (x \<in> Field r \<and> sorted_on r xs \<and> (\<forall>y\<in>set xs. (x, y) \<in> r))"
using \<open>Linear_order r\<close> unfolding order_on_defs by (induct xs arbitrary: x) (auto elim: transE)

lemma sorted_on_distinct_set_unique:
  assumes "sorted_on r xs" "distinct xs" "sorted_on r ys" "distinct ys" "set xs = set ys"
  shows "xs = ys"
proof -
  from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  from assms show ?thesis
  proof(induct rule: list_induct2[OF 1])
    case (2 x xs y ys) with \<open>Linear_order r\<close> show ?case
      unfolding order_on_defs
        by (simp add: sorted_on_Cons) (metis antisymD insertI1 insert_eq_iff)
  qed simp
qed

lemma set_insort_on:
  shows "set (insort_key_on r f x xs) = insert x (set xs)"
by (induct xs) auto

lemma sort_key_on_simps [simp]:
  shows "sort_key_on r f [] = []"
        "sort_key_on r f (x#xs) = insort_key_on r f x (sort_key_on r f xs)"
by (simp_all add: sort_key_on_def)

lemma set_sort_on [simp]:
  shows "set (sort_key_on r f xs) = set xs"
by (induct xs) (simp_all add: set_insort_on)

lemma distinct_insort_on:
  shows "distinct (insort_key_on r f x xs) = (x \<notin> set xs \<and> distinct xs)"
by(induct xs) (auto simp: set_insort_on)

lemma distinct_sort_on [simp]:
  shows "distinct (sort_key_on r f xs) = distinct xs"
by (induct xs) (simp_all add: distinct_insort_on)

lemma sorted_on_insort_key_on:
  assumes "f ` set (x # xs) \<subseteq> Field r"
  shows "sorted_on r (map f (insort_key_on r f x xs)) = sorted_on r (map f xs)"
using assms
proof(induct xs)
  case (Cons x xs) with \<open>Linear_order r\<close> show ?case
    unfolding order_on_defs
    by (auto 4 4 simp: sorted_on_Cons sorted_on_many set_insort_on refl_on_def total_on_def elim: transE)
qed simp

lemma sorted_on_insort_on:
  assumes "set (x # xs) \<subseteq> Field r"
  shows "sorted_on r (insort_on r x xs) = sorted_on r xs"
using sorted_on_insort_key_on[where f="\<lambda>x. x"] assms by simp

theorem sorted_on_sort_key_on [simp]:
  assumes "f ` set xs \<subseteq> Field r"
  shows "sorted_on r (map f (sort_key_on r f xs))"
using assms by (induct xs) (simp_all add: sorted_on_insort_key_on)

theorem sorted_on_sort_on [simp]:
  assumes "set xs \<subseteq> Field r"
  shows "sorted_on r (sort_on r xs)"
using sorted_on_sort_key_on[where f="\<lambda>x. x"] assms by simp

lemma finite_sorted_on_distinct_unique:
  assumes "A \<subseteq> Field r"
  assumes "finite A"
  shows "\<exists>!xs. set xs = A \<and> sorted_on r xs \<and> distinct xs"
proof -
  from \<open>finite A\<close> obtain xs where "set xs = A \<and> distinct xs"
    using finite_distinct_list by blast
  with \<open>A \<subseteq> Field r\<close> show ?thesis
    by (fastforce intro!: ex1I[where a="sort_on r xs"] simp: sorted_on_distinct_set_unique)
qed

end

lemma sorted_on_linord_of_list_subseteq_r:
  assumes "Linear_order r"
  assumes "sorted_on r xs"
  assumes "distinct xs"
  shows "linord_of_list (rev xs) \<subseteq> r"
using assms
proof(induct xs)
  case (Cons x xs)
  then have "linord_of_list (rev xs) \<subseteq> r" by (simp add: sorted_on_Cons)
  with Cons.prems show ?case
    by (clarsimp simp: linord_of_list_append linord_of_list_singleton sorted_on_Cons)
       (meson contra_subsetD subsetI underS_incl_iff)
qed simp

lemma sorted_on_linord_of_list:
  assumes "Linear_order r"
  assumes "set xs = Field r"
  assumes "sorted_on r xs"
  assumes "distinct xs"
  shows "linord_of_list (rev xs) = r"
proof(rule equalityI)
  from assms show "linord_of_list (rev xs) \<subseteq> r"
    using sorted_on_linord_of_list_subseteq_r by blast
next
  { fix x y assume xy: "(x, y) \<in> r"
    with \<open>Linear_order r\<close> have "(y, x) \<notin> r - Id"
      using Linear_order_in_diff_Id by (fastforce intro: FieldI1)
    with linord_of_list_Linear_order[of "rev xs" "Field r"] assms xy
    have "(x, y) \<in> linord_of_list (rev xs)"
      by simp (metis Diff_subset FieldI1 FieldI2 Linear_order_in_diff_Id linord_of_list_Field set_rev sorted_on_linord_of_list_subseteq_r subset_eq) }
  then show "r \<subseteq> linord_of_list (rev xs)" by clarsimp
qed

lemma linord_of_listP_rev:
  assumes "z # zs \<in> set (subseqs xs)"
  assumes "y \<in> set zs"
  shows "linord_of_listP z y (rev xs)"
using assms by (induct xs) (auto simp: Let_def linord_of_listP_append dest: subseqs_set)

lemma linord_of_list_sorted_on_subseqs:
  assumes "ys \<in> set (subseqs xs)"
  assumes "distinct xs"
  shows "sorted_on (linord_of_list (rev xs)) ys"
using assms
proof(induct ys)
  case (Cons y ys) then show ?case
    using linord_of_list_Linear_order[where xs="rev xs" and ys="Field (linord_of_list (rev xs))"]
    by (force simp: Cons_in_subseqsD sorted_on_Cons linord_of_list_linord_of_listP linord_of_listP_rev dest: subseqs_set)
qed simp

lemma linord_of_list_sorted_on:
  assumes "distinct xs"
  shows "sorted_on (linord_of_list (rev xs)) xs"
by (rule linord_of_list_sorted_on_subseqs[OF subseqs_refl \<open>distinct xs\<close>])

(*>*)

lemma linear_order_on_list:
  assumes "linear_order_on ys r"
  assumes "ys = Field r"
  assumes "finite ys"
  shows "\<exists>!xs. r = linord_of_list xs \<and> distinct xs \<and> set xs = ys"
using %invisible finite_sorted_on_distinct_unique[of r ys] sorted_on_linord_of_list[of r] assms
by simp (metis distinct_rev linord_of_list_sorted_on rev_rev_ident set_rev)

(*<*)

end
(*>*)


theory sort_ISortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster insert2 isort and2 ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory T144
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T86
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end