(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Matrix Operations in Fields\<close>

text \<open>We use our record based description of a field to perform matrix operations.\<close>

theory Matrix_Record_Based
imports
  Jordan_Normal_Form.Gauss_Jordan_Elimination
  Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
  Arithmetic_Record_Based
begin

definition mat_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a mat \<Rightarrow> 'b mat \<Rightarrow> bool" where
  "mat_rel R A B \<equiv> dim_row A = dim_row B \<and> dim_col A = dim_col B \<and>
     (\<forall> i j. i < dim_row B \<longrightarrow> j < dim_col B \<longrightarrow> R (A $$ (i,j)) (B $$ (i,j)))"

lemma right_total_mat_rel: "right_total R \<Longrightarrow> right_total (mat_rel R)"
  unfolding right_total_def
proof
  fix B
  assume "\<forall> y. \<exists> x. R x y"
  from choice[OF this] obtain f where f: "\<And> x. R (f x) x" by auto
  show "\<exists> A. mat_rel R A B"
    by (rule exI[of _ "map_mat f B"], unfold mat_rel_def, auto simp: f)
qed

lemma left_unique_mat_rel: "left_unique R \<Longrightarrow> left_unique (mat_rel R)"
  unfolding left_unique_def mat_rel_def mat_eq_iff by (auto, blast)

lemma right_unique_mat_rel: "right_unique R \<Longrightarrow> right_unique (mat_rel R)"
  unfolding right_unique_def mat_rel_def mat_eq_iff by (auto, blast)

lemma bi_unique_mat_rel: "bi_unique R \<Longrightarrow> bi_unique (mat_rel R)"
  using left_unique_mat_rel[of R] right_unique_mat_rel[of R]
  unfolding bi_unique_def left_unique_def right_unique_def by blast

lemma mat_rel_eq: "((R ===> R ===> (=))) (=) (=) \<Longrightarrow>
  ((mat_rel R ===> mat_rel R ===> (=))) (=) (=)"
  unfolding mat_rel_def rel_fun_def mat_eq_iff by (auto, blast+)

definition vec_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a vec \<Rightarrow> 'b vec \<Rightarrow> bool" where
  "vec_rel R A B \<equiv> dim_vec A = dim_vec B \<and> (\<forall> i. i < dim_vec B \<longrightarrow> R (A $ i) (B $ i))"

lemma right_total_vec_rel: "right_total R \<Longrightarrow> right_total (vec_rel R)"
  unfolding right_total_def
proof
  fix B
  assume "\<forall> y. \<exists> x. R x y"
  from choice[OF this] obtain f where f: "\<And> x. R (f x) x" by auto
  show "\<exists> A. vec_rel R A B"
    by (rule exI[of _ "map_vec f B"], unfold vec_rel_def, auto simp: f)
qed

lemma left_unique_vec_rel: "left_unique R \<Longrightarrow> left_unique (vec_rel R)"
  unfolding left_unique_def vec_rel_def vec_eq_iff by auto

lemma right_unique_vec_rel: "right_unique R \<Longrightarrow> right_unique (vec_rel R)"
  unfolding right_unique_def vec_rel_def vec_eq_iff by auto

lemma bi_unique_vec_rel: "bi_unique R \<Longrightarrow> bi_unique (vec_rel R)"
  using left_unique_vec_rel[of R] right_unique_vec_rel[of R]
  unfolding bi_unique_def left_unique_def right_unique_def by blast

lemma vec_rel_eq: "((R ===> R ===> (=))) (=) (=) \<Longrightarrow>
  ((vec_rel R ===> vec_rel R ===> (=))) (=) (=)"
  unfolding vec_rel_def rel_fun_def vec_eq_iff by (auto, blast+)

lemma multrow_transfer[transfer_rule]: "((R ===> R ===> R) ===> (=) ===> R
  ===> mat_rel R ===> mat_rel R) mat_multrow_gen mat_multrow_gen"
  unfolding mat_rel_def[abs_def] mat_multrow_gen_def[abs_def]
  by (intro rel_funI conjI allI impI eq_matI, auto simp: rel_fun_def)

(* we need index restrictions, TODO: can this be incorporated into transfer rule? *)
lemma swap_rows_transfer: "mat_rel R A B \<Longrightarrow> i < dim_row B \<Longrightarrow> j < dim_row B \<Longrightarrow>
  mat_rel R (mat_swaprows i j A) (mat_swaprows i j B)"
  unfolding mat_rel_def mat_swaprows_def
  by (intro rel_funI conjI allI impI eq_matI, auto)

lemma pivot_positions_gen_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
  shows
  "(R ===> mat_rel R ===> (=)) pivot_positions_gen pivot_positions_gen"
proof (intro rel_funI, goal_cases)
  case (1 ze ze' A A')
  note trans[transfer_rule] = 1
  from 1 have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
  obtain i j where id: "i = 0" "j = 0" and ij: "i \<le> dim_row A'" "j \<le> dim_col A'" by auto
  have "pivot_positions_main_gen ze A (dim_row A) (dim_col A) i j =
    pivot_positions_main_gen ze' A' (dim_row A') (dim_col A') i j"
    using ij
  proof (induct i j rule: pivot_positions_main_gen.induct[of "dim_row A'" "dim_col A'" A' ze'])
    case (1 i j)
    note simps[simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
    show ?case
    proof (cases "i < dim_row A' \<and> j < dim_col A'")
      case False
      with dim show ?thesis by auto
    next
      case True
      hence ij: "i < dim_row A'" "j < dim_col A'" and j: "Suc j \<le> dim_col A'" by auto
      note IH = 1(1-2)[OF ij _ _ j]
      from ij True trans have [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
        unfolding mat_rel_def by auto
      have eq: "(A $$ (i,j) = ze) = (A' $$ (i,j) = ze')" by transfer_prover
      show ?thesis
      proof (cases "A' $$ (i,j) = ze'")
        case True
        from ij have "i \<le> dim_row A'" by auto
        note IH = IH(1)[OF True this]
        thus ?thesis using True ij dim eq by simp
      next
        case False
        from ij have "Suc i \<le> dim_row A'" by auto
        note IH = IH(2)[OF False this]
        thus ?thesis using False ij dim eq by simp
      qed
    qed
  qed
  thus "pivot_positions_gen ze A = pivot_positions_gen ze' A'"
    unfolding pivot_positions_gen_def id .
qed

lemma set_pivot_positions_main_gen:
  "set (pivot_positions_main_gen ze A nr nc i j) \<subseteq> {0 ..< nr} \<times> {0 ..< nc}"
proof (induct i j rule: pivot_positions_main_gen.induct[of nr nc A ze])
  case (1 i j)
  note [simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
  from 1 show ?case
    by (cases "i < nr \<and> j < nc", auto)
qed

lemma find_base_vectors_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
  shows "((R ===> R) ===> R ===> R ===> mat_rel R
  ===> list_all2 (vec_rel R)) find_base_vectors_gen find_base_vectors_gen"
proof (intro rel_funI, goal_cases)
  case (1 um um' ze ze' on on' A A')
  note trans[transfer_rule] = 1 pivot_positions_gen_transfer[OF assms]
  from 1(4) have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
  have id: "pivot_positions_gen ze A = pivot_positions_gen ze' A'" by transfer_prover
  obtain xs where xs: "map snd (pivot_positions_gen ze' A') = xs" by auto
  obtain ys where ys: "[j\<leftarrow>[0..<dim_col A'] . j \<notin> set xs] = ys" by auto
  show "list_all2 (vec_rel R) (find_base_vectors_gen um ze on A)
    (find_base_vectors_gen um' ze' on' A')"
    unfolding find_base_vectors_gen_def Let_def id xs list_all2_conv_all_nth length_map ys dim
  proof (intro conjI[OF refl] allI impI)
    fix i
    assume i: "i < length ys"
    define y where "y = ys ! i"
    from i have y: "y < dim_col A'" unfolding y_def ys[symmetric] using nth_mem by fastforce
    let ?map = "map_of (map prod.swap (pivot_positions_gen ze' A'))"
    {
      fix i
      assume i: "i < dim_col A'"
      and neq: "i \<noteq> y"
      have "R (case ?map i of None \<Rightarrow> ze | Some j \<Rightarrow> um (A $$ (j, y)))
          (case ?map i of None \<Rightarrow> ze' | Some j \<Rightarrow> um' (A' $$ (j, y)))"
      proof (cases "?map i")
        case None
        with trans(2) show ?thesis by auto
      next
        case (Some j)
        from map_of_SomeD[OF this] have "(j,i) \<in> set (pivot_positions_gen ze' A')" by auto
        from subsetD[OF set_pivot_positions_main_gen this[unfolded pivot_positions_gen_def]]
        have j: "j < dim_row A'" by auto
        with trans(4) y have [transfer_rule]: "R (A $$ (j,y)) (A' $$ (j,y))" unfolding mat_rel_def by auto
        show ?thesis unfolding Some by (simp, transfer_prover)
      qed
    } note main = this
    show "vec_rel R (map (non_pivot_base_gen um ze on A (pivot_positions_gen ze' A')) ys ! i)
          (map (non_pivot_base_gen um' ze' on' A' (pivot_positions_gen ze' A')) ys ! i)"
      unfolding y_def[symmetric] nth_map[OF i]
      unfolding non_pivot_base_gen_def Let_def dim vec_rel_def
      by (intro conjI allI impI, force, insert main, auto simp: trans(3))
  qed
qed

lemma eliminate_entries_gen_transfer: assumes *[transfer_rule]: "(R ===> R ===> R) ad ad'"
  "(R ===> R ===> R) mul mul'"
  and vs: "\<And> j. j < dim_row B' \<Longrightarrow> R (vs j) (vs' j)"
  and i: "i < dim_row B'"
  and B: "mat_rel R B B'"
  shows "mat_rel R
   (eliminate_entries_gen ad mul vs B i j)
   (eliminate_entries_gen ad' mul' vs' B' i j)"
proof -
  note BB = B[unfolded mat_rel_def]
  show ?thesis unfolding mat_rel_def dim_eliminate_entries_gen
  proof (intro conjI impI allI)
    fix i' j'
    assume ij': "i' < dim_row B'" "j' < dim_col B'"
    with BB have ij: "i'< dim_row B" "j' < dim_col B" by auto
    have [transfer_rule]: "R (B $$ (i', j')) (B' $$ (i', j'))" using BB ij' by auto
    have [transfer_rule]: "R (B $$ (i, j')) (B' $$ (i, j'))" using BB ij' i by auto
    have [transfer_rule]: "R (vs i') (vs' i')" using ij' vs[of i'] by auto
    show "R (eliminate_entries_gen ad mul vs B i j $$ (i', j'))
        (eliminate_entries_gen ad' mul' vs' B' i j $$ (i', j'))"
      unfolding eliminate_entries_gen_def index_mat(1)[OF ij] index_mat(1)[OF ij'] split
      by transfer_prover
  qed (insert BB, auto)
qed

context
  fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero \<equiv> arith_ops_record.zero ops"
private abbreviation (input) one where "one \<equiv> arith_ops_record.one ops"
private abbreviation (input) plus where "plus \<equiv> arith_ops_record.plus ops"
private abbreviation (input) times where "times \<equiv> arith_ops_record.times ops"
private abbreviation (input) minus where "minus \<equiv> arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus \<equiv> arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide \<equiv> arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse \<equiv> arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo \<equiv> arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize \<equiv> arith_ops_record.normalize ops"

definition eliminate_entries_gen_zero :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> (integer \<Rightarrow> 'a) \<Rightarrow> 'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat" where
  "eliminate_entries_gen_zero minu time z v A I J = mat (dim_row A) (dim_col A) (\<lambda> (i, j).
     if v (integer_of_nat i) \<noteq> z \<and> i \<noteq> I then minu (A $$ (i,j)) (time (v (integer_of_nat i)) (A $$ (I,j))) else A $$ (i,j))"

definition eliminate_entries_i where "eliminate_entries_i \<equiv> eliminate_entries_gen_zero minus times zero"
definition multrow_i where "multrow_i \<equiv> mat_multrow_gen times"

lemma dim_eliminate_entries_gen_zero[simp]:
  "dim_row (eliminate_entries_gen_zero mm tt z v B i as) = dim_row B"
  "dim_col (eliminate_entries_gen_zero mm tt z v B i as) = dim_col B"
  unfolding eliminate_entries_gen_zero_def by auto

partial_function (tailrec) gauss_jordan_main_i :: "nat \<Rightarrow> nat \<Rightarrow> 'i mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'i mat" where
  [code]: "gauss_jordan_main_i nr nc A i j = (
    if i < nr \<and> j < nc then let aij = A $$ (i,j) in if aij = zero then
      (case [ i' . i' <- [Suc i ..< nr],  A $$ (i',j) \<noteq> zero]
        of [] \<Rightarrow> gauss_jordan_main_i nr nc A i (Suc j)
         | (i' # _) \<Rightarrow> gauss_jordan_main_i nr nc (swaprows i i' A) i j)
      else if aij = one then let
        v = (\<lambda> i. A $$ (nat_of_integer i,j)) in
        gauss_jordan_main_i nr nc
        (eliminate_entries_i v A i j) (Suc i) (Suc j)
      else let iaij = inverse aij; A' = multrow_i i iaij A;
        v = (\<lambda> i. A' $$ (nat_of_integer i,j))
        in gauss_jordan_main_i nr nc (eliminate_entries_i v A' i j) (Suc i) (Suc j)
    else A)"

definition gauss_jordan_single_i :: "'i mat \<Rightarrow> 'i mat" where
  "gauss_jordan_single_i A \<equiv> gauss_jordan_main_i (dim_row A) (dim_col A) A 0 0"

definition find_base_vectors_i :: "'i mat \<Rightarrow> 'i vec list" where
  "find_base_vectors_i A \<equiv> find_base_vectors_gen uminus zero one A"
end

(* **************************************************************************** *)
(* subsection \<open>Proofs\<close> *)

context field_ops
begin

lemma right_total_poly_rel[transfer_rule]: "right_total (mat_rel R)"
  using right_total_mat_rel[of R] right_total .

lemma bi_unique_poly_rel[transfer_rule]: "bi_unique (mat_rel R)"
  using bi_unique_mat_rel[of R] bi_unique .

lemma eq_mat_rel[transfer_rule]: "(mat_rel R ===> mat_rel R ===> (=)) (=) (=)"
  by (rule mat_rel_eq[OF eq])

lemma multrow_i[transfer_rule]: "((=) ===> R ===> mat_rel R ===> mat_rel R)
  (multrow_i ops) multrow"
  using multrow_transfer[of R] times unfolding multrow_i_def rel_fun_def by blast

lemma eliminate_entries_gen_zero[simp]:
  assumes "mat_rel R A A'" "I < dim_row A'" shows
  "eliminate_entries_gen_zero minus times zero v A I J = eliminate_entries_gen minus times (v o integer_of_nat) A I J"
  unfolding eliminate_entries_gen_def eliminate_entries_gen_zero_def
proof(standard,goal_cases)
  case (1 i j)
  have d1:"DP (A $$ (I, j))" and d2:"DP (A $$ (i, j))" using assms DPR 1
    unfolding mat_rel_def dim_col_mat dim_row_mat
    by (metis Domainp.DomainI)+
  have e1:"\<And> x. (0::'a) * x = 0" and e2:"\<And> x. x - (0::'a) = x" by auto
  from e1[untransferred,OF d1] e2[untransferred,OF d2] 1 show ?case by auto
qed auto

lemma eliminate_entries_i: assumes
  vs: "\<And> j. j < dim_row B' \<Longrightarrow> R (vs (integer_of_nat j)) (vs' j)"
  and i: "i < dim_row B'"
  and B: "mat_rel R B B'"
  shows "mat_rel R (eliminate_entries_i ops vs B i j)
    (eliminate_entries vs' B' i j)"
  unfolding eliminate_entries_i_def eliminate_entries_gen_zero[OF B i]
  by (rule eliminate_entries_gen_transfer, insert assms, auto simp: plus times minus)

lemma gauss_jordan_main_i:
  "nr = dim_row A' \<Longrightarrow> nc = dim_col A' \<Longrightarrow> mat_rel R A A' \<Longrightarrow> i \<le> nr \<Longrightarrow> j \<le> nc \<Longrightarrow>
    mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
proof -
  obtain P where P: "P = (A',i,j)" by auto
  let ?Rel = "measures [\<lambda> (A' :: 'a mat,i,j). nc - j, \<lambda> (A',i,j). if A' $$ (i,j) = 0 then 1 else 0]"
  have wf: "wf ?Rel" by simp
  show "nr = dim_row A' \<Longrightarrow> nc = dim_col A' \<Longrightarrow> mat_rel R A A' \<Longrightarrow> i \<le> nr \<Longrightarrow> j \<le> nc \<Longrightarrow>
    mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
    using P
  proof (induct P arbitrary: A' B' A i j rule: wf_induct[OF wf])
    case (1 P A' B' A i j)
    note prems = 1(2-6)
    note P = 1(7)
    note A[transfer_rule] = prems(3)
    note IH = 1(1)[rule_format, OF _ _ _ _ _ _ refl]
    note simps = gauss_jordan_main_code[of A' B' i j, unfolded Let_def, folded prems(1-2)]
      gauss_jordan_main_i.simps[of ops nr nc A i j] Let_def if_True if_False
    show ?case
    proof (cases "i < nr \<and> j < nc")
      case False
      hence id: "(i < nr \<and> j < nc) = False" by simp
      show ?thesis unfolding simps id by simp transfer_prover
    next
      case True note ij' = this
      hence id: "(i < nr \<and> j < nc) = True" "\<And> x y z. (if x = x then y else z) = y" by auto
      from True prems have ij [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
        unfolding mat_rel_def by auto
      from True prems have i: "i < dim_row A'" "j < dim_col A'" and i': "i < nr" "j < nc" by auto
      {
        fix i
        assume "i < dim_row A'"
        with i True prems have R[transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
          unfolding mat_rel_def by auto
        have "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)" by transfer_prover
        note this R
      } note eq_gen = this
      have eq: "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)"
        "(A $$ (i,j) = one) = (A' $$ (i,j) = 1)"
        by transfer_prover+
      show ?thesis
      proof (cases "A' $$ (i, j) = 0")
        case True
        hence eq: "A $$ (i,j) = zero" using eq by auto
        let ?is = "[ i' . i' <- [Suc i ..< nr],  A $$ (i',j) \<noteq> zero]"
        let ?is' = "[ i' . i' <- [Suc i ..< nr],  A' $$ (i',j) \<noteq> 0]"
        define xs where "xs = [Suc i..<nr]"
        have xs: "set xs \<subseteq> {0 ..< dim_row A'}" unfolding xs_def using prems by auto
        hence id': "?is = ?is'" unfolding xs_def[symmetric]
          by (induct xs, insert eq_gen, auto)
        show ?thesis
        proof (cases ?is')
          case Nil
          have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc A i (Suc j))
            (fst (gauss_jordan_main A' B' i (Suc j))))"
            unfolding True simps id eq unfolding Nil id'[unfolded Nil] by simp
          also have "\<dots>"
            by (rule IH, insert i prems P, auto)
          finally show ?thesis .
        next
          case (Cons i' idx')
          from arg_cong[OF this, of set] i
          have i': "i' < nr" "A' $$ (i', j) \<noteq> 0" by auto
          with ij' prems(1-2) have *: "i' < dim_row A'" "i < dim_row A'" "j < dim_col A'" by auto
          have rel: "((swaprows i i' A', i, j), P) \<in> ?Rel"
            by (simp add: P True * i')
          have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc (swaprows i i' A) i j)
            (fst (gauss_jordan_main (swaprows i i' A') (swaprows i i' B') i j)))"
             unfolding True simps id eq Cons id'[unfolded Cons] by simp
          also have "\<dots>"
            by (rule IH[OF rel _ _ swap_rows_transfer], insert i i' prems P True, auto)
          finally show ?thesis .
        qed
      next
        case False
        from False eq have neq: "(A $$ (i, j) = zero) = False" "(A' $$ (i, j) = 0) = False" by auto
        {
          fix B B' i
          assume B[transfer_rule]: "mat_rel R B B'" and dim: "dim_col B' = nc" and i: "i < dim_row B'"
          from dim i True have "j < dim_col B'" by simp
          with B i have "R (B $$ (i,j)) (B' $$ (i,j))"
            by (simp add: mat_rel_def)
        } note vec_rel = this
        from prems have dim: "dim_row A = dim_row A'" unfolding mat_rel_def by auto
        show ?thesis
        proof (cases "A' $$ (i, j) = 1")
          case True
          from True eq have eq: "(A $$ (i,j) = one) = True" "(A' $$ (i,j) = 1) = True" by auto
          note rel = vec_rel[OF A]
          show ?thesis unfolding simps id neq eq
            by (rule IH[OF _ _ _ eliminate_entries_i], insert rel prems ij i P dim, auto)
        next
          case False
          from False eq have eq: "(A $$ (i,j) = one) = False" "(A' $$ (i,j) = 1) = False" by auto
          show ?thesis unfolding simps id neq eq
          proof (rule IH, goal_cases)
            case 4
            have A': "mat_rel R (multrow_i ops i (inverse (A $$ (i, j))) A)
              (multrow i (inverse_class.inverse (A' $$ (i, j))) A')" by transfer_prover
            note rel = vec_rel[OF A']
            show ?case
              by (rule eliminate_entries_i[OF _ _ A'], insert rel prems i dim, auto)
          qed (insert prems i P, auto)
        qed
      qed
    qed
  qed
qed

lemma gauss_jordan_i[transfer_rule]:
  "(mat_rel R ===> mat_rel R) (gauss_jordan_single_i ops) gauss_jordan_single"
proof (intro rel_funI)
  fix A A'
  assume A: "mat_rel R A A'"
  show "mat_rel R (gauss_jordan_single_i ops A) (gauss_jordan_single A')"
    unfolding gauss_jordan_single_def gauss_jordan_single_i_def gauss_jordan_def
    by (rule gauss_jordan_main_i[OF _ _ A], insert A, auto simp: mat_rel_def)
qed

lemma find_base_vectors_i[transfer_rule]:
  "(mat_rel R ===> list_all2 (vec_rel R)) (find_base_vectors_i ops) find_base_vectors"
  unfolding find_base_vectors_i_def[abs_def]
  using find_base_vectors_transfer[OF eq] uminus zero one
  unfolding rel_fun_def by blast

end

lemma list_of_vec_transfer[transfer_rule]: "(vec_rel A ===> list_all2 A) list_of_vec list_of_vec"
  unfolding rel_fun_def vec_rel_def vec_eq_iff list_all2_conv_all_nth
  by auto

lemma IArray_sub'[simp]: "i < IArray.length a \<Longrightarrow> IArray.sub' (a, integer_of_nat i) = IArray.sub a i"
  by auto

lift_definition eliminate_entries_i2 ::
  "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (integer \<Rightarrow> 'a) \<Rightarrow> 'a mat_impl \<Rightarrow> integer \<Rightarrow> 'a mat_impl" is
  "\<lambda> z mminus ttimes v (nr, nc, a) i'.
   (nr,nc,let ai' = IArray.sub' (a, i') in (IArray.tabulate (integer_of_nat nr, \<lambda> i. let ai = IArray.sub' (a, i) in
     if i = i' then ai else
     let vi'j = v i
     in if vi'j = z then ai
        else
             IArray.tabulate (integer_of_nat nc, \<lambda> j. mminus (IArray.sub' (ai, j)) (ttimes vi'j
               (IArray.sub' (ai', j))))
       )))"
proof(goal_cases)
  case (1 z mm tt  vec prod nat2)
  thus ?case by(cases prod;cases "snd (snd prod)";auto simp:Let_def)
qed

lemma eliminate_entries_gen_zero [simp]:
  assumes "i<(dim_row A)" "j<(dim_col A)" shows
  "eliminate_entries_gen_zero mminus ttimes z v A I J $$ (i, j) =
   (if v (integer_of_nat i) = z \<or> i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v (integer_of_nat i)) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_zero_def by auto

lemma eliminate_entries_gen [simp]:
  assumes "i<(dim_row A)" "j<(dim_col A)" shows
  "eliminate_entries_gen mminus ttimes v A I J $$ (i, j) =
   (if i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v i) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_def by auto

lemma dim_mat_impl [simp]:
  "dim_row (mat_impl x) = dim_row_impl x"
  "dim_col (mat_impl x) = dim_col_impl x"
  by (cases "Rep_mat_impl x";auto simp:mat_impl.rep_eq dim_row_def dim_col_def dim_row_impl.rep_eq dim_col_impl.rep_eq)+

lemma dim_eliminate_entries_i2 [simp]:
  "dim_row_impl (eliminate_entries_i2 z mm tt v m i) = dim_row_impl m"
  "dim_col_impl (eliminate_entries_i2 z mm tt v m i) = dim_col_impl m"
  by (transfer, auto)+

lemma tabulate_nth: "i < n \<Longrightarrow> IArray.tabulate (integer_of_nat n, f) !! i = f (integer_of_nat i)"
  using of_fun_nth[of i n] by auto

lemma eliminate_entries_i2[code]:"eliminate_entries_gen_zero mm tt z v (mat_impl m) i j
   = (if i < dim_row_impl m
     then mat_impl (eliminate_entries_i2 z mm tt v m (integer_of_nat i))
     else (Code.abort (STR ''index out of range in eliminate_entries'')
       (\<lambda> _. eliminate_entries_gen_zero mm tt z v (mat_impl m) i j)))"
proof (cases "i < dim_row_impl m")
  case True
  hence id: "(i < dim_row_impl m) = True" by simp
  show ?thesis unfolding id if_True
  proof (standard;goal_cases)
    case (1 i j)
    have dims: "i < dim_row (mat_impl m)" "j < dim_col (mat_impl m)" using 1 by (auto simp:eliminate_entries_i2.rep_eq)
    then show ?case unfolding eliminate_entries_gen_zero[OF dims] using True
    proof(transfer, goal_cases)
      case (1 i m j ia v z mm tt)
      obtain nr nc M where m: "m = (nr,nc,M)" by (cases m)
      note 1 = 1[unfolded m, simplified]
      have mk: "\<And> f. mk_mat nr nc f (i,j) = f (i,j)"
         "\<And> f. mk_mat nr nc f (ia,j) = f (ia,j)"
        using 1 unfolding mk_mat_def mk_vec_def by auto
      note of_fun = of_fun_nth[OF 1(2)] of_fun_nth[OF 1(3)] tabulate_nth[OF 1(2)] tabulate_nth[OF 1(3)]
      let ?c1 = "v (integer_of_nat i) = z"
      show ?case
      proof (cases "?c1 \<or> i = ia")
        case True
        hence id: "(if ?c1 \<or> i = ia then x else y) = x"
          "(if integer_of_nat i = integer_of_nat ia then x else if ?c1 then x else y) = x" for x y
          by auto
        show ?thesis unfolding id m o_def Let_def split snd_conv mk of_fun by (auto simp: 1)
      next
        case False
        hence id: "?c1 = False " "(integer_of_nat i = integer_of_nat ia) = False" "(False \<or> i = ia) = False"
          by (auto simp add: integer_of_nat_eq_of_nat)
        show ?thesis unfolding m o_def Let_def split snd_conv mk of_fun id if_False
          by (auto simp: 1)
      qed
    qed
  qed (auto simp:eliminate_entries_i2.rep_eq)
qed auto

end


theory Max_DWD imports
  "../../tools/autocorres/AutoCorres"
begin
text{*

Author: Dan DaCosta
Description: Correctness proof for a function that finds the max value in an array. The correctness
in this case is based on the following declarative statements:

 - The max in a list should be greater than or equal to all elements in the list.

 - The max in a list should be equal to at least one element in the list.

*}

install_C_file max_DWD.c
autocorres [ heap_abs_syntax, ts_rules = nondet, unsigned_word_abs = max ] max_DWD.c
context max_DWD begin

definition array :: "lifted_globals \<Rightarrow> 32 word ptr \<Rightarrow> nat \<Rightarrow> bool"  where
 "array h p l \<equiv> (\<forall> i < l. is_valid_w32 h (p +\<^sub>p int i))"

lemma "
\<lbrace> \<lambda> (h::lifted_globals).
  array h p l
  \<and> l < UINT_MAX
  \<and> h' = h \<rbrace>
 max' p l
\<lbrace> \<lambda> (m::nat) (h::lifted_globals).
  h' = h
  \<and> (\<forall> j<l. unat h'[p +\<^sub>p int j] \<le> m)
  \<and> 0 < l \<longrightarrow> (\<exists> k<l. unat h'[p +\<^sub>p int k] = m)\<rbrace>!
"
apply (rule validNF_assume_pre)
apply (unfold max'_def)
apply (subst whileLoop_add_inv
  [where
    I = "\<lambda> (i,m) h.
      h' = h
      \<and> i \<le> l
      \<and> (\<forall> j<i. unat h'[p +\<^sub>p int j] \<le> m)
      \<and> (0 < i \<longrightarrow> (\<exists> k<i. unat h'[p +\<^sub>p int k] = m))
      \<and> (i = 0 \<longrightarrow> 0 = m)"
    and M = "\<lambda>((i,m),_).  l - i"])
apply wp
apply (auto simp add: array_def less_Suc_eq)
done


(*
  Title:    Social Decision Schemes.thy
  Author:   Manuel Eberl, TU München

  Definitions of Social Decision Schemes, their properties, and related concepts
*)

section \<open>Social Decision Schemes\<close>

theory Social_Decision_Schemes
imports
  Complex_Main
  "HOL-Probability.Probability"
  Preference_Profiles
  Elections
  Order_Predicates
  Stochastic_Dominance
  SD_Efficiency
begin

subsection \<open>Basic Social Choice definitions\<close>

context election
begin

text \<open>
  The set of lotteries, i.e. the probability mass functions on the type @{typ "'alt"}
  whose support is a subset of the alternative set.
\<close>
abbreviation lotteries where
  "lotteries \<equiv> lotteries_on alts"

text \<open>
  The probability that a lottery returns an alternative that is in the given set
\<close>
abbreviation lottery_prob :: "'alt lottery \<Rightarrow> 'alt set \<Rightarrow> real" where
  "lottery_prob \<equiv> measure_pmf.prob"

lemma lottery_prob_alts_superset:
  assumes "p \<in> lotteries" "alts \<subseteq> A"
  shows   "lottery_prob p A = 1"
  using assms by (subst measure_pmf.prob_eq_1) (auto simp: AE_measure_pmf_iff lotteries_on_def)

lemma lottery_prob_alts: "p \<in> lotteries \<Longrightarrow> lottery_prob p alts = 1"
  by (rule lottery_prob_alts_superset) simp_all

end

text \<open>
  In the context of an election, a preference profile is a function that
  assigns to each agent her preference relation (which is a total preorder)
\<close>

subsection \<open>Social Decision Schemes\<close>

text \<open>
  In the context of an election, a Social Decision Scheme (SDS) is a function that
  maps preference profiles to lotteries on the alternatives.
\<close>
locale social_decision_scheme = election agents alts
  for agents :: "'agent set" and alts :: "'alt set" +
  fixes sds :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery"
  assumes sds_wf: "is_pref_profile R \<Longrightarrow> sds R \<in> lotteries"

subsection \<open>Anonymity\<close>

text \<open>
  An SDS is anonymous if permuting the agents in the input does not change the result.
\<close>
locale anonymous_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes anonymous: "\<pi> permutes agents \<Longrightarrow> is_pref_profile R \<Longrightarrow> sds (R \<circ> \<pi>) = sds R"
begin

lemma anonymity_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
  assumes "mset (map snd xs) = mset (map snd ys)"
  shows   "sds (prefs_from_table xs) = sds (prefs_from_table ys)"
proof -
  from prefs_from_table_agent_permutation[OF assms] guess \<pi> .
  with anonymous[of \<pi>, of "prefs_from_table xs"] assms(1) show ?thesis
    by (simp add: pref_profile_from_tableI)
qed

context
begin
qualified lemma anonymity_prefs_from_table_aux:
  assumes "R1 = prefs_from_table xs" "prefs_from_table_wf agents alts xs"
  assumes "R2 = prefs_from_table ys" "prefs_from_table_wf agents alts ys"
  assumes "mset (map snd xs) = mset (map snd ys)"
  shows   "sds R1 = sds R2" unfolding assms(1,3)
  by (rule anonymity_prefs_from_table) (simp_all add: assms del: mset_map)
end

end

subsection \<open>Neutrality\<close>

text \<open>
  An SDS is neutral if permuting the alternatives in the input does not change the
  result, modulo the equivalent permutation in the output lottery.
\<close>
locale neutral_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes neutral: "\<sigma> permutes alts \<Longrightarrow> is_pref_profile R \<Longrightarrow>
                        sds (permute_profile \<sigma> R) = map_pmf \<sigma> (sds R)"
begin

text \<open>
  Alternative formulation of neutrality that shows that our definition is
  equivalent to that in the paper.
\<close>
lemma neutral':
  assumes "\<sigma> permutes alts"
  assumes "is_pref_profile R"
  assumes "a \<in> alts"
  shows   "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (sds R) a"
proof -
  from assms have A: "set_pmf (sds R) \<subseteq> alts" using sds_wf
    by (simp add: lotteries_on_def)
  from assms(1,2) have "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (map_pmf \<sigma> (sds R)) (\<sigma> a)"
    by (subst neutral) simp_all
  also from assms have "\<dots> = pmf (sds R) a"
    by (intro pmf_map_inj') (simp_all add: permutes_inj)
  finally show ?thesis .
qed

end

locale an_sds =
  anonymous_sds agents alts sds + neutral_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds
begin

lemma sds_anonymous_neutral:
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
  assumes eq: "anonymous_profile R1 =
                 image_mset (map ((`) \<sigma>)) (anonymous_profile R2)"
  shows   "sds R1 = map_pmf \<sigma> (sds R2)"
proof -
  interpret R1: pref_profile_wf agents alts R1 by fact
  interpret R2: pref_profile_wf agents alts R2 by fact
  from perm have wf': "is_pref_profile (permute_profile \<sigma> R2)"
    by (rule R2.wf_permute_alts)
  from eq perm have "anonymous_profile R1 = anonymous_profile (permute_profile \<sigma> R2)"
    by (simp add: R2.anonymous_profile_permute)
  from anonymous_profile_agent_permutation[OF this wf(1) wf']
    obtain \<pi> where "\<pi> permutes agents" "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by auto
  have "sds (permute_profile \<sigma> R2 \<circ> \<pi>) = sds (permute_profile \<sigma> R2)"
    by (rule anonymous) fact+
  also have "\<dots> = map_pmf \<sigma> (sds R2)"
    by (rule neutral) fact+
  also have "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by fact
  finally show ?thesis .
qed

lemma sds_anonymous_neutral':
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
  assumes eq: "anonymous_profile R1 =
                 image_mset (map ((`) \<sigma>)) (anonymous_profile R2)"
  shows   "pmf (sds R1) (\<sigma> x) = pmf (sds R2) x"
proof -
  have "sds R1 = map_pmf \<sigma> (sds R2)" by (intro sds_anonymous_neutral) fact+
  also have "pmf \<dots> (\<sigma> x) = pmf (sds R2) x" by (intro pmf_map_inj' permutes_inj[OF perm])
  finally show ?thesis .
qed

lemma sds_automorphism:
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
  assumes eq: "image_mset (map ((`) \<sigma>)) (anonymous_profile R) = anonymous_profile R"
  shows   "map_pmf \<sigma> (sds R) = sds R"
  using sds_anonymous_neutral[OF perm wf wf eq [symmetric]] ..

end

lemma an_sds_automorphism_aux:
  assumes wf: "prefs_from_table_wf agents alts yss" "R \<equiv> prefs_from_table yss"
  assumes an: "an_sds agents alts sds"
  assumes eq: "mset (map ((map ((`) (permutation_of_list xs))) \<circ> snd) yss) = mset (map snd yss)"
  assumes perm: "set (map fst xs) \<subseteq> alts" "set (map snd xs) = set (map fst xs)"
                "distinct (map fst xs)"
      and x: "x \<in> alts" "y = permutation_of_list xs x"
  shows   "pmf (sds R) x = pmf (sds R) y"
proof -
  note perm = list_permutesI[OF perm]
  let ?\<sigma> = "permutation_of_list xs"
  note perm' = permutation_of_list_permutes [OF perm]
  from wf have wf': "pref_profile_wf agents alts R" by (simp add: pref_profile_from_tableI)
  then interpret R: pref_profile_wf agents alts R .
  from perm' interpret R': pref_profile_wf agents alts "permute_profile ?\<sigma> R"
    by (simp add: R.wf_permute_alts)
  from an interpret an_sds agents alts sds .

  from eq wf have eq': "image_mset (map ((`) ?\<sigma>)) (anonymous_profile R) = anonymous_profile R"
    by (simp add: anonymise_prefs_from_table mset_map multiset.map_comp)
  from perm' x have "pmf (sds R) x = pmf (map_pmf ?\<sigma> (sds R)) (?\<sigma> x)"
    by (simp add: pmf_map_inj' permutes_inj)
  also from eq' x wf' perm' have "map_pmf ?\<sigma> (sds R) = sds R"
    by (intro sds_automorphism)
       (simp_all add: R.anonymous_profile_permute pref_profile_from_tableI)
  finally show ?thesis using x by simp
qed

subsection \<open>Ex-post efficiency\<close>

locale ex_post_efficient_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes ex_post_efficient:
    "is_pref_profile R \<Longrightarrow> set_pmf (sds R) \<inter> pareto_losers R = {}"
begin

lemma ex_post_efficient':
  assumes "is_pref_profile R" "y \<succ>[Pareto(R)] x"
  shows   "pmf (sds R) x = 0"
  using ex_post_efficient[of R] assms
  by (auto simp: set_pmf_eq pareto_losers_def)

lemma ex_post_efficient'':
  assumes "is_pref_profile R" "i \<in> agents"  "\<forall>i\<in>agents. y \<succeq>[R i] x" "\<not>y \<preceq>[R i] x"
  shows   "pmf (sds R) x = 0"
proof -
  from assms(1) interpret pref_profile_wf agents alts R .
  from assms(2-) show ?thesis
    by (intro ex_post_efficient'[OF assms(1), of _ y])
       (auto simp: Pareto_iff strongly_preferred_def)
qed

end

subsection \<open>SD efficiency\<close>

text \<open>
  An SDS is SD-efficient if it returns an SD-efficient lottery for every
  preference profile, i.e. if the SDS outputs a lottery, it is never the case
  that there is another lottery that is weakly preferred by all agents an
  strictly preferred by at least one agent.
\<close>
locale sd_efficient_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes SD_efficient: "is_pref_profile R \<Longrightarrow> SD_efficient R (sds R)"
begin

text \<open>
  An alternative formulation of SD-efficiency that is somewhat more convenient to use.
\<close>
lemma SD_efficient':
  assumes "is_pref_profile R" "q \<in> lotteries"
  assumes "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] sds R" "i \<in> agents" "q \<succ>[SD(R i)] sds R"
  shows   P
proof -
  interpret pref_profile_wf agents alts R by fact
  show ?thesis
    using SD_efficient[of R] sds_wf[OF assms(1)] assms unfolding SD_efficient_def' by blast
qed

text \<open>
  Any SD-efficient SDS is also ex-post efficient.
\<close>
sublocale ex_post_efficient_sds
proof unfold_locales
  fix R :: "('agent, 'alt) pref_profile" assume R_wf: "is_pref_profile R"
  interpret pref_profile_wf agents alts R by fact
  from R_wf show "set_pmf (sds R) \<inter> pareto_losers R = {}"
    by (intro SD_efficient_no_pareto_loser SD_efficient sds_wf)
qed

text \<open>
  The following rule can be used to derive facts from inefficient supports:
  If a set of alternatives is an inefficient support, at least one of the
  alternatives in it must receive probability 0.
\<close>
lemma SD_inefficient_support:
  assumes A: "A \<noteq> {}" "A \<subseteq> alts" and inefficient: "\<not>SD_efficient R (pmf_of_set A)"
  assumes wf: "is_pref_profile R"
  shows   "\<exists>x\<in>A. pmf (sds R) x = 0"
proof (rule ccontr)
  interpret pref_profile_wf agents alts R by fact
  assume "\<not>(\<exists>x\<in>A. pmf (sds R) x = 0)"
  with A have "set_pmf (pmf_of_set A) \<subseteq> set_pmf (sds R)"
     by (subst set_pmf_of_set) (auto simp: set_pmf_eq intro: finite_subset[OF _ finite_alts])
  from inefficient and this have "\<not>SD_efficient R (sds R)"
    by (rule SD_inefficient_support_subset) (simp add: wf sds_wf)
  moreover from SD_efficient wf have "SD_efficient R (sds R)" .
  ultimately show False by contradiction
qed

end

subsection \<open>Weak strategyproofness\<close>

context social_decision_scheme
begin

text \<open>
  The SDS is said to be manipulable for a particular preference profile,
  a particular agent, and a particular alternative preference ordering for that agent
  if the lottery obtained if the agent submits the alternative preferences strictly
  SD-dominates that obtained if the original preferences are submitted.
  (SD-dominated w.r.t. the original preferences)
\<close>
definition manipulable_profile
    :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where
  "manipulable_profile R i Ri' \<longleftrightarrow> sds (R(i := Ri')) \<succ>[SD (R i)] sds R"

end

text \<open>
  An SDS is weakly strategyproof (or just strategyproof) if it is not manipulable
  for any combination of preference profiles, agents, and alternative preference relations.
\<close>
locale strategyproof_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes strategyproof:
    "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
         \<not>manipulable_profile R i Ri'"

subsection \<open>Strong strategyproofness\<close>

context social_decision_scheme
begin

text \<open>
  The SDS is said to be strongly strategyproof for a particular preference profile,
  a particular agent, and a particular alternative preference ordering for that agent
  if the lottery obtained if the agent submits the alternative preferences is
  SD-dominated by the one obtained if the original preferences are submitted.
  (SD-dominated w.r.t. the original preferences)

  In other words: the SDS is strategyproof w.r.t the preference profile $R$ and
  the agent $i$ and the alternative preference relation $R_i'$ if the lottery for
  obtained for $R$ is at least as good for $i$ as the lottery obtained when $i$
  misrepresents her preferences as $R_i'$.
\<close>
definition strongly_strategyproof_profile
    :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where
  "strongly_strategyproof_profile R i Ri' \<longleftrightarrow> sds R \<succeq>[SD (R i)] sds (R(i := Ri'))"

lemma strongly_strategyproof_profileI [intro]:
  assumes "is_pref_profile R" "total_preorder_on alts Ri'" "i \<in> agents"
  assumes "\<And>x. x \<in> alts \<Longrightarrow> lottery_prob (sds (R(i := Ri'))) (preferred_alts (R i) x)
                               \<le> lottery_prob (sds R) (preferred_alts (R i) x)"
  shows "strongly_strategyproof_profile R i Ri'"
proof -
  interpret pref_profile_wf agents alts R by fact
  show ?thesis
    unfolding strongly_strategyproof_profile_def
    by rule (auto intro!: sds_wf assms pref_profile_wf.wf_update)
qed

lemma strongly_strategyproof_imp_not_manipulable:
  assumes "strongly_strategyproof_profile R i Ri'"
  shows   "\<not>manipulable_profile R i Ri'"
  using assms unfolding strongly_strategyproof_profile_def manipulable_profile_def
  by (auto simp: strongly_preferred_def)

end

text \<open>
  An SDS is strongly strategyproof if it is strongly strategyproof for all combinations
  of preference profiles, agents, and alternative preference relations.
\<close>
locale strongly_strategyproof_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes strongly_strategyproof:
    "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
         strongly_strategyproof_profile R i Ri'"
begin

text \<open>
  Any SDS that is strongly strategyproof is also weakly strategyproof.
\<close>
sublocale strategyproof_sds
  by unfold_locales
     (simp add: strongly_strategyproof_imp_not_manipulable strongly_strategyproof)

end

locale strategyproof_an_sds =
  strategyproof_sds agents alts sds + an_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds

end


section \<open>Rational types for code generation\<close>

theory Code_Rational
  imports "HOL.Real" "HOL-Library.Code_Target_Nat"
begin

subsection \<open>Type of target language rationals\<close>

typedef rational = "UNIV :: rat set"
  morphisms rat_of_rational rational_of_rat ..

setup_lifting type_definition_rational

lemma rational_eq_iff:
  "k = l \<longleftrightarrow> rat_of_rational k = rat_of_rational l"
  by transfer rule

lemma rational_eqI:
  "rat_of_rational k = rat_of_rational l \<Longrightarrow> k = l"
  using rational_eq_iff [of k l] by simp

lemma rat_of_rational_rational_of_rat [simp]:
  "rat_of_rational (rational_of_rat k) = k"
  by transfer rule

lemma rational_of_rat_rat_of_rational [simp]:
  "rational_of_rat (rat_of_rational k) = k"
  by transfer rule

instantiation rational :: ring_1
begin

lift_definition zero_rational :: rational
  is "0 :: rat"
  .

declare zero_rational.rep_eq [simp]

lift_definition one_rational :: rational
  is "1 :: rat"
  .

declare one_rational.rep_eq [simp]

lift_definition plus_rational :: "rational \<Rightarrow> rational \<Rightarrow> rational"
  is "plus :: rat \<Rightarrow> rat \<Rightarrow> rat"
  .

declare plus_rational.rep_eq [simp]

lift_definition uminus_rational :: "rational \<Rightarrow> rational"
  is "uminus :: rat \<Rightarrow> rat"
  .

declare uminus_rational.rep_eq [simp]

lift_definition minus_rational :: "rational \<Rightarrow> rational \<Rightarrow> rational"
  is "minus :: rat \<Rightarrow> rat \<Rightarrow> rat"
  .

declare minus_rational.rep_eq [simp]

lift_definition times_rational :: "rational \<Rightarrow> rational \<Rightarrow> rational"
  is "times :: rat \<Rightarrow> rat \<Rightarrow> rat"
  .

declare times_rational.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

instance rational :: Rings.dvd ..

instantiation rational :: field
begin

lift_definition inverse_rational :: "rational \<Rightarrow> rational"
  is "inverse :: rat \<Rightarrow> rat"
  .

lift_definition divide_rational :: "rational \<Rightarrow> rational \<Rightarrow> rational"
  is "divide :: rat \<Rightarrow> rat \<Rightarrow> rat"
  .

declare inverse_rational.rep_eq [simp]

instance proof
qed (transfer, simp add: field_simps)+

end

instantiation rational :: "{linordered_idom, equal}"
begin

lift_definition abs_rational :: "rational \<Rightarrow> rational"
  is "abs :: rat \<Rightarrow> rat"
  .

declare abs_rational.rep_eq [simp]

lift_definition sgn_rational :: "rational \<Rightarrow> rational"
  is "sgn :: rat \<Rightarrow> rat"
  .

declare sgn_rational.rep_eq [simp]

lift_definition less_eq_rational :: "rational \<Rightarrow> rational \<Rightarrow> bool"
  is "less_eq :: rat \<Rightarrow> rat \<Rightarrow> bool"
  .

lemma rational_less_eq_iff:
  "k \<le> l \<longleftrightarrow> rat_of_rational k \<le> rat_of_rational l"
  by (fact less_eq_rational.rep_eq)

lift_definition less_rational :: "rational \<Rightarrow> rational \<Rightarrow> bool"
  is "less :: rat \<Rightarrow> rat \<Rightarrow> bool"
  .

lemma rational_less_iff:
  "k < l \<longleftrightarrow> rat_of_rational k < rat_of_rational l"
  by (fact less_rational.rep_eq)

lift_definition equal_rational :: "rational \<Rightarrow> rational \<Rightarrow> bool"
  is "HOL.equal :: rat \<Rightarrow> rat \<Rightarrow> bool"
  .

instance
  by standard (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] mult_strict_right_mono linear)+

end

instance rational :: linordered_field ..

context
  includes lifting_syntax
  notes transfer_rule_numeral [transfer_rule]
begin

lemma [transfer_rule]:
  "((\<longleftrightarrow>) ===> pcr_rational) of_bool of_bool"
  by (unfold of_bool_def) transfer_prover

lemma [transfer_rule]:
  "((=) ===> pcr_rational) numeral numeral"
  by transfer_prover

lemma [transfer_rule]:
  "((=) ===> (=) ===> pcr_rational) Num.sub Num.sub"
  by (unfold Num.sub_def) transfer_prover

lemma [transfer_rule]:
  "(pcr_rational ===> (=) ===> pcr_rational) (^) (^)"
  by (unfold power_def) transfer_prover

end

lemma "(numeral x :: rat) / numeral y = Frct(numeral x, numeral y)"
  using Frct_code_post(6) by force

context
includes integer.lifting
begin

lift_definition Frct_integer :: "integer \<times> integer \<Rightarrow> rational"
  is "Frct :: int \<times> int \<Rightarrow> rat" .

definition rational_of_integer :: "integer \<Rightarrow> rational" where
"rational_of_integer x = Frct_integer (x, 1)"

lemma numeral_rational_integer: "numeral n = rational_of_integer (numeral n)"
  unfolding rational_of_integer_def
  by (transfer, simp only: Frct_code_post(4)[THEN sym])

lemma divide_integer_rational:
  "rational_of_integer x / rational_of_integer y = Frct_integer (x, y)"
  unfolding rational_of_integer_def
  by (transfer, simp add: Fract_of_int_quotient)

lemma uminus_Frct_integer: "- Frct_integer (x, y) = Frct_integer (- x, y)"
  by (transfer, simp)

lemma rational_power: "(rational_of_integer x :: rational) ^ n = rational_of_integer (x ^ n)"
  unfolding rational_of_integer_def
  by (transfer, simp add: Fract_of_int_eq)

end

declare numeral_rational_integer [code_unfold]
declare divide_integer_rational [code_unfold]
declare rational_power [code_unfold]
declare uminus_Frct_integer [code_unfold]

code_printing code_module Rational \<rightharpoonup> (Haskell)
 \<open>module Rational(fract, numerator, denominator) where

  import qualified Data.Ratio
  import Data.Ratio(numerator, denominator)

  fract (a, b) = a Data.Ratio.% b\<close>

code_printing
  type_constructor rational \<rightharpoonup> (Haskell) "Prelude.Rational"
  | class_instance rational :: "HOL.equal" \<rightharpoonup> (Haskell) -
  | constant "0 :: rational" \<rightharpoonup> (Haskell) "(0::Rational)"
  | constant "1 :: rational" \<rightharpoonup> (Haskell) "(1::Rational)"
  | constant "Frct_integer" \<rightharpoonup> (Haskell) "Rational.fract (_)"
  | constant "HOL.equal :: rational \<Rightarrow> rational \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) "(_) == (_)"
  |  constant "(<) :: rational \<Rightarrow> rational \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) "_ < _"
  |  constant "(\<le>) :: rational \<Rightarrow> rational \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) "_ <= _"
  | constant "(+) :: rational \<Rightarrow> rational \<Rightarrow> rational" \<rightharpoonup>
    (Haskell) "(_) + (_)"
  | constant "(-) :: rational \<Rightarrow> rational \<Rightarrow> rational" \<rightharpoonup>
    (Haskell) "(_) - (_)"
  | constant "(*) :: rational \<Rightarrow> rational \<Rightarrow> rational" \<rightharpoonup>
    (Haskell) "(_) * (_)"
  | constant "(/) :: rational \<Rightarrow> rational \<Rightarrow> rational" \<rightharpoonup>
    (Haskell) "(_) '/ (_)"
 | constant "uminus :: rational \<Rightarrow> rational" \<rightharpoonup>
    (Haskell) "Prelude.negate"

text \<open> We add a specific version of integer powers, so we can map these to the target function. \<close>

definition integer_power :: "'a::power \<Rightarrow> integer \<Rightarrow> 'a" where
"integer_power x y = x ^ (nat_of_integer y)"

lemma power_nat_of_integer [code_unfold]: "x ^ (nat_of_integer y) = integer_power x y"
  by (simp add: integer_power_def nat_of_integer_def)

code_printing
  constant "integer_power" \<rightharpoonup> (Haskell) "(_) ^ (_)"

definition numerator :: "rational \<Rightarrow> integer" where
"numerator x = integer_of_int (fst (quotient_of (rat_of_rational x)))"

definition denominator :: "rational \<Rightarrow> integer" where
"denominator x = integer_of_int (snd (quotient_of (rat_of_rational x)))"

code_printing
  constant numerator \<rightharpoonup> (Haskell) "numerator"
| constant denominator \<rightharpoonup> (Haskell) "denominator"

end