(*  Title:      Prime.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

A simproc for the predicate "prime_factorization (n::nat)" from "Factorial_Ring.thy".
*)

theory Prime_Factorization
  imports
    Main
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    HOL.Num
    Prime
begin

text\<open>Lemmata for prime_factorization (n::nat):\<close>

text\<open>Ball = bounded universal quantor\<close>
text\<open>"Multiset.Ball P prime" = all elements of P are prime\<close>

lemma prime_factorization_eqI_nat:
  assumes "Multiset.Ball MSet prime" "prod_mset MSet = n"
  shows   "prime_factorization n \<equiv> MSet"
proof -
  have "prime_factorization n = MSet"
    using assms by (simp add: prime_factorization_eqI)
  thus "prime_factorization n \<equiv> MSet" by (simp add: eq_reflection)
qed

lemma Ball_set_mset_empty: "Multiset.Ball {#} Pred"
  and Ball_set_mset_add:   "Pred n \<Longrightarrow> Multiset.Ball MSet Pred \<Longrightarrow> Multiset.Ball (add_mset n MSet) Pred"
  by auto

lemma prime_factorization_0': "prime_factorization (0::nat) \<equiv> {#}"
  by (auto simp: eq_reflection)

ML_file\<open>algorithms.ML\<close>
ML_file\<open>tools.ML\<close>

ML\<open>
signature PRIME_FACTORIZATION =
sig

(* defines the upper (and lower) bound for the simproc *)
val limit: int Config.T

val parse: Thm.cterm -> int

datatype cert = FACTORIZATION of int * int list | ZERO
val mk_cert: int -> cert
val generate_proof: Proof.context -> cert -> thm option

val prove: Proof.context -> int -> thm option
val simproc: Proof.context -> Thm.cterm -> thm option

(* helper tools *)
val get_cert_number : cert -> int

end

structure Prime_Factorization : PRIME_FACTORIZATION =
struct

val limit = Attrib.setup_config_int \<^binding>\<open>limit\<close> (K 1000000);
exception LIMIT

datatype cert = FACTORIZATION of int * int list | ZERO

fun parse ct = Tools.parse1 ct @{const_name "prime_factorization"}

fun mk_cert n =
    if n = 0 then ZERO
             else FACTORIZATION (n, Algorithms.factorize n)

exception ERROR
fun generate_proof _ ZERO =
    SOME @{thm prime_factorization_0'}
  | generate_proof ctxt (FACTORIZATION (n, fs)) =
    let
      (* initialize theorem "forall x in mset. prime x" *)
      val all_fs_prime_0 = @{thm Ball_set_mset_empty[of "prime :: nat \<Rightarrow> bool"]}
      (* iteratively fill elements into theorem *)
      fun build_thm [] all_fs_prime_iter = all_fs_prime_iter
        | build_thm (f::fs) all_fs_prime_iter =
                let val prime_f = case fst (Pratt.prove_prime [] f ctxt)
                                    of SOME thm => thm |
                                           NONE => raise ERROR
                in
                    build_thm fs (@{thm Ball_set_mset_add} OF [prime_f, all_fs_prime_iter])
                end
      val all_fs_prime = build_thm fs all_fs_prime_0
    in
        @{thm prime_factorization_eqI_nat}
            |> (fn thm => thm OF [all_fs_prime])
            |> Drule.infer_instantiate' ctxt (map (Tools.nat2ct' ctxt) [n])
            |> Tools.simp ctxt 1
            |> SOME
    end

fun prove ctxt n =                  (* n               *)
    n     |> mk_cert                (* cert            *)
          |> generate_proof ctxt    (* thm option      *)
    handle ERROR => NONE

fun simproc ctxt input =            (* term            *)
    input |> parse                  (* n               *)
          |> (fn n => if abs n < Config.get ctxt limit then n else raise LIMIT)
          |> prove ctxt             (* thm option      *)
    handle LIMIT => NONE
         | TERM _ => NONE

(* helper tools *)
fun get_cert_number ZERO = 0
  | get_cert_number (FACTORIZATION (n, _)) = n

end
\<close>

simproc_setup prime_factorization_simproc ("prime_factorization (numeral n::nat)") = \<open>K Prime_Factorization.simproc\<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_weird_nat_mul3_same
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

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

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3acc x y z))"
  oops

end


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

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

datatype Nat = Z | S "Nat"

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

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

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

theorem property0 :
  "((z = y2) ==> (elem z (insert y2 z2)))"
  oops

end


subsection\<open>Hilbert Calculus\<close>
theory HC
imports Formulas
begin

text\<open>We can define Hilbert Calculus as the modus ponens closure over a set of axioms:\<close>
inductive HC :: "'a formula  set \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<turnstile>\<^sub>H" 30) for \<Gamma> :: "'a formula set" where
Ax: "F \<in> \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>H F" |
MP: "\<Gamma> \<turnstile>\<^sub>H F \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> G \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>H G"
text\<open>.\<close>

context begin

text\<open>The problem with that is defining the axioms. Normally, we just write that @{term "F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F)"} is an axiom,
  and mean that anything can be substituted for @{term F} and @{term G}.
Now, we can't just write down a set \<open>{F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F), \dots\<close>.
Instead, defining it as an inductive set with no induction is a good idea.
\<close>
(* Note to self: Don't try to formulate these as a definition. Possible, but painful to use. *)
inductive_set AX0 where
"F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F) \<in> AX0" |
"(F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H)) \<in> AX0"
inductive_set AX10 where
"F \<in> AX0 \<Longrightarrow> F \<in> AX10" |
"F \<^bold>\<rightarrow> (F \<^bold>\<or> G) \<in> AX10" |
"G \<^bold>\<rightarrow> (F \<^bold>\<or> G) \<in> AX10" |
"(F \<^bold>\<rightarrow> H) \<^bold>\<rightarrow> ((G \<^bold>\<rightarrow> H) \<^bold>\<rightarrow> ((F \<^bold>\<or> G) \<^bold>\<rightarrow> H)) \<in> AX10" |
"(F \<^bold>\<and> G) \<^bold>\<rightarrow> F \<in> AX10" |
"(F \<^bold>\<and> G) \<^bold>\<rightarrow> G \<in> AX10" |
"F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> (F \<^bold>\<and> G)) \<in> AX10" |
"(F \<^bold>\<rightarrow> \<bottom>) \<^bold>\<rightarrow> \<^bold>\<not>F \<in> AX10" |
"\<^bold>\<not>F \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> \<bottom>) \<in> AX10" |
"(\<^bold>\<not>F \<^bold>\<rightarrow> \<bottom>) \<^bold>\<rightarrow> F \<in> AX10"
lemmas HC_intros[intro!] =
  AX0.intros[THEN HC.intros(1)]
  AX0.intros[THEN AX10.intros(1), THEN HC.intros(1)]
  AX10.intros(2-)[THEN HC.intros(1)]

text\<open>The first four axioms, as originally formulated by Hilbert~\cite{hilbert1928grundlagen}.\<close>
inductive_set AXH where
  "(F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F)) \<in> AXH" |
  "(F \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> G)) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> G) \<in> AXH" |
  "(F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)) \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H)) \<in> AXH" |
  "(G \<^bold>\<rightarrow> H) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H)) \<in> AXH"

lemma HC_mono: "S \<turnstile>\<^sub>H F \<Longrightarrow> S \<subseteq> T \<Longrightarrow> T \<turnstile>\<^sub>H F"
  by(induction rule: HC.induct) (auto intro: HC.intros)
lemma AX010: "AX0 \<subseteq> AX10"
  apply(rule)
  apply(cases rule: AX0.cases, assumption)
   apply(auto intro: AX10.intros)
done
lemma AX100[simp]: "AX0 \<union> AX10 = AX10" using AX010 by blast

text\<open>Hilbert's first four axioms and @{const AX0} are syntactically quite different.
  Derivability does not change:\<close>
lemma hilbert_folgeaxiome_as_strong_as_AX0: "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H F \<longleftrightarrow> AXH \<union> \<Gamma> \<turnstile>\<^sub>H F"
proof -
  have 0:
  "AX0 \<turnstile>\<^sub>H (F \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> G)) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> G)"
  "AX0 \<turnstile>\<^sub>H (F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)) \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H))"
  "AX0 \<turnstile>\<^sub>H (G \<^bold>\<rightarrow> H) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H))"
    for F G H using HC_intros(1,2) MP by metis+
  have H:
    "AXH \<turnstile>\<^sub>H (F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H))"
    for F G H
  proof -
    note AXH.intros[THEN HC.Ax]
    thus ?thesis using MP by metis (* 4s *)
  qed
  note * = H 0
  note * = *[THEN HC_mono, OF Un_upper1]
  show ?thesis (is "?Z \<longleftrightarrow> ?H") (* HC, where nothing is automatic (except for after this, nearly everything in this file is) *)
  proof
    assume ?Z thus ?H proof induction
      case MP thus ?case using HC.MP by blast
    next
      case (Ax F) thus ?case proof
        assume "F \<in> AX0" thus ?thesis by induction (simp_all add: AXH.intros(1) HC.Ax *)
      next
        assume "F \<in> \<Gamma>" thus ?case using HC.Ax[of F] by simp
      qed
    qed
  next
    assume ?H thus ?Z proof induction
      case MP thus ?case using HC.MP by blast
    next
      case (Ax F) thus ?case proof
        assume "F \<in> AXH" thus ?thesis by induction (simp_all add: AX0.intros(1) HC.Ax *)
      next
        assume "F \<in> \<Gamma>" thus ?case using HC.Ax[of F] by simp
      qed
    qed
  qed
qed

lemma "AX0 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> F" by (meson HC_intros(1,2) HC.MP)
(* Can you do that again, but slowly? *)
lemma imp_self: "AX0 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> F" proof -
  let ?d = "\<lambda>f. AX0 \<turnstile>\<^sub>H f"
  note MP
  moreover have "?d (F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F))" for G using HC_intros(1)[where G=G and F=F] .
  moreover {
    note MP
    moreover have "?d (F \<^bold>\<rightarrow> ((G \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> F))" for G using HC_intros(1)[where G="G \<^bold>\<rightarrow> F" and F=F] .
    moreover have "?d ((F \<^bold>\<rightarrow> ((G \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> F)) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F)) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> F)))" for G using HC_intros(2)[where G="G \<^bold>\<rightarrow> F" and F=F and H=F] .
    ultimately have "?d ((F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> F)) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> F))" for G . }
  ultimately show "?d (F \<^bold>\<rightarrow> F)" .
qed

(* You'd get the idea for this theorem just when writing the HCND proof. It's really quite natural. *)
theorem Deduction_theorem: "AX0 \<union> insert F \<Gamma> \<turnstile>\<^sub>H G \<Longrightarrow> AX0 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> G"
proof(induction rule: HC.induct)
  case (Ax G)
  show ?case proof cases
    assume "F = G"
    from imp_self have "AX0 \<turnstile>\<^sub>H G \<^bold>\<rightarrow> G" .
    with HC_mono show ?case unfolding \<open>F = G\<close> using sup_ge1 .
  next
    assume "F \<noteq> G"
    note HC.MP
    moreover {
      from \<open>F \<noteq> G\<close> \<open>G \<in> AX0 \<union> insert F \<Gamma>\<close> have "G \<in> AX0 \<union> \<Gamma>" by simp
      with HC.Ax have "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H G" .
    }
    moreover from HC_mono[OF HC_intros(1) sup_ge1] have "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H G \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> G)" .
    ultimately show ?case .
  qed
next
  case (MP G H)
  have "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H (F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)) \<^bold>\<rightarrow> ((F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H))" using HC_mono by blast
  with HC.MP \<open>AX0 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> (G \<^bold>\<rightarrow> H)\<close> have "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H (F \<^bold>\<rightarrow> G) \<^bold>\<rightarrow> (F \<^bold>\<rightarrow> H)" .
  with HC.MP \<open>AX0 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> G\<close> show "AX0 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> H" .
qed

end

end


(*  Title:      HOL/ex/While_Combinator_Example.thy
    Author:     Tobias Nipkow
    Copyright   2000 TU Muenchen
*)

section \<open>An application of the While combinator\<close>

theory While_Combinator_Example
imports "~~/src/HOL/Library/While_Combinator"
begin

text \<open>Computation of the @{term lfp} on finite sets via
  iteration.\<close>

theorem lfp_conv_while:
  "[| mono f; finite U; f U = U |] ==>
    lfp f = fst (while (\<lambda>(A, fA). A \<noteq> fA) (\<lambda>(A, fA). (fA, f fA)) ({}, f {}))"
apply (rule_tac P = "\<lambda>(A, B). (A \<subseteq> U \<and> B = f A \<and> A \<subseteq> B \<and> B \<subseteq> lfp f)" and
                r = "((Pow U \<times> UNIV) \<times> (Pow U \<times> UNIV)) \<inter>
                     inv_image finite_psubset (op - U o fst)" in while_rule)
   apply (subst lfp_unfold)
    apply assumption
   apply (simp add: monoD)
  apply (subst lfp_unfold)
   apply assumption
  apply clarsimp
  apply (blast dest: monoD)
 apply (fastforce intro!: lfp_lowerbound)
 apply (blast intro: wf_finite_psubset Int_lower2 [THEN [2] wf_subset])
apply (clarsimp simp add: finite_psubset_def order_less_le)
apply (blast dest: monoD)
done

subsection \<open>Example\<close>

text\<open>Cannot use @{thm[source]set_eq_subset} because it leads to
looping because the antisymmetry simproc turns the subset relationship
back into equality.\<close>

theorem "P (lfp (\<lambda>N::int set. {0} \<union> {(n + 2) mod 6 | n. n \<in> N})) =
  P {0, 4, 2}"
proof -
  have seteq: "!!A B. (A = B) = ((!a : A. a:B) & (!b:B. b:A))"
    by blast
  have aux: "!!f A B. {f n | n. A n \<or> B n} = {f n | n. A n} \<union> {f n | n. B n}"
    apply blast
    done
  show ?thesis
    apply (subst lfp_conv_while [where ?U = "{0, 1, 2, 3, 4, 5}"])
       apply (rule monoI)
      apply blast
     apply simp
    apply (simp add: aux set_eq_subset)
    txt \<open>The fixpoint computation is performed purely by rewriting:\<close>
    apply (simp add: while_unfold aux seteq del: subset_empty)
    done
qed

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_StoogeSort2Permutes
  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 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 elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort2 xs) xs"
  oops

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

chapter "Machine Word Setup"

theory WordSetup
imports WordEnum DistinctProp

begin

text {* This theory defines the standard platform-specific word size
and alignment. *}

definition
  word_bits :: nat where
  "word_bits \<equiv> len_of TYPE(32)"

definition
  word_size :: "'a :: numeral" where
  "word_size \<equiv> 4"

lemma word_bits_conv:
  "word_bits = 32" unfolding word_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

definition
  is_aligned :: "'a :: len word \<Rightarrow> nat \<Rightarrow> bool" where
  "is_aligned ptr n \<equiv> 2^n dvd unat ptr"

definition
  ptr_add :: "word32 \<Rightarrow> nat \<Rightarrow> word32" where
  "ptr_add ptr n \<equiv> ptr + of_nat n"

definition
  complement :: "('a :: len) word \<Rightarrow> 'a word"  where
 "complement x \<equiv> x xor -1"

definition
  alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
 "alignUp x n \<equiv> x + 2 ^ n - 1 && complement (2 ^ n - 1)"

end


(*  Title:      HOL/Matrix_LP/Cplex.thy
    Author:     Steven Obua
*)

theory Cplex
imports SparseMatrix LP ComputeFloat ComputeNumeral
begin

ML_file "Cplex_tools.ML"
ML_file "CplexMatrixConverter.ML"
ML_file "FloatSparseMatrixBuilder.ML"
ML_file "fspmlp.ML"

lemma spm_mult_le_dual_prts:
  assumes
  "sorted_sparse_matrix A1"
  "sorted_sparse_matrix A2"
  "sorted_sparse_matrix c1"
  "sorted_sparse_matrix c2"
  "sorted_sparse_matrix y"
  "sorted_sparse_matrix r1"
  "sorted_sparse_matrix r2"
  "sorted_spvec b"
  "le_spmat [] y"
  "sparse_row_matrix A1 \<le> A"
  "A \<le> sparse_row_matrix A2"
  "sparse_row_matrix c1 \<le> c"
  "c \<le> sparse_row_matrix c2"
  "sparse_row_matrix r1 \<le> x"
  "x \<le> sparse_row_matrix r2"
  "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
  shows
  "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
  (let s1 = diff_spmat c1 (mult_spmat y A2); s2 = diff_spmat c2 (mult_spmat y A1) in
  add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
  (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))))"
  apply (simp add: Let_def)
  apply (insert assms)
  apply (simp add: sparse_row_matrix_op_simps algebra_simps)
  apply (rule mult_le_dual_prts[where A=A, simplified Let_def algebra_simps])
  apply (auto)
  done

lemma spm_mult_le_dual_prts_no_let:
  assumes
  "sorted_sparse_matrix A1"
  "sorted_sparse_matrix A2"
  "sorted_sparse_matrix c1"
  "sorted_sparse_matrix c2"
  "sorted_sparse_matrix y"
  "sorted_sparse_matrix r1"
  "sorted_sparse_matrix r2"
  "sorted_spvec b"
  "le_spmat [] y"
  "sparse_row_matrix A1 \<le> A"
  "A \<le> sparse_row_matrix A2"
  "sparse_row_matrix c1 \<le> c"
  "c \<le> sparse_row_matrix c2"
  "sparse_row_matrix r1 \<le> x"
  "x \<le> sparse_row_matrix r2"
  "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
  shows
  "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
  (mult_est_spmat r1 r2 (diff_spmat c1 (mult_spmat y A2)) (diff_spmat c2 (mult_spmat y A1))))"
  by (simp add: assms mult_est_spmat_def spm_mult_le_dual_prts[where A=A, simplified Let_def])

ML_file "matrixlp.ML"

end