(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section \<open>Arithmetics via Records\<close>

text \<open>We create a locale for rings and fields based on a record
  that includes all the necessary operations.\<close>

theory Arithmetic_Record_Based
imports
  "HOL-Library.More_List"
  "HOL-Computational_Algebra.Euclidean_Algorithm"
begin
datatype 'a arith_ops_record = Arith_Ops_Record
  (zero : 'a)
  (one  : 'a)
  (plus : "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  (times : "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  (minus : "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  (uminus : "'a \<Rightarrow> 'a")
  (divide : "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  (inverse : "'a \<Rightarrow> 'a")
  ("modulo" : "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  (normalize : "'a \<Rightarrow> 'a")
  (unit_factor : "'a \<Rightarrow> 'a")
  (of_int : "int \<Rightarrow> 'a")
  (to_int : "'a \<Rightarrow> int")
  (DP : "'a \<Rightarrow> bool")

hide_const (open)
  zero
  one
  plus
  times
  minus
  uminus
  divide
  inverse
  modulo
  normalize
  unit_factor
  of_int
  to_int
  DP

fun listprod_i :: "'i arith_ops_record \<Rightarrow> 'i list \<Rightarrow> 'i" where
  "listprod_i ops (x # xs) = arith_ops_record.times ops x (listprod_i ops xs)"
| "listprod_i ops [] = arith_ops_record.one ops"

locale arith_ops = fixes ops :: "'i arith_ops_record" (structure)
begin

abbreviation (input) zero where "zero \<equiv> arith_ops_record.zero ops"
abbreviation (input) one where "one \<equiv> arith_ops_record.one ops"
abbreviation (input) plus where "plus \<equiv> arith_ops_record.plus ops"
abbreviation (input) times where "times \<equiv> arith_ops_record.times ops"
abbreviation (input) minus where "minus \<equiv> arith_ops_record.minus ops"
abbreviation (input) uminus where "uminus \<equiv> arith_ops_record.uminus ops"
abbreviation (input) divide where "divide \<equiv> arith_ops_record.divide ops"
abbreviation (input) inverse where "inverse \<equiv> arith_ops_record.inverse ops"
abbreviation (input) modulo where "modulo \<equiv> arith_ops_record.modulo ops"
abbreviation (input) normalize where "normalize \<equiv> arith_ops_record.normalize ops"
abbreviation (input) unit_factor where "unit_factor \<equiv> arith_ops_record.unit_factor ops"
abbreviation (input) DP where "DP \<equiv> arith_ops_record.DP ops"

partial_function (tailrec) gcd_eucl_i :: "'i \<Rightarrow> 'i \<Rightarrow> 'i" where
  "gcd_eucl_i a b = (if b = zero
    then normalize a else gcd_eucl_i b (modulo a b))"

partial_function (tailrec) euclid_ext_aux_i :: "'i \<Rightarrow> 'i \<Rightarrow> 'i \<Rightarrow> 'i \<Rightarrow> 'i \<Rightarrow> 'i \<Rightarrow> ('i \<times> 'i) \<times> 'i" where
  "euclid_ext_aux_i s' s t' t r' r = (
     if r = zero then let c = divide one (unit_factor r') in ((times s' c, times t' c), normalize r')
     else let q = divide r' r
          in  euclid_ext_aux_i s (minus s' (times q s)) t (minus t' (times q t)) r (modulo r' r))"

abbreviation (input) euclid_ext_i :: "'i \<Rightarrow> 'i \<Rightarrow> ('i \<times> 'i) \<times> 'i" where
  "euclid_ext_i \<equiv> euclid_ext_aux_i one zero zero one"

end

declare arith_ops.gcd_eucl_i.simps[code]
declare arith_ops.euclid_ext_aux_i.simps[code]

unbundle lifting_syntax

locale ring_ops = arith_ops ops for ops :: "'i arith_ops_record" +
  fixes R :: "'i \<Rightarrow> 'a :: comm_ring_1 \<Rightarrow> bool"
  assumes bi_unique[transfer_rule]: "bi_unique R"
  and right_total[transfer_rule]: "right_total R"
  and zero[transfer_rule]: "R zero 0"
  and one[transfer_rule]: "R one 1"
  and plus[transfer_rule]: "(R ===> R ===> R) plus (+)"
  and minus[transfer_rule]: "(R ===> R ===> R) minus (-)"
  and uminus[transfer_rule]: "(R ===> R) uminus Groups.uminus"
  and times[transfer_rule]: "(R ===> R ===> R) times ((*))"
  and eq[transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
  and DPR[transfer_domain_rule]: "Domainp R = DP"
begin
lemma left_right_unique[transfer_rule]: "left_unique R" "right_unique R"
  using bi_unique unfolding bi_unique_def left_unique_def right_unique_def by auto

lemma listprod_i[transfer_rule]: "(list_all2 R ===> R) (listprod_i ops) prod_list"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  thus ?case
  proof (induct xs ys rule: list_all2_induct)
    case (Cons x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one)
qed
end

locale idom_ops = ring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i \<Rightarrow> 'a :: idom \<Rightarrow> bool"

locale idom_divide_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i \<Rightarrow> 'a :: idom_divide \<Rightarrow> bool" +
  assumes divide[transfer_rule]: "(R ===> R ===> R) divide Rings.divide"

locale euclidean_semiring_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i \<Rightarrow> 'a :: {idom,normalization_euclidean_semiring} \<Rightarrow> bool"  +
  assumes modulo[transfer_rule]: "(R ===> R ===> R) modulo (mod)"
    and normalize[transfer_rule]: "(R ===> R) normalize Rings.normalize"
    and unit_factor[transfer_rule]: "(R ===> R) unit_factor Rings.unit_factor"
begin
lemma gcd_eucl_i [transfer_rule]: "(R ===> R ===> R) gcd_eucl_i Euclidean_Algorithm.gcd"
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  thus ?case
  proof (induct X Y arbitrary: x y rule: Euclidean_Algorithm.gcd.induct)
    case (1 X Y x y)
    note [transfer_rule] = 1(2-)
    note simps = gcd_eucl_i.simps[of x y] Euclidean_Algorithm.gcd.simps[of X Y]
    have eq: "(y = zero) = (Y = 0)" by transfer_prover
    show ?case
    proof (cases "Y = 0")
      case True
      hence *: "y = zero" using eq by simp
      have "R (normalize x) (Rings.normalize X)" by transfer_prover
      thus ?thesis unfolding simps unfolding True * by simp
    next
      case False
      with eq have yz: "y \<noteq> zero" by simp
      have "R (gcd_eucl_i y (modulo x y)) (Euclidean_Algorithm.gcd Y (X mod Y))"
        by (rule 1(1)[OF False], transfer_prover+)
      thus ?thesis unfolding simps using False yz by simp
    qed
  qed
qed
end

locale euclidean_ring_ops = euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i \<Rightarrow> 'a :: {idom,euclidean_ring_gcd} \<Rightarrow> bool"  +
  assumes divide[transfer_rule]: "(R ===> R ===> R) divide (div)"
begin
lemma euclid_ext_aux_i[transfer_rule]:
  "(R ===> R ===> R ===> R ===> R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_aux_i euclid_ext_aux"
proof (intro rel_funI, goal_cases)
  case (1 z Z a A b B c C x X y Y)
  thus ?case
  proof (induct Z A B C X Y arbitrary: z a b c x y rule: euclid_ext_aux.induct)
    case (1 Z A B C X Y z a b c x y)
    note [transfer_rule] = 1(2-)
    note simps = euclid_ext_aux_i.simps[of z a b c x y] euclid_ext_aux.simps[of Z A B C X Y]
    have eq: "(y = zero) = (Y = 0)" by transfer_prover
    show ?case
    proof (cases "Y = 0")
      case True
      hence *: "(y = zero) = True" "(Y = 0) = True" using eq by auto
      show ?thesis unfolding simps unfolding * if_True
        by transfer_prover
    next
      case False
      hence *: "(y = zero) = False" "(Y = 0) = False" using eq by auto
      have XY: "R (modulo x y) (X mod Y)" by transfer_prover
      have YA: "R (minus z (times (divide x y) a)) (Z - X div Y * A)" by transfer_prover
      have YC: "R (minus b (times (divide x y) c)) (B - X div Y * C)" by transfer_prover
      note [transfer_rule] = 1(1)[OF False refl 1(3) YA 1(5) YC 1(7) XY]

      show ?thesis unfolding simps * if_False Let_def by transfer_prover
    qed
  qed
qed

lemma euclid_ext_i [transfer_rule]:
  "(R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_i euclid_ext"
  by transfer_prover

end

locale field_ops = idom_divide_ops ops R + euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
  R :: "'i \<Rightarrow> 'a :: {field_gcd} \<Rightarrow> bool" +
  assumes inverse[transfer_rule]: "(R ===> R) inverse Fields.inverse"

lemma nth_default_rel[transfer_rule]: "(S ===> list_all2 S ===> (=) ===> S) nth_default nth_default"
proof (intro rel_funI, clarify, goal_cases)
  case (1 x y xs ys _ n)
  from 1(2) show ?case
  proof (induct arbitrary: n)
    case Nil
    thus ?case using 1(1) by simp
  next
    case (Cons x y xs ys n)
    thus ?case by (cases n, auto)
  qed
qed

lemma strip_while_rel[transfer_rule]:
  "((A ===> (=)) ===> list_all2 A ===> list_all2 A) strip_while strip_while"
  unfolding strip_while_def[abs_def] by transfer_prover

lemma list_all2_last[simp]: "list_all2 A (xs @ [x]) (ys @ [y]) \<longleftrightarrow> list_all2 A xs ys \<and> A x y"
proof (cases "length xs = length ys")
  case True
  show ?thesis by (simp add: list_all2_append[OF True])
next
  case False
  note len = list_all2_lengthD[of A]
  from len[of xs ys] len[of "xs @ [x]" "ys @ [y]"] False
  show ?thesis by auto
qed

end


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


theory sort_NStoogeSort2IsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun twoThirds :: "Nat => Nat" where
"twoThirds (Z) = Z"
| "twoThirds (S (Z)) = S Z"
| "twoThirds (S (S (Z))) = S Z"
| "twoThirds (S (S (S n))) = S (S (twoThirds n))"

fun third :: "Nat => Nat" where
"third (Z) = Z"
| "third (S (Z)) = Z"
| "third (S (S (Z))) = Z"
| "third (S (S (S n))) = S (third n)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

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

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

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) Pair2" where
"splitAt x y = Pair (take x y) (drop x y)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

function nstooge2sort2 :: "int list => int list"
         and nstoogesort2 :: "int list => int list"
         and nstooge2sort1 :: "int list => int list" where
"nstooge2sort2 x =
   case splitAt (twoThirds (length x)) x of
     | Pair ys zs =>
         case splitAt (twoThirds (length x)) x of
           | Pair xs zs2 => append (nstoogesort2 ys) zs2
         end
   end"
| "nstoogesort2 (Nil2) = Nil2"
| "nstoogesort2 (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nstoogesort2 (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "nstoogesort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "nstooge2sort1 x =
     case splitAt (third (length x)) x of
       | Pair ys zs =>
           case splitAt (third (length x)) x of
             | Pair xs zs2 => append ys (nstoogesort2 zs2)
           end
     end"
by pat_completeness auto

(*hipster twoThirds
          third
          take
          sort2
          length
          insert2
          isort
          drop
          splitAt
          append
          nstooge2sort2
          nstoogesort2
          nstooge2sort1 *)

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

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

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

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

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

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

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "Nat list => Nat list"
  and stoogesort2 :: "Nat list => Nat list"
  and stooge2sort1 :: "Nat list => Nat list" where
  "stooge2sort2 y =
   (case
      splitAt (idiv (S (times (S (S Z)) (length y))) (S (S (S Z)))) y
      of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((stoogesort2 xs) = (isort xs))"
  oops

end


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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Star p) s) =
      (case s of
         nil2 => True
         | cons2 x y => False |
         (recognise (Seq p (Star p)) s)))"
  oops

end