theory sledgeCategoryV3 imports FreeLogic

abbrevs "morphismE" = ":\<rightarrow>" and
        "morphism" = ":\<Rightarrow>" and
        "wedgeE" = "\<leftarrow>-()-\<rightarrow>" and
        "wedge" = "\<Leftarrow>-()-\<Rightarrow>" and
        "cowedgeE" = "-\<rightarrow>()\<leftarrow>-" and
        "ptimes" = "\<^bold>\<times>"

begin

(*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 300]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 e vampire remote_leo3, timeout = 120, isar_proofs = false]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section \<open>The Basics of Category Theory\<close>

class category =
  fixes domain:: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
        codomain:: "'a \<Rightarrow> 'a" ("cod _" [110] 111) and
        composition:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>" 110)

  assumes
        S1: "E(dom x) \<longrightarrow> E x" and
        S2: "E(cod y) \<longrightarrow> E y" and
        S3: "E(x\<cdot>y) \<longleftrightarrow> dom x \<simeq> cod y" and
        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y"
begin

lemmas catAx = S1 S2 S3 S4 S5 S6

subsection\<open>Basic Definitions\<close>

abbreviation type ("type") where "type x \<equiv> x \<cong> dom x"

abbreviation typeE ("typeE") where "typeE x \<equiv> x \<simeq> dom x"

abbreviation arrow ("(_):(_)\<Rightarrow>(_)" [120,120,120] 119) where
  "x:a\<Rightarrow>b \<equiv> dom x \<cong> a \<and> cod x \<cong> b"

abbreviation arrowE ("(_):(_)\<rightarrow>(_)" [120,120,120] 119) where
  "x:a\<rightarrow>b \<equiv> dom x \<simeq> a \<and> cod x \<simeq> b"

abbreviation wedge ("_\<Leftarrow>_- (_) -_\<Rightarrow>_" [120,0,0,0,120] 119) where
  "a \<Leftarrow>f- (x) -g\<Rightarrow> b \<equiv> f:x\<Rightarrow>a \<and> g:x\<Rightarrow>b"

abbreviation wedgeE ("_\<leftarrow>_- (_) -_\<rightarrow>_" [120,0,0,0,120] 119) where
  "a \<leftarrow>f- (x) -g\<rightarrow> b \<equiv> f:x\<rightarrow>a \<and> g:x\<rightarrow>b"

abbreviation cowedgeE ("_-_\<rightarrow> (_) \<leftarrow>_-_" [120,0,0,120] 119) where
  "a -f\<rightarrow> (x) \<leftarrow>g- b \<equiv> f:a\<rightarrow>x \<and> g:b\<rightarrow>x"

\<comment> \<open>arrows appear in counterclockwise order starting at lower right corner\<close>
abbreviation commutativeSquare ("commSquare") where
  "commSquare g p q f \<equiv> g\<cdot>p \<cong> f\<cdot>q"

abbreviation commutativeSquareE ("commSquareE") where
  "commSquareE g p q f \<equiv> g\<cdot>p \<simeq> f\<cdot>q"

abbreviation monic::"'a \<Rightarrow> bool" ("monic") where
  "(monic m) \<equiv> \<forall>f g. m\<cdot>f \<simeq> m\<cdot>g \<longrightarrow> f \<simeq> g"

abbreviation epi::"'a \<Rightarrow> bool" ("epi") where
  "(epi m) \<equiv> \<forall>f g. f\<cdot>m \<simeq> g\<cdot>m \<longrightarrow> f \<simeq> g"

abbreviation initial::"'a \<Rightarrow> bool" ("initial") where
  "(initial z) \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<^bold>\<exists>!f. f:z\<rightarrow>t)"

abbreviation final::"'a \<Rightarrow> bool" ("final") where
  "final z \<equiv> \<^bold>\<forall>t. (type t) \<longrightarrow> (\<^bold>\<exists>!f. f:t\<rightarrow>z)"

abbreviation isomorphism::"'a \<Rightarrow> bool" ("isomorphism") where
  "(isomorphism f) \<equiv> \<exists>g. f\<cdot>g \<cong> (dom g) \<and> g\<cdot>f \<cong> (dom f)"

abbreviation isomorphic::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<cong>" 120) where
  "isomorphic z y \<equiv> \<exists>f. dom f \<cong> z \<and> cod f \<cong> y \<and> isomorphism f"

abbreviation iso2::"'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "iso2 x y \<equiv> \<^bold>\<exists>f g. f\<cdot>g \<simeq> x \<and> g\<cdot>f \<simeq> y"

subsection\<open>More Advanced Definitions\<close>
(*ToDo*)

\<comment> \<open>e is the equalizer for f and g\<close>
abbreviation isEqualizer::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("Equalizer")
  where "isEqualizer f g e \<equiv> f \<cdot> e \<simeq> g \<cdot> e \<and>
          (\<^bold>\<forall>z. f \<cdot> z \<simeq> g \<cdot> z \<longrightarrow> (\<^bold>\<exists>!u. u:(dom z)\<rightarrow>(dom e) \<and> e \<cdot> u \<simeq> z))"

(*abbreviation coequalizer*)

abbreviation product::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("product") where
"product a b c p1 p2 \<equiv> p1:c\<Rightarrow>a \<and> p2:c\<Rightarrow>b \<and>
                         (\<^bold>\<forall>x f g. (a\<leftarrow>f-(x)-g\<rightarrow>b) \<longrightarrow>
                           (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))"

abbreviation coproduct::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("coproduct") where
"coproduct a b c p1 p2 \<equiv> p1:a\<Rightarrow>c \<and> p2:b\<Rightarrow>c \<and>
                          (\<^bold>\<forall>x f g. (a-f\<rightarrow>(x)\<leftarrow>g-b) \<longrightarrow>
                           (\<^bold>\<exists>!h. h:c\<rightarrow>x \<and> f \<simeq> h\<cdot>p1 \<and> g \<simeq> h\<cdot>p2))"

abbreviation isPullback ("pullback") where
  "pullback g p q f \<equiv> commSquare g p q f \<and>
                        (\<^bold>\<forall>\<beta> \<gamma>. (dom f)\<leftarrow>\<beta>-(dom \<beta>)-\<gamma>\<rightarrow>(dom g) \<and> f\<cdot>\<beta> \<simeq> g\<cdot>\<gamma> \<longrightarrow>
                          (\<^bold>\<exists>!\<delta>. \<delta>:(dom \<beta>)\<rightarrow>(dom p) \<and> q\<cdot>\<delta> \<simeq> \<beta> \<and> p\<cdot>\<delta> \<simeq> \<gamma>))"

abbreviation isPushout ("pushout") where
  "pushout p f g q \<equiv> commSquare g p q f \<and>
                        (\<^bold>\<forall>\<beta> \<gamma>. ((cod g)-\<gamma>\<rightarrow>(cod \<gamma>)\<leftarrow>\<beta>-(cod f)) \<and> \<beta>\<cdot>f \<simeq> \<gamma>\<cdot>g \<longrightarrow>
                          (\<^bold>\<exists>!\<delta>. \<delta>:(cod p)\<rightarrow>(cod \<gamma>) \<and> \<delta>\<cdot>q \<simeq> \<beta> \<and> \<delta>\<cdot>p \<simeq> \<gamma>))"

end

subsection\<open>Functors\<close>

abbreviation isFunctor::"('a::category \<Rightarrow> 'b::category) \<Rightarrow> bool" ("Functor") where
  "isFunctor F \<equiv> (\<forall>x. E x \<longleftrightarrow> E (F x)) \<and>
                  (\<forall>x. type x \<longrightarrow> type (F x)) \<and>
                   (\<forall>x. F (dom x) \<cong> dom (F x)) \<and>
                  (\<^bold>\<forall>x y. E(x\<cdot>y) \<longrightarrow> (F (x\<cdot>y) \<simeq> (F x) \<cdot> (F y)))"

abbreviation isNaturalTransformation::"('c \<Rightarrow> 'd) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('c::category \<Rightarrow> 'd::category) \<Rightarrow> bool" ("natTrans")
  where "natTrans F G \<upsilon> \<equiv> isFunctor F \<and> isFunctor G \<and>
                              (\<^bold>\<forall>f::'c. (\<upsilon> (cod f))\<cdot>(F f) \<simeq> (G f)\<cdot>(\<upsilon> (dom f)))"

section\<open>The product of two categories\<close>

(*axiomatization where productExistence1: "E (x::'a::category\<times>'b::category) \<longleftrightarrow> E (fst x) \<and> E (snd x)"
lemma "True" nitpick[satisfy] oops

instantiation prod :: (category, category) category
begin

lift_definition domain_prod::"'a\<times>'b \<Rightarrow> 'a\<times>'b" is
  "\<lambda>x. (dom (fst x), dom (snd x))" done

lift_definition codomain_prod::"'a\<times>'b \<Rightarrow> 'a\<times>'b" is
  "\<lambda>x. (cod (fst x), cod (snd x))" done

lift_definition composition_prod::"'a\<times>'b \<Rightarrow> 'a\<times>'b \<Rightarrow> 'a\<times>'b" is
  "\<lambda>x y. ((fst x) \<cdot> (fst y), (snd x) \<cdot> (snd y))" done

instance
proof
  show "\<And>x::'a \<times> 'b. E (dom x) \<longrightarrow> E x"
    by (simp add: S1 domain_prod.abs_eq productExistence1)
  show "\<And>y::'a \<times> 'b. E (cod y) \<longrightarrow> E y"
    by (simp add: S2 codomain_prod.rep_eq productExistence1)
  show "\<And>(x::'a \<times> 'b) y::'a \<times> 'b. E (x \<cdot> y) \<longleftrightarrow> dom x \<simeq> cod y"
    by (smt S3 codomain_prod.transfer domain_prod.transfer eq_snd_iff fst_conv productExistence1 sledgeCategoryV3.composition_prod.transfer)
  show "\<And>(x::'a \<times> 'b) (y::'a \<times> 'b) z::'a \<times> 'b. x \<cdot> (y \<cdot> z) \<cong> (x \<cdot> y) \<cdot> z"
    by (smt S4 composition_prod.rep_eq fstI productExistence1 sndI)
  show "\<And>x::'a \<times> 'b. x \<cdot> (dom x) \<cong> x"
    by (simp add: S5 domain_prod.abs_eq productExistence1 sledgeCategoryV3.composition_prod.abs_eq)
  show "\<And>y::'a \<times> 'b. (cod y) \<cdot> y \<cong> y"
    by (simp add: S6 codomain_prod.rep_eq composition_prod.rep_eq productExistence1)
qed

end*)

section\<open>Category with Binary Products\<close>

class productCategory = category +
  fixes product_func::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<^bold>\<times>" 115) and
        p1::"'a \<Rightarrow> 'a" and
        p2::"'a \<Rightarrow> 'a"
  assumes
          prodCat1: "E (a \<^bold>\<times> b) \<longrightarrow> (E a \<and> E b)" and
          prodCat2: "E (p1 a) \<longrightarrow> (E a)" and
          prodCat3: "E (p2 b) \<longrightarrow> (E b)" and
          prodCat4: "typeE a \<and> typeE b \<longrightarrow> product a b (a \<^bold>\<times> b) (p1 (a \<^bold>\<times> b)) (p2 (a \<^bold>\<times> b))" and
          prodCat5: "commSquare a (p1 ((dom a) \<^bold>\<times> (dom b))) (a \<^bold>\<times> b) (p1 ((cod a) \<^bold>\<times> (cod b)))" and
          prodCat6: "commSquare b (p2 ((dom a) \<^bold>\<times> (dom b))) (a \<^bold>\<times> b) (p2 ((cod a) \<^bold>\<times> (cod b)))"

begin
lemma "True" nitpick[satisfy] oops
lemma "\<exists>x::'a. E x" nitpick[satisfy] oops

lemmas prodCatAx = catAx prodCat1 prodCat2 prodCat3 prodCat4 prodCat5 prodCat6
lemmas prodCatAxPure = prodCat1 prodCat2 prodCat3 prodCat4 prodCat5 prodCat6

\<comment> \<open>We can decide about the domain of p1 in any case\<close>
lemma "((dom a) \<^bold>\<times> (dom b)) \<cong> dom (p1 ((dom a) \<^bold>\<times> (dom b)))"
  by (metis S1 S3 S5 S6 prodCat1 prodCat4 prodCat2)

\<comment> \<open>This is not true for the codomain: The reason is that (dom a) might exist even though (dom a \<times> dom b) does not.\<close>
lemma "(dom a) \<cong> cod (p1 ((dom a) \<^bold>\<times> (dom b)))" oops

lemma "type A" oops

lemma "(typeE a \<and> typeE b) \<longrightarrow> typeE (a \<^bold>\<times> b)"
  by (metis local.S3 local.S5 local.S6 local.prodCat4)

lemma "\<^bold>\<forall>a b. typeE a \<and> typeE b \<longrightarrow> (\<^bold>\<exists>p1 p2. product a b (a \<^bold>\<times> b) p1 p2)" (*sledgehammer (S2 S3 S5 catProd2 catProd1 catProd4 catProd3)*)
  by (smt S2 prodCat4)

end

section\<open>Cartesian Category\<close>

class cartesianCategory = productCategory +
  fixes equalizer::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<doteq>" 120) and
        finalObject::"'a" ("\<^bold>1") and
        finalMap::"'a \<Rightarrow> 'a" ("!\<^sub>1")
  assumes
        cartesian1: "f:(dom g)\<rightarrow>(cod g) \<longrightarrow> isEqualizer f g (f \<doteq> g)" and
        cartesian2: "final \<^bold>1" and
        cartesian3: "typeE t \<longrightarrow> (!\<^sub>1 t):t\<Rightarrow>\<^bold>1" and
        cartesian4: "E (!\<^sub>1 t) \<longrightarrow> typeE t" and
        cartesian5: "E (f \<doteq> g) \<longrightarrow> f:(dom g)\<rightarrow>(cod g)"
begin
lemma "True" nitpick[satisfy] oops

lemmas cartesianAx = prodCatAx cartesian1 cartesian2 cartesian3 cartesian4 cartesian5
lemmas cartesianAxPure = cartesian1 cartesian2 cartesian3 cartesian4 cartesian5

lemma "(f:(dom g) \<rightarrow> (cod g) \<and> isEqualizer f g e) \<longrightarrow> E e"
  using S2 S3 by blast

lemma "\<not> (E (f \<doteq> g)) \<longrightarrow> \<not> (f:(dom g) \<rightarrow> (cod g))"
  using S2 S3 cartesian1 by blast

lemma "typeE t \<longrightarrow> (!\<^sub>1 t):t\<rightarrow>\<^bold>1"
  using local.cartesian2 local.cartesian3 by auto

(*lemma "type t" sledgehammer (S1 S2 S3 S4 S5 S6 catProd1 catProd2 catProd3 catProd4 catProd5 catProd6 cartesian1 cartesian2 cartesian3 cartesian4 cartesian5)*)

end

section\<open>Cartesian Closed Category\<close>

abbreviation (in productCategory) isExponential:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Exp")
  where "Exp a b c \<epsilon> tp \<equiv> \<epsilon>:(c\<^bold>\<times>a)\<Rightarrow>b \<and> (\<^bold>\<forall>z f. f:(z \<^bold>\<times> a)\<rightarrow>b \<longrightarrow>
                            ((tp f):z\<rightarrow>c) \<and> \<epsilon> \<cdot> ((tp f) \<^bold>\<times> a) \<simeq> f \<and>
                              (\<^bold>\<forall>\<ff>. \<ff>:z\<rightarrow>c \<and> \<epsilon> \<cdot> (\<ff> \<^bold>\<times> a) \<simeq> f \<longrightarrow> \<ff> \<simeq> (tp f)))"

class exponentialCategory = cartesianCategory +
  fixes  exp::"'a \<Rightarrow> 'a \<Rightarrow> 'a" and
         evaluation::"'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<epsilon>") and
         tp::"'a \<Rightarrow> 'a"

  assumes G1: "(typeE a \<and> typeE b) \<longrightarrow> (Exp a b (exp b a) (\<epsilon> a b) tp)" and
          G2: "commSquare f (\<epsilon> (dom f) a) ((exp f a) \<^bold>\<times> a) (\<epsilon> (cod f) a)" and
          G3: "E (exp b a) \<longrightarrow> E b \<and> typeE a" and
          G4: "E (\<epsilon> a b) \<longrightarrow> typeE a \<and> E b" and
          G5: "E (tp a) \<longrightarrow> E a"
begin
lemma "True" nitpick[satisfy] oops

lemmas expCatAx = cartesianAx G1 G2 G3 G4 G5
lemmas expCatAxPure = G1 G2 G3 G4 G5

(*This helps justifing G2*)
lemma expArrow: "(commSquare f (\<epsilon> (dom f) a) ((tp (f\<cdot>(\<epsilon> (dom f) a))) \<^bold>\<times> a) (\<epsilon> (cod f) a))"
  by (smt expCatAx(1) expCatAx(18) expCatAx(19) expCatAx(2) expCatAx(20) expCatAx(22) expCatAx(3) expCatAx(4) expCatAx(6) expCatAx(7))

lemma expArrow2: "\<exists>e. (commSquare f (\<epsilon> (dom f) a) (e \<^bold>\<times> a) (\<epsilon> (cod f) a))" using expArrow by auto

(*proposition "E f \<and> typeE a \<and> E (\<epsilon> a (dom f)) \<and> E (\<epsilon> a (cod f)) \<longrightarrow> (\<^bold>\<exists>!e. (commSquare f (\<epsilon> a (dom f)) (a \<^bold>\<times> e) (\<epsilon> a (cod f))))" sledgehammer(expCatAx expArrow2)

proposition "E f \<and> typeE a \<and> E (\<epsilon> a (dom f)) \<longrightarrow> exp f a \<simeq> (tp (f\<cdot>(\<epsilon> a (dom f))))" *)

end

class topos = exponentialCategory +
  fixes classifier::'a ("\<Omega>") and
        true::'a ("true") and
        characteristicMap::"'a \<Rightarrow> 'a" ("char") and
        diagnalMap::"'a \<Rightarrow> 'a" ("\<Delta>")

  assumes T1: "(E m \<and> monic m) \<longrightarrow>
                (((char m):(cod m)\<rightarrow>\<Omega>) \<and> pullback true (!\<^sub>1 (dom m)) m (char m) \<and>
                  (\<^bold>\<forall>\<Phi>. ((\<Phi>:(cod m)\<rightarrow>\<Omega>) \<and> pullback true (!\<^sub>1 (dom m)) m \<Phi>) \<longrightarrow> \<Phi> \<simeq> (char m)))" and
          T2: "(p1((dom B)\<^bold>\<times>(dom B)))\<cdot>(\<Delta> B) \<cong> (dom B)" and
          T3: "(p2((dom B)\<^bold>\<times>(dom B)))\<cdot>(\<Delta> B) \<cong> (dom B)" and
          T4: "E (char m) \<longrightarrow> E m" and
          T5: "E (\<Delta> B) \<longrightarrow> E B"
begin

lemmas toposAx = expCatAx T1 T2 T3 T4 T5
lemmas toposAxPure = T1 T2 T3 T4 T5

\<comment> \<open>We do not axiomatize the existence of \<Omega> because one existing morphism leads to the desired behaviour. This way the empty topos is possible.\<close>
lemma "(\<exists>x::'a. E x) \<longrightarrow> E \<Omega>" (*sledgehammer (S1 S2 S3 S4 S5 S6 catProd1 catProd2 cartesian1 cartesian2 G1 G2 T1)*)
  by (smt S1 S2 S3 S5 S6 T1 cartesian2)

lemma "true:\<^bold>1\<Rightarrow>\<Omega>" (*sledgehammer(S1 S2 S3 S5 S6 T1 cartesian2 cartesian3)*)
  by (smt S1 S2 S3 S5 S6 T1 cartesian2 cartesian3)

\<comment> \<open>This justifies our skolemization of \<Delta>\<close>
lemma "typeE B \<longrightarrow>  (\<^bold>\<exists>!f. ((p1(B\<^bold>\<times>B))\<cdot>f \<simeq>  B \<and> (p2(B\<^bold>\<times>B))\<cdot>f \<simeq> B))" (*sledgehammer (S1 S2 S3 S4 S5 S6 catProd1 catProd2 catProd3 catProd4 catProd5 catProd6 cartesian1 cartesian2 G1 G2 T1 T2 T3 T4 T5)*)
  by (smt S2 S3 S4 S5 prodCat4)

abbreviation PredicateOfEquality::"'a \<Rightarrow> 'a" ("\<delta>") where
  "\<delta> \<equiv> \<lambda>B. char (\<Delta> B)"

end

end


theory bla
  imports Main
begin

definition bla :: "char \<Rightarrow> bool" where
"bla val = (nat_of_char val \<le> 90)"

declare bla_def [simp]

lemma "\<exists>x::char . bla x = True"
proof -
  {
    assume "\<not>(\<exists>x . bla x = True)"
    hence "\<forall>x . bla x \<noteq> True" by simp
    hence "bla CHR ''A'' \<noteq> True" by (rule allE)
    hence "False " by simp
  }
  thus ?thesis by auto
qed

lemma "\<exists>x::char . bla x "
proof -
  have "bla CHR ''Z''" by simp
  thus "\<exists>x. bla x " by (rule exI)
qed


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

chapter "List Manipulation Functions"

theory List_Lib
imports "~~/src/HOL/Main"
begin

definition list_replace :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_replace list a b \<equiv> map (\<lambda>x. if x = a then b else x) list"

primrec list_replace_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_replace_list [] a list' = []" |
  "list_replace_list (x # xs) a list' = (if x = a then list' @ xs
                           else x # list_replace_list xs a list')"

definition list_swap :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_swap list a b \<equiv> map (\<lambda>x. if x = a then b else if x = b then a else x) list"

primrec list_insert_after :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_insert_after [] a b = []" |
  "list_insert_after (x # xs) a b = (if x = a then x # b # xs
                                     else x # list_insert_after xs a b)"

primrec list_remove :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_remove [] a = []" |
  "list_remove (x # xs) a = (if x = a then (list_remove xs a)
                             else x # (list_remove xs a))"

fun after_in_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a option" where
  "after_in_list [] a = None" |
  "after_in_list [x] a = None" |
  "after_in_list (x # y # xs) a = (if a = x then Some y else after_in_list (y # xs) a)"

lemma zip_take1:
  "zip (take n xs) ys = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemma zip_take2:
  "zip xs (take n ys) = take n (zip xs ys)"
  apply (induct xs arbitrary: n ys)
  apply simp_all
  apply (case_tac n, simp_all)
  apply (case_tac ys, simp_all)
  done

lemmas zip_take = zip_take1 zip_take2

end


(*                                                        *)
(* Formalisation of some typical SOS-proofs.              *)
(*                                                        *)
(* This work was inspired by challenge suggested by Adam  *)
(* Chlipala on the POPLmark mailing list.                 *)
(*                                                        *)
(* We thank Nick Benton for helping us with the           *)
(* termination-proof for evaluation.                      *)
(*                                                        *)
(* The formalisation was done by Julien Narboux and       *)
(* Christian Urban.                                       *)

theory SOS
  imports "../Nominal"
begin

atom_decl name

text \<open>types and terms\<close>
nominal_datatype ty =
    TVar "nat"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
    Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"

lemma fresh_ty:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_nat)

text \<open>Parallel and single substitution.\<close>
fun
  lookup :: "(name\<times>trm) list \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x        = Var x"
| "lookup ((y,e)#\<theta>) x = (if x=y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

lemma lookup_fresh:
  fixes z::"name"
  assumes a: "z\<sharp>\<theta>" and b: "z\<sharp>x"
  shows "z \<sharp>lookup \<theta> x"
using a b
by (induct rule: lookup.induct) (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using assms
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

(* parallel substitution *)

nominal_primrec
  psubst :: "(name\<times>trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_<_>" [95,95] 105)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App e\<^sub>1 e\<^sub>2)> = App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma psubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t::"trm"
  shows "pi\<bullet>(\<theta><t>) = (pi\<bullet>\<theta>)<(pi\<bullet>t)>"
by (nominal_induct t avoiding: \<theta> rule: trm.strong_induct)
   (perm_simp add: fresh_bij lookup_eqvt)+

lemma fresh_psubst:
  fixes z::"name"
  and   t::"trm"
  assumes "z\<sharp>t" and "z\<sharp>\<theta>"
  shows "z\<sharp>(\<theta><t>)"
using assms
by (nominal_induct t avoiding: z \<theta> t rule: trm.strong_induct)
   (auto simp add: abs_fresh lookup_fresh)

lemma psubst_empty[simp]:
  shows "[]<t> = t"
  by (nominal_induct t rule: trm.strong_induct)
     (auto simp add: fresh_list_nil)

text \<open>Single substitution\<close>
abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t\<^sub>1 t\<^sub>2)[y::=t'] = App (t\<^sub>1[y::=t']) (t\<^sub>2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
by (simp_all add: fresh_list_cons fresh_list_nil)

lemma fresh_subst:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

lemma forget:
  assumes a: "x\<sharp>e"
  shows "e[x::=e'] = e"
using a
by (nominal_induct e avoiding: x e' rule: trm.strong_induct)
   (auto simp add: fresh_atm abs_fresh)

lemma psubst_subst_psubst:
  assumes h: "x\<sharp>\<theta>"
  shows "\<theta><e>[x::=e'] = ((x,e')#\<theta>)<e>"
  using h
by (nominal_induct e avoiding: \<theta> x e' rule: trm.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh')

text \<open>Typing Judgements\<close>

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
  v_nil[intro]:  "valid []"
| v_cons[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk> \<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

inductive_cases
  valid_elim[elim]: "valid ((x,T)#\<Gamma>)"

lemma valid_insert:
  assumes a: "valid (\<Delta>@[(x,T)]@\<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)"
using a
by (induct \<Delta>)
   (auto simp add:  fresh_list_append fresh_list_cons elim!: valid_elim)

lemma fresh_set:
  shows "y\<sharp>xs = (\<forall>x\<in>set xs. y\<sharp>x)"
by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

text \<open>Typing Relation\<close>

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
  t_Var[intro]:   "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| t_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> e\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T\<^sub>2"
| t_Lam[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> e : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T\<^sub>1\<rightarrow>T\<^sub>2"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh fresh_ty)

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
using a by (induct) (auto)

lemma t_App_elim:
  assumes a: "\<Gamma> \<turnstile> App t1 t2 : T"
  obtains T' where "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> t2 : T'"
using a
by (cases) (auto simp add: trm.inject)

lemma t_Lam_elim:
  assumes a: "\<Gamma> \<turnstile> Lam [x].t : T" "x\<sharp>\<Gamma>"
  obtains T\<^sub>1 and T\<^sub>2 where "(x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2" and "T=T\<^sub>1\<rightarrow>T\<^sub>2"
using a
by (cases rule: typing.strong_cases [where x="x"])
   (auto simp add: abs_fresh fresh_ty alpha trm.inject)

abbreviation
  "sub_context" :: "(name\<times>ty) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ \<subseteq> _" [55,55] 55)
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>\<^sub>1 \<longrightarrow> (x,T)\<in>set \<Gamma>\<^sub>2"

lemma weakening:
  fixes \<Gamma>\<^sub>1 \<Gamma>\<^sub>2::"(name\<times>ty) list"
  assumes "\<Gamma>\<^sub>1 \<turnstile> e: T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> e: T"
  using assms
proof(nominal_induct \<Gamma>\<^sub>1 e T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  case (t_Lam x \<Gamma>\<^sub>1 T\<^sub>1 t T\<^sub>2 \<Gamma>\<^sub>2)
  have vc: "x\<sharp>\<Gamma>\<^sub>2" by fact
  have ih: "\<lbrakk>valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2); (x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2\<rbrakk> \<Longrightarrow> (x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" by fact
  have "valid \<Gamma>\<^sub>2" by fact
  then have "valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2)" using vc by auto
  moreover
  have "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2" by fact
  then have "(x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2" by simp
  ultimately have "(x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" using ih by simp
  with vc show "\<Gamma>\<^sub>2 \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
qed (auto)

lemma type_substitutivity_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct \<Gamma>\<equiv>"\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: e' \<Delta> rule: typing.strong_induct)
  case (t_Var y T e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" by blast
qed (force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitutivity:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b type_substitutivity_aux[where \<Delta>="[]"]
by (auto)

text \<open>Values\<close>
inductive
  val :: "trm\<Rightarrow>bool"
where
  v_Lam[intro]:   "val (Lam [x].e)"

equivariance val

lemma not_val_App[simp]:
  shows
  "\<not> val (App e\<^sub>1 e\<^sub>2)"
  "\<not> val (Var x)"
  by (auto elim: val.cases)

text \<open>Big-Step Evaluation\<close>

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b_Lam[intro]:   "Lam [x].e \<Down> Lam [x].e"
| b_App[intro]:   "\<lbrakk>x\<sharp>(e\<^sub>1,e\<^sub>2,e'); e\<^sub>1\<Down>Lam [x].e; e\<^sub>2\<Down>e\<^sub>2'; e[x::=e\<^sub>2']\<Down>e'\<rbrakk> \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<Down> e'"

equivariance big

nominal_inductive big
  by (simp_all add: abs_fresh)

lemma big_preserves_fresh:
  fixes x::"name"
  assumes a: "e \<Down> e'" "x\<sharp>e"
  shows "x\<sharp>e'"
  using a by (induct) (auto simp add: abs_fresh fresh_subst)

lemma b_App_elim:
  assumes a: "App e\<^sub>1 e\<^sub>2 \<Down> e'" "x\<sharp>(e\<^sub>1,e\<^sub>2,e')"
  obtains f\<^sub>1 and f\<^sub>2 where "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" "e\<^sub>2 \<Down> f\<^sub>2" "f\<^sub>1[x::=f\<^sub>2] \<Down> e'"
  using a
by (cases rule: big.strong_cases[where x="x" and xa="x"])
   (auto simp add: trm.inject)

lemma subject_reduction:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
proof (nominal_induct avoiding: \<Gamma> arbitrary: T rule: big.strong_induct)
  case (b_App x e\<^sub>1 e\<^sub>2 e' e e\<^sub>2' \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> e\<^sub>1 : T'\<rightarrow>T" and a2: "\<Gamma> \<turnstile> e\<^sub>2 : T'"
    by (cases) (auto simp add: trm.inject)
  have ih1: "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T' \<rightarrow> T" by fact
  have ih2: "\<Gamma> \<turnstile> e\<^sub>2 : T' \<Longrightarrow> \<Gamma> \<turnstile> e\<^sub>2' : T'" by fact
  have ih3: "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T \<Longrightarrow> \<Gamma> \<turnstile> e' : T" by fact
  have "\<Gamma> \<turnstile> Lam [x].e : T'\<rightarrow>T" using ih1 a1 by simp
  then have "((x,T')#\<Gamma>) \<turnstile> e : T" using vc
    by (auto elim: t_Lam_elim simp add: ty.inject)
  moreover
  have "\<Gamma> \<turnstile> e\<^sub>2': T'" using ih2 a2 by simp
  ultimately have "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T" by (simp add: type_substitutivity)
  thus "\<Gamma> \<turnstile> e' : T" using ih3 by simp
qed (blast)

lemma subject_reduction2:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
by (nominal_induct avoiding: \<Gamma> T rule: big.strong_induct)
   (force elim: t_App_elim t_Lam_elim simp add: ty.inject type_substitutivity)+

lemma unicity_of_evaluation:
  assumes a: "e \<Down> e\<^sub>1"
  and     b: "e \<Down> e\<^sub>2"
  shows "e\<^sub>1 = e\<^sub>2"
  using a b
proof (nominal_induct e e\<^sub>1 avoiding: e\<^sub>2 rule: big.strong_induct)
  case (b_Lam x e t\<^sub>2)
  have "Lam [x].e \<Down> t\<^sub>2" by fact
  thus "Lam [x].e = t\<^sub>2" by cases (simp_all add: trm.inject)
next
  case (b_App x e\<^sub>1 e\<^sub>2 e' e\<^sub>1' e\<^sub>2' t\<^sub>2)
  have ih1: "\<And>t. e\<^sub>1 \<Down> t \<Longrightarrow> Lam [x].e\<^sub>1' = t" by fact
  have ih2:"\<And>t. e\<^sub>2 \<Down> t \<Longrightarrow> e\<^sub>2' = t" by fact
  have ih3: "\<And>t. e\<^sub>1'[x::=e\<^sub>2'] \<Down> t \<Longrightarrow> e' = t" by fact
  have app: "App e\<^sub>1 e\<^sub>2 \<Down> t\<^sub>2" by fact
  have vc: "x\<sharp>e\<^sub>1" "x\<sharp>e\<^sub>2" "x\<sharp>t\<^sub>2" by fact+
  then have "x\<sharp>App e\<^sub>1 e\<^sub>2" by auto
  from app vc obtain f\<^sub>1 f\<^sub>2 where x1: "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" and x2: "e\<^sub>2 \<Down> f\<^sub>2" and x3: "f\<^sub>1[x::=f\<^sub>2] \<Down> t\<^sub>2"
    by (auto elim!: b_App_elim)
  then have "Lam [x]. f\<^sub>1 = Lam [x]. e\<^sub>1'" using ih1 by simp
  then
  have "f\<^sub>1 = e\<^sub>1'" by (auto simp add: trm.inject alpha)
  moreover
  have "f\<^sub>2 = e\<^sub>2'" using x2 ih2 by simp
  ultimately have "e\<^sub>1'[x::=e\<^sub>2'] \<Down> t\<^sub>2" using x3 by simp
  thus "e' = t\<^sub>2" using ih3 by simp
qed

lemma reduces_evaluates_to_values:
  assumes h: "t \<Down> t'"
  shows "val t'"
using h by (induct) (auto)

(* Valuation *)

nominal_primrec
  V :: "ty \<Rightarrow> trm set"
where
  "V (TVar x) = {e. val e}"
| "V (T\<^sub>1 \<rightarrow> T\<^sub>2) = {Lam [x].e | x e. \<forall> v \<in> (V T\<^sub>1). \<exists> v'. e[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2}"
  by (rule TrueI)+

lemma V_eqvt:
  fixes pi::"name prm"
  assumes a: "x\<in>V T"
  shows "(pi\<bullet>x)\<in>V T"
using a
apply(nominal_induct T arbitrary: pi x rule: ty.strong_induct)
apply(auto simp add: trm.inject)
apply(simp add: eqvts)
apply(rule_tac x="pi\<bullet>xa" in exI)
apply(rule_tac x="pi\<bullet>e" in exI)
apply(simp)
apply(auto)
apply(drule_tac x="(rev pi)\<bullet>v" in bspec)
apply(force)
apply(auto)
apply(rule_tac x="pi\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="pi" in big.eqvt)
apply(perm_simp add: eqvts)
done

lemma V_arrow_elim_weak:
  assumes h:"u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "u = Lam [a].t" and "\<forall> v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h by (auto)

lemma V_arrow_elim_strong:
  fixes c::"'a::fs_name"
  assumes h: "u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "a\<sharp>c" "u = Lam [a].t" "\<forall>v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h
apply -
apply(erule V_arrow_elim_weak)
apply(subgoal_tac "\<exists>a'::name. a'\<sharp>(a,t,c)") (*A*)
apply(erule exE)
apply(drule_tac x="a'" in meta_spec)
apply(drule_tac x="[(a,a')]\<bullet>t" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: trm.inject alpha fresh_left fresh_prod calc_atm fresh_atm)
apply(perm_simp)
apply(force)
apply(drule meta_mp)
apply(rule ballI)
apply(drule_tac x="[(a,a')]\<bullet>v" in bspec)
apply(simp add: V_eqvt)
apply(auto)
apply(rule_tac x="[(a,a')]\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="[(a,a')]" in big.eqvt)
apply(perm_simp add: eqvts calc_atm)
apply(simp add: V_eqvt)
(*A*)
apply(rule exists_fresh')
apply(simp add: fin_supp)
done

lemma Vs_are_values:
  assumes a: "e \<in> V T"
  shows "val e"
using a by (nominal_induct T arbitrary: e rule: ty.strong_induct) (auto)

lemma values_reduce_to_themselves:
  assumes a: "val v"
  shows "v \<Down> v"
using a by (induct) (auto)

lemma Vs_reduce_to_themselves:
  assumes a: "v \<in> V T"
  shows "v \<Down> v"
using a by (simp add: values_reduce_to_themselves Vs_are_values)

text \<open>'\<theta> maps x to e' asserts that \<theta> substitutes x with e\<close>
abbreviation
  mapsto :: "(name\<times>trm) list \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> bool" ("_ maps _ to _" [55,55,55] 55)
where
 "\<theta> maps x to e \<equiv> (lookup \<theta> x) = e"

abbreviation
  v_closes :: "(name\<times>trm) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ Vcloses _" [55,55] 55)
where
  "\<theta> Vcloses \<Gamma> \<equiv> \<forall>x T. (x,T) \<in> set \<Gamma> \<longrightarrow> (\<exists>v. \<theta> maps x to v \<and> v \<in> V T)"

lemma case_distinction_on_context:
  fixes \<Gamma>::"(name\<times>ty) list"
  assumes asm1: "valid ((m,t)#\<Gamma>)"
  and     asm2: "(n,U) \<in> set ((m,T)#\<Gamma>)"
  shows "(n,U) = (m,T) \<or> ((n,U) \<in> set \<Gamma> \<and> n \<noteq> m)"
proof -
  from asm2 have "(n,U) \<in> set [(m,T)] \<or> (n,U) \<in> set \<Gamma>" by auto
  moreover
  { assume eq: "m=n"
    assume "(n,U) \<in> set \<Gamma>"
    then have "\<not> n\<sharp>\<Gamma>"
      by (induct \<Gamma>) (auto simp add: fresh_list_cons fresh_prod fresh_atm)
    moreover have "m\<sharp>\<Gamma>" using asm1 by auto
    ultimately have False using eq by auto
  }
  ultimately show ?thesis by auto
qed

lemma monotonicity:
  fixes m::"name"
  fixes \<theta>::"(name \<times> trm) list"
  assumes h1: "\<theta> Vcloses \<Gamma>"
  and     h2: "e \<in> V T"
  and     h3: "valid ((x,T)#\<Gamma>)"
  shows "(x,e)#\<theta> Vcloses (x,T)#\<Gamma>"
proof(intro strip)
  fix x' T'
  assume "(x',T') \<in> set ((x,T)#\<Gamma>)"
  then have "((x',T')=(x,T)) \<or> ((x',T')\<in>set \<Gamma> \<and> x'\<noteq>x)" using h3
    by (rule_tac case_distinction_on_context)
  moreover
  { (* first case *)
    assume "(x',T') = (x,T)"
    then have "\<exists>e'. ((x,e)#\<theta>) maps x to e' \<and> e' \<in> V T'" using h2 by auto
  }
  moreover
  { (* second case *)
    assume "(x',T') \<in> set \<Gamma>" and neq:"x' \<noteq> x"
      then have "\<exists>e'. \<theta> maps x' to e' \<and> e' \<in> V T'" using h1 by auto
      then have "\<exists>e'. ((x,e)#\<theta>) maps x' to e' \<and> e' \<in> V T'" using neq by auto
  }
  ultimately show "\<exists>e'.  ((x,e)#\<theta>) maps x' to e'  \<and> e' \<in> V T'" by blast
qed

lemma termination_aux:
  assumes h1: "\<Gamma> \<turnstile> e : T"
  and     h2: "\<theta> Vcloses \<Gamma>"
  shows "\<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T"
using h2 h1
proof(nominal_induct e avoiding: \<Gamma> \<theta> arbitrary: T rule: trm.strong_induct)
  case (App e\<^sub>1 e\<^sub>2 \<Gamma> \<theta> T)
  have ih\<^sub>1: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>1 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>1> \<Down> v \<and> v \<in> V T" by fact
  have ih\<^sub>2: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>2 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>2> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> e\<^sub>2 : T'" by (auto elim: t_App_elim)
  then obtain v\<^sub>1 v\<^sub>2 where "(i)": "\<theta><e\<^sub>1> \<Down> v\<^sub>1" "v\<^sub>1 \<in> V (T' \<rightarrow> T)"
                      and "(ii)": "\<theta><e\<^sub>2> \<Down> v\<^sub>2" "v\<^sub>2 \<in> V T'" using ih\<^sub>1 ih\<^sub>2 as\<^sub>1 by blast
  from "(i)" obtain x e'
            where "v\<^sub>1 = Lam [x].e'"
            and "(iii)": "(\<forall>v \<in> (V T').\<exists> v'. e'[x::=v] \<Down> v' \<and> v' \<in> V T)"
            and "(iv)":  "\<theta><e\<^sub>1> \<Down> Lam [x].e'"
            and fr: "x\<sharp>(\<theta>,e\<^sub>1,e\<^sub>2)" by (blast elim: V_arrow_elim_strong)
  from fr have fr\<^sub>1: "x\<sharp>\<theta><e\<^sub>1>" and fr\<^sub>2: "x\<sharp>\<theta><e\<^sub>2>" by (simp_all add: fresh_psubst)
  from "(ii)" "(iii)" obtain v\<^sub>3 where "(v)": "e'[x::=v\<^sub>2] \<Down> v\<^sub>3" "v\<^sub>3 \<in> V T" by auto
  from fr\<^sub>2 "(ii)" have "x\<sharp>v\<^sub>2" by (simp add: big_preserves_fresh)
  then have "x\<sharp>e'[x::=v\<^sub>2]" by (simp add: fresh_subst)
  then have fr\<^sub>3: "x\<sharp>v\<^sub>3" using "(v)" by (simp add: big_preserves_fresh)
  from fr\<^sub>1 fr\<^sub>2 fr\<^sub>3 have "x\<sharp>(\<theta><e\<^sub>1>,\<theta><e\<^sub>2>,v\<^sub>3)" by simp
  with "(iv)" "(ii)" "(v)" have "App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>) \<Down> v\<^sub>3" by auto
  then show "\<exists>v. \<theta><App e\<^sub>1 e\<^sub>2> \<Down> v \<and> v \<in> V T" using "(v)" by auto
next
  case (Lam x e \<Gamma> \<theta> T)
  have ih:"\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> Lam [x].e : T" by fact
  have fs: "x\<sharp>\<Gamma>" "x\<sharp>\<theta>" by fact+
  from as\<^sub>2 fs obtain T\<^sub>1 T\<^sub>2
    where "(i)": "(x,T\<^sub>1)#\<Gamma> \<turnstile> e:T\<^sub>2" and "(ii)": "T = T\<^sub>1 \<rightarrow> T\<^sub>2" using fs
    by (auto elim: t_Lam_elim)
  from "(i)" have "(iii)": "valid ((x,T\<^sub>1)#\<Gamma>)" by (simp add: typing_implies_valid)
  have "\<forall>v \<in> (V T\<^sub>1). \<exists>v'. (\<theta><e>)[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
  proof
    fix v
    assume "v \<in> (V T\<^sub>1)"
    with "(iii)" as\<^sub>1 have "(x,v)#\<theta> Vcloses (x,T\<^sub>1)#\<Gamma>" using monotonicity by auto
    with ih "(i)" obtain v' where "((x,v)#\<theta>)<e> \<Down> v' \<and> v' \<in> V T\<^sub>2" by blast
    then have "\<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" using fs by (simp add: psubst_subst_psubst)
    then show "\<exists>v'. \<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" by auto
  qed
  then have "Lam[x].\<theta><e> \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)" by auto
  then have "\<theta><Lam [x].e> \<Down> Lam [x].\<theta><e> \<and> Lam [x].\<theta><e> \<in> V (T\<^sub>1\<rightarrow>T\<^sub>2)" using fs by auto
  thus "\<exists>v. \<theta><Lam [x].e> \<Down> v \<and> v \<in> V T" using "(ii)" by auto
next
  case (Var x \<Gamma> \<theta> T)
  have "\<Gamma> \<turnstile> (Var x) : T" by fact
  then have "(x,T)\<in>set \<Gamma>" by (cases) (auto simp add: trm.inject)
  with Var have "\<theta><Var x> \<Down> \<theta><Var x> \<and> \<theta><Var x>\<in> V T"
    by (auto intro!: Vs_reduce_to_themselves)
  then show "\<exists>v. \<theta><Var x> \<Down> v \<and> v \<in> V T" by auto
qed

theorem termination_of_evaluation:
  assumes a: "[] \<turnstile> e : T"
  shows "\<exists>v. e \<Down> v \<and> val v"
proof -
  from a have "\<exists>v. []<e> \<Down> v \<and> v \<in> V T" by (rule termination_aux) (auto)
  thus "\<exists>v. e \<Down> v \<and> val v" using Vs_are_values by auto
qed

end


section "Splay Tree"

subsection "Basics"

theory Splay_Tree_Analysis_Base
imports
  Lemmas_log
  Splay_Tree.Splay_Tree
begin

declare size1_size[simp]

abbreviation "\<phi> t == log 2 (size1 t)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l a r) = \<phi> (Node l a r) + \<Phi> l + \<Phi> r"

fun T_splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_splay x Leaf = 1" |
"T_splay x (Node AB b CD) =
  (case cmp x b of
   EQ \<Rightarrow> 1 |
   LT \<Rightarrow> (case AB of
          Leaf \<Rightarrow> 1 |
          Node A a B \<Rightarrow>
            (case cmp x a of EQ \<Rightarrow> 1 |
             LT \<Rightarrow> if A = Leaf then 1 else T_splay x A + 1 |
             GT \<Rightarrow> if B = Leaf then 1 else T_splay x B + 1)) |
   GT \<Rightarrow> (case CD of
          Leaf \<Rightarrow> 1 |
          Node C c D \<Rightarrow>
            (case cmp x c of EQ \<Rightarrow> 1 |
             LT \<Rightarrow> if C = Leaf then 1 else T_splay x C + 1 |
             GT \<Rightarrow> if D = Leaf then 1 else T_splay x D + 1)))"

lemma T_splay_simps[simp]:
  "T_splay a (Node l a r) = 1"
  "x<b \<Longrightarrow> T_splay x (Node Leaf b CD) = 1"
  "a<b \<Longrightarrow> T_splay a (Node (Node A a B) b CD) = 1"
  "x<a \<Longrightarrow> x<b \<Longrightarrow> T_splay x (Node (Node A a B) b CD) =
   (if A = Leaf then 1 else T_splay x A + 1)"
  "x<b \<Longrightarrow> a<x \<Longrightarrow> T_splay x (Node (Node A a B) b CD) =
   (if B = Leaf then 1 else T_splay x B + 1)"
  "b<x \<Longrightarrow> T_splay x (Node AB b Leaf) = 1"
  "b<a \<Longrightarrow> T_splay a (Node AB b (Node C a D)) = 1"
  "b<x \<Longrightarrow> x<c \<Longrightarrow> T_splay x (Node AB b (Node C c D)) =
  (if C=Leaf then 1 else T_splay x C + 1)"
  "b<x \<Longrightarrow> c<x \<Longrightarrow> T_splay x (Node AB b (Node C c D)) =
  (if D=Leaf then 1 else T_splay x D + 1)"
by auto

declare T_splay.simps(2)[simp del]

definition T_insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_insert x t = 1 + (if t = Leaf then 0 else T_splay x t)"

fun T_splay_max :: "'a::linorder tree \<Rightarrow> nat" where
"T_splay_max Leaf = 1" |
"T_splay_max (Node A a Leaf) = 1" |
"T_splay_max (Node A a (Node B b C)) = (if C=Leaf then 1 else T_splay_max C + 1)"

definition T_delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_delete x t =
  1 + (if t = Leaf then 0
   else T_splay x t +
     (case splay x t of
        Node l a r \<Rightarrow> if x \<noteq> a then 0 else if l = Leaf then 0 else T_splay_max l))"

lemma ex_in_set_tree: "t \<noteq> Leaf \<Longrightarrow> bst t \<Longrightarrow>
  \<exists>x' \<in> set_tree t. splay x' t = splay x t \<and> T_splay x' t = T_splay x t"
proof(induction x t rule: splay.induct)
  case (6 x b c A)
  hence "splay x A \<noteq> Leaf" by simp
  then obtain A1 u A2 where [simp]: "splay x A = Node A1 u A2"
    by (metis tree.exhaust)
  have "b < c" "bst A" using "6.prems" by auto
  from "6.IH"[OF \<open>A \<noteq> Leaf\<close> \<open>bst A\<close>]
  obtain x' where "x' \<in> set_tree A" "splay x' A = splay x A" "T_splay x' A = T_splay x A"
    by blast
  moreover hence "x'<b" using "6.prems"(2) by auto
  ultimately show ?case using \<open>x<c\<close> \<open>x<b\<close> \<open>b<c\<close> \<open>bst A\<close> by force
next
  case (8 a x c B)
  hence "splay x B \<noteq> Leaf" by simp
  then obtain B1 u B2 where [simp]: "splay x B = Node B1 u B2"
    by (metis tree.exhaust)
  have "a < c" "bst B" using "8.prems" by auto
  from "8.IH"[OF \<open>B \<noteq> Leaf\<close> \<open>bst B\<close>]
  obtain x' where "x' \<in> set_tree B" "splay x' B = splay x B" "T_splay x' B = T_splay x B"
    by blast
  moreover hence "a<x' & x'<c" using "8.prems"(2) by simp
  ultimately show ?case using \<open>x<c\<close> \<open>a<x\<close> \<open>a<c\<close> \<open>bst B\<close> by force
next
  case (11 b x c C)
  hence "splay x C \<noteq> Leaf" by simp
  then obtain C1 u C2 where [simp]: "splay x C = Node C1 u C2"
    by (metis tree.exhaust)
  have "b < c" "bst C" using "11.prems" by auto
  from "11.IH"[OF \<open>C \<noteq> Leaf\<close> \<open>bst C\<close>]
  obtain x' where "x' \<in> set_tree C" "splay x' C = splay x C" "T_splay x' C = T_splay x C"
    by blast
  moreover hence "b<x' & x'<c" using "11.prems" by simp
  ultimately show ?case using \<open>b<x\<close> \<open>x<c\<close> \<open>b<c\<close> \<open>bst C\<close> by force
next
  case (14 a x c D)
  hence "splay x D \<noteq> Leaf" by simp
  then obtain D1 u D2 where [simp]: "splay x D = Node D1 u D2"
    by (metis tree.exhaust)
  have "a < c" "bst D" using "14.prems" by auto
  from "14.IH"[OF \<open>D \<noteq> Leaf\<close> \<open>bst D\<close>]
  obtain x' where "x' \<in> set_tree D" "splay x' D = splay x D" "T_splay x' D = T_splay x D"
    by blast
  moreover hence "c<x'" using "14.prems"(2) by simp
  ultimately show ?case using \<open>a<x\<close> \<open>c<x\<close> \<open>a<c\<close> \<open>bst D\<close> by force
qed (auto simp: le_less)

datatype 'a op = Empty | Splay 'a | Insert 'a | Delete 'a

fun arity :: "'a::linorder op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Splay x) = 1" |
"arity (Insert x) = 1" |
"arity (Delete x) = 1"

fun exec :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec (Splay x) [t] = splay x t" |
"exec (Insert x) [t] = Splay_Tree.insert x t" |
"exec (Delete x) [t] = Splay_Tree.delete x t"

fun cost :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Splay x) [t] = T_splay x t" |
"cost (Insert x) [t] = T_insert x t" |
"cost (Delete x) [t] = T_delete x t"

end


theory Lappend_assoc
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

hipster lappend
lemma lemma_a [thy_expl]: "lappend y LNil = y"
  apply (coinduction  arbitrary: y rule: Lappend_assoc.Llist.coinduct_strong)
by simp

lemma lemma_aa [thy_expl]: "lappend LNil y = y"
apply (coinduction  arbitrary: y rule: Lappend_assoc.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
apply (coinduction  arbitrary: y rule: Lappend_assoc.Llist.coinduct_strong)
apply simp
by (smt Llist.collapse(1) Llist.sel(2) lappend.disc_iff(2) lappend.simps(3) lappend.simps(4))

lemma lemma_ac [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lappend_assoc.Llist.coinduct_strong)
by simp

lemma lemma_ad [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lappend_assoc.Llist.coinduct_strong)
apply simp
by auto

lemma lemma_ae [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
apply (coinduction  arbitrary: y rule: Lappend_assoc.Llist.coinduct_strong)
sledgehammer
apply simp
by fastforce using (Llist.collapse(1) lemma_a)
(*How should this syntax be?*)

theorem  lappend_assoc: "lappend (lappend xs ys) zs = lappend xs (lappend ys zs)"
by (simp add: lemma_ad)
(*by hipster_coinduct_sledgehammer works also*)
end


(* Author: Tobias Nipkow *)

theory Abs_Int0
imports Abs_Int_init
begin

subsection "Orderings"

text{* The basic type classes @{class order}, @{class semilattice_sup} and @{class order_top} are
defined in @{theory Main}, more precisely in theories @{theory Orderings} and @{theory Lattices}.
If you view this theory with jedit, just click on the names to get there. *}

class semilattice_sup_top = semilattice_sup + order_top

instance "fun" :: (type, semilattice_sup_top) semilattice_sup_top ..

instantiation option :: (order)order
begin

fun less_eq_option where
"Some x \<le> Some y = (x \<le> y)" |
"None \<le> y = True" |
"Some _ \<le> None = False"

definition less_option where "x < (y::'a option) = (x \<le> y \<and> \<not> y \<le> x)"

lemma le_None[simp]: "(x \<le> None) = (x = None)"
by (cases x) simp_all

lemma Some_le[simp]: "(Some x \<le> u) = (\<exists>y. u = Some y \<and> x \<le> y)"
by (cases u) auto

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_option_def)
next
  case (2 x) show ?case by(cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, auto)
next
  case (4 x y) thus ?case by(cases y, simp, cases x, auto)
qed

end

instantiation option :: (sup)sup
begin

fun sup_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

lemma sup_None2[simp]: "x \<squnion> None = x"
by (cases x) simp_all

instance ..

end

instantiation option :: (semilattice_sup_top)semilattice_sup_top
begin

definition top_option where "\<top> = Some \<top>"

instance
proof (standard, goal_cases)
  case (4 a) show ?case by(cases a, simp_all add: top_option_def)
next
  case (1 x y) thus ?case by(cases x, simp, cases y, simp_all)
next
  case (2 x y) thus ?case by(cases y, simp, cases x, simp_all)
next
  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
qed

end

instantiation option :: (order)order_bot
begin

definition bot_option :: "'a option" where
"\<bottom> = None"

instance
proof (standard, goal_cases)
  case 1 thus ?case by(auto simp: bot_option_def)
qed

end

definition bot :: "com \<Rightarrow> 'a option acom" where
"bot c = annotate (\<lambda>p. None) c"

lemma bot_least: "strip C = c \<Longrightarrow> bot c \<le> C"
by(auto simp: bot_def less_eq_acom_def)

lemma strip_bot[simp]: "strip(bot c) = c"
by(simp add: bot_def)

subsubsection "Pre-fixpoint iteration"

definition pfp :: "(('a::order) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<le> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<le> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma while_least:
fixes q :: "'a::order"
assumes "\<forall>x\<in>L.\<forall>y\<in>L. x \<le> y \<longrightarrow> f x \<le> f y" and "\<forall>x. x \<in> L \<longrightarrow> f x \<in> L"
and "\<forall>x \<in> L. b \<le> x" and "b \<in> L" and "f q \<le> q" and "q \<in> L"
and "while_option P f b = Some p"
shows "p \<le> q"
using while_option_rule[OF _  assms(7)[unfolded pfp_def],
                        where P = "%x. x \<in> L \<and> x \<le> q"]
by (metis assms(1-6) order_trans)

lemma pfp_bot_least:
assumes "\<forall>x\<in>{C. strip C = c}.\<forall>y\<in>{C. strip C = c}. x \<le> y \<longrightarrow> f x \<le> f y"
and "\<forall>C. C \<in> {C. strip C = c} \<longrightarrow> f C \<in> {C. strip C = c}"
and "f C' \<le> C'" "strip C' = c" "pfp f (bot c) = Some C"
shows "C \<le> C'"
by(rule while_least[OF assms(1,2) _ _ assms(3) _ assms(5)[unfolded pfp_def]])
  (simp_all add: assms(4) bot_least)

lemma pfp_inv:
  "pfp f x = Some y \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P(f x)) \<Longrightarrow> P x \<Longrightarrow> P y"
unfolding pfp_def by (blast intro: while_option_rule)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using pfp_inv[OF assms(2), where P = "%x. g x = g x0"] assms(1) by simp

subsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text{* The interface for abstract values: *}

locale Val_semilattice =
fixes \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<le> b \<Longrightarrow> \<gamma> a \<le> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "val \<Rightarrow> 'av"
and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  assumes gamma_num': "i \<in> \<gamma>(num' i)"
  and gamma_plus': "i1 \<in> \<gamma> a1 \<Longrightarrow> i2 \<in> \<gamma> a2 \<Longrightarrow> i1+i2 \<in> \<gamma>(plus' a1 a2)"

type_synonym 'av st = "(vname \<Rightarrow> 'av)"

text{* The for-clause (here and elsewhere) only serves the purpose of fixing
the name of the type parameter @{typ 'av} which would otherwise be renamed to
@{typ 'a}. *}

locale Abs_Int_fun = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N i) S = num' i" |
"aval' (V x) S = S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

definition "asem x e S = (case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S)))"

definition "step' = Step asem (\<lambda>b S. S)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_fun \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_Top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(simp add: top_fun_def \<gamma>_fun_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f1 \<le> f2 \<Longrightarrow> \<gamma>\<^sub>s f1 \<subseteq> \<gamma>\<^sub>s f2"
by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

text{* Correctness: *}

lemma aval'_correct: "s : \<gamma>\<^sub>s S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)

lemma in_gamma_update: "\<lbrakk> s : \<gamma>\<^sub>s S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>s(S(x := a))"
by(simp add: \<gamma>_fun_def)

lemma gamma_Step_subcomm:
  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"  "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
by (induction C arbitrary: S) (auto simp: mono_gamma_o assms)

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: aval'_correct in_gamma_update asem_def split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  --"transfer the pfp'"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_fun_mono = Abs_Int_fun +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
begin

lemma mono_aval': "S \<le> S' \<Longrightarrow> aval' e S \<le> aval' e S'"
by(induction e)(auto simp: le_fun_def mono_plus')

lemma mono_update: "a \<le> a' \<Longrightarrow> S \<le> S' \<Longrightarrow> S(x := a) \<le> S'(x := a')"
by(simp add: le_fun_def)

lemma mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step)
  (auto simp: mono_update mono_aval' asem_def split: option.split)

lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
by (metis mono_step' order_refl)

lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
shows "C \<le> C'"
by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
  (simp_all add: mono_step'_top)

end

instantiation acom :: (type) vars
begin

definition "vars_acom = vars o strip"

instance ..

end

lemma finite_Cvars: "finite(vars(C::'a acom))"
by(simp add: vars_acom_def)

subsubsection "Termination"

lemma pfp_termination:
fixes x0 :: "'a::order" and m :: "'a \<Rightarrow> nat"
assumes mono: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
and m: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x < y \<Longrightarrow> m x > m y"
and I: "\<And>x y. I x \<Longrightarrow> I(f x)" and "I x0" and "x0 \<le> f x0"
shows "\<exists>x. pfp f x0 = Some x"
proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. I x & x \<le> f x"])
  show "wf {(y,x). ((I x \<and> x \<le> f x) \<and> \<not> f x \<le> x) \<and> y = f x}"
    by(rule wf_subset[OF wf_measure[of m]]) (auto simp: m I)
next
  show "I x0 \<and> x0 \<le> f x0" using `I x0` `x0 \<le> f x0` by blast
next
  fix x assume "I x \<and> x \<le> f x" thus "I(f x) \<and> f x \<le> f(f x)"
    by (blast intro: I mono)
qed

lemma le_iff_le_annos: "C1 \<le> C2 \<longleftrightarrow>
  strip C1 = strip C2 \<and> (\<forall> i<size(annos C1). annos C1 ! i \<le> annos C2 ! i)"
by(simp add: less_eq_acom_def anno_def)

locale Measure1_fun =
fixes m :: "'av::top \<Rightarrow> nat"
fixes h :: "nat"
assumes h: "m x \<le> h"
begin

definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
"m_s S X = (\<Sum> x \<in> X. m(S x))"

lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
by(simp add: m_s_def) (metis mult.commute of_nat_id sum_bounded_above[OF h])

fun m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
"m_o (Some S) X = m_s S X" |
"m_o None X = h * card X + 1"

lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
by(cases opt)(auto simp add: m_s_h le_SucI dest: m_s_h)

definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
"m_c C = sum_list (map (\<lambda>a. m_o a (vars C)) (annos C))"

text{* Upper complexity bound: *}
lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
proof-
  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
    by(simp add: m_c_def sum_list_sum_nth atLeast0LessThan)
  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
    apply(rule sum_mono) using m_o_h[OF finite_Cvars] by simp
  also have "\<dots> = ?a * (h * ?n + 1)" by simp
  finally show ?thesis .
qed

end

locale Measure_fun = Measure1_fun where m=m
  for m :: "'av::semilattice_sup_top \<Rightarrow> nat" +
assumes m2: "x < y \<Longrightarrow> m x > m y"
begin

text{* The predicates @{text "top_on_ty a X"} that follow describe that any abstract
state in @{text a} maps all variables in @{text X} to @{term \<top>}.
This is an important invariant for the termination proof where we argue that only
the finitely many variables in the program change. That the others do not change
follows because they remain @{term \<top>}. *}

fun top_on_st :: "'av st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
"top_on_st S X = (\<forall>x\<in>X. S x = \<top>)"

fun top_on_opt :: "'av st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
"top_on_opt (Some S) X = top_on_st S X" |
"top_on_opt None X = True"

definition top_on_acom :: "'av st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"

lemma top_on_top: "top_on_opt \<top> X"
by(auto simp: top_option_def)

lemma top_on_bot: "top_on_acom (bot c) X"
by(auto simp add: top_on_acom_def bot_def)

lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
by(simp add: top_on_acom_def post_in_annos)

lemma top_on_acom_simps:
  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
by(auto simp add: top_on_acom_def)

lemma top_on_sup:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2) X"
apply(induction o1 o2 rule: sup_option.induct)
apply(auto)
done

lemma top_on_Step: fixes C :: "'av st option acom"
assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
proof(induction C arbitrary: S)
qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)

lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
by(auto simp: le_less m2)

lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
  from assms(2,3,4) have "EX x:X. S1 x < S2 x"
    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
  from sum_strict_mono_ex1[OF `finite X` 1 2]
  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
qed

lemma m_s2: "finite(X) \<Longrightarrow> S1 = S2 on -X \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
apply(auto simp add: less_fun_def m_s_def)
apply(simp add: m_s2_rep le_fun_def)
done

lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (auto simp: m_s2 less_option_def)
next
  case 2 thus ?case by(auto simp: less_option_def le_imp_less_Suc m_s_h)
next
  case 3 thus ?case by (auto simp: less_option_def)
qed

lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
by(auto simp: le_less m_o2)

lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
  let ?X = "vars(strip C2)"
  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
  and strip_eq: "strip C1 = strip C2"
  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
    by (metis (lifting, no_types) finite_cvars m_o1 size_annos_same2)
  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
  hence 2: "\<exists>i < size(annos C2). ?P i" using `i < size(annos C2)` by blast
  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
    apply(rule sum_strict_mono_ex1) using 1 2 by (auto)
  thus ?thesis
    by(simp add: m_c_def vars_acom_def strip_eq sum_list_sum_nth atLeast0LessThan size_annos_same[OF strip_eq])
qed

end

locale Abs_Int_fun_measure =
  Abs_Int_fun_mono where \<gamma>=\<gamma> + Measure_fun where m=m
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
begin

lemma top_on_step': "top_on_acom C (-vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_option_def asem_def split: option.splits)

lemma AI_Some_measure: "\<exists>C. AI c = Some C"
unfolding AI_def
apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
using top_on_step' apply(auto simp add: vars_acom_def)
done

end

text{* Problem: not executable because of the comparison of abstract states,
i.e. functions, in the pre-fixpoint computation. *}

end


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Pratt's Counterexamples\<close>

theory Pratts_Counterexamples
  imports Regular_Algebras
begin

text \<open>We create two regular algebra models due to Pratt~\cite{Pratt} which are used to
        distinguish K1 algebras from K1l and K1r algebras.\<close>

datatype pratt1 =
  P1Bot ("\<bottom>\<^sub>1") |
  P1Nat nat ("[_]\<^sub>1") |
  P1Infty ("\<infinity>\<^sub>1") |
  P1Top ("\<top>\<^sub>1")

datatype pratt2 =
  P2Bot ("\<bottom>\<^sub>2") |
  P2Nat nat ("[_]\<^sub>2") |
  P2Infty ("\<infinity>\<^sub>2") |
  P2Top ("\<top>\<^sub>2")

fun pratt1_max where
  "pratt1_max [x]\<^sub>1 [y]\<^sub>1 = [max x y]\<^sub>1" |
  "pratt1_max x \<bottom>\<^sub>1 = x" |
  "pratt1_max \<bottom>\<^sub>1 y = y" |
  "pratt1_max \<infinity>\<^sub>1 [y]\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max [y]\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max \<infinity>\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max \<top>\<^sub>1 x = \<top>\<^sub>1" |
  "pratt1_max x \<top>\<^sub>1 = \<top>\<^sub>1"

fun pratt1_plus :: "pratt1 \<Rightarrow> pratt1 \<Rightarrow> pratt1" (infixl "+\<^sub>1" 65) where
  "[x]\<^sub>1 +\<^sub>1 [y]\<^sub>1 = [x + y]\<^sub>1" |
  "\<bottom>\<^sub>1 +\<^sub>1 x = \<bottom>\<^sub>1" |
  "x +\<^sub>1 \<bottom>\<^sub>1 = \<bottom>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 [0]\<^sub>1 = \<infinity>\<^sub>1" |
  "[0]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<top>\<^sub>1" | (* Can be adjusted to PInfty *)
  "\<top>\<^sub>1 +\<^sub>1 x = \<top>\<^sub>1" |
  "x +\<^sub>1 \<top>\<^sub>1 = \<top>\<^sub>1" |
  "[x]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 x = \<top>\<^sub>1"

lemma plusl_top_infty: "\<top>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<top>\<^sub>1"
  by (simp)

lemma plusl_infty_top: "\<infinity>\<^sub>1 +\<^sub>1 \<top>\<^sub>1  = \<top>\<^sub>1"
  by (simp)

lemma plusl_bot_infty: "\<bottom>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<bottom>\<^sub>1"
  by (simp)

lemma plusl_infty_bot: "\<infinity>\<^sub>1 +\<^sub>1 \<bottom>\<^sub>1  = \<bottom>\<^sub>1"
  by (simp)

lemma plusl_zero_infty: "[0]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1"
  by (simp)

lemma plusl_infty_zero: "\<infinity>\<^sub>1 +\<^sub>1 [0]\<^sub>1 = \<infinity>\<^sub>1"
  by (simp)

lemma plusl_infty_num [simp]: "x > 0 \<Longrightarrow> \<infinity>\<^sub>1 +\<^sub>1 [x]\<^sub>1 = \<top>\<^sub>1"
  by (case_tac x, simp_all)

lemma plusl_num_infty [simp]: "x > 0 \<Longrightarrow> [x]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1"
  by (case_tac x, simp_all)

fun pratt2_max where
  "pratt2_max [x]\<^sub>2 [y]\<^sub>2 = [max x y]\<^sub>2" |
  "pratt2_max x \<bottom>\<^sub>2 = x" |
  "pratt2_max \<bottom>\<^sub>2 y = y" |
  "pratt2_max \<infinity>\<^sub>2 [y]\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max [y]\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max \<infinity>\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max \<top>\<^sub>2 x = \<top>\<^sub>2" |
  "pratt2_max x \<top>\<^sub>2 = \<top>\<^sub>2"

fun pratt2_plus :: "pratt2 \<Rightarrow> pratt2 \<Rightarrow> pratt2" (infixl "+\<^sub>2" 65) where
  "[x]\<^sub>2 +\<^sub>2 [y]\<^sub>2 = [x + y]\<^sub>2" |
  "\<bottom>\<^sub>2 +\<^sub>2 x = \<bottom>\<^sub>2" |
  "x +\<^sub>2 \<bottom>\<^sub>2 = \<bottom>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 [0]\<^sub>2 = \<infinity>\<^sub>2" |
  "[0]\<^sub>2 +\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 \<infinity>\<^sub>2 = \<top>\<^sub>2" | (* Can be adjusted to PInfty *)
  "\<top>\<^sub>2 +\<^sub>2 x = \<top>\<^sub>2" |
  "x +\<^sub>2 \<top>\<^sub>2 = \<top>\<^sub>2" |
  "x +\<^sub>2 \<infinity>\<^sub>2 = \<top>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 [x]\<^sub>2 = \<infinity>\<^sub>2"

instantiation pratt1 :: selective_semiring
begin

  definition zero_pratt1_def:
    "0 \<equiv> \<bottom>\<^sub>1"

  definition one_pratt1_def:
    "1 \<equiv> [0]\<^sub>1"

  definition plus_pratt1_def:
    "x + y \<equiv> pratt1_max x y"

  definition times_pratt1_def:
    "x * y \<equiv> x +\<^sub>1 y"

  definition less_eq_pratt1_def:
    "(x::pratt1) \<le> y \<equiv> x + y = y"

  definition less_pratt1_def:
    "(x::pratt1) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: pratt1
    show "x + y + z = x + (y + z)"
      by (case_tac x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def)
    show "x + y = y + x"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt1_def)
    show "x * y * z = x * (y * z)"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis nat.exhaust plusl_zero_infty pratt1_plus.simps(14))
      apply (metis not0_implies_Suc plusl_infty_zero plusl_zero_infty pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_plus.simps(15))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_plus.simps(15) pratt1_plus.simps(9))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_plus.simps(15) pratt1_plus.simps(9))
    done
    show "(x + y) * z = x * z + y * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(8))+
    done
    show "1 * x = x"
      by (cases x, simp_all add: one_pratt1_def times_pratt1_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pratt1_def times_pratt1_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pratt1_def zero_pratt1_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pratt1_def zero_pratt1_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pratt1_def zero_pratt1_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pratt1_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pratt1_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt1_def max_def)
    show "x * (y + z) = x * y + x * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis nat.exhaust plusl_zero_infty pratt1_max.simps(7) pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(7))
      apply (metis nat.exhaust plusl_zero_infty pratt1_max.simps(6) pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(6))
      apply (metis neq0_conv plusl_infty_num plusl_infty_zero pratt1_max.simps(10) pratt1_max.simps(8))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_max.simps(11) pratt1_max.simps(13) pratt1_plus.simps(15))
    done
  qed
end

instance pratt1 :: dioid_one_zero ..

instantiation pratt2 :: selective_semiring
begin

  definition zero_pratt2_def:
    "0 \<equiv> \<bottom>\<^sub>2"

  definition one_pratt2_def:
    "1 \<equiv> [0]\<^sub>2"

  definition times_pratt2_def:
    "x * y \<equiv> x +\<^sub>2 y"

  definition plus_pratt2 :: "pratt2 \<Rightarrow> pratt2 \<Rightarrow> pratt2" where
    "plus_pratt2 x y \<equiv> pratt2_max x y"

  definition less_eq_pratt2_def:
    "(x::pratt2) \<le> y \<equiv> x + y = y"

  definition less_pratt2_def:
    "(x::pratt2) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: pratt2
    show "x + y + z = x + (y + z)"
      by (case_tac x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def)
    show "x + y = y + x"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt2_def)
    show "x * y * z = x * (y * z)"
      apply (cases x, case_tac[!] y, case_tac[!] z, auto simp add: times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_plus.simps(14) pratt2_plus.simps(6) pratt2_plus.simps(7) pratt2_plus.simps(9))
      apply (metis not0_implies_Suc pratt2_plus.simps(14) pratt2_plus.simps(15) pratt2_plus.simps(7) pratt2_plus.simps(9))
      apply (metis not0_implies_Suc pratt2_plus.simps(15) pratt2_plus.simps(6))
      apply (metis not0_implies_Suc pratt2_plus.simps(15) pratt2_plus.simps(6))
    done
    show "(x + y) * z = x * z + y * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_max.simps(10) pratt2_max.simps(8) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis max_0L max_0R max.left_idem nat.exhaust pratt2_max.simps(11)
                   pratt2_max.simps(13) pratt2_plus.simps(14) pratt2_plus.simps(7))
    done
    show "1 * x = x"
      by (cases x, simp_all add: one_pratt2_def times_pratt2_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pratt2_def times_pratt2_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pratt2_def zero_pratt2_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pratt2_def zero_pratt2_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pratt2_def zero_pratt2_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pratt2_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pratt2_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt2_def max_def)
    show "x * (y + z) = x * y + x * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_max.simps(12) pratt2_max.simps(7) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis nat.exhaust pratt2_max.simps(12) pratt2_max.simps(7) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis not0_implies_Suc pratt2_max.simps(6) pratt2_max.simps(9) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis nat.exhaust pratt2_max.simps(6) pratt2_max.simps(9) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis not0_implies_Suc pratt2_max.simps(8) pratt2_plus.simps(15) pratt2_plus.simps(6))
      apply (metis not0_implies_Suc pratt2_max.simps(8) pratt2_plus.simps(15) pratt2_plus.simps(6))
    done
  qed
end

lemma top_greatest: "x \<le> \<top>\<^sub>1"
  by (case_tac x, auto simp add: less_eq_pratt1_def plus_pratt1_def)

instantiation pratt1 :: star_op
begin

  definition star_pratt1 where
    "x\<^sup>\<star> \<equiv> if (x = \<bottom>\<^sub>1 \<or> x = [0]\<^sub>1) then [0]\<^sub>1 else \<top>\<^sub>1"
  instance ..
end

instantiation pratt2 :: star_op
begin
  definition star_pratt2 where
    "x\<^sup>\<star> \<equiv> if (x = \<bottom>\<^sub>2 \<or> x = [0]\<^sub>2) then [0]\<^sub>2 else \<top>\<^sub>2"
  instance ..
end

instance pratt1 :: K1r_algebra
proof
  fix x :: pratt1
  show "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
    by  (case_tac x, auto simp add: star_pratt1_def one_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
next
  fix x y :: pratt1
  show "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
    apply (case_tac x, case_tac[!] y)
    apply (auto simp add:star_pratt1_def one_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
    apply (rename_tac n, case_tac n)
    apply (simp_all)
    by (metis not0_implies_Suc plusl_zero_infty pratt1.distinct(7) pratt1_max.simps(6) pratt1_plus.simps(14))
qed

instance pratt2 :: K1l_algebra
proof
  fix x :: pratt2
  show "1 + x\<cdot>x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (case_tac x, auto simp add: star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
next
  fix x y :: pratt2
  show "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
    apply (case_tac x, case_tac[!] y)
    apply (auto simp add:star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
    apply (rename_tac n, case_tac n)
    apply (simp_all)
    apply (rename_tac n, case_tac n)
    apply (auto simp add:star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
  done
qed

lemma one_star_top: "[1]\<^sub>1\<^sup>\<star> = \<top>\<^sub>1"
  by (simp add:star_pratt1_def one_pratt1_def)

lemma pratt1_kozen_1l_counterexample:
  "\<exists> x y :: pratt1. \<not> (x \<cdot> y \<le> y \<and> x\<^sup>\<star> \<cdot> y \<le> y)"
proof -
  have "\<not> ([1]\<^sub>1 \<cdot> \<infinity>\<^sub>1 \<le> \<infinity>\<^sub>1 \<and> [1]\<^sub>1\<^sup>\<star> \<cdot> \<infinity>\<^sub>1 \<le> \<infinity>\<^sub>1)"
    by (auto simp add: star_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
  thus ?thesis
    by auto
qed

lemma pratt2_kozen_1r_counterexample:
  "\<exists> x y :: pratt2. \<not> (y \<cdot> x \<le> y \<and> y \<cdot> x\<^sup>\<star> \<le> y)"
proof -
  have "\<not> (\<infinity>\<^sub>2 \<cdot> [1]\<^sub>2 \<le> \<infinity>\<^sub>2 \<and> \<infinity>\<^sub>2 \<cdot> [1]\<^sub>2\<^sup>\<star> \<le> \<infinity>\<^sub>2)"
    by (auto simp add: star_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
  thus ?thesis
    by auto
qed

end


theory Chisholm_D imports SDL                 (*Christoph Benzmüller & Xavier Parent, 2018*)

begin (* Chisholm Example *)
 consts go::\<sigma> tell::\<sigma> kill::\<sigma>
 axiomatization where
  D1: "\<lfloor>\<^bold>O\<^bold>\<langle>go\<^bold>\<rangle>\<rfloor>" (*It ought to be that Jones goes to assist his neighbors.*) and
  D2: "\<lfloor>go \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  (*It ought to be that if Jones goes, then he tells them he is coming.*) and
  D3: "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" (*If Jones doesn't go, then he ought not tell them he is coming.*) and
  D4: "\<lfloor>\<^bold>\<not>go\<rfloor>\<^sub>c\<^sub>w" (*Jones doesn't go. (This is encoded as a locally valid statement.)*)

 (*Some Experiments*)
  sledgehammer_params [max_facts=20] (*Sets default parameters for the theorem provers*)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (*... and for the model finder.*)

 lemma True  nitpick [satisfy] oops  (*Consistency-check: Is there a model?*)
 lemma False sledgehammer      oops  (*Inconsistency-check: Can Falsum be derived?*)

 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" sledgehammer  nitpick oops   (*Should James not tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>kill\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James kill?*)
end

(*
  D2: "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>|go\<^bold>\<rangle>\<rfloor>" and
  D3: "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>|\<^bold>\<not>go\<^bold>\<rangle>\<rfloor>" and
*)