theory mutilated_actual
imports "Main"

begin

definition chessboard :: "(nat \<times> nat) set" where
  "chessboard = {..7} \<times> {..7}"

definition mchessboard :: "(nat \<times> nat) set" where
  "mchessboard = chessboard - {(0, 0), (7, 7)}"

datatype domino =
  horizontal "nat \<times> nat"
| vertical   "nat \<times> nat"

fun covers :: "domino \<Rightarrow> (nat \<times> nat) set" where
  "covers (horizontal (i, j)) = {(i, j), (i+1, j)}"
| "covers (vertical (i, j)) = {(i, j), (i, j+1)}"

definition white :: "(nat \<times> nat) set" where
  "white = {p. even (fst p + snd p)}"

definition flip :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)" where
  "flip p = (7 - fst p, snd p)"

theorem mutilated_chessboard:
  fixes s :: "domino set"
  assumes h1 : "\<forall> x \<in> s. \<forall> y \<in> s. x \<noteq> y \<longrightarrow> covers x \<inter> covers y = {}" and
          h1a : "finite s"
  shows "(\<Union> x \<in> s. covers x) \<noteq> mchessboard"
proof
  have "bij_betw flip (chessboard \<inter> white) (chessboard \<inter> -white)"
  proof -
    have aux1: "\<forall> x. x \<in> chessboard \<longrightarrow> flip x \<in> chessboard"
      by (auto simp add: chessboard_def flip_def)
    have aux2: "\<forall> x \<in> chessboard. flip x \<in> white \<longleftrightarrow> x \<in> -white"
      by (auto simp add: chessboard_def flip_def white_def)
    have aux3: "inj_on flip (chessboard \<inter> white)"
      by (auto simp add: inj_on_def flip_def chessboard_def white_def)
    have aux4: "\<forall> x \<in> chessboard \<inter> -white. x \<in> flip ` (chessboard \<inter> white)"
    proof -
      have aux4a: "\<forall> x \<in> chessboard. flip (flip x) = x"
        by (auto simp add: flip_def chessboard_def)
      show ?thesis
        by (metis IntI Int_iff aux1 aux2 aux4a imageI)
    qed
    show ?thesis
      by (auto simp add: bij_betw_def aux1 aux2 aux3 aux4)
  qed
  hence h2: "card (chessboard \<inter> white) = card (chessboard \<inter> -white)"
    using bij_betw_same_card by blast
  have h2a: "(0, 0) \<in> chessboard \<inter> white" and h2b: "(7, 7) \<in> chessboard \<inter> white"
    by (simp add: chessboard_def white_def)+
  have h3: "card (mchessboard \<inter> white) < card (mchessboard \<inter> -white)"
  proof -
    have aux5: "mchessboard \<inter> white = chessboard \<inter> white - {(0, 0), (7, 7)}"
      by (auto simp add: mchessboard_def)
    have aux6: "mchessboard \<inter> -white = chessboard \<inter> -white"
      by (auto simp add: mchessboard_def chessboard_def white_def)
    have aux7: "(chessboard \<inter> white = mchessboard \<inter> white \<union> {(0, 0), (7, 7)}) \<and>
                  (mchessboard \<inter> white) \<inter> {(0, 0), (7, 7)} = {}"
      using aux5 h2a h2b by auto
    have aux7a: "finite chessboard \<and> finite mchessboard"
      by (auto simp add: chessboard_def mchessboard_def)
    have aux7b: "(0, 0) \<notin> insert (7, 7) (mchessboard \<inter> white)"
      using h2a mchessboard_def by auto
    have aux7c: "(7, 7) \<notin> mchessboard \<inter> white"
      by (simp add: aux5)
    have aux7d: "card (insert (0, 0) (insert (7, 7) (mchessboard \<inter> white))) =
                   Suc (Suc (card (mchessboard \<inter> white)))"
      using aux7a aux7b aux7c by auto
    have aux8: "card (chessboard \<inter> white) = card (mchessboard \<inter> white) + 2"
      using aux7 by (auto simp add: aux7d)
    show ?thesis
      by (auto simp add: aux5 aux6 aux8 h2 [symmetric])
  qed
  have h9: "\<forall> x. card (covers x \<inter> white) = card (covers x \<inter> -white)"
  proof -
    have aux9a: "\<forall> a b. (a, b) \<in> white \<longleftrightarrow> (Suc a, b) \<notin> white"
      by (auto simp add: white_def)
    have aux9b: "\<forall> a b. {(a, b), (Suc a, b)} \<inter> white = {(a, b)} \<or>
                        {(a, b), (Suc a, b)} \<inter> white = {(Suc a, b)}"
      by (metis Int_insert_left_if0 Int_insert_left_if1 aux9a inf_bot_right inf_commute)
    have aux9c: "\<forall> a b. (a, b) \<in> white \<longleftrightarrow> (a, Suc b) \<notin> white"
      by (auto simp add: white_def)
    have aux9d: "\<forall> a b. {(a, b), (a, Suc b)} \<inter> white = {(a, b)} \<or>
                        {(a, b), (a, Suc b)} \<inter> white = {(a, Suc b)}"
      by (metis Int_insert_left_if1 Int_insert_right_if0 aux9c inf_bot_right inf_commute)
    have aux9e: "\<forall> x. card (covers x \<inter> white) = 1"
    proof
      fix x
      show "card (covers x \<inter> white) = 1"
        apply (induction x)
         apply auto
        using aux9b card_Suc_eq apply force
        using aux9d card_Suc_eq by force
    qed
    have aux9f: "\<forall> a b. {(a, b), (Suc a, b)} \<inter> - white = {(a, b)} \<or>
                        {(a, b), (Suc a, b)} \<inter> - white = {(Suc a, b)}"
      by (metis Compl_disjoint Compl_iff Int_insert_left aux9a inf_commute inf_compl_bot_left1)
    have aux9g: "\<forall> a b. {(a, b), (a, Suc b)} \<inter> - white = {(a, b)} \<or>
                        {(a, b), (a, Suc b)} \<inter> - white = {(a, Suc b)}"
      by (metis Compl_disjoint Compl_iff Int_insert_left_if0 Int_insert_left_if1 aux9c inf_right_idem)
    have aux9h: "\<forall> x. card (covers x \<inter> -white) = 1"
    proof
      fix x
      show "card (covers x \<inter> - white) = 1"
        apply (induction x)
        apply auto
        using aux9f card_Suc_eq apply force
        using aux9g card_Suc_eq by force
    qed
    show ?thesis
      using aux9e aux9h by simp
  qed
  with h1 h1a have h4: "card ((\<Union> x \<in> s. covers x) \<inter> white) = card ((\<Union> x \<in> s. covers x) \<inter> -white)"
  proof -
    have aux10e: "\<forall> x. finite (covers x)"
    proof
      fix x
      show "finite (covers x)"
        apply (cases x)
        by auto
    qed
    have aux10f: "\<forall> x. finite (covers x \<inter> white)"
      using aux10e by auto
    have aux10g: "\<forall> x \<in> s. \<forall> y \<in> s. x \<noteq> y \<longrightarrow> (covers x \<inter> white) \<inter> (covers y \<inter> white) = {}"
      using h1 by auto
    have aux10h: "\<forall> x \<in> s. \<forall> y \<in> s. x \<noteq> y \<longrightarrow> (covers x \<inter> - white) \<inter> (covers y \<inter> - white) = {}"
      using h1 by auto
    have aux10a: "(\<Union> x \<in> s. covers x) \<inter> white = (\<Union> x \<in> s. covers x \<inter> white)"
      by simp
    have aux10b: "(\<Union> x \<in> s. covers x) \<inter> -white = (\<Union> x \<in> s. covers x \<inter> -white)"
      by simp
    with h1a aux10e aux10g have aux10c:
        "card ((\<Union> x \<in> s. covers x) \<inter> white) = (\<Sum> x \<in> s. card (covers x \<inter> white))"
     by (smt aux10a card_UN_disjoint finite_Int sum.cong)
    with h1 h1a aux10e aux10h have aux10d:
        "card ((\<Union> x \<in> s. covers x) \<inter> - white) = (\<Sum> x \<in> s. card (covers x \<inter> - white))"
      by (smt aux10b card_UN_disjoint finite_Int sum.cong)
    show ?thesis
      by (simp add: aux10c aux10d h9)
  qed
  assume "(\<Union> x \<in> s. covers x) = mchessboard"
  with h3 h4 show False
    by auto
qed

end


(*  Title:      Sequents/LK/Propositional.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Classical sequent calculus: examples with propositional connectives *}

theory Propositional
imports "../LK"
begin

text "absorptive laws of & and | "

lemma "|- P & P <-> P"
  by fast_prop

lemma "|- P | P <-> P"
  by fast_prop

text "commutative laws of & and | "

lemma "|- P & Q  <->  Q & P"
  by fast_prop

lemma "|- P | Q  <->  Q | P"
  by fast_prop

text "associative laws of & and | "

lemma "|- (P & Q) & R  <->  P & (Q & R)"
  by fast_prop

lemma "|- (P | Q) | R  <->  P | (Q | R)"
  by fast_prop

text "distributive laws of & and | "

lemma "|- (P & Q) | R  <-> (P | R) & (Q | R)"
  by fast_prop

lemma "|- (P | Q) & R  <-> (P & R) | (Q & R)"
  by fast_prop

text "Laws involving implication"

lemma "|- (P|Q --> R) <-> (P-->R) & (Q-->R)"
  by fast_prop

lemma "|- (P & Q --> R) <-> (P--> (Q-->R))"
  by fast_prop

lemma "|- (P --> Q & R) <-> (P-->Q)  &  (P-->R)"
  by fast_prop

text "Classical theorems"

lemma "|- P|Q --> P| ~P&Q"
  by fast_prop

lemma "|- (P-->Q)&(~P-->R)  -->  (P&Q | R)"
  by fast_prop

lemma "|- P&Q | ~P&R  <->  (P-->Q)&(~P-->R)"
  by fast_prop

lemma "|- (P-->Q) | (P-->R)  <->  (P --> Q | R)"
  by fast_prop

(*If and only if*)

lemma "|- (P<->Q) <-> (Q<->P)"
  by fast_prop

lemma "|- ~ (P <-> ~P)"
  by fast_prop

(*Sample problems from
  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.
*)

(*1*)
lemma "|- (P-->Q)  <->  (~Q --> ~P)"
  by fast_prop

(*2*)
lemma "|- ~ ~ P  <->  P"
  by fast_prop

(*3*)
lemma "|- ~(P-->Q) --> (Q-->P)"
  by fast_prop

(*4*)
lemma "|- (~P-->Q)  <->  (~Q --> P)"
  by fast_prop

(*5*)
lemma "|- ((P|Q)-->(P|R)) --> (P|(Q-->R))"
  by fast_prop

(*6*)
lemma "|- P | ~ P"
  by fast_prop

(*7*)
lemma "|- P | ~ ~ ~ P"
  by fast_prop

(*8.  Peirce's law*)
lemma "|- ((P-->Q) --> P)  -->  P"
  by fast_prop

(*9*)
lemma "|- ((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by fast_prop

(*10*)
lemma "Q-->R, R-->P&Q, P-->(Q|R) |- P<->Q"
  by fast_prop

(*11.  Proved in each direction (incorrectly, says Pelletier!!)  *)
lemma "|- P<->P"
  by fast_prop

(*12.  "Dijkstra's law"*)
lemma "|- ((P <-> Q) <-> R)  <->  (P <-> (Q <-> R))"
  by fast_prop

(*13.  Distributive law*)
lemma "|- P | (Q & R)  <-> (P | Q) & (P | R)"
  by fast_prop

(*14*)
lemma "|- (P <-> Q) <-> ((Q | ~P) & (~Q|P))"
  by fast_prop

(*15*)
lemma "|- (P --> Q) <-> (~P | Q)"
  by fast_prop

(*16*)
lemma "|- (P-->Q) | (Q-->P)"
  by fast_prop

(*17*)
lemma "|- ((P & (Q-->R))-->S) <-> ((~P | Q | S) & (~P | ~R | S))"
  by fast_prop

end


(*<*)
theory ChisholmExampleEnhanced
  imports TheoryCombination
begin

declare [[smt_solver=cvc4]]
declare [[smt_oracle]]
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 2]
(*>*)

(*****Chisholm Paradox  (Enhanced)****)
type_synonym cwe = "c\<Rightarrow>w\<Rightarrow>e" \<comment> \<open>type alias for indexical individual terms\<close>
abbreviation I::cwe where "I \<equiv> \<lambda>c w. Agent c"

consts goPred::"e\<Rightarrow>m" \<comment> \<open> predicate: to go to assist one's neighbours\<close>
consts tellPred::"e\<Rightarrow>m" \<comment> \<open>predicate: to tell one is coming\<close>
abbreviation Go::"(c\<Rightarrow>w\<Rightarrow>e)\<Rightarrow>m"  where "Go \<alpha> \<equiv> \<lambda>c w. goPred (\<alpha> c w) c w"  \<comment> \<open>type-lifted predicate\<close>
abbreviation Tell::"(c\<Rightarrow>w\<Rightarrow>e)\<Rightarrow>m" where "Tell \<alpha> \<equiv> \<lambda>c w. tellPred (\<alpha> c w) c w"  \<comment> \<open>type-lifted\<close>

axiomatization where
 B1: "\<lfloor>\<^bold>O\<langle>Go(I)\<rangle>\<rfloor>\<^sup>D" and (*It ought to be that I go to assist my neighbours*)
 B2: "\<lfloor>\<^bold>O\<langle>Tell(I)|Go(I)\<rangle>\<rfloor>\<^sup>D" and (*It ought to be that if I go, then I tell them I am coming*)
 B3: "\<lfloor>\<^bold>O\<langle>\<^bold>\<not>Tell(I)|\<^bold>\<not>Go(I)\<rangle>\<rfloor>\<^sup>D" and (*If I don't go, then I ought not tell them I am coming*)
 B4: "\<lfloor>\<^bold>\<not>(Go(I))\<rfloor>\<^sub>C"  (*I don't go (locally valid statement)*)

lemma True nitpick [satisfy] oops

abbreviation "violated \<phi> \<equiv> \<^bold>O\<^sub>i(\<phi>) \<^bold>\<and> \<^bold>\<not>\<phi>"

lemma "(\<lfloor>\<^bold>\<box>\<^sub>a\<^bold>\<not>(Go(I))\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>p(Go(I) \<^bold>\<and> Tell(I))\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>p(Go(I) \<^bold>\<and> \<^bold>\<not>(Tell(I)))\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<not>(Tell(I))\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>a(Tell(I))\<rfloor>\<^sub>C \<and>  \<lfloor>\<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(Tell(I)))\<rfloor>\<^sub>C)
       \<longrightarrow> (\<lfloor>violated (Go(I))\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>O\<^sub>a(\<^bold>\<not>(Tell(I)))\<rfloor>\<^sub>C)"
  using sem_4a sem_4b sem_5b sem_5e B1 B3 B4 by smt

end


(* Title:      N-Omega-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>N-Omega-Algebras\<close>

theory N_Omega_Algebras

imports Omega_Algebras Recursion

begin

class itering_apx = bounded_itering + n_algebra_apx
begin

lemma circ_L:
  "L\<^sup>\<circ> = L \<squnion> 1"
  by (metis sup_commute mult_top_circ n_L_top_L)

lemma C_circ_import:
  "C (x\<^sup>\<circ>) \<le> (C x)\<^sup>\<circ>"
proof -
  have 1: "C x * x\<^sup>\<circ> \<le> (C x)\<^sup>\<circ> * C x"
    using C_mult_propagate circ_simulate order.eq_iff by blast
  have "C (x\<^sup>\<circ>) = C (1 \<squnion> x * x\<^sup>\<circ>)"
    by (simp add: circ_left_unfold)
  also have "... = C 1 \<squnion> C (x * x\<^sup>\<circ>)"
    by (simp add: inf_sup_distrib1)
  also have "... \<le> 1 \<squnion> C (x * x\<^sup>\<circ>)"
    using sup_left_isotone by auto
  also have "... = 1 \<squnion> C x * x\<^sup>\<circ>"
    by (simp add: n_L_T_meet_mult)
  also have "... \<le> (C x)\<^sup>\<circ>"
    using 1 by (meson circ_reflexive order.trans le_supI right_plus_below_circ)
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 4.3 and Theorem 4.4\<close>

lemma circ_apx_isotone:
  assumes "x \<sqsubseteq> y"
  shows "x\<^sup>\<circ> \<sqsubseteq> y\<^sup>\<circ>"
proof -
  have 1: "x \<le> y \<squnion> L \<and> C y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  have "C (y\<^sup>\<circ>) \<le> (C y)\<^sup>\<circ>"
    by (simp add: C_circ_import)
  also have "... \<le> x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * n(x) * top"
    using 1 by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "... \<le> x\<^sup>\<circ> \<squnion> (x\<^sup>\<circ> * bot \<squnion> n(x\<^sup>\<circ> * x) * top)"
    using n_n_top_split_n_top sup_right_isotone by blast
  also have "... \<le> x\<^sup>\<circ> \<squnion> (x\<^sup>\<circ> * bot \<squnion> n(x\<^sup>\<circ>) * top)"
    using circ_plus_same left_plus_below_circ mult_left_isotone n_isotone sup_right_isotone by auto
  also have "... = x\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ>) * top"
    by (meson sup.left_idem sup_relative_same_increasing zero_right_mult_decreasing)
  finally have 2: "C (y\<^sup>\<circ>) \<le> x\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ>) * top"
    .
  have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> * L\<^sup>\<circ>"
    using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone n_L_below_L le_iff_sup mult_assoc)
  also have "... = y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * L"
    using circ_L mult_left_dist_sup sup_commute by auto
  also have "... \<le> y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot \<squnion> L"
    using n_L_split_L semiring.add_left_mono sup_assoc by auto
  finally have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> \<squnion> L"
    using sup.absorb1 zero_right_mult_decreasing by force
  thus "x\<^sup>\<circ> \<sqsubseteq> y\<^sup>\<circ>"
    using 2 by (simp add: apx_def)
qed

end

class n_omega_algebra_1 = bounded_left_zero_omega_algebra + n_algebra_apx + Omega +
  assumes Omega_def: "x\<^sup>\<Omega> = n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star>"
begin

text \<open>AACP Theorem 8.13\<close>

lemma C_omega_export:
  "C (x\<^sup>\<omega>) = (C x)\<^sup>\<omega>"
proof -
  have "C (x\<^sup>\<omega>) = C x * C (x\<^sup>\<omega>)"
    by (metis C_mult_propagate n_L_T_meet_mult omega_unfold)
  hence 1: "C (x\<^sup>\<omega>) \<le> (C x)\<^sup>\<omega>"
    using eq_refl omega_induct_mult by auto
  have "(C x)\<^sup>\<omega> = C (x * (C x)\<^sup>\<omega>)"
    using n_L_T_meet_mult omega_unfold by auto
  also have "... \<le> C (x\<^sup>\<omega>)"
    by (metis calculation C_decreasing inf_le1 le_infI omega_induct_mult)
  finally show ?thesis
    using 1 order.antisym by blast
qed

text \<open>AACP Theorem 8.2\<close>

lemma L_mult_star:
  "L * x\<^sup>\<star> = L"
  by (metis n_L_top_L star.circ_left_top mult_assoc)

text \<open>AACP Theorem 8.3\<close>

lemma mult_L_star:
  "(x * L)\<^sup>\<star> = 1 \<squnion> x * L"
  by (metis L_mult_star star.circ_mult_1 mult_assoc)

lemma mult_L_omega_below:
  "(x * L)\<^sup>\<omega> \<le> x * L"
  by (metis mult_right_isotone n_L_below_L omega_slide)

text \<open>AACP Theorem 8.5\<close>

lemma mult_L_sup_star:
  "(x * L \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
  using L_mult_star mult_1_right mult_left_dist_sup star_sup_1 sup_commute mult_L_star mult_assoc by auto

lemma mult_L_sup_omega_below:
  "(x * L \<squnion> y)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have "(x * L \<squnion> y)\<^sup>\<omega> \<le> y\<^sup>\<star> * x * L \<squnion> (y\<^sup>\<star> * x * L)\<^sup>\<star> * y\<^sup>\<omega>"
    by (metis sup_commute mult_assoc omega_decompose sup_left_isotone mult_L_omega_below)
  also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (smt (z3) le_iff_sup le_supI mult_left_dist_sup n_L_below_L star_left_induct sup.cobounded2 sup.left_idem sup.orderE sup_assoc sup_commute mult_assoc)
  finally show ?thesis
    .
qed

lemma n_Omega_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<Omega> \<le> y\<^sup>\<Omega>"
  by (metis Omega_def sup_mono mult_left_isotone n_isotone omega_isotone star_isotone)

lemma n_star_below_Omega:
  "x\<^sup>\<star> \<le> x\<^sup>\<Omega>"
  by (simp add: Omega_def)

lemma mult_L_star_mult_below:
  "(x * L)\<^sup>\<star> * y \<le> y \<squnion> x * L"
  by (metis sup_right_isotone mult_assoc mult_right_isotone n_L_below_L star_left_induct)

end

sublocale n_omega_algebra_1 < star: itering_apx where circ = star ..

class n_omega_algebra = n_omega_algebra_1 + n_algebra_apx +
  assumes n_split_omega_mult: "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> * n(x\<^sup>\<omega>) * top"
  assumes tarski: "x * L \<le> x * L * x * L"
begin

text \<open>AACP Theorem 8.4\<close>

lemma mult_L_omega:
  "(x * L)\<^sup>\<omega> = x * L"
  apply (rule order.antisym)
  apply (rule mult_L_omega_below)
  using omega_induct_mult tarski mult_assoc by auto

text \<open>AACP Theorem 8.6\<close>

lemma mult_L_sup_omega:
  "(x * L \<squnion> y)\<^sup>\<omega> = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
  apply (rule order.antisym)
  apply (rule mult_L_sup_omega_below)
  by (metis le_supI omega_isotone omega_sub_dist_2 sup.cobounded2 sup_commute mult_L_omega mult_assoc)

text \<open>AACP Theorem 8.1\<close>

lemma tarski_mult_top_idempotent:
  "x * L = x * L * x * L"
  by (metis omega_unfold mult_L_omega mult_assoc)

text \<open>AACP Theorem 8.7\<close>

lemma n_below_n_omega:
  "n(x) \<le> n(x\<^sup>\<omega>)"
proof -
  have "n(x) * L \<le> n(x) * L * n(x) * L"
    by (simp add: tarski)
  also have "... \<le> x * n(x) * L"
    by (simp add: mult_isotone n_L_decreasing)
  finally have "n(x) * L \<le> x\<^sup>\<omega>"
    by (simp add: omega_induct_mult mult_assoc)
  thus ?thesis
    by (simp add: n_galois)
qed

text \<open>AACP Theorem 8.14\<close>

lemma n_split_omega_sup_zero:
  "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top"
proof -
  have "n(x\<^sup>\<omega>) * top \<squnion> x * (x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top) = n(x\<^sup>\<omega>) * top \<squnion> x * x\<^sup>\<star> * bot \<squnion> x * n(x\<^sup>\<omega>) * top"
    by (simp add: mult_left_dist_sup sup_assoc mult_assoc)
  also have "... \<le> n(x\<^sup>\<omega>) * top \<squnion> x * x\<^sup>\<star> * bot \<squnion> x * bot \<squnion> n(x\<^sup>\<omega>) * top"
    by (metis sup_assoc sup_right_isotone n_n_top_split_n_top omega_unfold)
  also have "... = x * x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top"
    by (smt sup_assoc sup_commute sup_left_top sup_bot_right mult_assoc mult_left_dist_sup)
  also have "... \<le> x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top"
    by (metis sup_left_isotone mult_left_isotone star.left_plus_below_circ)
  finally have "x\<^sup>\<star> * n(x\<^sup>\<omega>) * top \<le> x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top"
    using star_left_induct mult_assoc by auto
  thus ?thesis
    using n_split_omega_mult order_trans by blast
qed

lemma n_split_omega_sup:
  "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> \<squnion> n(x\<^sup>\<omega>) * top"
  by (metis sup_left_isotone n_split_omega_sup_zero order_trans zero_right_mult_decreasing)

text \<open>AACP Theorem 8.12\<close>

lemma n_dist_omega_star:
  "n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) = n(y\<^sup>\<omega>) \<squnion> n(y\<^sup>\<star> * z)"
proof -
  have "n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) = n(C (y\<^sup>\<omega>) \<squnion> C (y\<^sup>\<star> * z))"
    by (metis inf_sup_distrib1 n_C)
  also have "... \<le> n(C (y\<^sup>\<omega>) \<squnion> y\<^sup>\<star> * z)"
    using n_isotone semiring.add_right_mono sup_commute by auto
  also have "... \<le> n(y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<omega>) * top \<squnion> y\<^sup>\<star> * z)"
    using n_isotone semiring.add_right_mono n_split_omega_sup_zero by blast
  also have "... = n(y\<^sup>\<omega>) \<squnion> n(y\<^sup>\<star> * z)"
    by (smt sup_assoc sup_commute sup_bot_right mult_left_dist_sup n_dist_n_add)
  finally show ?thesis
    by (simp add: order.antisym n_isotone)
qed

lemma mult_L_sup_circ_below:
  "(x * L \<squnion> y)\<^sup>\<Omega> \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have "(x * L \<squnion> y)\<^sup>\<Omega> \<le> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L) * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (simp add: Omega_def mult_L_sup_omega)
  also have "... = n(y\<^sup>\<omega>) * L \<squnion> n(y\<^sup>\<star> * x * L) * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (simp add: semiring.distrib_right mult_assoc n_dist_omega_star)
  also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (smt (z3) le_supI sup.cobounded1 sup_assoc sup_commute sup_idem sup_right_isotone mult_L_sup_star n_L_decreasing)
  finally show ?thesis
    .
qed

lemma n_mult_omega_L_below_zero:
  "n(y * x\<^sup>\<omega>) * L \<le> y * x\<^sup>\<star> * bot \<squnion> y * n(x\<^sup>\<omega>) * L"
proof -
  have "n(y * x\<^sup>\<omega>) * L \<le> C (y * x\<^sup>\<omega>) \<sqinter> L"
    by (metis n_C n_L_decreasing_meet_L)
  also have "... \<le> y * C (x\<^sup>\<omega>) \<sqinter> L"
    using inf.sup_left_isotone n_L_T_meet_mult n_L_T_meet_mult_propagate by auto
  also have "... \<le> y * (x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top) \<sqinter> L"
    using inf.sup_left_isotone mult_right_isotone n_split_omega_sup_zero by auto
  also have "... = (y * x\<^sup>\<star> * bot \<sqinter> L) \<squnion> (y * n(x\<^sup>\<omega>) * top \<sqinter> L)"
    using inf_sup_distrib2 mult_left_dist_sup mult_assoc by auto
  also have "... \<le> (y * x\<^sup>\<star> * bot \<sqinter> L) \<squnion> y * n(x\<^sup>\<omega>) * L"
    using n_vector_meet_L sup_right_isotone by auto
  also have "... \<le> y * x\<^sup>\<star> * bot \<squnion> y * n(x\<^sup>\<omega>) * L"
    using sup_left_isotone by auto
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 8.10\<close>

lemma n_mult_omega_L_star_zero:
  "y * x\<^sup>\<star> * bot \<squnion> n(y * x\<^sup>\<omega>) * L = y * x\<^sup>\<star> * bot \<squnion> y * n(x\<^sup>\<omega>) * L"
  apply (rule order.antisym)
  apply (simp add: n_mult_omega_L_below_zero)
  by (smt sup_assoc sup_commute sup_bot_left sup_right_isotone mult_assoc mult_left_dist_sup n_n_L_split_n_L)

text \<open>AACP Theorem 8.11\<close>

lemma n_mult_omega_L_star:
  "y * x\<^sup>\<star> \<squnion> n(y * x\<^sup>\<omega>) * L = y * x\<^sup>\<star> \<squnion> y * n(x\<^sup>\<omega>) * L"
  by (metis zero_right_mult_decreasing n_mult_omega_L_star_zero sup_relative_same_increasing)

lemma n_mult_omega_L_below:
  "n(y * x\<^sup>\<omega>) * L \<le> y * x\<^sup>\<star> \<squnion> y * n(x\<^sup>\<omega>) * L"
  using sup_right_divisibility n_mult_omega_L_star by blast

lemma n_omega_L_below_zero:
  "n(x\<^sup>\<omega>) * L \<le> x * x\<^sup>\<star> * bot \<squnion> x * n(x\<^sup>\<omega>) * L"
  by (metis omega_unfold n_mult_omega_L_below_zero)

lemma n_omega_L_below:
  "n(x\<^sup>\<omega>) * L \<le> x\<^sup>\<star> \<squnion> x * n(x\<^sup>\<omega>) * L"
  by (metis omega_unfold n_mult_omega_L_below sup_left_isotone star.left_plus_below_circ order_trans)

lemma n_omega_L_star_zero:
  "x * x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * L = x * x\<^sup>\<star> * bot \<squnion> x * n(x\<^sup>\<omega>) * L"
  by (metis n_mult_omega_L_star_zero omega_unfold)

text \<open>AACP Theorem 8.8\<close>

lemma n_omega_L_star:
  "x\<^sup>\<star> \<squnion> n(x\<^sup>\<omega>) * L = x\<^sup>\<star> \<squnion> x * n(x\<^sup>\<omega>) * L"
  by (metis star.circ_mult_upper_bound star.left_plus_below_circ bot_least n_omega_L_star_zero sup_relative_same_increasing)

text \<open>AACP Theorem 8.9\<close>

lemma n_omega_L_star_zero_star:
  "x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * L = x\<^sup>\<star> * bot \<squnion> x\<^sup>\<star> * n(x\<^sup>\<omega>) * L"
  by (metis n_mult_omega_L_star_zero star_mult_omega mult_assoc star.circ_transitive_equal)

text \<open>AACP Theorem 8.8\<close>

lemma n_omega_L_star_star:
  "x\<^sup>\<star> \<squnion> n(x\<^sup>\<omega>) * L = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * n(x\<^sup>\<omega>) * L"
  by (metis zero_right_mult_decreasing n_omega_L_star_zero_star sup_relative_same_increasing)

lemma n_Omega_left_unfold:
  "1 \<squnion> x * x\<^sup>\<Omega> = x\<^sup>\<Omega>"
  by (smt Omega_def sup_assoc sup_commute mult_assoc mult_left_dist_sup n_omega_L_star star.circ_left_unfold)

lemma n_Omega_left_slide:
  "(x * y)\<^sup>\<Omega> * x \<le> x * (y * x)\<^sup>\<Omega>"
proof -
  have "(x * y)\<^sup>\<Omega> * x \<le> x * y * n((x * y)\<^sup>\<omega>) * L \<squnion> (x * y)\<^sup>\<star> * x"
    by (smt Omega_def sup_commute sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L n_omega_L_star)
  also have "... \<le> x * (y * bot \<squnion> n(y * (x * y)\<^sup>\<omega>) * L) \<squnion> (x * y)\<^sup>\<star> * x"
    by (metis mult_right_isotone n_n_L_split_n_L sup_commute sup_right_isotone mult_assoc)
  also have "... = x * (y * x)\<^sup>\<Omega>"
    by (smt (verit, del_insts) le_supI1 star_slide Omega_def sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_dist_sup omega_slide star.circ_increasing star.circ_slide bot_least)
  finally show ?thesis
    .
qed

lemma n_Omega_sup_1:
  "(x \<squnion> y)\<^sup>\<Omega> = x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
proof -
  have 1: "(x \<squnion> y)\<^sup>\<Omega> = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star>"
    by (simp add: Omega_def omega_decompose semiring.distrib_right star.circ_sup_9 n_dist_omega_star)
  have "n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<le> (x\<^sup>\<star> * y)\<^sup>\<star> \<squnion> x\<^sup>\<star> * (y * n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L)"
    by (metis n_omega_L_below mult_assoc)
  also have "... \<le> (x\<^sup>\<star> * y)\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * bot \<squnion> x\<^sup>\<star> * n((y * x\<^sup>\<star>)\<^sup>\<omega>) * L"
    by (smt sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone n_n_L_split_n_L omega_slide)
  also have "... = (x\<^sup>\<star> * y)\<^sup>\<star> \<squnion> x\<^sup>\<star> * n((y * x\<^sup>\<star>)\<^sup>\<omega>) * L"
    by (metis sup_commute le_iff_sup star.circ_sub_dist_1 zero_right_mult_decreasing)
  also have "... \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<squnion> x\<^sup>\<star> * n((y * x\<^sup>\<star>)\<^sup>\<omega>) * L"
    by (metis star_outer_increasing star_slide star_star_absorb sup_left_isotone)
  also have "... \<le> x\<^sup>\<star> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis Omega_def sup_commute mult_assoc mult_left_dist_sup mult_right_isotone n_Omega_isotone n_star_below_Omega)
  also have "... \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (simp add: mult_left_isotone n_star_below_Omega)
  finally have 2: "n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    .
  have "n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L \<le> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> * y * n(x\<^sup>\<omega>) * L"
    by (smt sup_assoc sup_commute mult_left_one mult_right_dist_sup n_mult_omega_L_below star.circ_mult star.circ_slide)
  also have "... = n(x\<^sup>\<omega>) * L * (y * x\<^sup>\<Omega>)\<^sup>\<star> \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<Omega>)\<^sup>\<star>"
    by (smt Omega_def sup_assoc mult_L_sup_star mult_assoc mult_left_dist_sup L_mult_star)
  also have "... \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (simp add: Omega_def mult_isotone)
  finally have 3: "n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    .
  have "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis star_slide mult_isotone mult_right_isotone n_star_below_Omega order_trans star_isotone)
  hence 4: "(x \<squnion> y)\<^sup>\<Omega> \<le> x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega>"
    using 1 2 3 by simp
  have 5: "x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega> \<le> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * n((y * x\<^sup>\<Omega>)\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<Omega>)\<^sup>\<star>"
    by (smt Omega_def sup_assoc sup_left_isotone mult_assoc mult_left_dist_sup mult_right_dist_sup mult_right_isotone n_L_below_L)
  have "n(x\<^sup>\<omega>) * L \<le> n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L"
    by (metis sup_commute sup_ge1 mult_left_isotone n_isotone star.circ_loop_fixpoint)
  hence 6: "n(x\<^sup>\<omega>) * L \<le> (x \<squnion> y)\<^sup>\<Omega>"
    using 1 order_lesseq_imp by fastforce
  have "x\<^sup>\<star> * n((y * x\<^sup>\<Omega>)\<^sup>\<omega>) * L \<le> x\<^sup>\<star> * n((y * x\<^sup>\<star>)\<^sup>\<omega> \<squnion> (y * x\<^sup>\<star>)\<^sup>\<star> * y * n(x\<^sup>\<omega>) * L) * L"
    by (metis Omega_def mult_L_sup_omega_below mult_assoc mult_left_dist_sup mult_left_isotone mult_right_isotone n_isotone)
  also have "... \<le> x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<star> * ((y * x\<^sup>\<star>)\<^sup>\<omega> \<squnion> (y * x\<^sup>\<star>)\<^sup>\<star> * y * n(x\<^sup>\<omega>) * L)) * L"
    by (simp add: n_n_L_split_n_L)
  also have "... \<le> x\<^sup>\<star> \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> * y * n(x\<^sup>\<omega>) * L) * L"
    using omega_slide semiring.distrib_left sup_mono zero_right_mult_decreasing mult_assoc by fastforce
  also have "... \<le> x\<^sup>\<star> \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L) * L"
    by (smt sup_right_divisibility sup_right_isotone mult_left_isotone n_isotone star.circ_mult)
  also have "... \<le> x\<^sup>\<star> \<squnion> n((x \<squnion> y)\<^sup>\<omega>) * L"
    by (metis sup_right_isotone mult_assoc mult_left_isotone mult_right_isotone n_L_decreasing n_isotone omega_decompose)
  also have "... \<le> (x \<squnion> y)\<^sup>\<Omega>"
    by (simp add: Omega_def le_supI1 star_isotone sup_commute)
  finally have 7: "x\<^sup>\<star> * n((y * x\<^sup>\<Omega>)\<^sup>\<omega>) * L \<le> (x \<squnion> y)\<^sup>\<Omega>"
    .
  have "x\<^sup>\<star> * (y * x\<^sup>\<Omega>)\<^sup>\<star> \<le> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L"
    by (smt Omega_def sup_right_isotone mult_L_sup_star mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ star_slide)
  also have "... \<le> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L"
    by (simp add: n_mult_omega_L_star)
  also have "... \<le> (x \<squnion> y)\<^sup>\<Omega>"
    by (smt Omega_def sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound omega_decompose star.circ_sup)
  finally have "n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * n((y * x\<^sup>\<Omega>)\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * (y * x\<^sup>\<Omega>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<Omega>"
    using 6 7 by simp
  hence "x\<^sup>\<Omega> * (y * x\<^sup>\<Omega>)\<^sup>\<Omega> \<le> (x \<squnion> y)\<^sup>\<Omega>"
    using 5 order.trans by blast
  thus ?thesis
    using 4 order.antisym by blast
qed

end

sublocale n_omega_algebra < nL_omega: left_zero_conway_semiring where circ = Omega
  apply unfold_locales
  apply (simp add: n_Omega_left_unfold)
  apply (simp add: n_Omega_left_slide)
  by (simp add: n_Omega_sup_1)

(* circ_plus_same does not hold in the non-strict model using Omega *)

context n_omega_algebra
begin

text \<open>AACP Theorem 8.16\<close>

lemma omega_apx_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x\<^sup>\<omega> \<sqsubseteq> y\<^sup>\<omega>"
proof -
  have 1: "x \<le> y \<squnion> L \<and> C y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  have "n(x) * top \<squnion> x * (x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top) \<le> n(x) * top \<squnion> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    by (metis le_supI n_split_top sup.cobounded1 sup_assoc mult_assoc mult_left_dist_sup sup_right_isotone omega_unfold)
  also have "... \<le> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_below_n_omega sup_assoc sup_idem)
  finally have 2: "x\<^sup>\<star> * n(x) * top \<le> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    using star_left_induct mult_assoc by auto
  have "C (y\<^sup>\<omega>) = (C y)\<^sup>\<omega>"
    by (simp add: C_omega_export)
  also have "... \<le> (x \<squnion> n(x) * top)\<^sup>\<omega>"
    using 1 omega_isotone by blast
  also have "... = (x\<^sup>\<star> * n(x) * top)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * n(x) * top)\<^sup>\<star> * x\<^sup>\<omega>"
    by (simp add: omega_decompose mult_assoc)
  also have "... \<le> x\<^sup>\<star> * n(x) * top \<squnion> (x\<^sup>\<star> * n(x) * top)\<^sup>\<star> * x\<^sup>\<omega>"
    using mult_top_omega sup_left_isotone by blast
  also have "... = x\<^sup>\<star> * n(x) * top \<squnion> (1 \<squnion> x\<^sup>\<star> * n(x) * top * (x\<^sup>\<star> * n(x) * top)\<^sup>\<star>) * x\<^sup>\<omega>"
    by (simp add: star_left_unfold_equal)
  also have "... \<le> x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * n(x) * top"
    by (smt sup_mono sup_least mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest sup.cobounded2)
  also have "... \<le> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    using 2 by simp
  finally have 3: "C (y\<^sup>\<omega>) \<le> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    .
  have "x\<^sup>\<omega> \<le> (y \<squnion> L)\<^sup>\<omega>"
    using 1 omega_isotone by simp
  also have "... = (y\<^sup>\<star> * L)\<^sup>\<omega> \<squnion> (y\<^sup>\<star> * L)\<^sup>\<star> * y\<^sup>\<omega>"
    by (simp add: omega_decompose)
  also have "... = y\<^sup>\<star> * L * (y\<^sup>\<star> * L)\<^sup>\<omega> \<squnion> (y\<^sup>\<star> * L)\<^sup>\<star> * y\<^sup>\<omega>"
    using omega_unfold by auto
  also have "... \<le> y\<^sup>\<star> * L \<squnion> (y\<^sup>\<star> * L)\<^sup>\<star> * y\<^sup>\<omega>"
    by (metis sup_left_isotone n_L_below_L mult_assoc mult_right_isotone)
  also have "... = y\<^sup>\<star> * L \<squnion> (1 \<squnion> y\<^sup>\<star> * L * (y\<^sup>\<star> * L)\<^sup>\<star>) * y\<^sup>\<omega>"
    by (simp add: star_left_unfold_equal)
  also have "... \<le> y\<^sup>\<star> * L \<squnion> y\<^sup>\<omega>"
    by (simp add: mult_L_star_mult_below star_left_unfold_equal sup_commute)
  also have "... \<le> y\<^sup>\<star> * bot \<squnion> L \<squnion> y\<^sup>\<omega>"
    using n_L_split_L sup_left_isotone by auto
  finally have "x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> L"
    by (simp add: star_bot_below_omega sup.absorb1 sup.left_commute sup_commute)
  thus "x\<^sup>\<omega> \<sqsubseteq> y\<^sup>\<omega>"
    using 3 by (simp add: apx_def)
qed

lemma combined_apx_left_isotone:
  "x \<sqsubseteq> y \<Longrightarrow> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * z \<sqsubseteq> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_left_isotone_2:
  "x \<sqsubseteq> y \<Longrightarrow> (x\<^sup>\<omega> \<sqinter> L) \<squnion> x\<^sup>\<star> * z \<sqsubseteq> (y\<^sup>\<omega> \<sqinter> L) \<squnion> y\<^sup>\<star> * z"
  by (metis sup_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)

lemma combined_apx_right_isotone:
  "y \<sqsubseteq> z \<Longrightarrow> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * y \<sqsubseteq> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * z"
  by (simp add: mult_apx_isotone sup_apx_left_isotone sup_commute)

lemma combined_apx_right_isotone_2:
  "y \<sqsubseteq> z \<Longrightarrow> (x\<^sup>\<omega> \<sqinter> L) \<squnion> x\<^sup>\<star> * y \<sqsubseteq> (x\<^sup>\<omega> \<sqinter> L) \<squnion> x\<^sup>\<star> * z"
  by (simp add: mult_apx_right_isotone sup_apx_right_isotone)

lemma combined_apx_isotone:
  "x \<sqsubseteq> y \<Longrightarrow> w \<sqsubseteq> z \<Longrightarrow> n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w \<sqsubseteq> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_isotone_2:
  "x \<sqsubseteq> y \<Longrightarrow> w \<sqsubseteq> z \<Longrightarrow> (x\<^sup>\<omega> \<sqinter> L) \<squnion> x\<^sup>\<star> * w \<sqsubseteq> (y\<^sup>\<omega> \<sqinter> L) \<squnion> y\<^sup>\<star> * z"
  by (meson combined_apx_left_isotone_2 combined_apx_right_isotone_2 apx.order.trans)

lemma n_split_nu_mu:
  "C (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<le> y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
proof -
  have "C (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<le> C (y\<^sup>\<omega>) \<squnion> y\<^sup>\<star> * z"
    by (simp add: inf_sup_distrib1 le_supI1 sup_commute)
  also have "... \<le> y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<omega>) * top \<squnion> y\<^sup>\<star> * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "... \<le> y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound sup_right_isotone by force
  finally show ?thesis
    .
qed

lemma n_split_nu_mu_2:
  "C (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<le> y\<^sup>\<star> * z \<squnion> ((y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<sqinter> L) \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
proof -
  have "C (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<le> C (y\<^sup>\<omega>) \<squnion> y\<^sup>\<star> * z"
    using inf.sup_left_isotone sup_inf_distrib2 by auto
  also have "... \<le> y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<omega>) * top \<squnion> y\<^sup>\<star> * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "... \<le> y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound semiring.add_left_mono by auto
  finally show ?thesis
    using order_lesseq_imp semiring.add_right_mono sup.cobounded1 by blast
qed

lemma loop_exists:
  "C (\<nu> (\<lambda>x . y * x \<squnion> z)) \<le> \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * top"
  using omega_loop_nu star_loop_mu n_split_nu_mu by auto

lemma loop_exists_2:
  "C (\<nu> (\<lambda>x . y * x \<squnion> z)) \<le> \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> (\<nu> (\<lambda>x . y * x \<squnion> z) \<sqinter> L) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * top"
  by (simp add: omega_loop_nu star_loop_mu n_split_nu_mu_2)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (\<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * L)"
proof -
  have "kappa_mu_nu_L (\<lambda>x . y * x \<squnion> z)"
    by (metis affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_L_def nu_below_mu_nu_L_kappa_mu_nu_L)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_L_def by force
qed

lemma loop_apx_least_fixpoint_2:
  "apx.is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (\<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> (\<nu> (\<lambda>x . y * x \<squnion> z) \<sqinter> L))"
proof -
  have "kappa_mu_nu (\<lambda>x . y * x \<squnion> z)"
    by (metis affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone loop_exists_2 nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_def by force
qed

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (\<lambda>x . y * x \<squnion> z)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by blast

lemma loop_semantics:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by force

lemma loop_semantics_2:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> (\<nu> (\<lambda>x . y * x \<squnion> z) \<sqinter> L)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint_2 by force

text \<open>AACP Theorem 8.15\<close>

lemma loop_semantics_kappa_mu_nu:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z"
proof -
  have "\<kappa> (\<lambda>x . y * x \<squnion> z) = y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * L"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint by auto
  thus ?thesis
    by (smt n_dist_omega_star sup_assoc mult_right_dist_sup sup_commute le_iff_sup n_L_decreasing)
qed

text \<open>AACP Theorem 8.15\<close>

lemma loop_semantics_kappa_mu_nu_2:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = (y\<^sup>\<omega> \<sqinter> L) \<squnion> y\<^sup>\<star> * z"
proof -
  have "\<kappa> (\<lambda>x . y * x \<squnion> z) = y\<^sup>\<star> * z \<squnion> ((y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<sqinter> L)"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint_2 by auto
  thus ?thesis
    by (metis sup_absorb2 sup_ge2 sup_inf_distrib1 sup_monoid.add_commute)
qed

text \<open>AACP Theorem 8.16\<close>

lemma loop_semantics_apx_left_isotone:
  "w \<sqsubseteq> y \<Longrightarrow> \<kappa> (\<lambda>x . w * x \<squnion> z) \<sqsubseteq> \<kappa> (\<lambda>x . y * x \<squnion> z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_left_isotone_2)

text \<open>AACP Theorem 8.16\<close>

lemma loop_semantics_apx_right_isotone:
  "w \<sqsubseteq> z \<Longrightarrow> \<kappa> (\<lambda>x . y * x \<squnion> w) \<sqsubseteq> \<kappa> (\<lambda>x . y * x \<squnion> z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_right_isotone_2)

lemma loop_semantics_apx_isotone:
  "v \<sqsubseteq> y \<Longrightarrow> w \<sqsubseteq> z \<Longrightarrow> \<kappa> (\<lambda>x . v * x \<squnion> w) \<sqsubseteq> \<kappa> (\<lambda>x . y * x \<squnion> z)"
  using apx_transitive_2 loop_semantics_apx_left_isotone loop_semantics_apx_right_isotone by blast

end

end


theory anders_saturation imports Main "~~/src/HOL/Hoare/HeapSyntax"
begin

(* Since both pre* and post* are described as saturation procedures, we here define a generalised
   saturation procedure in the hope that we can reuse some proofs. *)

(* Note: I did not manage to complete this... *)

definition saturate_step where
  "saturate_step f S \<equiv> S \<union> Collect (f S)"

definition start_from where
  "start_from init f \<equiv> \<lambda>s. init \<union> f s"

definition saturate where
  "saturate f init \<equiv> lfp (start_from init (saturate_step f))"

(* Some simple lemmas that I think can help us...*)

lemma saturate_step_mono: "mono f \<Longrightarrow> mono (saturate_step f)"
  unfolding saturate_step_def mono_def
  by blast

lemma start_from_mono: "mono f \<Longrightarrow> mono (start_from init f)"
  unfolding start_from_def mono_def
  by blast
lemma start_from_init_mono: "mono (\<lambda>init. start_from init f)"
  unfolding start_from_def mono_def
  using le_fun_def by fastforce
lemma start_from_subseteq: "init \<subseteq> (start_from init f) rel"
  by (simp add: start_from_def)
lemma start_from_lfp_subseteq: "init \<subseteq> lfp (start_from init f)"
  by (metis Un_subset_iff lfp_greatest start_from_def)

lemma saturate_mono: "mono f \<Longrightarrow> mono (start_from init (saturate_step f))"
  by (simp add: saturate_step_mono start_from_mono)

lemma saturate_subseteq: "init \<subseteq> saturate f init"
  using start_from_lfp_subseteq
  unfolding saturate_def
  by fast

(* From here it is mostly some desperate attempts to define good induction rules on the saturation procedure.
   Not really successful.  *)

lemma mono_f_intersect_implication:
  assumes "mono f"
      and "f (X \<inter> {x. x \<in> X \<longrightarrow> P x}) x"
    shows "f {x \<in> X. P x} x"
proof -
  have "(X \<inter> {x. x \<in> X \<longrightarrow> P x}) \<subseteq> {x \<in> X. P x}" by auto
  thus ?thesis using assms unfolding mono_def by auto
qed

lemma saturate_induct [case_names mono elem base step]:
  fixes f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono_f: "mono f"
    and elem: "x \<in> saturate f init"
    and base: "\<And>t. t \<in> init \<Longrightarrow> P t"
    and step: "\<And>t. \<lbrakk>f {x \<in> saturate f init. P x} t\<rbrakk> \<Longrightarrow> P t"
  shows "P x"
  using assms unfolding saturate_def
proof (induct rule: lfp_induct_set[where ?f="start_from init (saturate_step f)"])
  case 1
  then show ?case using elem unfolding saturate_def by simp
next
  case 2
  then show ?case using mono_f saturate_mono by fast
next
  case (3 x)
  then show ?case
    unfolding saturate_def start_from_def saturate_step_def
    by auto (drule_tac ?X="lfp (\<lambda>s. init \<union> (s \<union> Collect (f s)))" in mono_f_intersect_implication[OF mono_f], blast)
qed

lemma saturate_induct2 [case_names mono elem base step]:
  fixes f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono_f: "mono f"
    and elem: "x \<in> saturate f init"
    and base: "\<And>t. t \<in> init \<Longrightarrow> P t"
    and step: "\<And>S t. \<lbrakk>S \<subseteq> saturate f init; f {x \<in> S. P x} t\<rbrakk> \<Longrightarrow> P t"
  shows "P x"
  using assms unfolding saturate_def
  apply (induct rule: lfp_ordinal_induct[OF saturate_mono[OF mono_f]])
  unfolding start_from_def saturate_step_def
   apply auto
  subgoal for S
    apply (cases "x \<in> init", blast)
    oops

(*lemma saturate_converse_induct':
  fixes f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono_f: "mono f"
    and mono_g: "mono g"
    and elem: "x \<in> g (saturate f init)"
    and base: "x \<in> g init \<Longrightarrow> P x (g init)"
    and step: "\<And>S. \<lbrakk>x \<in> g (start_from init (saturate_step f) S) \<or> P x (g (start_from init (saturate_step f) S))\<rbrakk>
                     \<Longrightarrow> x \<in> g S \<or> P x (g S)"
  shows "P x (g init)"
using assms
proof (induct rule: saturate_induct[OF mono_f])
  case elem
  then show ?case sorry
next
  case (base t)
  then show ?case sorry
next
  case (step t)
  then show ?case sorry
qed*)

lemma saturate_converse_induct:
  fixes f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono_f: "mono f"
    and mono_g: "mono g"
    and elem: "x \<in> g (saturate f init)"
    and base: "\<And>x. x \<in> g init \<Longrightarrow> P x (g init)"
    and step: "\<And>x S. \<lbrakk>x \<in> g (start_from init (saturate_step f) S) \<or> P x (g (start_from init (saturate_step f) S))\<rbrakk>
                     \<Longrightarrow> x \<in> g S \<or> P x (g S)"
  shows "P x (g init)"
  using assms unfolding saturate_def
proof (induct rule: lfp_ordinal_induct[OF saturate_mono[OF mono_f]])
  case (1 S)
  then show ?case
  proof -
    have "x \<in> g S \<or> P x (g S)" using 1
      by blast
    thus ?case using 1
      apply (cases "x \<in> g S", blast)
      apply (cases "x \<in> g init", blast)
      apply clarsimp
      unfolding start_from_def saturate_step_def mono_def
      apply -
      apply (cases "x \<in> g (Collect (f S))")
       (* apply auto *)
      oops
next
  case (2 M)
  then show ?case oops
qed
thm start_from_def saturate_step_def

lemma "mono f \<Longrightarrow> x \<notin> f X \<Longrightarrow> x \<in> f (X \<union> Y) \<Longrightarrow> x \<in> f Y" unfolding mono_def
  try
  oops

(*
lemma saturate_converse_induct2:
  fixes f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono_f: "mono f"
    and mono_g: "mono g"
    and base: "P (g (saturate f init))"
    and step: "\<And>S. \<lbrakk>P (g (start_from init (saturate_step f) S))\<rbrakk> \<Longrightarrow> P (g S)"
  shows "\<exists>x \<in> (g init). P x"
  using assms unfolding saturate_def start_from_def saturate_step_def
  apply -
  oops
*)

(*
definition saturate_step_some where
  "saturate_step_some f S \<equiv> (if (\<exists>t. t \<notin> S \<and> f S t) then insert (SOME t. t \<notin> S \<and> f S t) S else S)"
*)

(* Trying to define it as an algorithm instead... yeah, well, trying... *)
lemma "VARS (S::'a set) S' init
    {mono f \<and>
    (\<forall>t. t \<in> init \<longrightarrow> P t) \<and>
    (\<forall>S t. f {x \<in> S. P x} t \<longrightarrow> P t)}
    S:={};
    S':=init;
    WHILE S \<noteq> S' INV {f S x \<or> x \<in> S} DO
      S:=S';
      S':=insert (SOME x. f S x) S
    OD
    {x \<in> S \<longrightarrow> P x}"
  apply vcg_simp
  oops

end


theory Group_By
imports Main
begin

fun group_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "group_by f [] = []" |
  "group_by f (h#t) = (
    let
      group = (takeWhile (f h) t);
      dropped = drop (length group) t
    in
      (h#group)#(group_by f dropped)
  )"

lemma "(group_by f xs = []) = (xs = [])"
  by (induct xs, auto simp add: Let_def)

lemma not_empty_group_by_drop: "\<forall>x \<in> set (group_by f (drop l xs)). x \<noteq> []"
  by (induct xs arbitrary: l, auto simp add: drop_Cons' Let_def)

lemma no_empty_groups: "\<forall>x\<in>set (group_by f xs). x \<noteq> []"
  by (metis not_empty_group_by_drop empty_iff empty_set group_by.elims list.distinct(1) set_ConsD)

lemma "(drop (length (takeWhile f l)) l) = dropWhile f l"
  by (simp add: dropWhile_eq_drop)

lemma takeWhile_dropWhile: "takeWhile f l @ dropWhile f l = l' \<Longrightarrow> l' = l"
  by simp

lemma append_pref: "l' = l'' \<Longrightarrow> (l@l' = l@l'')"
  by simp

lemma dropWhile_drop: "\<exists>x. dropWhile f l = drop x l"
  using dropWhile_eq_drop by blast

lemma group_by_inverse: "foldr (@) (group_by f l) [] = l"
proof(induct l)
  case (Cons a l)
  then show ?case
    apply (simp add: Let_def dropWhile_eq_drop[symmetric])
    apply (rule takeWhile_dropWhile[of "f a"])
    apply (rule append_pref)
    apply (insert dropWhile_drop[of "f a" l])
    apply (erule exE)
    by (simp add: group_by_drop_foldr)
qed auto

end


(*  Title:      HOL/ex/Sqrt_Script.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section {* Square roots of primes are irrational (script version) *}

theory Sqrt_Script
imports Complex_Main "~~/src/HOL/Number_Theory/Primes"
begin

text {*
  \medskip Contrast this linear Isabelle/Isar script with Markus
  Wenzel's more mathematical version.
*}

subsection {* Preliminaries *}

lemma prime_nonzero:  "prime (p::nat) \<Longrightarrow> p \<noteq> 0"
  by (force simp add: prime_nat_def)

lemma prime_dvd_other_side:
    "(n::nat) * n = p * (k * k) \<Longrightarrow> prime p \<Longrightarrow> p dvd n"
  apply (subgoal_tac "p dvd n * n", blast dest: prime_dvd_mult_nat)
  apply auto
  done

lemma reduction: "prime (p::nat) \<Longrightarrow>
    0 < k \<Longrightarrow> k * k = p * (j * j) \<Longrightarrow> k < p * j \<and> 0 < j"
  apply (rule ccontr)
  apply (simp add: linorder_not_less)
  apply (erule disjE)
   apply (frule mult_le_mono, assumption)
   apply auto
  apply (force simp add: prime_nat_def)
  done

lemma rearrange: "(j::nat) * (p * j) = k * k \<Longrightarrow> k * k = p * (j * j)"
  by (simp add: ac_simps)

lemma prime_not_square:
    "prime (p::nat) \<Longrightarrow> (\<And>k. 0 < k \<Longrightarrow> m * m \<noteq> p * (k * k))"
  apply (induct m rule: nat_less_induct)
  apply clarify
  apply (frule prime_dvd_other_side, assumption)
  apply (erule dvdE)
  apply (simp add: nat_mult_eq_cancel_disj prime_nonzero)
  apply (blast dest: rearrange reduction)
  done

subsection {* Main theorem *}

text {*
  The square root of any prime number (including @{text 2}) is
  irrational.
*}

theorem prime_sqrt_irrational:
    "prime (p::nat) \<Longrightarrow> x * x = real p \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<notin> \<rat>"
  apply (rule notI)
  apply (erule Rats_abs_nat_div_natE)
  apply (simp del: real_of_nat_mult
              add: abs_if divide_eq_eq prime_not_square real_of_nat_mult [symmetric])
  done

lemmas two_sqrt_irrational =
  prime_sqrt_irrational [OF two_is_prime_nat]

end


theory LTL_Explanations
  imports "HOL-Library.Stream" "HOL-Library.Simps_Case_Conv"
    "Well_Quasi_Orders.Well_Quasi_Orders"
begin

declare [[names_short]]

datatype ltl = P nat | Conj ltl ltl | Disj ltl ltl | Neg ltl | Since ltl ltl | Until ltl ltl

primrec pd where
  "pd (P n) = 0"
| "pd (Conj phi psi) = max (pd phi) (pd psi)"
| "pd (Disj phi psi) = max (pd phi) (pd psi)"
| "pd (Neg phi) = pd phi"
| "pd (Since phi psi) = 1 + max (pd phi) (pd psi)"
| "pd (Until phi psi) = max (pd phi) (pd psi)"

context
  fixes rho :: "nat set stream"
begin

primrec sat where
  "sat i (P n) = (n \<in> rho !! i)"
| "sat i (Conj phi psi) = (sat i phi \<and> sat i psi)"
| "sat i (Disj phi psi) = (sat i phi \<or> sat i psi)"
| "sat i (Neg phi) = (\<not> sat i phi)"
| "sat i (Since phi psi) = (\<exists>j \<le> i. sat j psi \<and> (\<forall>k \<in> {j <.. i}. sat k phi))"
| "sat i (Until phi psi) = (\<exists>j \<ge> i. sat j psi \<and> (\<forall>k \<in> {i ..< j}. sat k phi))"

lemma not_sat_SinceD:
  assumes unsat: "\<not> sat i (Since phi psi)" and witness: "\<exists>j \<le> i. sat j psi"
  shows "\<exists>j \<le> i. \<not> sat j phi \<and> (\<forall>k \<in> {j .. i}. \<not> sat k psi)"
proof -
  define A and j where "A \<equiv> {j. j \<le> i \<and> sat j psi}" "j \<equiv> Max A"
  with witness have "j \<le> i" "sat j psi" "\<And>k. k \<in> {j <.. i} \<Longrightarrow> \<not> sat k psi"
    using Max_in[of A] Max_ge[of A] by auto
  with unsat show ?thesis by force
qed

lemma not_sat_UntilD:
  assumes unsat: "\<not> sat i (Until phi psi)" and witness: "\<exists>j \<ge> i. sat j psi"
  shows "\<exists>j \<ge> i. \<not> sat j phi \<and> (\<forall>k \<in> {i .. j}. \<not> sat k psi)"
proof -
  from witness obtain jmax where jmax: "jmax \<ge> i" "sat jmax psi" by blast
  moreover define A and j where "A \<equiv> {j. j \<ge> i \<and> j \<le> jmax \<and> sat j psi}" "j \<equiv> Min A"
  ultimately have "j \<ge> i" "sat j psi" "\<And>k. k \<in> {i ..< j} \<Longrightarrow> \<not> sat k psi"
    using Min_in[of A] Min_le[of A] by fastforce+
  with unsat show ?thesis by force
qed

end

locale lasso =
  fixes u :: "nat set list"
    and v :: "nat set list"
  assumes v_nonempty[simp]: "v \<noteq> []"
begin

definition rho where
  "rho = u @- cycle v"

abbreviation threshold where
  "threshold i psi \<equiv> max i (length u + length v * pd psi) + length v"

inductive SAT and VIO where
  SP: "n \<in> rho !! i \<Longrightarrow> SAT i (P n)"
| VP: "n \<notin> rho !! i \<Longrightarrow> VIO i (P n)"
| SConj: "SAT i phi \<Longrightarrow> SAT i psi \<Longrightarrow> SAT i (Conj phi psi)"
| VConjL: "VIO i phi \<Longrightarrow> VIO i (Conj phi psi)"
| VConjR: "VIO i psi \<Longrightarrow> VIO i (Conj phi psi)"
| SDisjL: "SAT i phi \<Longrightarrow> SAT i (Disj phi psi)"
| SDisjR: "SAT i psi \<Longrightarrow> SAT i (Disj phi psi)"
| VDisj: "VIO i phi \<Longrightarrow> VIO i psi \<Longrightarrow> VIO i (Disj phi psi)"
| SNeg: "VIO i phi \<Longrightarrow> SAT i (Neg phi)"
| VNeg: "SAT i phi \<Longrightarrow> VIO i (Neg phi)"
| SSince: "j \<le> i \<Longrightarrow> SAT j psi \<Longrightarrow> (\<And>k. k \<in> {j <.. i} \<Longrightarrow> SAT k phi) \<Longrightarrow> SAT i (Since phi psi)"
| VSince: "j \<le> i \<Longrightarrow> VIO j phi \<Longrightarrow> (\<And>k. k \<in> {j .. i} \<Longrightarrow> VIO k psi) \<Longrightarrow> VIO i (Since phi psi)"
| VSince_never: "(\<And>k. k \<in> {0 .. i} \<Longrightarrow> VIO k psi) \<Longrightarrow> VIO i (Since phi psi)"
| SUntil: "j \<ge> i \<Longrightarrow> SAT j psi \<Longrightarrow> (\<And>k. k \<in> {i ..< j} \<Longrightarrow> SAT k phi) \<Longrightarrow> SAT i (Until phi psi)"
| VUntil: "j \<ge> i \<Longrightarrow> VIO j phi \<Longrightarrow> (\<And>k. k \<in> {i .. j} \<Longrightarrow> VIO k psi) \<Longrightarrow> VIO i (Until phi psi)"
| VUntil_never: "(\<And>k. k \<in> {i ..< threshold i psi} \<Longrightarrow> VIO k psi) \<Longrightarrow> VIO i (Until phi psi)"

lemma completeness: "(sat rho i phi \<longrightarrow> SAT i phi) \<and> (\<not> sat rho i phi \<longrightarrow> VIO i phi)"
proof (induct phi arbitrary: i)
  case (Since phi psi)
  then show ?case
  proof (cases "\<exists>j\<le>i. sat rho j psi")
    case True
    from not_sat_SinceD[OF _ True, of phi] Since show ?thesis
      by (auto elim!: VSince SSince)
  qed (auto intro: SAT_VIO.intros)
next
  case (Until phi psi)
  then show ?case
  proof (cases "\<exists>j\<ge>i. sat rho j psi")
    case True
    from not_sat_UntilD[OF _ True, of phi] Until show ?thesis
      by (auto elim!: VUntil SUntil)
  qed (auto intro: SAT_VIO.intros)
qed (auto intro: SAT_VIO.intros)

lemma snth_cycle: "xs \<noteq> [] \<Longrightarrow> cycle xs !! n = xs ! (n mod length xs)"
proof (induct n arbitrary: xs)
  case (Suc n)
  from Suc(2) show ?case
    unfolding snth.simps cycle.simps
    by (subst Suc(1)) (auto simp: neq_Nil_conv nth_append nth_Cons' mod_Suc less_antisym)
qed (auto simp: neq_Nil_conv)

lemma sat_shift1: "k \<ge> length u + length v * pd phi \<Longrightarrow>
  sat rho k phi \<longleftrightarrow> sat rho (k + length v) phi"
proof (induct phi arbitrary: k)
  case (P x)
  then show ?case apply (auto simp: rho_def snth_cycle[OF v_nonempty])
     apply (metis add_diff_assoc2 mod_add_self2)+
    done
next
  case (Conj phi1 phi2)
  from Conj(1)[of k] Conj(2)[of k] Conj(3) show ?case
    by (simp add: nat_mult_max_right)
next
  case (Disj phi1 phi2)
  from Disj(1)[of k] Disj(2)[of k] Disj(3) show ?case
    by (simp add: nat_mult_max_right)
next
  case (Neg phi)
  from Neg(1)[of k] Neg(2) show ?case by simp
next
  case (Since phi1 phi2)
  from Since(3) show ?case
    apply (simp add: nat_mult_max_right nat_mult_distrib) apply safe
    subgoal for j
      apply (cases "j < k - length v")
      subgoal
        apply (rule exI[of _ j])
        apply safe
        subgoal by simp
        subgoal for i
          apply (cases "i \<le> k")
           apply simp
          apply (drule bspec[of _ _ "i - length v"]; auto)
          apply (subst (asm) Since; auto)
          done
        done
      subgoal
        apply (rule exI[of _ "j + length v"])
        apply safe
        subgoal by simp
        subgoal by (subst Since(2)[symmetric]; auto)
        subgoal for i
          apply (drule bspec[of _ _ "i - length v"])
           apply auto []
          apply (subst (asm) Since(1); auto)
          done
        done
      done
    subgoal for j
      apply (cases "j \<le> k")
      subgoal
        apply (rule exI[of _ j])
        apply safe
        subgoal by simp
        done
      apply (rule exI[of _ "j - length v"])
      apply safe
      subgoal by auto
      subgoal by (subst Since(2); auto)
      subgoal by (subst Since(1); auto)
      done
    done
next
  case (Until phi1 phi2)
  from Until(3) show ?case
    apply (simp add: nat_mult_max_right) apply safe
    subgoal for j
      apply (rule exI[of _ "j + length v"])
      apply safe
      subgoal by simp
      subgoal by (subst Until(2)[symmetric]; simp)
      subgoal for i
        apply (drule bspec[of _ _ "i - length v"])
         apply auto []
        apply (subst (asm) Until(1); auto)
        done
      done
    subgoal for j
      apply (rule exI[of _ "j - length v"])
      apply safe
      subgoal by auto
      subgoal by (subst Until(2); auto)
      subgoal by (subst Until(1); auto)
      done
    done
qed

lemma sat_shift: "k \<ge> length u + length v * pd phi \<Longrightarrow>
  sat rho (k + n * length v) phi \<longleftrightarrow> sat rho k phi"
  by (induct n arbitrary: k)
    (simp_all add: sat_shift1[symmetric] add.assoc[symmetric])

end

typedef 'a nelist = "{xs :: 'a list. xs \<noteq> []}" by auto

setup_lifting type_definition_nelist

lift_bnf (no_warn_wits) (neset: 'a) nelist
  for map: nemap
  by auto

lift_definition nenth :: "'a nelist \<Rightarrow> nat \<Rightarrow> 'a" (infixl "ne!" 100) is nth .
lift_definition nehd :: "'a nelist \<Rightarrow> 'a" is hd .
lift_definition netl :: "'a nelist \<Rightarrow> 'a list" is tl .
lift_definition nelast :: "'a nelist \<Rightarrow> 'a" is last .
lift_definition neupto :: "nat \<Rightarrow> nat \<Rightarrow> nat nelist" is "\<lambda>i j. if i > j then [i] else [i ..< j+1]"
  by auto

lift_definition size_nelist :: "('a \<Rightarrow> nat) \<Rightarrow> 'a nelist \<Rightarrow> nat" is size_list .

instantiation nelist :: (size) size begin
definition size_nelist :: "'a nelist \<Rightarrow> nat" where
  size_nelist_overloaded_def: "size_nelist = LTL_Explanations.size_nelist size"
instance proof qed
end

lemma size_nelist_o_map: "size_nelist g \<circ> nemap f = size_nelist (g \<circ> f)"
  unfolding nemap_def
  apply (auto simp: fun_eq_iff size_nelist_def)
  by (metis (mono_tags, lifting) Abs_nelist_inverse LTL_Explanations.size_nelist.rep_eq List.list.map_disc_iff Rep_nelist mem_Collect_eq size_list_map)

setup \<open>
  BNF_LFP_Size.register_size_global \<^type_name>\<open>nelist\<close> \<^const_name>\<open>size_nelist\<close>
    @{thm size_nelist_overloaded_def}
    @{thms }
    @{thms size_nelist_o_map}
\<close>

datatype sproof = SAtm nat nat | SNeg vproof | SConj sproof sproof | SDisjL sproof | SDisjR sproof
                | SSince sproof "sproof list" | SUntil "sproof list" sproof
     and vproof = VAtm nat nat | VNeg sproof | VConjL vproof | VConjR vproof | VDisj vproof vproof
                | VSince vproof "vproof nelist" | VUntil "vproof nelist" vproof
                | VSince_never "vproof nelist" | VUntil_never "vproof nelist"

lemma neq_Nil_conv_snoc: "(xs \<noteq> []) = (\<exists>y ys. xs = ys @ [y])"
by (induct xs) auto

lemma size_last_estimation[termination_simp]: "xs \<noteq> [] \<Longrightarrow> size (last xs) < size_list size xs"
  by (induct xs) auto
lemma size_nehd_estimation[termination_simp]: "size (nehd xs) < size_nelist size xs"
  unfolding size_nelist_overloaded_def by transfer (auto simp: neq_Nil_conv)
lemma size_nelast_estimation[termination_simp]: "size (nelast xs) < size_nelist size xs"
  unfolding size_nelist_overloaded_def by transfer (auto simp: neq_Nil_conv_snoc)
lemma size_nelist_estimation[termination_simp]: "x \<in> neset xs \<Longrightarrow> y < f x \<Longrightarrow> y < size_nelist f xs"
  unfolding size_nelist_overloaded_def neset_def by transfer (simp add: size_list_estimation)
lemma size_nelist_estimation'[termination_simp]: "x \<in> neset xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_nelist f xs"
  unfolding size_nelist_overloaded_def neset_def by transfer (simp add: size_list_estimation')
lemma nehd_neset: "nehd xs \<in> neset xs" and nelast_neset: "nelast xs \<in> neset xs"
  unfolding neset_def by (transfer, auto)+

fun s_at and v_at where
  "s_at (SAtm _ n) = n"
| "s_at (SNeg vphi) = v_at vphi"
| "s_at (SConj sphi spsi) = s_at sphi"
| "s_at (SDisjL sphi) = s_at sphi"
| "s_at (SDisjR spsi) = s_at spsi"
| "s_at (SSince spsi sphis) = (case sphis of [] \<Rightarrow> s_at spsi | _ \<Rightarrow> s_at (last sphis))"
| "s_at (SUntil sphis spsi) = (case sphis of [] \<Rightarrow> s_at spsi | x # _ \<Rightarrow> s_at x)"
| "v_at (VAtm _ n) = n"
| "v_at (VNeg sphi) = s_at sphi"
| "v_at (VConjL vphi) = v_at vphi"
| "v_at (VConjR vpsi) = v_at vpsi"
| "v_at (VDisj vphi vpsi) = v_at vphi"
| "v_at (VSince vpsi vphis) = v_at (nelast vphis)"
| "v_at (VUntil vphis vpsi) = v_at (nehd vphis)"
| "v_at (VSince_never vpsis) = v_at (nelast vpsis)"
| "v_at (VUntil_never vpsis) = v_at (nehd vpsis)"

context lasso begin

fun s_check and v_check where
  "s_check f p = (case (f, p) of
    (P a, SAtm b n) \<Rightarrow> (a = b \<and> a \<in> rho !! n)
  | (Neg phi, SNeg sphi) \<Rightarrow> v_check phi sphi
  | (Conj phi psi, SConj sphi spsi) \<Rightarrow> s_check phi sphi \<and> s_check psi spsi \<and> s_at sphi = s_at spsi
  | (Disj phi psi, SDisjL sphi) \<Rightarrow> s_check phi sphi
  | (Disj phi psi, SDisjR spsi) \<Rightarrow> s_check psi spsi
  | (Since phi psi, SSince spsi sphis) \<Rightarrow>
    (let i = s_at (SSince spsi sphis);
         j = s_at spsi
    in map s_at sphis = [Suc j ..< Suc i] \<and> s_check psi spsi \<and> (\<forall>sphi \<in> set sphis. s_check phi sphi))
  | (Until phi psi, SUntil sphis spsi) \<Rightarrow>
    (let i = s_at (SUntil sphis spsi);
         j = s_at spsi
    in map s_at sphis = [i ..< j] \<and> s_check psi spsi \<and> (\<forall>sphi \<in> set sphis. s_check phi sphi))
  | (_, _) \<Rightarrow> False)"
| "v_check f p = (case (f, p) of
    (P a, VAtm b n) \<Rightarrow> (a = b \<and> a \<notin> rho !! n)
  | (Neg phi, VNeg sphi) \<Rightarrow> s_check phi sphi
  | (Disj phi psi, VDisj vphi vpsi) \<Rightarrow> v_check phi vphi \<and> v_check psi vpsi \<and> v_at vphi = v_at vpsi
  | (Conj phi psi, VConjL vphi) \<Rightarrow> v_check phi vphi
  | (Conj phi psi, VConjR vpsi) \<Rightarrow> v_check psi vpsi
  | (Since phi psi, VSince vphi vpsis) \<Rightarrow>
    (let i = v_at (VSince vphi vpsis);
         j = v_at vphi
    in j \<le> i \<and> nemap v_at vpsis = neupto j i \<and> v_check phi vphi \<and> (\<forall>vpsi \<in> neset vpsis. v_check psi vpsi))
  | (Until phi psi, VUntil vpsis vphi) \<Rightarrow>
    (let i = v_at (VUntil vpsis vphi);
         j = v_at vphi
    in i \<le> j \<and> nemap v_at vpsis = neupto i j \<and> v_check phi vphi \<and> (\<forall>vpsi \<in> neset vpsis. v_check psi vpsi))
  | (Since phi psi, VSince_never vpsis) \<Rightarrow>
    (let i = v_at (VSince_never vpsis)
    in nemap v_at vpsis = neupto 0 i \<and> (\<forall>vpsi \<in> neset vpsis. v_check psi vpsi))
  | (Until phi psi, VUntil_never vpsis) \<Rightarrow>
    (let i = v_at (VUntil_never vpsis)
    in nemap v_at vpsis = neupto i (threshold i psi) \<and> (\<forall>vpsi \<in> neset vpsis. v_check psi vpsi))
  | (_, _) \<Rightarrow> False)"

declare s_check.simps[simp del] v_check.simps[simp del]
simps_of_case s_check_simps[simp, code]: s_check.simps[unfolded prod.case] (splits: ltl.split sproof.split)
simps_of_case v_check_simps[simp, code]: v_check.simps[unfolded prod.case] (splits: ltl.split sproof.split)

lemma Cons_eq_upt_conv: "x # xs = [m ..< n] \<longleftrightarrow> m < n \<and> x = m \<and> xs = [Suc m ..< n]"
  by (induct n arbitrary: xs) (force simp: Cons_eq_append_conv)+

lemma map_setE[elim_format]: "map f xs = ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> \<exists>x\<in>set xs. f x = y"
  by (induct xs arbitrary: ys) auto

lemma neset_neupto[simp]: "neset (neupto i j) = (if j < i then {i} else {i .. j})"
  unfolding neset_def
  by transfer (auto simp: neupto_def)

lemma nemap_nesetE[elim_format]: "nemap f xs = ys \<Longrightarrow> y \<in> neset ys \<Longrightarrow> \<exists>x\<in>neset xs. f x = y"
  unfolding neset_def nemap_def
  apply auto
  apply transfer
  subgoal for y f xs ys
    apply (induct xs arbitrary: ys)
     apply (auto simp: Abs_nelist_inverse)
    done
  done

lemma check_sound:
  "s_check phi sphi \<Longrightarrow> SAT (s_at sphi) phi"
  "v_check phi vphi \<Longrightarrow> VIO (v_at vphi) phi"
proof (induction sphi and vphi arbitrary: phi and phi)
  case SAtm
  then show ?case by (cases phi) (auto intro: SAT_VIO.SP)
next
  case SNeg
  then show ?case by (cases phi) (auto intro: SAT_VIO.SNeg)
next
  case SConj
  then show ?case by (cases phi) (auto intro: SAT_VIO.SConj)
next
  case SDisjL
  then show ?case by (cases phi) (auto intro: SAT_VIO.SDisjL)
next
  case SDisjR
  then show ?case by (cases phi) (auto intro: SAT_VIO.SDisjR)
next
  case (SSince spsi sphis)
  then show ?case
  proof (cases phi)
    case (Since phi psi)
    show ?thesis
      using SSince
      unfolding Since
      apply (intro SAT_VIO.SSince[of "s_at spsi"])
        apply (auto simp: Let_def le_Suc_eq Cons_eq_append_conv Cons_eq_upt_conv
          split: if_splits list.splits)
      subgoal for k z zs
        apply (cases "k \<le> s_at z")
         apply (fastforce simp: le_Suc_eq elim!: map_setE[of _ _ _ k])+
        done
      done
  qed auto
next
  case (SUntil sphis spsi)
  then show ?case
  proof (cases phi)
    case (Until phi psi)
    show ?thesis
      using SUntil
      unfolding Until
      apply (intro SAT_VIO.SUntil[of _ "s_at spsi"])
        apply (auto simp: Let_def le_Suc_eq Cons_eq_append_conv Cons_eq_upt_conv
          split: if_splits list.splits)
      subgoal for k z zs
        apply (cases "k \<le> s_at z")
         apply (fastforce simp: le_Suc_eq elim!: map_setE[of _ _ _ k])+
        done
      done
  qed auto
next
  case VAtm
  then show ?case by (cases phi) (auto intro: SAT_VIO.VP)
next
  case VNeg
  then show ?case by (cases phi) (auto intro: SAT_VIO.VNeg)
next
  case VConjL
  then show ?case by (cases phi) (auto intro: SAT_VIO.VConjL)
next
  case VConjR
  then show ?case by (cases phi) (auto intro: SAT_VIO.VConjR)
next
  case VDisj
  then show ?case by (cases phi) (auto intro: SAT_VIO.VDisj)
next
  case VSince
  then show ?case
    by (cases phi) (auto simp: Let_def split: if_splits elim: nemap_nesetE intro!: SAT_VIO.VSince)
next
  case VUntil
  then show ?case
    by (cases phi) (auto simp: Let_def split: if_splits elim: nemap_nesetE intro!: SAT_VIO.VUntil)
next
  case VSince_never
  then show ?case
    by (cases phi) (auto elim: nemap_nesetE intro!: SAT_VIO.VSince_never)
next
  case VUntil_never
  then show ?case
    by (cases phi) (auto 0 4 simp: Let_def elim: nemap_nesetE intro!: SAT_VIO.VUntil_never)
qed

lemma SAT_or_VIO: "SAT i \<phi> \<or> VIO i \<phi>"
  using completeness by blast

end

definition "satoms x = rec_sproof (\<lambda>a _. {a}) (\<lambda>_. id) (\<lambda>_ _. (\<union>)) (\<lambda>_. id) (\<lambda>_. id)
   (\<lambda>_ xs. (\<union>) (\<Union>(set (map snd xs)))) (\<lambda>xs _. (\<union>) (\<Union>(set (map snd xs))))
   (\<lambda>a _. {a}) (\<lambda>_. id) (\<lambda>_. id) (\<lambda>_. id) (\<lambda>_ _. (\<union>))
   (\<lambda>_ xs. (\<union>) (\<Union>(neset (nemap snd xs)))) (\<lambda>xs _. (\<union>) (\<Union>(neset (nemap snd xs))))
   (\<lambda>xs. (\<Union>(neset (nemap snd xs)))) (\<lambda>xs. (\<Union>(neset (nemap snd xs)))) x"

definition "vatoms x = rec_vproof (\<lambda>a _. {a}) (\<lambda>_. id) (\<lambda>_ _. (\<union>)) (\<lambda>_. id) (\<lambda>_. id)
   (\<lambda>_ xs. (\<union>) (\<Union>(set (map snd xs)))) (\<lambda>xs _. (\<union>) (\<Union>(set (map snd xs))))
   (\<lambda>a _. {a}) (\<lambda>_. id) (\<lambda>_. id) (\<lambda>_. id) (\<lambda>_ _. (\<union>))
   (\<lambda>_ xs. (\<union>) (\<Union>(neset (nemap snd xs)))) (\<lambda>xs _. (\<union>) (\<Union>(neset (nemap snd xs))))
   (\<lambda>xs. (\<Union>(neset (nemap snd xs)))) (\<lambda>xs. (\<Union>(neset (nemap snd xs)))) x"
lemmas satoms_simps[simp] =
   sproof.rec[THEN trans[OF satoms_def], folded satoms_def vatoms_def,
     unfolded id_apply list.map_comp o_def snd_conv list.set_map]
lemmas vatoms_simps[simp] =
   vproof.rec[THEN trans[OF vatoms_def], folded satoms_def vatoms_def,
     unfolded id_apply nelist.map_comp o_def snd_conv nelist.set_map]

end


theory Chapter18_2_Typechecking
imports Chapter18_1_Language
begin

primrec is_ok :: "unit env => expr => bool"
where "is_ok del (Var v) = (lookup del v = Some ())"
    | "is_ok del (Num x) = True"
    | "is_ok del Zero = True"
    | "is_ok del (Succ e) = is_ok del e"
    | "is_ok del (IsZ et e0 es) = (is_ok del et & is_ok del e0 & is_ok (extend del ()) es)"
    | "is_ok del (Lam e) = is_ok (extend del ()) e"
    | "is_ok del (Appl e1 e2) = (is_ok del e1 & is_ok del e2)"
    | "is_ok del (Fix e) = is_ok (extend del ()) e"

lemma [simp]: "is_ok (extend_at n del ()) e ==> n in del ==> is_ok del e' ==>
                  is_ok del (subst e' n e)"
by (induction e arbitrary: n del e', fastforce+)

end


theory Exercises2_03
  imports Main
begin

(*---------------- Exercise 2.3----------------*)
(* count function *)
fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x [] = 0" |
"count x (Cons y xs) = (if x=y  then Suc (count x xs) else (count x xs))"

theorem countlength : "(count x xs) \<le> List.length xs"
  apply(induction xs)
   apply(auto)
  done

end


theory T105
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. undr(x, join(y, z)) = join(undr(x, y), undr(x, 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. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T5
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. undr(x, join(y, z)) = join(undr(x, y), undr(x, 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 T48
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(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(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Datalog
  imports Main
begin

datatype ('oid, 'val) operation
  = MakeList
  | MakeMap
  | MakeVal "'val"
  | InsertAfter "'oid"
  | ListAssign "'oid" "'oid"
  | MapAssign "'oid" "string" "'oid"
  | ListRemove "'oid"
  | MapRemove  "'oid" "string"

fun oid_references :: "('o, 'v) operation \<Rightarrow> 'o set" where
  "oid_references (InsertAfter oid) = {oid}" |
  "oid_references (ListAssign oid1 oid2) = {oid1, oid2}" |
  "oid_references (MapAssign oid1 _ oid2) = {oid1, oid2}" |
  "oid_references (ListRemove oid) = {oid}" |
  "oid_references (MapRemove oid _) = {oid}" |
  "oid_references _ = {}"

type_synonym ('oid, 'val) database = "'oid \<rightharpoonup> ('oid, 'val) operation"

locale datalog =
  fixes \<D> :: "('oid::{linorder}, 'val) database"
  assumes ref_older: "\<D> oid = Some oper \<Longrightarrow> x \<in> oid_references oper \<Longrightarrow> x < oid"

locale db_extension = datalog +
  fixes oid and oper
  assumes oid_is_latest [simp]: "n \<in> dom \<D> \<Longrightarrow> n < oid"
    and oid_not_present [simp]: "\<D> oid = None"
    and still_valid_database: "datalog (\<D>(oid \<mapsto> oper))"

lemma db_extension_datalog:
  assumes "db_extension \<D> oid oper"
  shows "datalog \<D>"
  using assms db_extension.axioms(1) by blast

end


(*  Title:      ZF/AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>The Axiom of Choice\<close>

theory AC imports Main_ZF begin

text\<open>This definition comes from Halmos (1960), page 59.\<close>
axiomatization where
  AC: "[| a \<in> A;  !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"

(*The same as AC, but no premise @{term"a \<in> A"}*)
lemma AC_Pi: "[| !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"
apply (case_tac "A=0")
apply (simp add: Pi_empty1)
(*The non-trivial case*)
apply (blast intro: AC)
done

(*Using dtac, this has the advantage of DELETING the universal quantifier*)
lemma AC_ball_Pi: "\<forall>x \<in> A. \<exists>y. y \<in> B(x) ==> \<exists>y. y \<in> Pi(A,B)"
apply (rule AC_Pi)
apply (erule bspec, assumption)
done

lemma AC_Pi_Pow: "\<exists>f. f \<in> (\<Prod>X \<in> Pow(C)-{0}. X)"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
apply (erule_tac [2] exI, blast)
done

lemma AC_func:
     "[| !!x. x \<in> A ==> (\<exists>y. y \<in> x) |] ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
prefer 2 apply (blast dest: apply_type intro: Pi_type, blast)
done

lemma non_empty_family: "[| 0 \<notin> A;  x \<in> A |] ==> \<exists>y. y \<in> x"
by (subgoal_tac "x \<noteq> 0", blast+)

lemma AC_func0: "0 \<notin> A ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule AC_func)
apply (simp_all add: non_empty_family)
done

lemma AC_func_Pow: "\<exists>f \<in> (Pow(C)-{0}) -> C. \<forall>x \<in> Pow(C)-{0}. f`x \<in> x"
apply (rule AC_func0 [THEN bexE])
apply (rule_tac [2] bexI)
prefer 2 apply assumption
apply (erule_tac [2] fun_weaken_type, blast+)
done

lemma AC_Pi0: "0 \<notin> A ==> \<exists>f. f \<in> (\<Prod>x \<in> A. x)"
apply (rule AC_Pi)
apply (simp_all add: non_empty_family)
done

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

header "Regular Expressions Equivalence Framework"

(*<*)
theory Automaton
imports "../Regular-Sets/Regular_Exp" "~~/src/HOL/Library/While_Combinator"
begin
(*>*)

primrec add_atoms :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "add_atoms Zero = id"
| "add_atoms One = id"
| "add_atoms (Atom a) = List.insert a"
| "add_atoms (Plus r s) = add_atoms s o add_atoms r"
| "add_atoms (Times r s) = add_atoms s o add_atoms r"
| "add_atoms (Star r) = add_atoms r"

lemma set_add_atoms: "set (add_atoms r as) = atoms r \<union> set as"
by (induction r arbitrary: as) auto

lemma rtrancl_fold_product:
shows "{((r,s),(f a r,f a s))| r s a. a : A}^* =
       {((r,s),(fold f w r,fold f w s))| r s w. w : lists A}" (is "?L = ?R")
proof-
  { fix r s r' s'
    have "((r,s),(r',s')) : ?L \<Longrightarrow> ((r,s),(r',s')) : ?R"
    proof(induction rule: converse_rtrancl_induct2)
      case refl show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
  } moreover
  { fix r s r' s'
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> ((r, s), fold f w r, fold f w s) :?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "((r,s),(r',s')) : ?R \<Longrightarrow> ((r,s),(r',s')) : ?L" by auto
  } ultimately show ?thesis by (auto simp: in_lists_conv_set) blast
qed

lemma rtrancl_fold_product1:
shows "{(r,s). \<exists>a \<in> A. s = f a r}^* =
       {(r,fold f w r) | r w. w : lists A}" (is "?L = ?R")
proof-
  { fix r s
    have "(r,s) : ?L \<Longrightarrow> (r,s) : ?R"
    proof(induction rule: converse_rtrancl_induct)
      case base show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
  } moreover
  { fix r s
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> (r, fold f w r) :?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "(r,s) : ?R \<Longrightarrow> (r,s) : ?L" by auto
  } ultimately show ?thesis by (auto simp: in_lists_conv_set) blast
qed

locale rexp_DA =
fixes init :: "'a rexp \<Rightarrow> 's"
fixes delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
fixes final :: "'s \<Rightarrow> bool"
fixes L :: "'s \<Rightarrow> 'a lang"
assumes L_init: "L (init r) = lang r"
assumes L_delta: "L(delta a s) = Deriv a (L s)"
assumes final_iff_Nil: "final s \<longleftrightarrow> [] \<in> L s"
begin

lemma L_deltas: "L (fold delta w s) = fold Deriv w (L s)"
  by (induction w arbitrary: s) (auto simp add: L_delta)

definition closure :: "'a list \<Rightarrow> 's * 's \<Rightarrow> (('s * 's) list * ('s * 's) set) option"
where
"closure as = rtrancl_while (\<lambda>(p,q). final p = final q)
          (\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as)"
(* stop when same opti? *)

theorem closure_sound_complete:
assumes result: "closure as (init r,init s) = Some(ws,R)"
and atoms: "set as = atoms r \<union> atoms s"
shows "ws = [] \<longleftrightarrow> lang r = lang s"
proof -
  have leq: "(lang r = lang s) =
  (\<forall>(r',s') \<in> {((r0,s0),(delta a r0,delta a s0))| r0 s0 a. a : set as}^* `` {(init r,init s)}.
    final r' = final s')"
    by (simp add: atoms rtrancl_fold_product Ball_def lang_eq_ext_Nil_fold_Deriv imp_ex
      L_deltas L_init final_iff_Nil del: Un_iff)
  have "{(x,y). y \<in> set ((\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as) x)} =
    {((r,s), delta a r, delta a s) |r s a. a \<in> set as}"
    by auto
  with atoms rtrancl_while_Some[OF result[unfolded closure_def]]
  show ?thesis by (auto simp add: leq Ball_def split: if_splits)
qed

subsection {* The overall procedure *}

definition check_eqv :: "'a rexp \<Rightarrow> 'a rexp \<Rightarrow> bool" where
"check_eqv r s =
  (let as = add_atoms r (add_atoms s [])
   in case closure as (init r, init s) of
     Some([],_) \<Rightarrow> True | _ \<Rightarrow> False)"

(* completeness needs termination of closure, otherwise result could be None *)

text{* Auxiliary functions: *}
definition reachable :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 's set" where
"reachable as s =
  snd(the(rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. delta a s) as) (init s)))"

definition automaton :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> (('s * 'a) * 's) set" where
"automaton as s =
  snd (the
  (let i = init s;
       start = (([i], {i}), {});
       test = \<lambda>((ws, Z), A). ws \<noteq> [];
       step = \<lambda>((ws, Z), A).
         (let s = hd ws;
              new_edges = map (\<lambda>a. ((s, a), delta a s)) as;
              new = remdups (filter (\<lambda>ss. ss \<notin> Z) (map snd new_edges))
         in ((new @ tl ws, set new \<union> Z), set new_edges \<union> A))
  in while_option test step start))"

definition match :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
"match s w = final (fold delta w (init s))"

lemma match_correct: "match s w \<longleftrightarrow> w \<in> lang s"
  unfolding match_def
  by (induct w arbitrary: s)
    (auto simp: L_init L_delta in_fold_Deriv final_iff_Nil L_deltas Deriv_def)

end

locale rexp_DFA = rexp_DA +
assumes fin: "finite {fold delta w (init s) | w. True}"
begin

lemma finite_rtrancl_delta_Image:
  "finite ({((r,s),(delta a r,delta a s))| r s a. a : A}^* `` {(init r, init s)})"
  unfolding rtrancl_fold_product Image_singleton
  by (auto intro: finite_subset[OF _ finite_cartesian_product[OF fin fin]])

lemma "termination": "\<exists>st. closure as (init r,init s) = Some st" (is "\<exists>_. closure as ?i = _")
unfolding closure_def proof (rule rtrancl_while_finite_Some)
  show "finite ({(x, st). st \<in> set ((\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as) x)}\<^sup>* `` {?i})"
    by (rule finite_subset[OF Image_mono[OF rtrancl_mono] finite_rtrancl_delta_Image]) auto
qed

lemma completeness:
assumes "lang r = lang s" shows "check_eqv r s"
proof -
  let ?as = "add_atoms r (add_atoms s [])"
  obtain ws R where 1: "closure ?as (init r, init s) = Some(ws,R)"
    using "termination" by fastforce
  with closure_sound_complete[OF this] assms
  show "check_eqv r s" by (simp add: check_eqv_def set_add_atoms)
qed

lemma finite_rtrancl_delta_Image1:
  "finite ({(r,s). \<exists>a \<in> A. s = delta a r}^* `` {init r})"
  unfolding rtrancl_fold_product1 by (auto intro: finite_subset[OF _ fin])

lemma reachable: "reachable as r = {fold delta w (init r) | w. w \<in> lists (set as)}"
  and finite_reachable: "finite (reachable as r)"
proof -
  obtain wsZ where *: "rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. delta a s) as) (init r) = Some wsZ"
    by (atomize_elim,intro rtrancl_while_finite_Some Image_mono rtrancl_mono
      finite_subset[OF _ finite_rtrancl_delta_Image1[of "set as" r]]) auto
  then show "reachable as r = {fold delta w (init r) | w. w \<in> lists (set as)}"
    unfolding reachable_def by (cases wsZ)
      (auto dest!: rtrancl_while_Some split: if_splits simp: rtrancl_fold_product1 image_iff)
  then show "finite (reachable as r)" by (auto intro: finite_subset[OF _ fin])
qed

end

(*<*)
end
(*>*)


theory BinSearch
  imports Syntax
begin

hide_const first last sorted

definition sorted :: "'a :: linorder array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "sorted a i j \<equiv> \<forall>x y. i \<le> x \<and> x \<le> y \<and> y \<le> j \<longrightarrow> a<x> \<le> a<y>"

lemma sorted_section1: "sorted a f l \<Longrightarrow> f \<le> m \<Longrightarrow> m < l \<Longrightarrow> a<m> < v \<Longrightarrow> (\<exists>x \<in> \<lbrace>Suc m, l\<rbrace>. a<x> = v) \<longleftrightarrow> (\<exists>x \<in>\<lbrace>f, l\<rbrace>. a<x> = v)"
  apply (auto simp: sorted_def interval_def)
  apply (rule_tac x=x in exI)
  apply clarsimp
  apply (metis leD less_imp_le_nat not_less_eq_eq)
done

lemma sorted_section2: "sorted a f l \<Longrightarrow> f \<le> m \<Longrightarrow> m \<le> l \<Longrightarrow> v \<le> a<m> \<Longrightarrow> (\<exists>x \<in> \<lbrace>f, m\<rbrace>. a<x> = v) \<longleftrightarrow> (\<exists>x \<in> \<lbrace>f, l\<rbrace>. a<x> = v)"
  apply (auto simp: sorted_def interval_def)
  by (meson eq_iff nat_le_linear)

record state =
  first :: nat
  mid :: nat
  last :: nat

abbreviation f :: "nat \<times> nat \<Rightarrow> nat" where "f \<equiv> fst"
abbreviation l :: "nat \<times> nat \<Rightarrow> nat" where "l \<equiv> snd"

lemma "\<forall>u. \<turnstile> \<lbrace> (f u = `first \<and> l u = `last \<and> `first \<le> `last \<and> sorted a `first `last) \<rbrace>
  rec BinSearch in
    `mid := (`first + `last) div 2;
    if `first \<noteq> `last then
      if a<`mid> < v then
        `first := `mid + 1;
        \<lbrace> u. (f u + l u) div 2 + 1 = `first \<and> l u = `last \<and> `first \<le> `last \<and> sorted a `first `last
          \<and> sorted a (f u) (l u) \<and> a<(f u + l u) div 2> < v \<rbrace>
        BinSearch
        \<lbrace> (f u + l u) div 2 + 1 \<le> `mid \<and> `mid \<le> l u \<and> (a<`mid> = v \<longleftrightarrow> (\<exists>x \<in> \<lbrace>(f u + l u) div 2 + 1, l u\<rbrace>. a<x> = v))
          \<and> sorted a (f u) (l u) \<and> a<(f u + l u) div 2> < v \<rbrace>
      else
        if a<`mid> > v then
          `last := `mid;
          \<lbrace> u. (f u = `first \<and> (f u + l u) div 2 = `last \<and> `first \<le> `last \<and> sorted a `first `last
            \<and> sorted a (f u) (l u) \<and> v < a<(f u + l u) div 2> ) \<rbrace>
          BinSearch
          \<lbrace> f u \<le> `mid \<and> `mid \<le> (f u + l u) div 2 \<and> (a<`mid> = v \<longleftrightarrow> (\<exists>x \<in> \<lbrace>f u, (f u + l u) div 2\<rbrace>. a<x> = v))
            \<and> sorted a (f u) (l u) \<and> v < a<(f u + l u) div 2> \<rbrace>
        fi
      fi
    fi
    end
  \<lbrace> f u \<le> `mid \<and> `mid \<le> l u \<and> (a<`mid> = v \<longleftrightarrow> (\<exists>x \<in> \<lbrace>f u, l u\<rbrace>. a<x> = v)) \<rbrace>"
apply hoare
apply force
apply clarsimp
apply (rule conjI)
apply force
apply (rule sorted_section1)
apply simp+
apply force
apply clarsimp
apply (rule conjI)
apply simp
apply (rule sorted_section2)
apply simp+
apply clarsimp
apply (auto simp: sorted_def interval_def)
apply (rule_tac x="(first xa + last xa) div 2" in exI)
apply force
done

end