theory IICF_Indexed_Array_List
imports
  "HOL-Library.Rewrite"
  "../Intf/IICF_List"
  "List-Index.List_Index"
  IICF_Array
  IICF_MS_Array_List
begin

  (* TODO: Move *)

  abbreviation "snatb_rel N \<equiv> b_rel snat_rel (\<lambda>x. x<N)"
  abbreviation "snatb_rel' TYPE('l::len2) N \<equiv> b_rel (snat_rel' TYPE('l)) (\<lambda>x. x<N)"
  abbreviation "snatb_assn N \<equiv> b_assn snat_assn (\<lambda>x. x<N)"
  abbreviation "snatb_assn' TYPE('l::len2) N \<equiv> (snatb_assn N :: _ \<Rightarrow> 'l word \<Rightarrow> _)"

  (* TODO: Move, clean up proof *)

  (* TODO: Move *)

  (*
  lemma range_snatb_conv: "Range (snatb_rel' TYPE('l) N) = {0..<N} \<inter> Range (snat_rel' TYPE('l::len2))"
    unfolding snatb_rel_def
    by (auto simp: range_comp_nbn_conv)

  lemma in_snatb_rel_bound: "(a,b)\<in>snatb_rel N \<Longrightarrow> b<N"
    by (simp add: in_snat_nbn_conv snatb_rel_def)
  *)

  text \<open>We implement distinct lists of natural numbers in the range @{text "{0..<N}"}
    by a length counter and two arrays of size @{text N}.
    The first array stores the list, and the second array stores the positions of
    the elements in the list, or @{text N} if the element is not in the list.

    This allows for an efficient index query.

    The implementation is done in two steps:
      First, we use a list and a fixed size list for the index mapping.
      Second, we refine the lists to arrays.
 \<close>

  type_synonym aial = "nat list \<times> nat option list"

  locale ial_invar = fixes
         maxsize :: nat
    and  l :: "nat list"
    and qp :: "nat option list"
    assumes maxsize_eq[simp]: "maxsize = length qp"
    assumes l_distinct[simp]: "distinct l"
    assumes l_set: "set l \<subseteq> {0..<length qp}"
    assumes qp_def: "\<forall>k<length qp. qp!k = (if k\<in>set l then Some (List_Index.index l k) else None)"
  begin
    lemma l_len: "length l \<le> length qp"
    proof -
      from card_mono[OF _ l_set] have "card (set l) \<le> length qp" by auto
      with distinct_card[OF l_distinct] show ?thesis by simp
    qed

    lemma idx_len[simp]: "i<length l \<Longrightarrow> l!i < length qp"
      using l_set
      by (metis atLeastLessThan_iff nth_mem psubsetD psubsetI)

    lemma l_set_simp[simp]: "k\<in>set l \<Longrightarrow> k < length qp"
      by (auto dest: set_mp[OF l_set])

    lemma qpk_idx: "k<length qp \<Longrightarrow> qp ! k \<noteq> None \<longleftrightarrow> k \<in> set l"
    proof (rule iffI)
      assume A: "k<length qp"
      {
        assume "qp!k \<noteq> None"
        with spec[OF qp_def, of k] A show "k\<in>set l"
          by (auto split: if_split_asm)
      }
      {
        assume "k\<in>set l"
        thus "qp!k\<noteq>None"
          using qp_def by (auto split: if_split_asm) []
      }
    qed

    lemma lqpk[simp]: "k \<in> set l \<Longrightarrow> l ! (the (qp ! k)) = k"
      using spec[OF qp_def, of k] by auto

    lemma "\<lbrakk>i<length l; j<length l; l!i=l!j\<rbrakk> \<Longrightarrow> i=j"
      by (simp add: nth_eq_iff_index_eq)

    lemmas index_swap[simp] = index_swap_if_distinct[folded swap_def, OF l_distinct]

    lemma swap_invar:
      assumes "i<length l" "j<length l"
      shows "ial_invar (length qp) (swap l i j) (qp[l ! j := Some i, l ! i := Some j])"
      using assms
      apply unfold_locales
      apply auto []
      apply auto []
      apply auto []
      apply (auto simp: simp: nth_list_update nth_eq_iff_index_eq index_nth_id) []
      using qp_def apply auto [2]
      done

  end

  definition "ial_rel1 maxsize \<equiv> br fst (uncurry (ial_invar maxsize))"

  definition op_ial_empty_sz :: "nat \<Rightarrow> 'a list"
    where [simp]: "op_ial_empty_sz ms \<equiv> op_list_empty"

  definition "aial_empty N \<equiv> do {
    let l = op_marl_empty N;
    let qp = op_array_custom_replicate N None;
    RETURN (l,qp)
  }"

  lemma aial_empty_refine: "(aial_empty N,RETURN op_list_empty) \<in> \<langle>ial_rel1 N\<rangle>nres_rel"
    unfolding aial_empty_def
    apply (refine_vcg nres_relI)
    apply (clarsimp simp: ial_rel1_def br_def)
    apply unfold_locales
    apply auto
    done

  definition "aial_swap \<equiv> \<lambda>(l,qp) i j. do {
    vi \<leftarrow> mop_list_get l i;
    vj \<leftarrow> mop_list_get l j;
    l \<leftarrow> mop_list_set l i vj;
    l \<leftarrow> mop_list_set l j vi;
    qp \<leftarrow> mop_list_set qp vj (Some i);
    qp \<leftarrow> mop_list_set qp vi (Some j);
    RETURN (l,qp)
  }"

  lemma in_ial_rel1_conv:
    "((pq, qp), l) \<in> ial_rel1 ms \<longleftrightarrow> pq=l \<and> ial_invar ms l qp"
    by (auto simp: ial_rel1_def in_br_conv)

  lemma aial_swap_refine:
    "(aial_swap,mop_list_swap) \<in> ial_rel1 maxsize \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
  proof (intro fun_relI nres_relI; clarsimp simp: in_ial_rel1_conv; refine_vcg; clarsimp)
    fix l qp i j
    assume [simp]: "i<length l" "j<length l" and "ial_invar maxsize l qp"
    then interpret ial_invar maxsize l qp by simp

    show "aial_swap (l, qp) i j \<le> SPEC (\<lambda>c. (c, swap l i j) \<in> ial_rel1 maxsize)"
      unfolding aial_swap_def
      apply refine_vcg
      apply (auto simp add: in_ial_rel1_conv swap_def[symmetric] swap_invar)
      done
  qed

  definition aial_length :: "aial \<Rightarrow> nat nres"
    where "aial_length \<equiv> \<lambda>(l,_). RETURN (op_list_length l)"

  lemma aial_length_refine: "(aial_length, mop_list_length) \<in> ial_rel1 maxsize \<rightarrow> \<langle>nbn_rel (maxsize+1)\<rangle>nres_rel"
    apply (intro fun_relI nres_relI)
    unfolding ial_rel1_def in_br_conv aial_length_def ial_invar_def
    apply (auto split: if_splits)
    by (meson ial_invar.intro ial_invar.l_len le_imp_less_Suc)

  definition aial_index :: "aial \<Rightarrow> nat \<Rightarrow> nat nres" where
    "aial_index \<equiv> \<lambda>(l,qp) k. do {
      ASSERT (k\<in>set l);
      i \<leftarrow> mop_list_get qp k;
      ASSERT (i\<noteq>None);
      RETURN (the i)
    }"

  lemma aial_index_refine:
    "(uncurry aial_index, uncurry mop_list_index) \<in>
      [\<lambda>(l,k). k\<in>set l]\<^sub>f ial_rel1 maxsize \<times>\<^sub>r nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
    apply (intro fun_relI nres_relI frefI)
    unfolding ial_rel1_def
  proof (clarsimp simp:  in_br_conv)
    fix l qp k
    assume "ial_invar maxsize l qp"
    then interpret ial_invar maxsize l qp .

    assume "k\<in>set l"
    then show "aial_index (l,qp) k \<le> RETURN (index l k)"
      unfolding aial_index_def
      apply (refine_vcg)
      by (auto simp: qp_def)
  qed

  definition aial_butlast :: "aial \<Rightarrow> aial nres" where
    "aial_butlast \<equiv> \<lambda>(l,qp). do {
      ASSERT (l\<noteq>[]);
      len \<leftarrow> mop_list_length l;
      k \<leftarrow> mop_list_get l (len - 1);
      l \<leftarrow> mop_list_butlast l;
      qp \<leftarrow> mop_list_set qp k None;
      RETURN (l,qp)
    }"

  lemma aial_butlast_refine: "(aial_butlast, mop_list_butlast) \<in> ial_rel1 maxsize \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
    apply (intro fun_relI nres_relI)
    unfolding ial_rel1_def
  proof (clarsimp simp: in_br_conv simp del: mop_list_butlast_alt)
    fix l qp
    assume "ial_invar maxsize l qp"
    then interpret ial_invar maxsize l qp .

    {
      assume A: "l\<noteq>[]"
      have "ial_invar (length qp) (butlast l) (qp[l ! (length l - Suc 0) := None])"
        apply standard
        apply clarsimp_all
        apply (auto simp: distinct_butlast) []
        using l_set apply (auto dest: in_set_butlastD) []
        using qp_def A l_distinct
        apply (auto simp: nth_list_update neq_Nil_rev_conv index_append simp del: l_distinct)
        done
    } note aux1=this

    show "aial_butlast (l, qp) \<le> \<Down> (br fst (uncurry (ial_invar maxsize))) (mop_list_butlast l)"
      unfolding aial_butlast_def mop_list_butlast_alt
      apply refine_vcg
      apply (clarsimp_all simp: in_br_conv aux1)
      done
  qed

  definition aial_append :: "aial \<Rightarrow> nat \<Rightarrow> aial nres" where
    "aial_append \<equiv> \<lambda>(l,qp) k. do {
      ASSERT (k<length qp \<and> k\<notin>set l \<and> length l < length qp);
      len \<leftarrow> mop_list_length l;
      l \<leftarrow> mop_list_append l k;
      qp \<leftarrow> mop_list_set qp k (Some len);
      RETURN (l,qp)
    }"

  lemma aial_append_refine:
    "(uncurry aial_append,uncurry mop_list_append) \<in>
      [\<lambda>(l,k). k<maxsize \<and> k\<notin>set l]\<^sub>f ial_rel1 maxsize \<times>\<^sub>r nat_rel \<rightarrow> \<langle>ial_rel1 maxsize\<rangle>nres_rel"
    apply (intro frefI nres_relI)
    unfolding ial_rel1_def
  proof (clarsimp simp: in_br_conv)
    fix l qp k
    assume KLM: "k<maxsize" and KNL: "k\<notin>set l"
    assume "ial_invar maxsize l qp"
    then interpret ial_invar maxsize l qp .

    from KLM have KLL: "k<length qp" by simp

    note distinct_card[OF l_distinct, symmetric]
    also from KNL l_set have "set l \<subseteq> {0..<k} \<union> {Suc k..<length qp}"
      by (auto simp: nat_less_le)
    from card_mono[OF _ this] have "card (set l) \<le> card \<dots>"
      by simp
    also note card_Un_le
    also have "card {0..<k} + card {Suc k..<length qp} = k + (length qp - Suc k)"
      by simp
    also have "\<dots> < length qp" using KLL by simp
    finally have LLEN: "length l < length qp" .

    have aux1[simp]: "ial_invar (length qp) (l @ [k]) (qp[k := Some (length l)])"
      apply standard
      apply (clarsimp_all simp: KNL KLL)
      using KLL apply (auto simp: Suc_le_eq LLEN) []
      apply (auto simp: index_append KNL nth_list_update')
      apply (simp add: qp_def)
      apply (simp add: qp_def)
      done

    show "aial_append (l, qp) k \<le> \<Down> (br fst (uncurry (ial_invar maxsize))) (RETURN (l@[k]))"
      unfolding aial_append_def mop_list_append_def
      apply refine_vcg
      apply (clarsimp_all simp: in_br_conv KLL KNL LLEN)
      done
  qed

  definition aial_get :: "aial \<Rightarrow> nat \<Rightarrow> nat nres" where
    "aial_get \<equiv> \<lambda>(l,qp) i. mop_list_get l i"

  lemma aial_get_refine: "(aial_get,mop_list_get) \<in> ial_rel1 maxsize \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
    apply (intro fun_relI nres_relI)
    unfolding aial_get_def ial_rel1_def mop_list_get_def in_br_conv
    apply refine_vcg
    apply clarsimp_all
    done

  definition aial_contains :: "nat \<Rightarrow> aial \<Rightarrow> bool nres" where
    "aial_contains \<equiv> \<lambda>k (l,qp). do {
      ASSERT (k<length qp);
      i \<leftarrow> mop_list_get qp k;
      RETURN (i\<noteq>None)
    }"

  lemma aial_contains_refine: "(uncurry aial_contains,uncurry mop_list_contains)
    \<in> [\<lambda>(k,_). k<maxsize]\<^sub>f (nat_rel \<times>\<^sub>r ial_rel1 maxsize) \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
    apply (intro frefI nres_relI)
    unfolding ial_rel1_def
  proof (clarsimp simp: in_br_conv)
    fix l qp k
    assume A: "k<maxsize"
    assume "ial_invar maxsize l qp"
    then interpret ial_invar maxsize l qp .

    show "aial_contains k (l, qp) \<le> RETURN (k\<in>set l)"
      unfolding aial_contains_def
      apply refine_vcg
      using A
      by (auto simp: l_len qp_def split: if_split_asm)

  qed

  type_synonym 'l ial = "('l,'l word) marl \<times> 'l word ptr"

  context
    fixes M :: nat
    defines "M \<equiv> max_snat (LENGTH ('l::len2))"
  begin

    abbreviation "ial2_assn N
      \<equiv> marl_assn' TYPE('l) (snat_assn' TYPE('l)) N \<times>\<^sub>a array_assn (snat_option_assn' TYPE('l))"

    private abbreviation (input) "idx_assn \<equiv> snat_assn' TYPE('l)"

    definition ial_assn :: "_ \<Rightarrow> _ \<Rightarrow> 'l ial \<Rightarrow> _" where "ial_assn N \<equiv> hr_comp (hr_comp (ial2_assn N) (ial_rel1 N)) (\<langle>nbn_rel N\<rangle>list_rel)"
    lemmas [fcomp_norm_unfold] = ial_assn_def[symmetric]

    (* TODO: Move *)
    lemma list_rel_below_id_ext: "A\<subseteq>Id \<Longrightarrow> \<langle>A\<rangle>list_rel \<subseteq> Id"
      by (metis list_rel_id list_rel_mono)

    lemma b_rel_below: "b_rel R \<Phi> \<subseteq> R" by (simp add: b_rel_def)

    lemma br_comp_b_rel_Id_conv: "br \<alpha> I O b_rel Id \<Phi> = br \<alpha> (\<lambda>x. I x \<and> \<Phi> (\<alpha> x))"
      by (auto simp: in_br_conv)

    find_theorems "?x = ?y" "_\<in>?x \<longleftrightarrow> _\<in>?y"

    lemma b_rel_Id_list_rel_conv: "\<langle>b_rel Id \<Phi>\<rangle>list_rel = b_rel Id (\<lambda>xs. \<forall>x\<in>set xs. \<Phi> x)"
      apply (clarsimp simp: set_eq_iff)
      subgoal for xs ys
        apply (induction xs arbitrary: ys)
        subgoal by auto
        subgoal for x xs ys by (cases ys) auto
        done
      done

    lemma ial_rel1_comp_nbn_rel[fcomp_norm_unfold, simp]: "ial_rel1 N O \<langle>nbn_rel N\<rangle>list_rel = ial_rel1 N"
      apply (clarsimp simp: ial_rel1_def in_br_conv; safe; clarsimp simp: in_br_conv)
      subgoal using list_rel_below_id_ext[OF b_rel_below] by auto []
      subgoal for a b
        apply (simp add: b_rel_Id_list_rel_conv br_comp_b_rel_Id_conv in_br_conv)
        by (metis (full_types) ial_invar.l_set_simp ial_invar_def)
      done

    lemma ial_assn_fold'[fcomp_norm_unfold]: "hrr_comp nat_rel
                        (hrr_comp nat_rel (\<lambda>N _. marl_assn' TYPE('l) snat_assn N \<times>\<^sub>a array_assn snat.option_assn)
                          ial_rel1)
                        (\<lambda>x. \<langle>nat_rel\<rangle>list_rel) = (\<lambda>N _. ial_assn N)"
      unfolding ial_assn_def
      by (auto simp: fun_eq_iff hrr_comp_nondep hr_comp_assoc)

    abbreviation "ial_assn' TYPE('l) N \<equiv> ial_assn N"

    sepref_definition ial_empty_impl [llvm_code]
      is aial_empty :: "idx_assn\<^sup>k \<rightarrow>\<^sub>a\<^sub>d (\<lambda>N _. ial2_assn N)"
      unfolding aial_empty_def
      by sepref

    definition [simp]: "ial_empty_aux (N::nat) \<equiv> op_list_empty"
    sepref_decl_op ial_empty: ial_empty_aux :: "nat_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
    lemma ial_fold_custom_empty:
      "[] = op_ial_empty N"
      "op_list_empty = op_ial_empty N"
      "mop_list_empty = mop_ial_empty N"
      by auto

    lemma aial_empty_refine':
      "(aial_empty, RETURN o op_ial_empty) \<in> nat_rel \<rightarrow>\<^sub>f\<^sub>d (\<lambda>N. \<langle>ial_rel1 N\<rangle>nres_rel)"
      apply (rule frefI)
      using aial_empty_refine
      by auto

    sepref_decl_impl ial_empty_impl.refine[FCOMP aial_empty_refine'] uses op_ial_empty.fref[where A="Id"] .

    sepref_definition ial_swap_impl [llvm_code] is "uncurry2 aial_swap" :: "(ial2_assn N)\<^sup>d*\<^sub>aidx_assn\<^sup>k*\<^sub>aidx_assn\<^sup>k \<rightarrow>\<^sub>a ial2_assn N"
      unfolding aial_swap_def
      by sepref
    sepref_decl_impl (ismop) ial_swap_impl.refine[FCOMP aial_swap_refine, of N N for N] uses mop_list_swap.fref[where A="nbn_rel N"] .

    sepref_definition ial_length_impl [llvm_inline] is "aial_length" :: "(ial2_assn N)\<^sup>k \<rightarrow>\<^sub>a idx_assn"
      unfolding aial_length_def
      by sepref
    sepref_decl_impl (ismop) ial_length_impl.refine[FCOMP aial_length_refine, of N N for N] uses mop_list_length.fref[where A="nbn_rel N"] .

    sepref_definition ial_index_impl [llvm_inline] is "uncurry aial_index" :: "(ial2_assn N)\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a idx_assn"
      unfolding aial_index_def
      by sepref

    context
      (*notes snatb_rel_def[symmetric, fcomp_norm_unfold] *)
    begin
      sepref_decl_impl (ismop) ial_index_impl.refine[FCOMP aial_index_refine, of N N for N]
      uses mop_list_index.fref[where A="nbn_rel N"]
      .
    end

    sepref_definition ial_butlast_impl [llvm_code] is "aial_butlast" :: "(ial2_assn N)\<^sup>d \<rightarrow>\<^sub>a ial2_assn N"
      unfolding aial_butlast_def
      apply (annot_snat_const "TYPE('l)")
      by sepref
    sepref_decl_impl (ismop) ial_butlast_impl.refine[FCOMP aial_butlast_refine, of N N for N]
      uses mop_list_butlast.fref[where A="nbn_rel N"] .

    private lemma aial_append_impl_aux: "((l, qp), l') \<in> ial_rel1 maxsize \<Longrightarrow> l'=l \<and> maxsize = length qp"
      unfolding ial_rel1_def
      by (clarsimp simp: in_br_conv ial_invar.maxsize_eq[symmetric])

    sepref_definition ial_append_impl [llvm_code] is "uncurry aial_append" :: "[\<lambda>(lqp,_). lqp\<in>Domain (ial_rel1 N)]\<^sub>a (ial2_assn N)\<^sup>d *\<^sub>a idx_assn\<^sup>k \<rightarrow> ial2_assn N"
      unfolding aial_append_def
      supply [dest!] = aial_append_impl_aux
      by sepref

    lemmas ial_append_impl_refine_aux = ial_append_impl.refine[of N, FCOMP aial_append_refine[of N]] for N

    private lemma append_fref': "(uncurry mop_list_append, uncurry mop_list_append) \<in> \<langle>nbn_rel N\<rangle>list_rel \<times>\<^sub>r nbn_rel N \<rightarrow>\<^sub>f \<langle>\<langle>nbn_rel N\<rangle>list_rel\<rangle>nres_rel"
      by (rule mop_list_append.fref)

    (* TODO: Move *)
    lemma right_unique_inv[relator_props]: "IS_LEFT_UNIQUE R \<Longrightarrow> IS_RIGHT_UNIQUE (R\<inverse>)"
      by (simp add: IS_LEFT_UNIQUE_def)
    lemma left_unique_inv[relator_props]: "IS_RIGHT_UNIQUE R \<Longrightarrow> IS_LEFT_UNIQUE (R\<inverse>)"
      by (simp add: IS_LEFT_UNIQUE_def)

    lemma left_unique_id[relator_props]: "IS_LEFT_UNIQUE Id" by (auto simp: IS_LEFT_UNIQUE_def)

    context
      (*notes [fcomp_norm_unfold] = snatb_rel_def[symmetric]*)
    begin
      sepref_decl_impl (ismop) ial_append_impl_refine_aux[where N = N] uses append_fref'[where N=N]
        apply parametricity
        apply simp
        apply simp
        by tagged_solver+

      sepref_definition ial_get_impl [llvm_inline] is "uncurry aial_get" :: "(ial2_assn N)\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a idx_assn"
        unfolding aial_get_def by sepref

      sepref_decl_impl (ismop) ial_get: ial_get_impl.refine[FCOMP aial_get_refine, of N N for N]
        uses mop_list_get.fref[where A="nbn_rel N"] .

      sepref_definition ial_contains_impl [llvm_code] is "uncurry aial_contains" :: "idx_assn\<^sup>k *\<^sub>a (ial2_assn N)\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
        unfolding aial_contains_def
        by sepref

      private lemma list_contains_fref':
        "(uncurry mop_list_contains, uncurry mop_list_contains) \<in> nbn_rel N \<times>\<^sub>r \<langle>nbn_rel N\<rangle>list_rel \<rightarrow>\<^sub>f \<langle>bool_rel\<rangle>nres_rel"
        apply (rule mop_list_contains.fref)
        by tagged_solver+

      sepref_decl_impl (ismop) ial_contains_impl.refine[FCOMP aial_contains_refine, of N N]
        uses list_contains_fref'[where N=N]
        apply parametricity
        unfolding IS_BELOW_ID_def by auto

    end
  end

  schematic_goal ial_assn_free[sepref_frame_free_rules]: "MK_FREE (ial_assn N) (?fr)"
    unfolding ial_assn_def
    by sepref_dbg_side (* TODO: Use proper method here! *)

  lemma ial_assn_boundD[sepref_bounds_dest]:
    "rdomp (ial_assn' TYPE('l::len2) N) xs \<Longrightarrow> length xs \<le> N \<and> N < max_snat LENGTH('l)"
    unfolding ial_assn_def ial_rel1_def
    supply [simp] = in_br_conv
    by sepref_bounds

end


(*  File:       Blacks_Rule.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>Black's Rule\<close>

theory Blacks_Rule
  imports Pairwise_Majority_Rule
          Borda_Rule
          Borda_Scoring_Rule
begin

text
\<open>This is Black's voting rule. It is composed of a function that determines
the Condorcet winner, i.e., the Pairwise Majority rule, and the Borda rule.
Whenever there exists no Condorcet winner, it elects the choice made by the
Borda rule, otherwise the Condorcet winner is elected.\<close>

subsection \<open>Definition\<close>

fun blacks_rule :: "'a Electoral_Module" where
  "blacks_rule A p = (pairwise_majority_rule \<triangleright> borda_rule) A p"

fun blacks_rule_scoring :: "'a Electoral_Module" where
  "blacks_rule_scoring A p = (pairwise_majority_rule \<triangleright> borda_Scoring_Rule) A p"

lemma pairwise_majority_rule_homogeneity:
  shows "homogeneity pairwise_majority_rule"
  unfolding pairwise_majority_rule.simps condorcet.simps
  using elector_homogeneity condorcet_homogeneity
  by blast

lemma blacks_rule_hom:
  shows "homogeneity blacks_rule_scoring" unfolding blacks_rule_scoring.simps
  using seq_hom pairwise_majority_rule_homogeneity borda_hom by blast

end


header {* Monad-Zero-Plus Class *}

theory Monad_Zero_Plus
imports Monad_Zero Monad_Plus
begin

hide_const (open) Fixrec.mplus

class functor_zero_plus = functor_zero + functor_plus +
  assumes plusU_zeroU_left:
    "plusU\<cdot>zeroU\<cdot>m = m"
  assumes plusU_zeroU_right:
    "plusU\<cdot>m\<cdot>zeroU = m"

class monad_zero_plus = monad_zero + monad_plus + functor_zero_plus

lemma fplus_fzero_left:
  fixes m :: "'a\<cdot>'f::functor_zero_plus"
  shows "fplus\<cdot>fzero\<cdot>m = m"
unfolding fplus_def fzero_def
by (simp add: coerce_simp plusU_zeroU_left)

lemma fplus_fzero_right:
  fixes m :: "'a\<cdot>'f::functor_zero_plus"
  shows "fplus\<cdot>m\<cdot>fzero = m"
unfolding fplus_def fzero_def
by (simp add: coerce_simp plusU_zeroU_right)

lemmas mplus_mzero_left =
  fplus_fzero_left [where 'f="'m::monad_zero_plus"] for f

lemmas mplus_mzero_right =
  fplus_fzero_right [where 'f="'m::monad_zero_plus"] for f

end


(*  Title       : Deriv.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section{* Differentiation (Nonstandard) *}

theory HDeriv
imports HLim
begin

text{*Nonstandard Definitions*}

definition
  nsderiv :: "['a::real_normed_field \<Rightarrow> 'a, 'a, 'a] \<Rightarrow> bool"
          ("(NSDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60) where
  "NSDERIV f x :> D = (\<forall>h \<in> Infinitesimal - {0}.
      (( *f* f)(star_of x + h)
       - star_of (f x))/h @= star_of D)"

definition
  NSdifferentiable :: "['a::real_normed_field \<Rightarrow> 'a, 'a] \<Rightarrow> bool"
    (infixl "NSdifferentiable" 60) where
  "f NSdifferentiable x = (\<exists>D. NSDERIV f x :> D)"

definition
  increment :: "[real=>real,real,hypreal] => hypreal" where
  "increment f x h = (@inc. f NSdifferentiable x &
           inc = ( *f* f)(hypreal_of_real x + h) - hypreal_of_real (f x))"

subsection {* Derivatives *}

lemma DERIV_NS_iff:
      "(DERIV f x :> D) = ((%h. (f(x + h) - f(x))/h) -- 0 --NS> D)"
by (simp add: DERIV_def LIM_NSLIM_iff)

lemma NS_DERIV_D: "DERIV f x :> D ==> (%h. (f(x + h) - f(x))/h) -- 0 --NS> D"
by (simp add: DERIV_def LIM_NSLIM_iff)

lemma hnorm_of_hypreal:
  "\<And>r. hnorm (( *f* of_real) r::'a::real_normed_div_algebra star) = \<bar>r\<bar>"
by transfer (rule norm_of_real)

lemma Infinitesimal_of_hypreal:
  "x \<in> Infinitesimal \<Longrightarrow>
   (( *f* of_real) x::'a::real_normed_div_algebra star) \<in> Infinitesimal"
apply (rule InfinitesimalI2)
apply (drule (1) InfinitesimalD2)
apply (simp add: hnorm_of_hypreal)
done

lemma of_hypreal_eq_0_iff:
  "\<And>x. (( *f* of_real) x = (0::'a::real_algebra_1 star)) = (x = 0)"
by transfer (rule of_real_eq_0_iff)

lemma NSDeriv_unique:
     "[| NSDERIV f x :> D; NSDERIV f x :> E |] ==> D = E"
apply (subgoal_tac "( *f* of_real) epsilon \<in> Infinitesimal - {0::'a star}")
apply (simp only: nsderiv_def)
apply (drule (1) bspec)+
apply (drule (1) approx_trans3)
apply simp
apply (simp add: Infinitesimal_of_hypreal Infinitesimal_epsilon)
apply (simp add: of_hypreal_eq_0_iff hypreal_epsilon_not_zero)
done

text {*First NSDERIV in terms of NSLIM*}

text{*first equivalence *}
lemma NSDERIV_NSLIM_iff:
      "(NSDERIV f x :> D) = ((%h. (f(x + h) - f(x))/h) -- 0 --NS> D)"
apply (simp add: nsderiv_def NSLIM_def, auto)
apply (drule_tac x = xa in bspec)
apply (rule_tac [3] ccontr)
apply (drule_tac [3] x = h in spec)
apply (auto simp add: mem_infmal_iff starfun_lambda_cancel)
done

text{*second equivalence *}
lemma NSDERIV_NSLIM_iff2:
     "(NSDERIV f x :> D) = ((%z. (f(z) - f(x)) / (z-x)) -- x --NS> D)"
  by (simp add: NSDERIV_NSLIM_iff DERIV_LIM_iff LIM_NSLIM_iff [symmetric])

(* while we're at it! *)

lemma NSDERIV_iff2:
     "(NSDERIV f x :> D) =
      (\<forall>w.
        w \<noteq> star_of x & w \<approx> star_of x -->
        ( *f* (%z. (f z - f x) / (z-x))) w \<approx> star_of D)"
by (simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

(*FIXME DELETE*)
lemma hypreal_not_eq_minus_iff:
  "(x \<noteq> a) = (x - a \<noteq> (0::'a::ab_group_add))"
by auto

lemma NSDERIVD5:
  "(NSDERIV f x :> D) ==>
   (\<forall>u. u \<approx> hypreal_of_real x -->
     ( *f* (%z. f z - f x)) u \<approx> hypreal_of_real D * (u - hypreal_of_real x))"
apply (auto simp add: NSDERIV_iff2)
apply (case_tac "u = hypreal_of_real x", auto)
apply (drule_tac x = u in spec, auto)
apply (drule_tac c = "u - hypreal_of_real x" and b = "hypreal_of_real D" in approx_mult1)
apply (drule_tac [!] hypreal_not_eq_minus_iff [THEN iffD1])
apply (subgoal_tac [2] "( *f* (%z. z-x)) u \<noteq> (0::hypreal) ")
apply (auto simp add:
         approx_minus_iff [THEN iffD1, THEN mem_infmal_iff [THEN iffD2]]
         Infinitesimal_subset_HFinite [THEN subsetD])
done

lemma NSDERIVD4:
     "(NSDERIV f x :> D) ==>
      (\<forall>h \<in> Infinitesimal.
               (( *f* f)(hypreal_of_real x + h) -
                 hypreal_of_real (f x))\<approx> (hypreal_of_real D) * h)"
apply (auto simp add: nsderiv_def)
apply (case_tac "h = (0::hypreal) ")
apply auto
apply (drule_tac x = h in bspec)
apply (drule_tac [2] c = h in approx_mult1)
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD])
done

lemma NSDERIVD3:
     "(NSDERIV f x :> D) ==>
      (\<forall>h \<in> Infinitesimal - {0}.
               (( *f* f)(hypreal_of_real x + h) -
                 hypreal_of_real (f x))\<approx> (hypreal_of_real D) * h)"
apply (auto simp add: nsderiv_def)
apply (rule ccontr, drule_tac x = h in bspec)
apply (drule_tac [2] c = h in approx_mult1)
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD] simp add: mult.assoc)
done

text{*Differentiability implies continuity
         nice and simple "algebraic" proof*}
lemma NSDERIV_isNSCont: "NSDERIV f x :> D ==> isNSCont f x"
apply (auto simp add: nsderiv_def isNSCont_NSLIM_iff NSLIM_def)
apply (drule approx_minus_iff [THEN iffD1])
apply (drule hypreal_not_eq_minus_iff [THEN iffD1])
apply (drule_tac x = "xa - star_of x" in bspec)
 prefer 2 apply (simp add: add.assoc [symmetric])
apply (auto simp add: mem_infmal_iff [symmetric] add.commute)
apply (drule_tac c = "xa - star_of x" in approx_mult1)
apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
            simp add: mult.assoc nonzero_mult_divide_cancel_right)
apply (drule_tac x3=D in
           HFinite_star_of [THEN [2] Infinitesimal_HFinite_mult,
             THEN mem_infmal_iff [THEN iffD1]])
apply (auto simp add: mult.commute
            intro: approx_trans approx_minus_iff [THEN iffD2])
done

text{*Differentiation rules for combinations of functions
      follow from clear, straightforard, algebraic
      manipulations*}
text{*Constant function*}

(* use simple constant nslimit theorem *)
lemma NSDERIV_const [simp]: "(NSDERIV (%x. k) x :> 0)"
by (simp add: NSDERIV_NSLIM_iff)

text{*Sum of functions- proved easily*}

lemma NSDERIV_add: "[| NSDERIV f x :> Da;  NSDERIV g x :> Db |]
      ==> NSDERIV (%x. f x + g x) x :> Da + Db"
apply (auto simp add: NSDERIV_NSLIM_iff NSLIM_def)
apply (auto simp add: add_divide_distrib diff_divide_distrib dest!: spec)
apply (drule_tac b = "star_of Da" and d = "star_of Db" in approx_add)
apply (auto simp add: ac_simps algebra_simps)
done

text{*Product of functions - Proof is trivial but tedious
  and long due to rearrangement of terms*}

lemma lemma_nsderiv1:
  fixes a b c d :: "'a::comm_ring star"
  shows "(a*b) - (c*d) = (b*(a - c)) + (c*(b - d))"
by (simp add: right_diff_distrib ac_simps)

lemma lemma_nsderiv2:
  fixes x y z :: "'a::real_normed_field star"
  shows "[| (x - y) / z = star_of D + yb; z \<noteq> 0;
         z \<in> Infinitesimal; yb \<in> Infinitesimal |]
      ==> x - y \<approx> 0"
apply (simp add: nonzero_divide_eq_eq)
apply (auto intro!: Infinitesimal_HFinite_mult2 HFinite_add
            simp add: mult.assoc mem_infmal_iff [symmetric])
apply (erule Infinitesimal_subset_HFinite [THEN subsetD])
done

lemma NSDERIV_mult: "[| NSDERIV f x :> Da; NSDERIV g x :> Db |]
      ==> NSDERIV (%x. f x * g x) x :> (Da * g(x)) + (Db * f(x))"
apply (auto simp add: NSDERIV_NSLIM_iff NSLIM_def)
apply (auto dest!: spec
      simp add: starfun_lambda_cancel lemma_nsderiv1)
apply (simp (no_asm) add: add_divide_distrib diff_divide_distrib)
apply (drule bex_Infinitesimal_iff2 [THEN iffD2])+
apply (auto simp add: times_divide_eq_right [symmetric]
            simp del: times_divide_eq_right times_divide_eq_left)
apply (drule_tac D = Db in lemma_nsderiv2, assumption+)
apply (drule_tac
     approx_minus_iff [THEN iffD2, THEN bex_Infinitesimal_iff2 [THEN iffD2]])
apply (auto intro!: approx_add_mono1
            simp add: distrib_right distrib_left mult.commute add.assoc)
apply (rule_tac b1 = "star_of Db * star_of (f x)"
         in add.commute [THEN subst])
apply (auto intro!: Infinitesimal_add_approx_self2 [THEN approx_sym]
                    Infinitesimal_add Infinitesimal_mult
                    Infinitesimal_star_of_mult
                    Infinitesimal_star_of_mult2
          simp add: add.assoc [symmetric])
done

text{*Multiplying by a constant*}
lemma NSDERIV_cmult: "NSDERIV f x :> D
      ==> NSDERIV (%x. c * f x) x :> c*D"
apply (simp only: times_divide_eq_right [symmetric] NSDERIV_NSLIM_iff
                  minus_mult_right right_diff_distrib [symmetric])
apply (erule NSLIM_const [THEN NSLIM_mult])
done

text{*Negation of function*}
lemma NSDERIV_minus: "NSDERIV f x :> D ==> NSDERIV (%x. -(f x)) x :> -D"
proof (simp add: NSDERIV_NSLIM_iff)
  assume "(\<lambda>h. (f (x + h) - f x) / h) -- 0 --NS> D"
  hence deriv: "(\<lambda>h. - ((f(x+h) - f x) / h)) -- 0 --NS> - D"
    by (rule NSLIM_minus)
  have "\<forall>h. - ((f (x + h) - f x) / h) = (- f (x + h) + f x) / h"
    by (simp add: minus_divide_left)
  with deriv
  have "(\<lambda>h. (- f (x + h) + f x) / h) -- 0 --NS> - D" by simp
  then show "(\<lambda>h. (f (x + h) - f x) / h) -- 0 --NS> D \<Longrightarrow>
    (\<lambda>h. (f x - f (x + h)) / h) -- 0 --NS> - D" by simp
qed

text{*Subtraction*}
lemma NSDERIV_add_minus: "[| NSDERIV f x :> Da; NSDERIV g x :> Db |] ==> NSDERIV (%x. f x + -g x) x :> Da + -Db"
by (blast dest: NSDERIV_add NSDERIV_minus)

lemma NSDERIV_diff:
  "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x - g x) x :> Da-Db"
  using NSDERIV_add_minus [of f x Da g Db] by simp

text{*  Similarly to the above, the chain rule admits an entirely
   straightforward derivation. Compare this with Harrison's
   HOL proof of the chain rule, which proved to be trickier and
   required an alternative characterisation of differentiability-
   the so-called Carathedory derivative. Our main problem is
   manipulation of terms.*}

(* lemmas *)

lemma NSDERIV_zero:
      "[| NSDERIV g x :> D;
               ( *f* g) (star_of x + xa) = star_of (g x);
               xa \<in> Infinitesimal;
               xa \<noteq> 0
            |] ==> D = 0"
apply (simp add: nsderiv_def)
apply (drule bspec, auto)
done

(* can be proved differently using NSLIM_isCont_iff *)
lemma NSDERIV_approx:
     "[| NSDERIV f x :> D;  h \<in> Infinitesimal;  h \<noteq> 0 |]
      ==> ( *f* f) (star_of x + h) - star_of (f x) \<approx> 0"
apply (simp add: nsderiv_def)
apply (simp add: mem_infmal_iff [symmetric])
apply (rule Infinitesimal_ratio)
apply (rule_tac [3] approx_star_of_HFinite, auto)
done

(*---------------------------------------------------------------
   from one version of differentiability

                f(x) - f(a)
              --------------- \<approx> Db
                  x - a
 ---------------------------------------------------------------*)

lemma NSDERIVD1: "[| NSDERIV f (g x) :> Da;
         ( *f* g) (star_of(x) + xa) \<noteq> star_of (g x);
         ( *f* g) (star_of(x) + xa) \<approx> star_of (g x)
      |] ==> (( *f* f) (( *f* g) (star_of(x) + xa))
                   - star_of (f (g x)))
              / (( *f* g) (star_of(x) + xa) - star_of (g x))
             \<approx> star_of(Da)"
by (auto simp add: NSDERIV_NSLIM_iff2 NSLIM_def)

(*--------------------------------------------------------------
   from other version of differentiability

                f(x + h) - f(x)
               ----------------- \<approx> Db
                       h
 --------------------------------------------------------------*)

lemma NSDERIVD2: "[| NSDERIV g x :> Db; xa \<in> Infinitesimal; xa \<noteq> 0 |]
      ==> (( *f* g) (star_of(x) + xa) - star_of(g x)) / xa
          \<approx> star_of(Db)"
by (auto simp add: NSDERIV_NSLIM_iff NSLIM_def mem_infmal_iff starfun_lambda_cancel)

lemma lemma_chain: "(z::'a::real_normed_field star) \<noteq> 0 ==> x*y = (x*inverse(z))*(z*y)"
proof -
  assume z: "z \<noteq> 0"
  have "x * y = x * (inverse z * z) * y" by (simp add: z)
  thus ?thesis by (simp add: mult.assoc)
qed

text{*This proof uses both definitions of differentiability.*}
lemma NSDERIV_chain: "[| NSDERIV f (g x) :> Da; NSDERIV g x :> Db |]
      ==> NSDERIV (f o g) x :> Da * Db"
apply (simp (no_asm_simp) add: NSDERIV_NSLIM_iff NSLIM_def
                mem_infmal_iff [symmetric])
apply clarify
apply (frule_tac f = g in NSDERIV_approx)
apply (auto simp add: starfun_lambda_cancel2 starfun_o [symmetric])
apply (case_tac "( *f* g) (star_of (x) + xa) = star_of (g x) ")
apply (drule_tac g = g in NSDERIV_zero)
apply (auto simp add: divide_inverse)
apply (rule_tac z1 = "( *f* g) (star_of (x) + xa) - star_of (g x) " and y1 = "inverse xa" in lemma_chain [THEN ssubst])
apply (erule hypreal_not_eq_minus_iff [THEN iffD1])
apply (rule approx_mult_star_of)
apply (simp_all add: divide_inverse [symmetric])
apply (blast intro: NSDERIVD1 approx_minus_iff [THEN iffD2])
apply (blast intro: NSDERIVD2)
done

text{*Differentiation of natural number powers*}
lemma NSDERIV_Id [simp]: "NSDERIV (%x. x) x :> 1"
by (simp add: NSDERIV_NSLIM_iff NSLIM_def del: divide_self_if)

lemma NSDERIV_cmult_Id [simp]: "NSDERIV (op * c) x :> c"
by (cut_tac c = c and x = x in NSDERIV_Id [THEN NSDERIV_cmult], simp)

lemma NSDERIV_inverse:
  fixes x :: "'a::real_normed_field"
  assumes "x \<noteq> 0" -- {* can't get rid of @{term "x \<noteq> 0"} because it isn't continuous at zero *}
  shows "NSDERIV (\<lambda>x. inverse x) x :> - (inverse x ^ Suc (Suc 0))"
proof -
  { fix h :: "'a star"
    assume h_Inf: "h \<in> Infinitesimal"
    from this assms have not_0: "star_of x + h \<noteq> 0" by (rule Infinitesimal_add_not_zero)
    assume "h \<noteq> 0"
    from h_Inf have "h * star_of x \<in> Infinitesimal" by (rule Infinitesimal_HFinite_mult) simp
    with assms have "inverse (- (h * star_of x) + - (star_of x * star_of x)) \<approx>
      inverse (- (star_of x * star_of x))"
      apply - apply (rule inverse_add_Infinitesimal_approx2)
      apply (auto
        dest!: hypreal_of_real_HFinite_diff_Infinitesimal
        simp add: inverse_minus_eq [symmetric] HFinite_minus_iff)
      done
    moreover from not_0 `h \<noteq> 0` assms
      have "inverse (- (h * star_of x) + - (star_of x * star_of x)) =
        (inverse (star_of x + h) - inverse (star_of x)) / h"
      apply (simp add: division_ring_inverse_diff nonzero_inverse_mult_distrib [symmetric]
        nonzero_inverse_minus_eq [symmetric] ac_simps ring_distribs)
      apply (subst nonzero_inverse_minus_eq [symmetric])
      using distrib_right [symmetric, of h "star_of x" "star_of x"] apply simp
      apply (simp add: field_simps)
      done
    ultimately have "(inverse (star_of x + h) - inverse (star_of x)) / h \<approx>
      - (inverse (star_of x) * inverse (star_of x))"
      using assms by (simp add: nonzero_inverse_mult_distrib [symmetric] nonzero_inverse_minus_eq [symmetric])
  } then show ?thesis by (simp add: nsderiv_def)
qed

subsubsection {* Equivalence of NS and Standard definitions *}

lemma divideR_eq_divide: "x /\<^sub>R y = x / y"
by (simp add: divide_inverse mult.commute)

text{*Now equivalence between NSDERIV and DERIV*}
lemma NSDERIV_DERIV_iff: "(NSDERIV f x :> D) = (DERIV f x :> D)"
by (simp add: DERIV_def NSDERIV_NSLIM_iff LIM_NSLIM_iff)

(* NS version *)
lemma NSDERIV_pow: "NSDERIV (%x. x ^ n) x :> real n * (x ^ (n - Suc 0))"
by (simp add: NSDERIV_DERIV_iff DERIV_pow)

text{*Derivative of inverse*}

lemma NSDERIV_inverse_fun:
  fixes x :: "'a::{real_normed_field}"
  shows "[| NSDERIV f x :> d; f(x) \<noteq> 0 |]
      ==> NSDERIV (%x. inverse(f x)) x :> (- (d * inverse(f(x) ^ Suc (Suc 0))))"
by (simp add: NSDERIV_DERIV_iff DERIV_inverse_fun del: power_Suc)

text{*Derivative of quotient*}

lemma NSDERIV_quotient:
  fixes x :: "'a::{real_normed_field}"
  shows "[| NSDERIV f x :> d; NSDERIV g x :> e; g(x) \<noteq> 0 |]
       ==> NSDERIV (%y. f(y) / (g y)) x :> (d*g(x)
                            - (e*f(x))) / (g(x) ^ Suc (Suc 0))"
by (simp add: NSDERIV_DERIV_iff DERIV_quotient del: power_Suc)

lemma CARAT_NSDERIV: "NSDERIV f x :> l ==>
      \<exists>g. (\<forall>z. f z - f x = g z * (z-x)) & isNSCont g x & g x = l"
by (auto simp add: NSDERIV_DERIV_iff isNSCont_isCont_iff CARAT_DERIV
                   mult.commute)

lemma hypreal_eq_minus_iff3: "(x = y + z) = (x + -z = (y::hypreal))"
by auto

lemma CARAT_DERIVD:
  assumes all: "\<forall>z. f z - f x = g z * (z-x)"
      and nsc: "isNSCont g x"
  shows "NSDERIV f x :> g x"
proof -
  from nsc
  have "\<forall>w. w \<noteq> star_of x \<and> w \<approx> star_of x \<longrightarrow>
         ( *f* g) w * (w - star_of x) / (w - star_of x) \<approx>
         star_of (g x)"
    by (simp add: isNSCont_def nonzero_mult_divide_cancel_right)
  thus ?thesis using all
    by (simp add: NSDERIV_iff2 starfun_if_eq cong: if_cong)
qed

subsubsection {* Differentiability predicate *}

lemma NSdifferentiableD: "f NSdifferentiable x ==> \<exists>D. NSDERIV f x :> D"
by (simp add: NSdifferentiable_def)

lemma NSdifferentiableI: "NSDERIV f x :> D ==> f NSdifferentiable x"
by (force simp add: NSdifferentiable_def)

subsection {*(NS) Increment*}
lemma incrementI:
      "f NSdifferentiable x ==>
      increment f x h = ( *f* f) (hypreal_of_real(x) + h) -
      hypreal_of_real (f x)"
by (simp add: increment_def)

lemma incrementI2: "NSDERIV f x :> D ==>
     increment f x h = ( *f* f) (hypreal_of_real(x) + h) -
     hypreal_of_real (f x)"
apply (erule NSdifferentiableI [THEN incrementI])
done

(* The Increment theorem -- Keisler p. 65 *)
lemma increment_thm: "[| NSDERIV f x :> D; h \<in> Infinitesimal; h \<noteq> 0 |]
      ==> \<exists>e \<in> Infinitesimal. increment f x h = hypreal_of_real(D)*h + e*h"
apply (frule_tac h = h in incrementI2, simp add: nsderiv_def)
apply (drule bspec, auto)
apply (drule bex_Infinitesimal_iff2 [THEN iffD2], clarify)
apply (frule_tac b1 = "hypreal_of_real (D) + y"
        in mult_right_cancel [THEN iffD2])
apply (erule_tac [2] V = "(( *f* f) (hypreal_of_real (x) + h) - hypreal_of_real (f x)) / h = hypreal_of_real (D) + y" in thin_rl)
apply assumption
apply (simp add: times_divide_eq_right [symmetric])
apply (auto simp add: distrib_right)
done

lemma increment_thm2:
     "[| NSDERIV f x :> D; h \<approx> 0; h \<noteq> 0 |]
      ==> \<exists>e \<in> Infinitesimal. increment f x h =
              hypreal_of_real(D)*h + e*h"
by (blast dest!: mem_infmal_iff [THEN iffD2] intro!: increment_thm)

lemma increment_approx_zero: "[| NSDERIV f x :> D; h \<approx> 0; h \<noteq> 0 |]
      ==> increment f x h \<approx> 0"
apply (drule increment_thm2,
       auto intro!: Infinitesimal_HFinite_mult2 HFinite_add simp add: distrib_right [symmetric] mem_infmal_iff [symmetric])
apply (erule Infinitesimal_subset_HFinite [THEN subsetD])
done

end


(*
  File:         PAC_Polynomials_Term.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Polynomials_Term
  imports PAC_Polynomials
    Refine_Imperative_HOL.IICF
begin

section \<open>Terms\<close>

text \<open>We define some helper functions.\<close>

subsection \<open>Ordering\<close>

(*Taken from WB_More_Refinement*)
lemma fref_to_Down_curry_left:
  fixes f:: \<open>'a \<Rightarrow> 'b \<Rightarrow> 'c nres\<close> and
    A::\<open>(('a \<times> 'b) \<times> 'd) set\<close>
  shows
    \<open>(uncurry f, g) \<in> [P]\<^sub>f A \<rightarrow> \<langle>B\<rangle>nres_rel \<Longrightarrow>
      (\<And>a b x'. P x' \<Longrightarrow> ((a, b), x') \<in> A \<Longrightarrow> f a b \<le> \<Down> B (g x'))\<close>
  unfolding fref_def uncurry_def nres_rel_def
  by auto

lemma fref_to_Down_curry_right:
  fixes g :: \<open>'a \<Rightarrow> 'b \<Rightarrow> 'c nres\<close> and f :: \<open>'d \<Rightarrow> _ nres\<close> and
    A::\<open>('d \<times> ('a \<times> 'b)) set\<close>
  shows
    \<open>(f, uncurry g) \<in> [P]\<^sub>f A \<rightarrow> \<langle>B\<rangle>nres_rel \<Longrightarrow>
      (\<And>a b x'. P (a,b) \<Longrightarrow> (x', (a, b)) \<in> A \<Longrightarrow> f x' \<le> \<Down> B (g a b))\<close>
  unfolding fref_def uncurry_def nres_rel_def
  by auto

type_synonym term_poly_list = \<open>string list\<close>
type_synonym llist_polynomial = \<open>(term_poly_list \<times> int) list\<close>

text \<open>We instantiate the characters with typeclass linorder to be able to talk abourt sorted and
  so on.\<close>

definition less_eq_char :: \<open>char \<Rightarrow> char \<Rightarrow> bool\<close> where
  \<open>less_eq_char c d = (((of_char c) :: nat) \<le> of_char d)\<close>

definition less_char :: \<open>char \<Rightarrow> char \<Rightarrow> bool\<close> where
  \<open>less_char c d = (((of_char c) :: nat) < of_char d)\<close>

global_interpretation char: linorder less_eq_char less_char
  using linorder_char
  unfolding linorder_class_def class.linorder_def
    less_eq_char_def[symmetric] less_char_def[symmetric]
    class.order_def order_class_def
    class.preorder_def preorder_class_def
    ord_class_def
  apply auto
  done

abbreviation less_than_char :: \<open>(char \<times> char) set\<close> where
  \<open>less_than_char \<equiv> p2rel less_char\<close>

lemma less_than_char_def:
  \<open>(x,y) \<in> less_than_char \<longleftrightarrow> less_char x y\<close>
  by (auto simp: p2rel_def)

lemma trans_less_than_char[simp]:
    \<open>trans less_than_char\<close> and
  irrefl_less_than_char:
    \<open>irrefl less_than_char\<close> and
  antisym_less_than_char:
    \<open>antisym less_than_char\<close>
  by (auto simp: less_than_char_def trans_def irrefl_def antisym_def)

subsection \<open>Polynomials\<close>

definition var_order_rel :: \<open>(string \<times> string) set\<close> where
  \<open>var_order_rel \<equiv> lexord less_than_char\<close>

abbreviation var_order :: \<open>string \<Rightarrow> string \<Rightarrow> bool\<close> where
  \<open>var_order \<equiv> rel2p var_order_rel\<close>

abbreviation term_order_rel :: \<open>(term_poly_list \<times> term_poly_list) set\<close> where
  \<open>term_order_rel \<equiv> lexord var_order_rel\<close>

abbreviation term_order :: \<open>term_poly_list \<Rightarrow> term_poly_list \<Rightarrow> bool\<close> where
  \<open>term_order \<equiv> rel2p term_order_rel\<close>

definition term_poly_list_rel :: \<open>(term_poly_list \<times> term_poly) set\<close> where
  \<open>term_poly_list_rel = {(xs, ys).
     ys = mset xs \<and>
     distinct xs \<and>
     sorted_wrt (rel2p var_order_rel) xs}\<close>

definition unsorted_term_poly_list_rel :: \<open>(term_poly_list \<times> term_poly) set\<close> where
  \<open>unsorted_term_poly_list_rel = {(xs, ys).
     ys = mset xs \<and> distinct xs}\<close>

definition poly_list_rel :: \<open>_ \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>poly_list_rel R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel \<and>
     0 \<notin># snd `# ys}\<close>

definition sorted_poly_list_rel_wrt :: \<open>('a \<Rightarrow> 'a \<Rightarrow> bool)
     \<Rightarrow> ('a \<times> string multiset) set \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>sorted_poly_list_rel_wrt S R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel \<and>
     sorted_wrt S (map fst xs) \<and>
     distinct (map fst xs) \<and>
     0 \<notin># snd `# ys}\<close>

abbreviation sorted_poly_list_rel where
  \<open>sorted_poly_list_rel R \<equiv> sorted_poly_list_rel_wrt R term_poly_list_rel\<close>

abbreviation sorted_poly_rel where
  \<open>sorted_poly_rel \<equiv> sorted_poly_list_rel term_order\<close>

definition sorted_repeat_poly_list_rel_wrt :: \<open>('a \<Rightarrow> 'a \<Rightarrow> bool)
     \<Rightarrow> ('a \<times> string multiset) set \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>sorted_repeat_poly_list_rel_wrt S R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel \<and>
     sorted_wrt S (map fst xs) \<and>
     0 \<notin># snd `# ys}\<close>

abbreviation sorted_repeat_poly_list_rel where
  \<open>sorted_repeat_poly_list_rel R \<equiv> sorted_repeat_poly_list_rel_wrt R term_poly_list_rel\<close>

abbreviation sorted_repeat_poly_rel where
  \<open>sorted_repeat_poly_rel \<equiv> sorted_repeat_poly_list_rel (rel2p (Id \<union> lexord var_order_rel))\<close>

abbreviation unsorted_poly_rel where
  \<open>unsorted_poly_rel \<equiv> poly_list_rel term_poly_list_rel\<close>

lemma sorted_poly_list_rel_empty_l[simp]:
  \<open>([], s') \<in> sorted_poly_list_rel_wrt S T \<longleftrightarrow> s' = {#}\<close>
  by (cases s')
    (auto simp: sorted_poly_list_rel_wrt_def list_mset_rel_def br_def)

definition fully_unsorted_poly_list_rel :: \<open>_ \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>fully_unsorted_poly_list_rel R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel}\<close>

abbreviation fully_unsorted_poly_rel where
  \<open>fully_unsorted_poly_rel \<equiv> fully_unsorted_poly_list_rel unsorted_term_poly_list_rel\<close>

lemma fully_unsorted_poly_list_rel_empty_iff[simp]:
  \<open>(p, {#}) \<in> fully_unsorted_poly_list_rel R \<longleftrightarrow> p = []\<close>
  \<open>([], p') \<in> fully_unsorted_poly_list_rel R \<longleftrightarrow> p' = {#}\<close>
  by (auto simp: fully_unsorted_poly_list_rel_def list_mset_rel_def br_def)

definition poly_list_rel_with0 :: \<open>_ \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>poly_list_rel_with0 R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel}\<close>

abbreviation unsorted_poly_rel_with0 where
  \<open>unsorted_poly_rel_with0 \<equiv> fully_unsorted_poly_list_rel term_poly_list_rel\<close>

lemma poly_list_rel_with0_empty_iff[simp]:
  \<open>(p, {#}) \<in> poly_list_rel_with0 R \<longleftrightarrow> p = []\<close>
  \<open>([], p') \<in> poly_list_rel_with0 R \<longleftrightarrow> p' = {#}\<close>
  by (auto simp: poly_list_rel_with0_def list_mset_rel_def br_def)

definition sorted_repeat_poly_list_rel_with0_wrt :: \<open>('a \<Rightarrow> 'a \<Rightarrow> bool)
     \<Rightarrow> ('a \<times> string multiset) set \<Rightarrow> (('a \<times> int) list \<times> mset_polynomial) set\<close> where
  \<open>sorted_repeat_poly_list_rel_with0_wrt S R = {(xs, ys).
     (xs, ys) \<in> \<langle>R \<times>\<^sub>r int_rel\<rangle>list_rel O list_mset_rel \<and>
     sorted_wrt S (map fst xs)}\<close>

abbreviation sorted_repeat_poly_list_rel_with0 where
  \<open>sorted_repeat_poly_list_rel_with0 R \<equiv> sorted_repeat_poly_list_rel_with0_wrt R term_poly_list_rel\<close>

abbreviation sorted_repeat_poly_rel_with0 where
  \<open>sorted_repeat_poly_rel_with0 \<equiv> sorted_repeat_poly_list_rel_with0 (rel2p (Id \<union> lexord var_order_rel))\<close>

lemma term_poly_list_relD:
  \<open>(xs, ys) \<in> term_poly_list_rel \<Longrightarrow> distinct xs\<close>
  \<open>(xs, ys) \<in> term_poly_list_rel \<Longrightarrow> ys = mset xs\<close>
  \<open>(xs, ys) \<in> term_poly_list_rel \<Longrightarrow> sorted_wrt (rel2p var_order_rel) xs\<close>
  \<open>(xs, ys) \<in> term_poly_list_rel \<Longrightarrow> sorted_wrt (rel2p (Id \<union> var_order_rel)) xs\<close>
  apply (auto simp: term_poly_list_rel_def; fail)+
  by (metis (mono_tags, lifting) CollectD UnI2 rel2p_def sorted_wrt_mono_rel split_conv
    term_poly_list_rel_def)

end