theory LazyPrelude_Maybe
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"DiffSymDef\",
     \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\", \"TE3\", \"TE4\",
     \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IOE01\", \"IOE02\",
     \"IOE03\", \"IOE04\", \"IOE05\", \"IOE06\", \"IOE07\", \"IOE08\",
     \"IOE09\", \"LeIrreflexivity\", \"LeTAsymmetry\",
     \"LeTTransitive\", \"LeTTotal\", \"GeDef\", \"GeIrreflexivity\",
     \"GeTAsymmetry\", \"GeTTransitive\", \"GeTTotal\", \"LeqDef\",
     \"LeqReflexivity\", \"LeqTTransitive\", \"LeqTTotal\", \"GeqDef\",
     \"GeqReflexivity\", \"GeqTTransitive\", \"GeqTTotal\",
     \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\", \"EqFOrdRel\",
     \"EqTOrdTSubstE\", \"EqTOrdFSubstE\", \"EqTOrdTSubstD\",
     \"EqTOrdFSubstD\", \"LeTGeFEqFRel\", \"LeFGeTEqTRel\",
     \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\", \"LeqFGetFRel\",
     \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\", \"GeqFLeqFRel\",
     \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\", \"GeFLeTEqTRel\",
     \"GeqTLeFRel\", \"GeqFLeTRel\", \"LeqTLeTEqTRel\",
     \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\", \"GeqFGeFEqFRel\",
     \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\", \"CmpLTDef\",
     \"CmpEQDef\", \"CmpGTDef\", \"MaxYDef\", \"MaxXDef\", \"MinXDef\",
     \"MinYDef\", \"MaxSym\", \"MinSym\", \"TO1\", \"TO2\", \"TO3\",
     \"TO4\", \"TO5\", \"TO6\", \"TO7\", \"IUO01\", \"IUO02\",
     \"IUO03\", \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"IOO13\",
     \"IOO14\", \"IOO15\", \"IOO16\", \"IOO17\", \"IOO18\", \"IOO19\",
     \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\", \"IOO24\", \"IOO25\",
     \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\", \"IOO30\", \"IOO31\",
     \"IOO32\", \"IOO33\", \"IBO5\", \"IBO6\", \"IBO7\", \"IBO8\",
     \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\", \"MaybeJustDef\",
     \"MaybeNothingDef\", \"IME01\", \"IME03\", \"IMO01\", \"IMO02\",
     \"IME02\", \"IMO03\", \"IMO04\", \"IMO05\", \"IMO06\", \"IMO07\",
     \"IMO08\", \"IMO09\", \"IMO10\", \"IMO11\", \"IMO12\"]"

typedecl Bool
typedecl ('a1) Maybe
typedecl Unit
typedecl X_Nat

datatype Ordering = EQ | GT | LT

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
Nothing :: "'a Maybe"
X_Just :: "'a partial => 'a Maybe partial" ("Just/'(_')" [3] 999)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a partial => 'a partial => bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a partial => 'a partial => bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a partial => 'a partial => bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a partial => 'a partial => bool" ("(_/ <''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
X_max :: "'a partial => 'a partial => 'a partial"
X_min :: "'a partial => 'a partial => 'a partial"
compare :: "'a partial => 'a partial => Ordering partial"
maybe :: "'b partial => ('a partial => 'b partial) => 'a Maybe partial => 'b partial"
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

AndTrue [rule_format] : "ALL x. True && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH"

NotFalse1 [rule_format] : "ALL x. Not' x = (~ x)"

NotTrue1 [rule_format] : "ALL x. ~ Not' x = x"

notNot1 [rule_format] : "ALL x. (~ x) = Not' x"

notNot2 [rule_format] : "ALL x. (~ ~ x) = (~ Not' x)"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x"

EqualTransT [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y ==' z --> x ==' z"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffFDef [rule_format] : "ALL x. ALL y. (~ x /= y) = x ==' y"

TE1 [rule_format] : "ALL x. ALL y. ~ x ==' y --> ~ x = y"

TE2 [rule_format] : "ALL x. ALL y. Not' (x ==' y) = (~ x ==' y)"

TE3 [rule_format] : "ALL x. ALL y. (~ Not' (x ==' y)) = x ==' y"

TE4 [rule_format] : "ALL x. ALL y. (~ x ==' y) = (~ x ==' y)"

IUE1 [rule_format] : "makePartial () ==' makePartial ()"

IUE2 [rule_format] : "~ makePartial () /= makePartial ()"

IBE1 [rule_format] : "makePartial () ==' makePartial ()"

IBE2 [rule_format] : "undefinedOp ==' undefinedOp"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

IBE4 [rule_format] : "~ makePartial () ==' undefinedOp"

IBE5 [rule_format] : "makePartial () /= undefinedOp"

IBE6 [rule_format] : "undefinedOp /= makePartial ()"

IBE7 [rule_format] : "Not' (makePartial () ==' undefinedOp)"

IBE8 [rule_format] : "~ Not' Not' (makePartial () ==' undefinedOp)"

IOE01 [rule_format] : "makePartial LT ==' makePartial LT"

IOE02 [rule_format] : "makePartial EQ ==' makePartial EQ"

IOE03 [rule_format] : "makePartial GT ==' makePartial GT"

IOE04 [rule_format] : "~ makePartial LT ==' makePartial EQ"

IOE05 [rule_format] : "~ makePartial LT ==' makePartial GT"

IOE06 [rule_format] : "~ makePartial EQ ==' makePartial GT"

IOE07 [rule_format] : "makePartial LT /= makePartial EQ"

IOE08 [rule_format] : "makePartial LT /= makePartial GT"

IOE09 [rule_format] : "makePartial EQ /= makePartial GT"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x <' y"

LeTAsymmetry [rule_format] : "ALL x. ALL y. x <' y --> ~ y <' x"

LeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. x <' y & y <' z --> x <' z"

LeTTotal [rule_format] :
"ALL x. ALL y. (x <' y | y <' x) | x ==' y"

GeDef [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x >' y"

GeTAsymmetry [rule_format] : "ALL x. ALL y. x >' y --> ~ y >' x"

GeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >' y) && (y >' z) --> x >' z"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y)"

LeqDef [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <=' x"

LeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x <=' y) && (y <=' z) --> x <=' z"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >=' x"

GeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >=' y) && (y >=' z) --> x >=' z"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (~ x <' y & ~ x >' y)"

EqFSOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <' y | x >' y)"

EqTOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (x <=' y & x >=' y)"

EqFOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <=' y | x >=' y)"

EqTOrdTSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y <' z --> x <' z"

EqTOrdFSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ y <' z --> ~ x <' z"

EqTOrdTSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & z <' y --> z <' x"

EqTOrdFSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ z <' y --> ~ z <' x"

LeTGeFEqFRel [rule_format] :
"ALL x. ALL y. x <' y = (~ x >' y & ~ x ==' y)"

LeFGeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x <' y) = (x >' y | x ==' y)"

LeTGeTRel [rule_format] : "ALL x. ALL y. x <' y = y >' x"

LeFGeFRel [rule_format] : "ALL x. ALL y. (~ x <' y) = (~ y >' x)"

LeqTGetTRel [rule_format] : "ALL x. ALL y. x <=' y = y >=' x"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ y >=' x)"

GeTLeTRel [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeFLeFRel [rule_format] : "ALL x. ALL y. (~ x >' y) = (~ y <' x)"

GeqTLeqTRel [rule_format] : "ALL x. ALL y. x >=' y = y <=' x"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ y <=' x)"

LeqTGeFRel [rule_format] : "ALL x. ALL y. x <=' y = (~ x >' y)"

LeqFGeTRel [rule_format] : "ALL x. ALL y. (~ x <=' y) = x >' y"

GeTLeFEqFRel [rule_format] :
"ALL x. ALL y. x >' y = (~ x <' y & ~ x ==' y)"

GeFLeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x >' y) = (x <' y | x ==' y)"

GeqTLeFRel [rule_format] : "ALL x. ALL y. x >=' y = (~ x <' y)"

GeqFLeTRel [rule_format] : "ALL x. ALL y. (~ x >=' y) = x <' y"

LeqTLeTEqTRel [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y | x ==' y)"

LeqFLeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ x <' y & ~ x ==' y)"

GeqTGeTEqTRel [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y | x ==' y)"

GeqFGeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ x >' y & ~ x ==' y)"

LeTGeqFRel [rule_format] : "ALL x. ALL y. x <' y = (~ x >=' y)"

GeTLeqFRel [rule_format] : "ALL x. ALL y. x >' y = (~ x <=' y)"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial LT = x <' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial GT = x >' y"

MaxYDef [rule_format] : "ALL x. ALL y. X_max x y ==' y = x <=' y"

MaxXDef [rule_format] : "ALL x. ALL y. X_max x y ==' x = y <=' x"

MinXDef [rule_format] : "ALL x. ALL y. X_min x y ==' x = x <=' y"

MinYDef [rule_format] : "ALL x. ALL y. X_min x y ==' y = y <=' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"

TO1 [rule_format] : "ALL x. ALL y. (x ==' y | x <' y) = x <=' y"

TO2 [rule_format] : "ALL x. ALL y. x ==' y --> ~ x <' y"

TO3 [rule_format] :
"ALL x. ALL y. Not' Not' (x <' y) | Not' (x <' y)"

TO4 [rule_format] : "ALL x. ALL y. x <' y --> Not' (x ==' y)"

TO5 [rule_format] :
"ALL w. ALL x. ALL y. ALL z. (x <' y & y <' z) & z <' w --> x <' w"

TO6 [rule_format] : "ALL x. ALL z. z <' x --> Not' (x <' z)"

TO7 [rule_format] : "ALL x. ALL y. x <' y = y >' x"

IUO01 [rule_format] : "makePartial () <=' makePartial ()"

IUO02 [rule_format] : "~ makePartial () <' makePartial ()"

IUO03 [rule_format] : "makePartial () >=' makePartial ()"

IUO04 [rule_format] : "~ makePartial () >' makePartial ()"

IUO05 [rule_format] :
"X_max (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO06 [rule_format] :
"X_min (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO07 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IOO13 [rule_format] : "makePartial LT <' makePartial EQ"

IOO14 [rule_format] : "makePartial EQ <' makePartial GT"

IOO15 [rule_format] : "makePartial LT <' makePartial GT"

IOO16 [rule_format] : "makePartial LT <=' makePartial EQ"

IOO17 [rule_format] : "makePartial EQ <=' makePartial GT"

IOO18 [rule_format] : "makePartial LT <=' makePartial GT"

IOO19 [rule_format] : "makePartial EQ >=' makePartial LT"

IOO20 [rule_format] : "makePartial GT >=' makePartial EQ"

IOO21 [rule_format] : "makePartial GT >=' makePartial LT"

IOO22 [rule_format] : "makePartial EQ >' makePartial LT"

IOO23 [rule_format] : "makePartial GT >' makePartial EQ"

IOO24 [rule_format] : "makePartial GT >' makePartial LT"

IOO25 [rule_format] :
"X_max (makePartial LT) (makePartial EQ) ==' makePartial EQ"

IOO26 [rule_format] :
"X_max (makePartial EQ) (makePartial GT) ==' makePartial GT"

IOO27 [rule_format] :
"X_max (makePartial LT) (makePartial GT) ==' makePartial GT"

IOO28 [rule_format] :
"X_min (makePartial LT) (makePartial EQ) ==' makePartial LT"

IOO29 [rule_format] :
"X_min (makePartial EQ) (makePartial GT) ==' makePartial EQ"

IOO30 [rule_format] :
"X_min (makePartial LT) (makePartial GT) ==' makePartial LT"

IOO31 [rule_format] :
"compare (makePartial LT) (makePartial LT) ==' makePartial EQ"

IOO32 [rule_format] :
"compare (makePartial EQ) (makePartial EQ) ==' makePartial EQ"

IOO33 [rule_format] :
"compare (makePartial GT) (makePartial GT) ==' makePartial EQ"

IBO5 [rule_format] : "undefinedOp <' makePartial ()"

IBO6 [rule_format] : "~ undefinedOp >=' makePartial ()"

IBO7 [rule_format] : "makePartial () >=' undefinedOp"

IBO8 [rule_format] : "~ makePartial () <' undefinedOp"

IBO9 [rule_format] :
"X_max undefinedOp (makePartial ()) ==' makePartial ()"

IBO10 [rule_format] :
"X_min undefinedOp (makePartial ()) ==' undefinedOp"

IBO11 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IBO12 [rule_format] :
"compare undefinedOp undefinedOp ==' makePartial EQ"

MaybeJustDef [rule_format] :
"ALL f. ALL x. ALL y. maybe y f (Just(x)) = f x"

MaybeNothingDef [rule_format] :
"ALL f. ALL y. maybe y f (makePartial Nothing) = y"

IME01 [rule_format] : "ALL x. ALL y. Just(x) ==' Just(y) = x ==' y"

IME03 [rule_format] : "ALL x. ~ Just(x) ==' makePartial Nothing"

IMO01 [rule_format] : "ALL x. makePartial Nothing <' Just(x)"

IMO02 [rule_format] : "ALL x. ALL y. Just(x) <' Just(y) = x <' y"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IUE1 [simp]
declare IUE2 [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IUO01 [simp]
declare IUO02 [simp]
declare IUO03 [simp]
declare IUO04 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare MaybeJustDef [simp]
declare MaybeNothingDef [simp]
declare IME01 [simp]
declare IME03 [simp]
declare IMO01 [simp]
declare IMO02 [simp]

theorem IME02 : "makePartial Nothing ==' makePartial Nothing"
by (auto)

ML "Header.record \"IME02\""

theorem IMO03 : "ALL x. ~ makePartial Nothing >=' Just(x)"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IMO03\""

theorem IMO04 : "ALL x. Just(x) >=' makePartial Nothing"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IMO04\""

theorem IMO05 : "ALL x. ~ Just(x) <' makePartial Nothing"
by (auto)

ML "Header.record \"IMO05\""

theorem IMO06 :
"ALL x.
 compare (makePartial Nothing) (Just(x)) ==' makePartial EQ =
 makePartial Nothing ==' Just(x)"
by (auto)

ML "Header.record \"IMO06\""

theorem IMO07 :
"ALL x.
 compare (makePartial Nothing) (Just(x)) ==' makePartial LT =
 makePartial Nothing <' Just(x)"
by (auto)

ML "Header.record \"IMO07\""

theorem IMO08 :
"ALL x.
 compare (makePartial Nothing) (Just(x)) ==' makePartial GT =
 makePartial Nothing >' Just(x)"
apply(rule allI)+
apply(simp add: GeDef)
done

ML "Header.record \"IMO08\""

theorem IMO09 :
"ALL x.
 makePartial Nothing <=' Just(x) =
 X_max (makePartial Nothing) (Just(x)) ==' Just(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO09\""

theorem IMO10 :
"ALL x.
 Just(x) <=' makePartial Nothing =
 X_max (makePartial Nothing) (Just(x)) ==' makePartial Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO10\""

theorem IMO11 :
"ALL x.
 makePartial Nothing <=' Just(x) =
 X_min (makePartial Nothing) (Just(x)) ==' makePartial Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO11\""

theorem IMO12 :
"ALL x.
 Just(x) <=' makePartial Nothing =
 X_min (makePartial Nothing) (Just(x)) ==' Just(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO12\""

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Par\<close> as a semicategory\<close>
theory CZH_SMC_Par
  imports
    CZH_DG_Par
    CZH_SMC_Rel
    CZH_SMC_Subsemicategory
begin

subsection\<open>Background\<close>

text\<open>
The methodology chosen for the exposition
of \<open>Par\<close> as a semicategory is analogous to the
one used in the previous chapter for the exposition of \<open>Par\<close> as a digraph.
\<close>

named_theorems smc_Par_cs_simps
named_theorems smc_Par_cs_intros

lemmas (in arr_Par) [smc_Par_cs_simps] =
  dg_Rel_shared_cs_simps

lemmas (in arr_Par) [smc_cs_intros, smc_Par_cs_intros] =
  arr_Par_axioms'

lemmas [smc_Par_cs_simps] =
  dg_Rel_shared_cs_simps
  arr_Par.arr_Par_length
  arr_Par_comp_Par_id_Par_left
  arr_Par_comp_Par_id_Par_right

lemmas [smc_Par_cs_intros] =
  dg_Rel_shared_cs_intros
  arr_Par_comp_Par

subsection\<open>\<open>Par\<close> as a semicategory\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition smc_Par :: "V \<Rightarrow> V"
  where "smc_Par \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Par \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>),
      (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_Par_components:
  shows "smc_Par \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "smc_Par \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Par \<alpha> T}"
    and "smc_Par \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "smc_Par \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
    and "smc_Par \<alpha>\<lparr>Comp\<rparr> = (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_Par_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_smc_Par: "smc_dg (smc_Par \<alpha>) = dg_Par \<alpha>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> (smc_dg (smc_Par \<alpha>)) = 4\<^sub>\<nat>"
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (dg_Par \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_Par_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (smc_dg (smc_Par \<alpha>)) = \<D>\<^sub>\<circ> (dg_Par \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_dg (smc_Par \<alpha>)) \<Longrightarrow> smc_dg (smc_Par \<alpha>)\<lparr>a\<rparr> = dg_Par \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_Par_def dg_Par_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: dg_Par_def smc_dg_def)

lemmas_with [folded smc_dg_smc_Par, unfolded slicing_simps]:
  smc_Par_Obj_iff = dg_Par_Obj_iff
  and smc_Par_Arr_iff[smc_Par_cs_simps] = dg_Par_Arr_iff
  and smc_Par_Dom_vsv[smc_Par_cs_intros] = dg_Par_Dom_vsv
  and smc_Par_Dom_vdomain[smc_Par_cs_simps] = dg_Par_Dom_vdomain
  and smc_Par_Dom_vrange = dg_Par_Dom_vrange
  and smc_Par_Dom_app[smc_Par_cs_simps] = dg_Par_Dom_app
  and smc_Par_Cod_vsv[smc_Par_cs_intros] = dg_Par_Cod_vsv
  and smc_Par_Cod_vdomain[smc_Par_cs_simps] = dg_Par_Cod_vdomain
  and smc_Par_Cod_vrange = dg_Par_Cod_vrange
  and smc_Par_Cod_app[smc_Par_cs_simps] = dg_Par_Cod_app
  and smc_Par_is_arrI = dg_Par_is_arrI
  and smc_Par_is_arrD = dg_Par_is_arrD
  and smc_Par_is_arrE = dg_Par_is_arrE

lemmas [smc_cs_simps] = smc_Par_is_arrD(2,3)

lemmas [smc_Par_cs_intros] = smc_Par_is_arrI

lemmas_with (in \<Z>) [folded smc_dg_smc_Par, unfolded slicing_simps]:
  smc_Par_Hom_vifunion_in_Vset = dg_Par_Hom_vifunion_in_Vset
  and smc_Par_incl_Par_is_arr = dg_Par_incl_Par_is_arr
  and smc_Par_incl_Par_is_arr'[smc_Par_cs_intros] = dg_Par_incl_Par_is_arr'

lemmas [smc_Par_cs_intros] = \<Z>.smc_Par_incl_Par_is_arr'

subsubsection\<open>Composable arrows\<close>

lemma smc_Par_composable_arrs_dg_Par:
  "composable_arrs (dg_Par \<alpha>) = composable_arrs (smc_Par \<alpha>)"
  unfolding composable_arrs_def smc_dg_smc_Par[symmetric] slicing_simps by simp

lemma smc_Par_Comp:
  "smc_Par \<alpha>\<lparr>Comp\<rparr> = (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (smc_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_Par_components smc_Par_composable_arrs_dg_Par ..

subsubsection\<open>Composition\<close>

lemma smc_Par_Comp_app[smc_Par_cs_simps]:
  assumes "S : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C" and "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
  shows "S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = S \<circ>\<^sub>R\<^sub>e\<^sub>l T"
proof-
  from assms have "[S, T]\<^sub>\<circ> \<in>\<^sub>\<circ> composable_arrs (smc_Par \<alpha>)"
    by (auto simp: smc_cs_intros)
  then show "S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = S \<circ>\<^sub>R\<^sub>e\<^sub>l T"
    unfolding smc_Par_Comp by (simp add: nat_omega_simps)
qed

lemma smc_Par_Comp_vdomain: "\<D>\<^sub>\<circ> (smc_Par \<alpha>\<lparr>Comp\<rparr>) = composable_arrs (smc_Par \<alpha>)"
  unfolding smc_Par_Comp by simp

lemma (in \<Z>) smc_Par_Comp_vrange: "\<R>\<^sub>\<circ> (smc_Par \<alpha>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> set {T. arr_Par \<alpha> T}"
proof(rule vsubsetI)
  interpret digraph \<alpha> \<open>smc_dg (smc_Par \<alpha>)\<close>
    unfolding smc_dg_smc_Par by (simp add: digraph_dg_Par)
  fix R assume "R \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (smc_Par \<alpha>\<lparr>Comp\<rparr>)"
  then obtain ST
    where R_def: "R = smc_Par \<alpha>\<lparr>Comp\<rparr>\<lparr>ST\<rparr>"
      and "ST \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_Par \<alpha>\<lparr>Comp\<rparr>)"
    unfolding smc_Par_components by (blast dest: rel_VLambda.vrange_atD)
  then obtain S T A B C
    where "ST = [S, T]\<^sub>\<circ>"
      and S: "S : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C"
      and T: "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    by (auto simp: smc_Par_Comp_vdomain)
  with R_def have R_def': "R = S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T" by simp
  note S_D = dg_is_arrD(1)[unfolded slicing_simps, OF S]
    and T_D = dg_is_arrD(1)[unfolded slicing_simps, OF T]
  from S_D T_D have "arr_Par \<alpha> S" "arr_Par \<alpha> T"
    by (simp_all add: smc_Par_components)
  from this show "R \<in>\<^sub>\<circ> set {T. arr_Par \<alpha> T}"
    unfolding R_def' smc_Par_Comp_app[OF S T] by (auto simp: arr_Par_comp_Par)
qed

subsubsection\<open>\<open>Par\<close> is a semicategory\<close>

lemma (in \<Z>) semicategory_smc_Par: "semicategory \<alpha> (smc_Par \<alpha>)"
proof(intro semicategoryI, unfold smc_dg_smc_Par)
  show "vfsequence (smc_Par \<alpha>)" unfolding smc_Par_def by simp
  show "vcard (smc_Par \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_Par_def by (simp add: nat_omega_simps)
  show "(GF \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_Par \<alpha>\<lparr>Comp\<rparr>)) \<longleftrightarrow>
    (\<exists>G F B C A. GF = [G, F]\<^sub>\<circ> \<and> G : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C \<and> F : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B)"
    for GF
    unfolding smc_Par_Comp_vdomain by (auto intro: composable_arrsI)
  show [intro]: "G \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> F : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C"
    if "G : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C" and "F : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" for G B C F A
  proof-
    from that have "arr_Par \<alpha> G" "arr_Par \<alpha> F" by (auto elim: smc_Par_is_arrE)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: smc_cs_simps smc_Par_cs_simps
            cs_intro: smc_Par_cs_intros
        )
  qed
  show "H \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> G \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> F = H \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> (G \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> F)"
    if "H : C \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> D"
      and "G : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C"
      and "F : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    for H C D G B F A
  proof-
    from that have "arr_Par \<alpha> H" "arr_Par \<alpha> G" "arr_Par \<alpha> F"
      by (auto simp: smc_Par_is_arrD)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: smc_cs_simps smc_Par_cs_simps
            cs_intro: smc_Par_cs_intros
        )
  qed
qed (auto simp: digraph_dg_Par smc_Par_components)

subsubsection\<open>\<open>Par\<close> is a wide subsemicategory of \<open>Rel\<close>\<close>

lemma (in \<Z>) wide_subsemicategory_smc_Par_smc_Rel:
  "smc_Par \<alpha> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> smc_Rel \<alpha>"
proof-
  interpret Rel: semicategory \<alpha> \<open>smc_Rel \<alpha>\<close> by (rule semicategory_smc_Rel)
  interpret Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)
  show ?thesis
  proof
    (
      intro wide_subsemicategoryI subsemicategoryI,
      unfold smc_dg_smc_Par smc_dg_smc_Rel
    )
    from wide_subdigraph_dg_Par_dg_Rel show wsd:
      "dg_Par \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>" "dg_Par \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
      by auto
    interpret wide_subdigraph \<alpha> \<open>dg_Par \<alpha>\<close> \<open>dg_Rel \<alpha>\<close> by (rule wsd(2))
    show "G \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> F = G \<circ>\<^sub>A\<^bsub>smc_Rel \<alpha>\<^esub> F"
      if "G : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C" and "F : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" for G B C F A
    proof-
      from that have "G : B \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> C" and "F : A \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B"
        by
          (
            cs_concl cs_shallow
              cs_simp: smc_dg_smc_Par[symmetric] cs_intro: slicing_intros
          )+
      then have "G : B \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> C" and "F : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
        by (cs_concl cs_shallow cs_intro: dg_sub_fw_cs_intros)+
      then have "G : B \<mapsto>\<^bsub>smc_Rel \<alpha>\<^esub> C" and "F : A \<mapsto>\<^bsub>smc_Rel \<alpha>\<^esub> B"
        unfolding smc_dg_smc_Rel[symmetric] slicing_simps by simp_all
      from that this show "G \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> F = G \<circ>\<^sub>A\<^bsub>smc_Rel \<alpha>\<^esub> F"
        by (cs_concl cs_shallow cs_simp: smc_Par_cs_simps smc_Rel_cs_simps)
    qed
  qed (auto simp: smc_cs_intros)
qed

subsection\<open>Monic arrow and epic arrow\<close>

lemma smc_Par_is_monic_arrI[intro]:
  assumes "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" and "v11 (T\<lparr>ArrVal\<rparr>)" and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
  shows "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Par \<alpha>\<^esub> B"
proof(intro is_monic_arrI)

  interpret T: arr_Par \<alpha> T by (intro smc_Par_is_arrD(1)[OF assms(1)])
  interpret Par_Rel: wide_subsemicategory \<alpha> \<open>smc_Par \<alpha>\<close> \<open>smc_Rel \<alpha>\<close>
    by (rule T.wide_subsemicategory_smc_Par_smc_Rel)
  interpret v11: v11 \<open>T\<lparr>ArrVal\<rparr>\<close> by (rule assms(2))

  show T: "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" by (rule assms(1))
  fix S R A'
  assume S: "S : A' \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
    and R: "R : A' \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
    and TS_TR: "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S = T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R"
  from assms(3) T Par_Rel.subsemicategory_axioms have "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Rel \<alpha>\<^esub> B"
    by (intro smc_Rel_is_monic_arrI)
      (auto dest: v11.v11_vimage_vpsubset_neq elim!: smc_sub_fw_cs_intros)
  moreover from S Par_Rel.subsemicategory_axioms have "S : A' \<mapsto>\<^bsub>smc_Rel \<alpha>\<^esub> A"
    by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
  moreover from R Par_Rel.subsemicategory_axioms have "R : A' \<mapsto>\<^bsub>smc_Rel \<alpha>\<^esub> A"
    by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)
  moreover from T S R TS_TR Par_Rel.subsemicategory_axioms have
    "T \<circ>\<^sub>A\<^bsub>smc_Rel \<alpha>\<^esub> S = T \<circ>\<^sub>A\<^bsub>smc_Rel \<alpha>\<^esub> R"
    by (auto simp: smc_sub_bw_cs_simps)
  ultimately show "S = R" by (rule is_monic_arrD(2))
qed

lemma smc_Par_is_monic_arrD:
  assumes "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Par \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" and "v11 (T\<lparr>ArrVal\<rparr>)" and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
proof-

  from assms show T: "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" by auto
  interpret T: arr_Par \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    using T by (auto dest: smc_Par_is_arrD)

  show "v11 (T\<lparr>ArrVal\<rparr>)"
  proof(intro v11I)

    show "vsv ((T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>)"
    proof(intro vsvI)

      fix a b c assume "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>" and "\<langle>a, c\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>"

      then have bar: "\<langle>b, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" and car: "\<langle>c, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" by auto
      with T.arr_Rel_ArrVal_vdomain have [intro]: "b \<in>\<^sub>\<circ> A" "c \<in>\<^sub>\<circ> A" by auto

      define R where "R = [set {\<langle>0, b\<rangle>}, set {0}, A]\<^sub>\<circ>"
      define S where "S = [set {\<langle>0, c\<rangle>}, set {0}, A]\<^sub>\<circ>"

      have R_components:
        "R\<lparr>ArrVal\<rparr> = set {\<langle>0, b\<rangle>}" "R\<lparr>ArrDom\<rparr> = set {0}" "R\<lparr>ArrCod\<rparr> = A"
        unfolding R_def by (simp_all add: arr_Rel_components)

      have S_components:
        "S\<lparr>ArrVal\<rparr> = set {\<langle>0, c\<rangle>}" "S\<lparr>ArrDom\<rparr> = set {0}" "S\<lparr>ArrCod\<rparr> = A"
        unfolding S_def by (simp_all add: arr_Rel_components)

      have R: "R : set {0} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par \<alpha> R"
          unfolding R_def
          by (rule T.arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: R_components)

      have S: "S : set {0} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par \<alpha> S"
          unfolding S_def
          by (rule T.arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: S_components)

      have "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R = [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        unfolding smc_Par_Comp_app[OF T R]
      proof
        (
          rule arr_Par_eqI[of \<alpha>],
          unfold comp_Rel_components arr_Rel_components R_components
        )
        from R T show "arr_Par \<alpha> (T \<circ>\<^sub>R\<^sub>e\<^sub>l R)"
          by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
        show "arr_Par \<alpha> [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        proof(rule T.arr_Par_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "\<R>\<^sub>\<circ> (set {\<langle>0, a\<rangle>}) \<subseteq>\<^sub>\<circ> B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset T.Axiom_of_Powers)
        show "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>} = set {\<langle>0, a\<rangle>}"
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from bar show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>}) = set {0}" by auto
          with bar show
            "a' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>}) \<Longrightarrow>
              (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, b\<rangle>})\<lparr>a'\<rparr> = set {\<langle>0, a\<rangle>}\<lparr>a'\<rparr>"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed simp_all

      moreover have "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S = [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        unfolding smc_Par_Comp_app[OF T S]
      proof
        (
          rule arr_Par_eqI[of \<alpha>],
          unfold comp_Rel_components arr_Rel_components S_components
        )
        from T S show "arr_Par \<alpha> (T \<circ>\<^sub>R\<^sub>e\<^sub>l S)"
          by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
        show "arr_Par \<alpha> [set {\<langle>0, a\<rangle>}, set {0}, B]\<^sub>\<circ>"
        proof(rule T.arr_Par_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "\<R>\<^sub>\<circ> (set {\<langle>0, a\<rangle>}) \<subseteq>\<^sub>\<circ> B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset T.Axiom_of_Powers)
        show "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>} = set {\<langle>0, a\<rangle>}"
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from car show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>}) = set {0}" by auto
          with car show "a' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>}) \<Longrightarrow>
            (T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> set {\<langle>0, c\<rangle>})\<lparr>a'\<rparr> = set {\<langle>0, a\<rangle>}\<lparr>a'\<rparr>"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed simp_all
      ultimately have "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R = T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S" by simp
      from assms R S this have "R = S" by blast
      with R_components(1) S_components(1) show "b = c" by simp
    qed auto

  qed auto

  show "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
  proof(intro vsubset_antisym vsubsetI)
    from T.arr_Rel_ArrVal_vdomain show "x \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<Longrightarrow> x \<in>\<^sub>\<circ> A" for x
      by auto
    fix a assume [simp]: "a \<in>\<^sub>\<circ> A" show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    proof(rule ccontr)
      assume a: "a \<notin>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
      define R where "R = [set {\<langle>0, a\<rangle>}, set {0, 1}, A]\<^sub>\<circ>"
      define S where "S = [set {\<langle>1, a\<rangle>}, set {0, 1}, A]\<^sub>\<circ>"
      have R: "R : set {0, 1} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par \<alpha> R"
          unfolding R_def
        proof(rule T.arr_Par_vfsequenceI)
          from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
            by blast
        qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (auto simp: R_def arr_Rel_components)
      have S: "S : set {0, 1} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par \<alpha> S"
          unfolding S_def
        proof(rule T.arr_Par_vfsequenceI)
          from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
            by blast
        qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (auto simp: S_def arr_Rel_components)
      with a have "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> R\<lparr>ArrVal\<rparr> = 0"
        unfolding R_def arr_Rel_components
        by (intro vsubset_antisym vsubsetI) auto
      moreover with a have "T\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> S\<lparr>ArrVal\<rparr> = 0"
        unfolding S_def arr_Rel_components
        by (intro vsubset_antisym vsubsetI) auto
      ultimately have "T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R = T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S"
        using R T S
        by
          (
            intro arr_Par_eqI[of \<alpha> \<open>T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> R\<close> \<open>T \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S\<close>];
            elim smc_Par_is_arrE
          )
          (
            auto simp:
              dg_Par_cs_intros
              smc_Par_Comp_app[OF T R]
              smc_Par_Comp_app[OF T S]
              comp_Rel_components
          )
      from R S this assms have "R = S" by blast
      then show False unfolding R_def S_def by simp
    qed
  qed

qed

lemma smc_Par_is_monic_arr:
  "T : A \<mapsto>\<^sub>m\<^sub>o\<^sub>n\<^bsub>smc_Par \<alpha>\<^esub> B \<longleftrightarrow>
    T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B \<and> v11 (T\<lparr>ArrVal\<rparr>) \<and> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
  by (intro iffI) (auto simp: smc_Par_is_monic_arrD smc_Par_is_monic_arrI)

context
begin

private lemma smc_Par_is_epic_arr_vsubset:
  assumes "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
    and "R : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C"
    and "S : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> C"
    and "R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T"
  shows "R\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> S\<lparr>ArrVal\<rparr>"
proof
  interpret T: arr_Par \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    using assms smc_Par_is_arrD by auto
  interpret R: arr_Par \<alpha> R
    rewrites [simp]: "R\<lparr>ArrDom\<rparr> = B" and [simp]: "R\<lparr>ArrCod\<rparr> = C"
    using assms smc_Par_is_arrD by auto
  from assms(5) have "(R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T)\<lparr>ArrVal\<rparr> = (S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T)\<lparr>ArrVal\<rparr>"
    by simp
  then have eq: "R\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr> = S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
    unfolding
      smc_Par_Comp_app[OF assms(3,1)]
      smc_Par_Comp_app[OF assms(4,1)]
      comp_Rel_components
    by simp
  fix bc assume prems: "bc \<in>\<^sub>\<circ> R\<lparr>ArrVal\<rparr>"
  moreover with R.ArrVal.vbrelation obtain b c where bc_def: "bc = \<langle>b, c\<rangle>" by auto
  ultimately have [simp]: "b \<in>\<^sub>\<circ> B" and "c \<in>\<^sub>\<circ> C"
    using R.arr_Rel_ArrVal_vdomain R.arr_Rel_ArrVal_vrange by auto
  note [intro] = prems[unfolded bc_def]
  have "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)" by (simp add: assms(2))
  then obtain a where ab: "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" by auto
  then have "\<langle>a, c\<rangle> \<in>\<^sub>\<circ> S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" unfolding eq[symmetric] by auto
  then obtain b' where ab': "\<langle>b', c\<rangle> \<in>\<^sub>\<circ> S\<lparr>ArrVal\<rparr>" and "\<langle>a, b'\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
    by clarsimp
  with ab ab' T.vsv T.ArrVal.vsv show "bc \<in>\<^sub>\<circ> S\<lparr>ArrVal\<rparr>" unfolding bc_def by blast
qed

lemma smc_Par_is_epic_arrI:
  assumes "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  shows "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Par \<alpha>\<^esub> B"
  unfolding is_epic_arr_def
proof
  (
    intro is_monic_arrI[
      of \<open>op_smc (smc_Par \<alpha>)\<close>, unfolded smc_op_simps, OF assms(1)
      ]
  )

  interpret T: arr_Par \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    using assms smc_Par_is_arrD by auto

  interpret semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule T.semicategory_smc_Par)

  fix R S a
  assume prems:
    "R : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> a"
    "S : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> a"
    "T \<circ>\<^sub>A\<^bsub>op_smc (smc_Par \<alpha>)\<^esub> R = T \<circ>\<^sub>A\<^bsub>op_smc (smc_Par \<alpha>)\<^esub> S"

  from prems(3) have RT_ST: "R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T"
    unfolding
      op_smc_Comp[OF prems(1) assms(1)]
      op_smc_Comp[OF prems(2) assms(1)]
    by simp
  from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(1,2) this]
  have RS: "R\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> S\<lparr>ArrVal\<rparr>".

  from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(2,1) RT_ST[symmetric]]
  have SR: "S\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> R\<lparr>ArrVal\<rparr>".

  from prems show "R = S"
    by (intro arr_Par_eqI[of \<alpha> R S])
      (auto simp: RS SR vsubset_antisym elim!: smc_Par_is_arrE)

qed

lemma smc_Par_is_epic_arrD:
  assumes "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Par \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
proof-

  from assms show T: "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    unfolding is_epic_arr_def by (auto simp: op_smc_is_arr)

  interpret T: arr_Par \<alpha> T
    rewrites [simp]: "T\<lparr>ArrDom\<rparr> = A" and [simp]: "T\<lparr>ArrCod\<rparr> = B"
    using T by (auto elim: smc_Par_is_arrE)

  interpret semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule T.semicategory_smc_Par)

  show "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  proof(intro vsubset_antisym vsubsetI)
    from T.arr_Rel_ArrVal_vrange show "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<Longrightarrow> y \<in>\<^sub>\<circ> B" for y
      by auto
    fix b assume [intro]: "b \<in>\<^sub>\<circ> B" show "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    proof(rule ccontr)
      assume prems: "b \<notin>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
      define R where "R = [set {\<langle>b, 0\<rangle>}, B, set {0, 1}]\<^sub>\<circ>"
      define S where "S = [set {\<langle>b, 1\<rangle>}, B, set {0, 1}]\<^sub>\<circ>"
      have R: "R : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> set {0, 1}"
        unfolding R_def
      proof
        (
          intro smc_Par_is_arrI T.arr_Par_vfsequenceI,
          unfold arr_Rel_components
        )
        from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      have S: "S : B \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> set {0, 1}"
        unfolding S_def
      proof
        (
          intro smc_Par_is_arrI T.arr_Par_vfsequenceI,
          unfold arr_Rel_components
        )
        from T.Axiom_of_Infinity vone_in_omega show "set {0, 1} \<in>\<^sub>\<circ> Vset \<alpha>"
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      from prems have "R\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr> = 0"
        unfolding R_def arr_Rel_components
        by (auto intro!: vsubset_antisym vsubsetI)
      moreover from prems have "S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr> = 0"
        unfolding S_def arr_Rel_components
        by (auto intro!: vsubset_antisym vsubsetI)
      ultimately have "R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T = S \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> T"
        unfolding smc_Par_Comp_app[OF R T] smc_Par_Comp_app[OF S T]
        by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
      from is_epic_arrD(2)[OF assms R S this] show False
        unfolding R_def S_def by simp
    qed
  qed

qed

end

lemma smc_Par_is_epic_arr:
  "T : A \<mapsto>\<^sub>e\<^sub>p\<^sub>i\<^bsub>smc_Par \<alpha>\<^esub> B \<longleftrightarrow> T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B \<and> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  by (intro iffI) (simp_all add: smc_Par_is_epic_arrD smc_Par_is_epic_arrI)

subsection\<open>Terminal object, initial object and null object\<close>

lemma (in \<Z>) smc_Par_obj_terminal: "obj_terminal (smc_Par \<alpha>) A \<longleftrightarrow> A = 0"
proof-

  interpret semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)

  have "(\<forall>A\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B) \<longleftrightarrow> B = 0" for B
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "\<forall>A\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"

    then obtain T where "T : 0 \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" by (meson vempty_is_zet)
    then have [simp]: "B \<in>\<^sub>\<circ> Vset \<alpha>" by (fastforce simp: smc_Par_components(1))

    show "B = 0"
    proof(rule ccontr)
      assume "B \<noteq> 0"
      then obtain b where "b \<in>\<^sub>\<circ> B" using trad_foundation by auto
      have "[set {\<langle>0, b\<rangle>}, set {0}, B]\<^sub>\<circ> : set {0} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: \<open>b \<in>\<^sub>\<circ> B\<close> vsubset_vsingleton_leftI)
      moreover have "[0, set {0}, B]\<^sub>\<circ> : set {0} \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: \<open>b \<in>\<^sub>\<circ> B\<close> vsubset_vsingleton_leftI)
      moreover have "[set {\<langle>0, b\<rangle>}, set {0}, B]\<^sub>\<circ> \<noteq> [0, set {0}, B]\<^sub>\<circ>" by simp
      ultimately show False
        by (metis prems smc_is_arrE smc_Par_components(1))
    qed

  next

    fix A assume [simp]: "B = 0" "A \<in>\<^sub>\<circ> Vset \<alpha>"
    show "\<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    proof(intro ex1I [of _ \<open>[0, A, 0]\<^sub>\<circ>\<close>])
      show zAz: "[0, A, 0]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
        by
          (
            intro smc_Par_is_arrI arr_Par_vfsequenceI,
            unfold arr_Rel_components
          )
          simp_all
      show "T = [0, A, 0]\<^sub>\<circ>" if "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" for T
      proof(rule arr_Par_eqI[of \<alpha>], unfold arr_Rel_components)
        interpret arr_Par \<alpha> T using that by (simp add: smc_Par_is_arrD(1))
        from zAz show "arr_Par \<alpha> [0, A, 0]\<^sub>\<circ>" by (auto elim: smc_Par_is_arrE)
        from arr_Par_axioms that show "T\<lparr>ArrVal\<rparr> = 0"
          by (clarsimp simp: vsv.vsv_vrange_vempty smc_Par_is_arrD(3))
      qed (use that in \<open>auto dest: smc_Par_is_arrD\<close>)
    qed

  qed

  then show ?thesis
    apply(intro iffI obj_terminalI)
    subgoal by (metis smc_is_arrD(2) obj_terminalE)
    subgoal by blast
    subgoal by (metis smc_Par_components(1))
    done

qed

lemma (in \<Z>) smc_Par_obj_initial: "obj_initial (smc_Par \<alpha>) A \<longleftrightarrow> A = 0"
proof-

  interpret Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)

  have "(\<forall>B\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B) \<longleftrightarrow> (A = 0)" for A
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "\<forall>B\<in>\<^sub>\<circ>Vset \<alpha>. \<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"

    then obtain T where "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> 0"
      by (meson vempty_is_zet)
    then have [simp]: "A \<in>\<^sub>\<circ> Vset \<alpha>" by (fastforce simp: smc_Par_components(1))

    show "A = 0"
    proof(rule ccontr)
      assume "A \<noteq> 0"
      then obtain a where "a \<in>\<^sub>\<circ> A" using trad_foundation by auto
      have "[set {\<langle>a, 0\<rangle>}, A, set {0}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> set {0}"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: \<open>a \<in>\<^sub>\<circ> A\<close> vsubset_vsingleton_leftI)
      moreover have "[0, A, set {0}]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> set {0}"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: \<open>a \<in>\<^sub>\<circ> A\<close> vsubset_vsingleton_leftI)
      moreover have "[set {\<langle>a, 0\<rangle>}, A, set {0}]\<^sub>\<circ> \<noteq> [0, A, set {0}]\<^sub>\<circ>" by simp
      ultimately show False
        by (metis prems Par.smc_is_arrE smc_Par_components(1))
    qed

  next

    fix B assume prems[simp]: "A = 0" "B \<in>\<^sub>\<circ> Vset \<alpha>"

    show "\<exists>!T. T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    proof(intro ex1I[of _ \<open>[0, 0, B]\<^sub>\<circ>\<close>])
      show zzB: "[0, 0, B]\<^sub>\<circ> : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
        by
          (
            intro smc_Par_is_arrI arr_Par_vfsequenceI,
            unfold arr_Rel_components
          )
          simp_all
      show "T = [0, 0, B]\<^sub>\<circ>" if "T : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B" for T
      proof(rule arr_Par_eqI[of \<alpha>], unfold arr_Rel_components)
        interpret arr_Par \<alpha> T using that by (simp add: smc_Par_is_arrD(1))
        show "arr_Par \<alpha> T" by (rule arr_Par_axioms)
        from zzB show "arr_Par \<alpha> [0, 0, B]\<^sub>\<circ>" by (auto elim: smc_Par_is_arrE)
        from arr_Par_axioms that show "T\<lparr>ArrVal\<rparr> = 0"
          by (elim smc_Par_is_arrE arr_ParE)
            (
              auto
                intro: ArrVal.vsv_vrange_vempty
                simp: ArrVal.vdomain_vrange_is_vempty
            )
      qed (use that in \<open>auto dest: smc_Par_is_arrD\<close>)
    qed
  qed

  then show ?thesis
    unfolding obj_initial_def
    apply(intro iffI obj_terminalI, elim obj_terminalE, unfold smc_op_simps)
    subgoal by (metis smc_Par_components(1))
    subgoal by (simp add: smc_Par_components(1))
    subgoal by (metis smc_Par_components(1))
    done

qed

lemma (in \<Z>) smc_Par_obj_terminal_obj_initial:
  "obj_initial (smc_Par \<alpha>) A \<longleftrightarrow> obj_terminal (smc_Par \<alpha>) A"
  unfolding smc_Par_obj_initial smc_Par_obj_terminal by simp

lemma (in \<Z>) smc_Par_obj_null: "obj_null (smc_Par \<alpha>) A \<longleftrightarrow> A = 0"
  unfolding obj_null_def smc_Par_obj_terminal smc_Par_obj_initial by simp

subsection\<open>Zero arrow\<close>

lemma (in \<Z>) smc_Par_is_zero_arr:
  assumes "A \<in>\<^sub>\<circ> smc_Par \<alpha>\<lparr>Obj\<rparr>" and "B \<in>\<^sub>\<circ> smc_Par \<alpha>\<lparr>Obj\<rparr>"
  shows "T : A \<mapsto>\<^sub>0\<^bsub>smc_Par \<alpha>\<^esub> B \<longleftrightarrow> T = [0, A, B]\<^sub>\<circ>"
proof(intro HOL.ext iffI)
  interpret Par: semicategory \<alpha> \<open>smc_Par \<alpha>\<close> by (rule semicategory_smc_Par)
  fix T A B assume "T : A \<mapsto>\<^sub>0\<^bsub>smc_Par \<alpha>\<^esub> B"
  with smc_Par_is_arrD(1) obtain R S
    where T_def: "T = R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> S"
      and S: "S : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> 0"
      and R: "R : 0 \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    by (auto simp: arr_Par_def \<Z>.smc_Par_obj_initial obj_null_def)
  interpret S: arr_Par \<alpha> S
    rewrites [simp]: "S\<lparr>ArrDom\<rparr> = A" and [simp]: "S\<lparr>ArrCod\<rparr> = 0"
    using S smc_Par_is_arrD by auto
  interpret R: arr_Par \<alpha> R
    rewrites [simp]: "R\<lparr>ArrDom\<rparr> = 0" and [simp]: "R\<lparr>ArrCod\<rparr> = B"
    using R smc_Par_is_arrD by auto
  have S_def: "S = [0, A, 0]\<^sub>\<circ>"
    by
      (
        rule arr_Rel_eqI[of \<alpha>],
        unfold arr_Rel_components,
        insert S.arr_Rel_ArrVal_vrange S.ArrVal.vbrelation_vintersection_vrange
      )
      (
        auto simp:
        S.arr_Rel_axioms
        S.arr_Rel_ArrDom_in_Vset
        arr_Rel_vfsequenceI vbrelationI
      )
  show "T = [0, A, B]\<^sub>\<circ>"
     unfolding T_def smc_Par_Comp_app[OF R S]
     by (rule arr_Rel_eqI[of \<alpha>], unfold comp_Rel_components)
       (
         auto simp:
          \<Z>_axioms
          S_def
          R.arr_Rel_axioms
          S.arr_Rel_axioms
          arr_Rel_comp_Rel
          arr_Rel_components
          R.arr_Rel_ArrCod_in_Vset
          S.arr_Rel_ArrDom_in_Vset
          \<Z>.arr_Rel_vfsequenceI
          vbrelation_vempty
       )
next
  fix T assume prems: "T = [0, A, B]\<^sub>\<circ>"
  let ?S = \<open>[0, A, 0]\<^sub>\<circ>\<close> and ?R = \<open>[0, 0, B]\<^sub>\<circ>\<close>
  have S: "arr_Par \<alpha> ?S" and R: "arr_Par \<alpha> ?R"
    by (all\<open>intro arr_Par_vfsequenceI\<close>)
      (simp_all add: assms[unfolded smc_Par_components])
  have SA0: "?S : A \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> 0"
    by (intro smc_Par_is_arrI) (simp_all add: S arr_Rel_components)
  moreover have R0B: "?R : 0 \<mapsto>\<^bsub>smc_Par \<alpha>\<^esub> B"
    by (intro smc_Par_is_arrI) (simp_all add: R arr_Rel_components)
  moreover have "T = ?R \<circ>\<^sub>A\<^bsub>smc_Par \<alpha>\<^esub> ?S"
    unfolding smc_Par_Comp_app[OF R0B SA0]
  proof
    (
      rule arr_Par_eqI[of \<alpha>],
      unfold comp_Rel_components arr_Rel_components prems
    )
    show "arr_Par \<alpha> [0, A, B]\<^sub>\<circ>"
      unfolding prems
      by (intro arr_Par_vfsequenceI)
        (auto simp: assms[unfolded smc_Par_components])
  qed (use R S in \<open>auto simp: smc_Par_cs_intros\<close>)
  ultimately show "T : A \<mapsto>\<^sub>0\<^bsub>smc_Par \<alpha>\<^esub> B"
    by (simp add: is_zero_arrI smc_Par_obj_null)
qed

text\<open>\newpage\<close>

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                  April 2006               |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_norm
imports CSP_T_law_basic
begin

(*********************************************************
                       ?-div
 *********************************************************)

lemma cspT_input_DIV:
  "? :A -> Pf =T[M,M] (? :A -> Pf [+] DIV) |~| ? a:A -> DIV"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)
done

(*********************************************************
                    !set-!set-div
 *********************************************************)

lemma cspT_Rep_int_choice_sum_set_Ext_pre_choice_DIV:
  "!! c:C .. (!set X:(Xsf c) .. (? a:X -> DIV))
   =T[M1,M2] !set X:(Union {(Xsf c) |c. c : sumset C}) .. (? a:X -> DIV)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
 apply (rule_tac x="Xsf c" in exI)
 apply (force)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
  apply (rule_tac x="c" in bexI)
  apply (force)
  apply (simp)
done

lemma cspT_Rep_int_choice_set_set_Ext_pre_choice_DIV:
  "!set Y:Ys .. (!set X:(Xsf Y) .. (? a:X -> DIV))
   =T[M1,M2] !set X:(Union {(Xsf Y) |Y. Y : Ys}) .. (? a:X -> DIV)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
 apply (rule_tac x="Xsf X" in exI)
 apply (force)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
  apply (rule_tac x="Y" in bexI)
  apply (force)
  apply (simp)
done

lemma cspT_Rep_int_choice_nat_set_Ext_pre_choice_DIV:
  "!nat n:N .. (!set X:(Xsf n) .. (? a:X -> DIV))
   =T[M1,M2] !set X:(Union {(Xsf n) |n. n : N}) .. (? a:X -> DIV)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
 apply (rule_tac x="Xsf n" in exI)
 apply (force)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE bexE disjE)
 apply (simp_all)
  apply (rule_tac x="n" in bexI)
  apply (force)
  apply (simp)
done

lemmas cspT_Rep_int_choice_set_Ext_pre_choice_DIV =
       cspT_Rep_int_choice_sum_set_Ext_pre_choice_DIV
       cspT_Rep_int_choice_set_set_Ext_pre_choice_DIV
       cspT_Rep_int_choice_nat_set_Ext_pre_choice_DIV

(*********************************************************
                      ?-!set-<=
 *********************************************************)

lemma cspT_input_Rep_int_choice_set_subset:
  "[| Xs <= Ys ; ALL Y:Ys. EX X:Xs. X <= Y & Y <= A |] ==>
   ((? :A -> Pf) [+] Q)
   |~| (!set X : Xs .. ? a:X -> DIV)
   =T[M,M]
   ((? :A -> Pf) [+] Q)
   |~| (!set Y : Ys .. ? a:Y -> DIV)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim disjE conjE exE bexE)
 apply (simp_all)
 apply (force)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (elim disjE conjE exE bexE)
 apply (simp_all)
 apply (drule_tac x="X" in bspec, simp)
 apply (force)
done

lemmas cspT_norm = cspT_input_DIV
                   cspT_Rep_int_choice_set_Ext_pre_choice_DIV
                   cspT_input_Rep_int_choice_set_subset

end


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

(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Abstract Separation Logic, Alternative Definition"

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

text {*
  This theory contains an alternative definition of speration algebra,
  following Calcagno et al very closely. While some of the abstract
  development is more algebraic, it is cumbersome to instantiate.
  We only use it to prove equivalence and to give an impression of how
  it would look like.
*}

(* The @{text "++"} notation is a horrible choice, but this theory is
   only intended to show how the development would look like, not to
   actually use it. We remove the notation for map-add so it doesn't
   conflict.
*)
no_notation map_add (infixl "++" 100)

definition
  lift2 :: "('a => 'b => 'c option) \<Rightarrow> 'a option => 'b option => 'c option"
where
  "lift2 f a b \<equiv> case (a,b) of (Some a, Some b) \<Rightarrow> f a b | _ \<Rightarrow> None"

class sep_algebra_alt = zero +
  fixes add :: "'a => 'a => 'a option" (infixr "\<oplus>" 65)

  assumes add_zero [simp]: "x \<oplus> 0 = Some x"
  assumes add_comm: "x \<oplus> y = y \<oplus> x"
  assumes add_assoc: "lift2 add a (lift2 add b c) = lift2 add (lift2 add a b) c"

begin

definition
  disjoint :: "'a => 'a => bool" (infix "##" 60)
where
  "a ## b \<equiv> a \<oplus> b \<noteq> None"

lemma disj_com: "x ## y = y ## x"
  by (auto simp: disjoint_def add_comm)

lemma disj_zero [simp]: "x ## 0"
  by (auto simp: disjoint_def)

lemma disj_zero2 [simp]: "0 ## x"
  by (subst disj_com) simp

lemma add_zero2 [simp]: "0 \<oplus> x = Some x"
  by (subst add_comm) auto

definition
  substate :: "'a => 'a => bool" (infix "\<preceq>" 60) where
  "a \<preceq> b \<equiv> \<exists>c. a \<oplus> c = Some b"

definition
  sep_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "**" 61)
  where
  "P ** Q \<equiv> \<lambda>s. \<exists>p q. p \<oplus> q = Some s \<and> P p \<and> Q q"

definition emp :: "'a \<Rightarrow> bool" ("\<box>") where
  "\<box> \<equiv> \<lambda>s. s = 0"

definition
  sep_impl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>\<^sup>*" 25)
  where
  "P \<longrightarrow>\<^sup>* Q \<equiv> \<lambda>h. \<forall>h' h''. h \<oplus> h' = Some h'' \<and> P h' \<longrightarrow> Q h''"

definition
  "sep_true \<equiv> \<lambda>s. True"

definition
  "sep_false \<equiv> \<lambda>s. False"

abbreviation
  add2 :: "'a option => 'a option => 'a option" (infixr "++" 65)
where
  "add2 == lift2 add"

lemma add2_None [simp]:
  "x ++ None = None"
  by (simp add: lift2_def split: option.splits)

lemma None_add2 [simp]:
  "None ++ x = None"
  by (simp add: lift2_def split: option.splits)

lemma add2_Some_Some:
  "Some x ++ Some y = x \<oplus> y"
  by (simp add: lift2_def)

lemma add2_zero [simp]:
  "Some x ++ Some 0 = Some x"
  by (simp add: add2_Some_Some)

lemma zero_add2 [simp]:
  "Some 0 ++ Some x = Some x"
  by (simp add: add2_Some_Some)

lemma sep_conjE:
  "\<lbrakk> (P ** Q) s; \<And>p q. \<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: sep_conj_def)

lemma sep_conjI:
  "\<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> (P ** Q) s"
  by (auto simp: sep_conj_def)

lemma sep_conj_comI:
  "(P ** Q) s \<Longrightarrow> (Q ** P) s"
  by (auto intro!: sep_conjI elim!: sep_conjE simp: add_comm)

lemma sep_conj_com:
  "P ** Q = Q ** P"
  by (auto intro: sep_conj_comI)

lemma lift_to_add2:
  "\<lbrakk>z \<oplus> q = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> Some z ++ Some x ++ Some y = Some s"
  by (simp add: add2_Some_Some)

lemma lift_to_add2':
  "\<lbrakk>q \<oplus> z = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> (Some x ++ Some y) ++ Some z = Some s"
  by (simp add: add2_Some_Some)

lemma add2_Some:
  "(x ++ Some y = Some z) = (\<exists>x'. x = Some x' \<and> x' \<oplus> y = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma Some_add2:
  "(Some x ++ y = Some z) = (\<exists>y'. y = Some y' \<and> x \<oplus> y' = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma sep_conj_assoc:
  "P ** (Q ** R) = (P ** Q) ** R"
  unfolding sep_conj_def
  apply (rule ext)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) lift_to_add2)
   apply (subst (asm) add_assoc)
   apply (fastforce simp: add2_Some_Some add2_Some)
  apply clarsimp
  apply (drule (1) lift_to_add2')
  apply (subst (asm) add_assoc [symmetric])
  apply (fastforce simp: add2_Some_Some Some_add2)
  done

lemma sep_true[simp]: "sep_true s" by (simp add: sep_true_def)
lemma sep_false[simp]: "\<not>sep_false x" by (simp add: sep_false_def)

lemma sep_conj_sep_true:
  "P s \<Longrightarrow> (P ** sep_true) s"
  by (auto simp: sep_conjI [where q=0])

lemma sep_conj_sep_true':
  "P s \<Longrightarrow> (sep_true ** P) s"
  by (auto simp: sep_conjI [where p=0])

lemma disjoint_submaps_exist:
  "\<exists>h\<^sub>0 h\<^sub>1. h\<^sub>0 \<oplus> h\<^sub>1 = Some h"
  by (rule_tac x=0 in exI, auto)

lemma sep_conj_true[simp]:
  "(sep_true ** sep_true) = sep_true"
  unfolding sep_conj_def
  by (auto intro: disjoint_submaps_exist)

lemma sep_conj_false_right[simp]:
  "(P ** sep_false) = sep_false"
  by (force elim: sep_conjE)

lemma sep_conj_false_left[simp]:
  "(sep_false ** P) = sep_false"
  by (subst sep_conj_com) (rule sep_conj_false_right)

lemma sep_conj_left_com:
  "(P ** (Q ** R)) = (Q ** (P ** R))" (is "?x = ?y")
proof -
  have "?x = ((Q ** R) ** P)" by (simp add: sep_conj_com)
  also have "\<dots> = (Q ** (R ** P))" by (subst sep_conj_assoc, simp)
  finally show ?thesis by (simp add: sep_conj_com)
qed

lemmas sep_conj_ac = sep_conj_com sep_conj_assoc sep_conj_left_com

lemma empty_empty[simp]: "\<box> 0"
  by (simp add: emp_def)

lemma sep_conj_empty[simp]:
  "(P ** \<box>) = P"
  by (simp add: sep_conj_def emp_def)

  lemma sep_conj_empty'[simp]:
  "(\<box> ** P) = P"
  by (subst sep_conj_com, rule sep_conj_empty)

lemma sep_conj_sep_emptyI:
  "P s \<Longrightarrow> (P ** \<box>) s"
  by simp

lemma sep_conj_true_P[simp]:
  "(sep_true ** (sep_true ** P)) = (sep_true ** P)"
  by (simp add: sep_conj_assoc)

lemma sep_conj_disj:
  "((\<lambda>s. P s \<or> Q s) ** R) s = ((P ** R) s \<or> (Q ** R) s)" (is "?x = (?y \<or> ?z)")
  by (auto simp: sep_conj_def)

lemma sep_conj_conj:
  "((\<lambda>s. P s \<and> Q s) ** R) s \<Longrightarrow> (P ** R) s \<and> (Q ** R) s"
  by (force intro: sep_conjI elim!: sep_conjE)

lemma sep_conj_exists1:
  "((\<lambda>s. \<exists>x. P x s) ** Q) s = (\<exists>x. (P x ** Q) s)"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_exists2:
  "(P ** (\<lambda>s. \<exists>x. Q x s)) = (\<lambda>s. (\<exists>x. (P ** Q x) s))"
  by (force intro!: sep_conjI elim!: sep_conjE)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_forall:
  "((\<lambda>s. \<forall>x. P x s) ** Q) s \<Longrightarrow> (P x ** Q) s"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_impl:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> P' s; \<And>s. Q s \<Longrightarrow> Q' s \<rbrakk> \<Longrightarrow> (P' ** Q') s"
  by (erule sep_conjE, auto intro!: sep_conjI)

lemma sep_conj_impl1:
  assumes P: "\<And>s. P s \<Longrightarrow> I s"
  shows "(P ** R) s \<Longrightarrow> (I ** R) s"
  by (auto intro: sep_conj_impl P)

lemma sep_conj_sep_true_left:
  "(P ** Q) s \<Longrightarrow> (sep_true ** Q) s"
  by (erule sep_conj_impl, simp+)

lemma sep_conj_sep_true_right:
  "(P ** Q) s \<Longrightarrow> (P ** sep_true) s"
  by (subst (asm) sep_conj_com, drule sep_conj_sep_true_left,
      simp add: sep_conj_ac)

lemma sep_globalise:
  "\<lbrakk> (P ** R) s; (\<And>s. P s \<Longrightarrow> Q s) \<rbrakk> \<Longrightarrow> (Q ** R) s"
  by (fast elim: sep_conj_impl)

lemma sep_implI:
  assumes a: "\<And>h' h''. \<lbrakk> h \<oplus> h' = Some h''; P h' \<rbrakk> \<Longrightarrow> Q h''"
  shows "(P \<longrightarrow>\<^sup>* Q) h"
  unfolding sep_impl_def by (auto elim: a)

lemma sep_implD:
  "(x \<longrightarrow>\<^sup>* y) h \<Longrightarrow> \<forall>h' h''. h \<oplus> h' = Some h'' \<and> x h' \<longrightarrow> y h''"
  by (force simp: sep_impl_def)

lemma sep_impl_sep_true[simp]:
  "(P \<longrightarrow>\<^sup>* sep_true) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_false[simp]:
  "(sep_false \<longrightarrow>\<^sup>* P) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>\<^sup>* P) s \<Longrightarrow> P s"
  apply (drule sep_implD)
  apply (erule_tac x=0 in allE)
  apply simp
  done

lemma sep_impl_sep_true_false[simp]:
  "(sep_true \<longrightarrow>\<^sup>* sep_false) = sep_false"
  by (force dest: sep_impl_sep_true_P)

lemma sep_conj_sep_impl:
  "\<lbrakk> P s; \<And>s. (P ** Q) s \<Longrightarrow> R s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s"
proof (rule sep_implI)
  fix h' h h''
  assume "P h" and "h \<oplus> h' = Some h''" and "Q h'"
  hence "(P ** Q) h''" by (force intro: sep_conjI)
  moreover assume "\<And>s. (P ** Q) s \<Longrightarrow> R s"
  ultimately show "R h''" by simp
qed

lemma sep_conj_sep_impl2:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s \<rbrakk> \<Longrightarrow> R s"
  by (force dest: sep_implD elim: sep_conjE)

lemma sep_conj_sep_impl_sep_conj2:
  "(P ** R) s \<Longrightarrow> (P ** (Q \<longrightarrow>\<^sup>* (Q ** R))) s"
  by (erule (1) sep_conj_impl, erule sep_conj_sep_impl, simp add: sep_conj_ac)

lemma sep_conj_triv_strip2:
  "Q = R \<Longrightarrow> (Q ** P) = (R ** P)" by simp

end

end


theory ArityAnalysisCorrDenotational
imports ArityAnalysisSpec "../Launchbury/Denotational" ArityTransform
begin

context ArityAnalysisLetSafe
begin

inductive eq :: "Arity \<Rightarrow> Value \<Rightarrow> Value \<Rightarrow> bool" where
   "eq 0 v v"
 |  "(\<And> v. eq n (v1 \<down>Fn v) (v2 \<down>Fn v)) \<Longrightarrow> eq (inc\<cdot>n) v1 v2"

lemma eq_inc_simp:
  "eq (inc\<cdot>n) v1 v2 \<longleftrightarrow> (\<forall> v . eq n (v1 \<down>Fn v) (v2 \<down>Fn v))"
  by (auto elim: eq.cases intro: eq.intros)

lemma eq_FnI:
  "(\<And> v. eq (pred\<cdot>n) (f1\<cdot>v) (f2\<cdot>v)) \<Longrightarrow> eq n (Fn\<cdot>f1) (Fn\<cdot>f2)"
  by (induction n rule: Arity_ind) (auto intro: eq.intros cfun_eqI)

lemma eq_refl[simp]: "eq a v v"
  by (induction a arbitrary: v rule: Arity_ind) (auto intro!: eq.intros)

lemma eq_trans[trans]: "eq a v1 v2 \<Longrightarrow> eq a v2 v3 \<Longrightarrow> eq a v1 v3"
  apply (induction a arbitrary: v1 v2 v3 rule: Arity_ind)
  apply (auto elim!: eq.cases intro!: eq.intros)
  apply blast
  done

lemma eq_Fn: "eq a v1 v2 \<Longrightarrow> eq (pred\<cdot>a) (v1 \<down>Fn v) (v2 \<down>Fn v)"
apply (induction a  rule: Arity_ind[case_names 0 inc])
apply (auto simp add: eq_inc_simp)
done

lemma eq_inc_same: "eq a v1 v2 \<Longrightarrow> eq (inc\<cdot>a) v1 v2"
by (induction a  arbitrary: v1 v2 rule: Arity_ind[case_names 0 inc])  (auto simp add: eq_inc_simp)

lemma eq_mono: "a \<sqsubseteq> a' \<Longrightarrow> eq a' v1 v2 \<Longrightarrow> eq a v1 v2"
proof (induction a  rule: Arity_ind[case_names 0 inc])
  case 0 thus ?case by auto
next
  case (inc a)
  show "eq (inc\<cdot>a) v1 v2"
  proof (cases "inc\<cdot>a = a'")
    case True with inc show ?thesis by simp
  next
    case False with `inc\<cdot>a \<sqsubseteq> a'` have "a \<sqsubseteq> a'"
      by (simp add: inc_def)(transfer, simp)
    from this inc.prems(2)
    have "eq a v1 v2" by (rule inc.IH)
    thus ?thesis by (rule eq_inc_same)
  qed
qed

lemma eq_join[simp]: "eq (a \<squnion> a') v1 v2 \<longleftrightarrow> eq a v1 v2 \<and> eq a' v1 v2"
  using Arity_total[of a a']
  apply (auto elim!: eq_mono[OF join_above1] eq_mono[OF join_above2])
  apply (metis join_self_below(2))
  apply (metis join_self_below(1))
  done

lemma eq_adm: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda> x. eq a (f x) (g x))"
proof (induction a arbitrary: f g rule: Arity_ind[case_names 0 inc])
  case 0 thus ?case by simp
next
  case inc
  show ?case
  apply (subst eq_inc_simp)
  apply (rule adm_all)
  apply (rule inc)
  apply (intro cont2cont inc(2,3))+
  done
qed

inductive eq\<rho> :: "AEnv \<Rightarrow> (var \<Rightarrow> Value) \<Rightarrow> (var \<Rightarrow> Value) \<Rightarrow> bool" where
 eq\<rho>I: "(\<And> x a. ae x = up\<cdot>a \<Longrightarrow> eq a (\<rho>1 x) (\<rho>2 x)) \<Longrightarrow> eq\<rho> ae \<rho>1 \<rho>2"

lemma eq\<rho>E: "eq\<rho> ae \<rho>1 \<rho>2 \<Longrightarrow> ae x = up\<cdot>a \<Longrightarrow> eq a (\<rho>1 x) (\<rho>2 x)"
  by (auto simp add: eq\<rho>.simps)

lemma eq\<rho>_refl[simp]: "eq\<rho> ae \<rho> \<rho>"
  by (simp add: eq\<rho>.simps)

lemma eq_esing_up[simp]: "eq\<rho> (esing x\<cdot>(up\<cdot>a)) \<rho>1 \<rho>2 \<longleftrightarrow> eq a (\<rho>1 x) (\<rho>2 x)"
  by (auto simp add: eq\<rho>.simps)

lemma eq\<rho>_mono:
  assumes "ae \<sqsubseteq> ae'"
  assumes "eq\<rho> ae' \<rho>1 \<rho>2"
  shows "eq\<rho> ae \<rho>1 \<rho>2"
proof (rule eq\<rho>I)
  fix x a
  assume "ae x = up\<cdot>a"
  with `ae \<sqsubseteq> ae'` have "up\<cdot>a \<sqsubseteq> ae' x" by (metis fun_belowD)
  then obtain a' where "ae' x = up\<cdot>a'" by (metis Exh_Up below_antisym minimal)
  with `eq\<rho> ae' \<rho>1 \<rho>2`
  have "eq a' (\<rho>1 x) (\<rho>2 x)" by (auto simp add: eq\<rho>.simps)
  with `up\<cdot>a \<sqsubseteq> ae' x` and `ae' x = up\<cdot>a'`
  show "eq a (\<rho>1 x) (\<rho>2 x)" by (metis eq_mono up_below)
qed

lemma eq\<rho>_adm: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda> x. eq\<rho> a (f x) (g x))"
  apply (simp add: eq\<rho>.simps)
  apply (intro adm_lemmas eq_adm)
  apply (erule cont2cont_fun)+
  done

lemma up_join_eq_up[simp]: "up\<cdot>(n::'a::Finite_Join_cpo) \<squnion> up\<cdot>n' = up\<cdot>(n \<squnion> n')"
  apply (rule lub_is_join)
  apply (auto simp add: is_lub_def )
  apply (case_tac u)
  apply auto
  done

lemma eq\<rho>_join[simp]: "eq\<rho> (ae \<squnion> ae') \<rho>1 \<rho>2 \<longleftrightarrow> eq\<rho> ae \<rho>1 \<rho>2 \<and> eq\<rho> ae' \<rho>1 \<rho>2"
  apply (auto elim!: eq\<rho>_mono[OF join_above1] eq\<rho>_mono[OF join_above2])
  apply (auto intro!: eq\<rho>I)
  apply (case_tac "ae x", auto elim: eq\<rho>E)
  apply (case_tac "ae' x", auto elim: eq\<rho>E)
  done

lemma eq\<rho>_override[simp]:
  "eq\<rho> ae (\<rho>1 ++\<^bsub>S\<^esub> \<rho>2) (\<rho>1' ++\<^bsub>S\<^esub>\<rho>2') \<longleftrightarrow> eq\<rho> ae (\<rho>1 f|` (- S)) (\<rho>1' f|` (- S)) \<and>  eq\<rho> ae (\<rho>2 f|` S) (\<rho>2' f|` S)"
  by (auto simp add: lookup_env_restr_eq eq\<rho>.simps lookup_override_on_eq)

lemma Aexp_heap_below_Aheap:
  assumes "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'"
  assumes "map_of \<Gamma> x = Some e'"
  shows "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a"
proof-
  from assms(1)
  have "Aexp e'\<cdot>a' = ABind x e'\<cdot>(Aheap \<Gamma> e\<cdot>a)"
    by (simp del: join_comm fun_meet_simp)
  also have "\<dots> \<sqsubseteq> ABinds \<Gamma>\<cdot>(Aheap \<Gamma> e\<cdot>a)"
    by (rule monofun_cfun_fun[OF ABind_below_ABinds[OF `map_of _ _ = _`]])
  also have "\<dots> \<sqsubseteq> ABinds \<Gamma>\<cdot>(Aheap \<Gamma> e\<cdot>a) \<squnion>  Aexp e\<cdot>a"
    by simp
  also note Aexp_Let
  finally
  show ?thesis by this simp_all
qed

lemma Aexp_body_below_Aheap:
  shows "Aexp e\<cdot>a \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a"
  by (rule below_trans[OF join_above2 Aexp_Let])

lemma Aexp_correct: "eq\<rho> (Aexp e\<cdot>a) \<rho>1 \<rho>2 \<Longrightarrow> eq a (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>1\<^esub>) (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
proof(induction a e arbitrary: \<rho>1 \<rho>2 rule: transform.induct[case_names App Lam Var Let Bool IfThenElse])
  case (Var a x)
  from `eq\<rho> (Aexp (Var x)\<cdot>a) \<rho>1 \<rho>2`
  have "eq\<rho> (esing x\<cdot>(up\<cdot>a)) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_Var_singleton])
  thus ?case by simp
next
  case (App a e x)
  from `eq\<rho> (Aexp (App e x)\<cdot>a) \<rho>1 \<rho>2`
  have "eq\<rho> (Aexp e\<cdot>(inc\<cdot>a) \<squnion> esing x\<cdot>(up\<cdot>0)) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_App])
  hence "eq\<rho> (Aexp e\<cdot>(inc\<cdot>a)) \<rho>1 \<rho>2" and "\<rho>1 x = \<rho>2 x" by simp_all
  from App(1)[OF this(1)] this(2)
  show ?case by (auto elim: eq.cases)
next
  case (Lam a x e)
  from  `eq\<rho> (Aexp (Lam [x]. e)\<cdot>a) \<rho>1 \<rho>2`
  have "eq\<rho> (env_delete x (Aexp e\<cdot>(pred\<cdot>a))) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_Lam])
  hence "\<And> v. eq\<rho> (Aexp e\<cdot>(pred\<cdot>a)) (\<rho>1(x := v)) (\<rho>2(x := v))"  by (auto intro!: eq\<rho>I elim!: eq\<rho>E)
  from Lam(1)[OF this]
  show ?case by (auto intro: eq_FnI simp del: fun_upd_apply)
next
  case (Bool b)
  show ?case by simp
next
  case (IfThenElse a scrut e\<^sub>1 e\<^sub>2)
  from `eq\<rho> (Aexp (scrut ? e\<^sub>1 : e\<^sub>2)\<cdot>a) \<rho>1 \<rho>2`
  have "eq\<rho> (Aexp scrut\<cdot>0 \<squnion> Aexp e\<^sub>1\<cdot>a \<squnion> Aexp e\<^sub>2\<cdot>a) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_IfThenElse])
  hence "eq\<rho> (Aexp scrut\<cdot>0) \<rho>1 \<rho>2"
  and   "eq\<rho> (Aexp e\<^sub>1\<cdot>a) \<rho>1 \<rho>2"
  and   "eq\<rho> (Aexp e\<^sub>2\<cdot>a) \<rho>1 \<rho>2" by simp_all
  from IfThenElse(1)[OF this(1)] IfThenElse(2)[OF this(2)] IfThenElse(3)[OF this(3)]
  show ?case
    by (cases "\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>2\<^esub>") auto
next
  case (Let a \<Gamma> e)

  have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<lbrace>\<Gamma>\<rbrace>\<rho>1) (\<lbrace>\<Gamma>\<rbrace>\<rho>2)"
  proof(induction rule: parallel_HSem_ind[case_names adm bottom step])
    case adm thus ?case by (intro eq\<rho>_adm cont2cont)
  next
    case bottom show ?case by simp
  next
    case (step \<rho>1' \<rho>2')
    show ?case
    proof (rule eq\<rho>I)
      fix x a'
      assume ass: "(Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'"
      show "eq a' ((\<rho>1 ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>1'\<^esub>) x) ((\<rho>2 ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>2'\<^esub>) x)"
      proof(cases "x \<in> domA \<Gamma>")
        case [simp]: True
        then obtain e' where [simp]: "map_of \<Gamma> x = Some e'" by (metis domA_map_of_Some_the)
        have "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'" using ass by simp
        hence "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a" using `map_of _ _ = _` by (rule Aexp_heap_below_Aheap)
        hence "eq\<rho> (Aexp e'\<cdot>a') \<rho>1' \<rho>2'" using step(1) by (rule eq\<rho>_mono)
        hence "eq a' (\<lbrakk> e' \<rbrakk>\<^bsub>\<rho>1'\<^esub>) (\<lbrakk> e' \<rbrakk>\<^bsub>\<rho>2'\<^esub>)"
          by (rule Let(1)[OF map_of_SomeD[OF `map_of _ _ = _`]])
        thus ?thesis by (simp add: lookupEvalHeap')
      next
        case [simp]: False
        with edom_Aheap have "x \<notin> edom (Aheap \<Gamma> e\<cdot>a)" by blast
        hence "(Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'" using ass by (simp add: edomIff)
        with `eq\<rho> (Aexp (Let \<Gamma> e)\<cdot>a) \<rho>1 \<rho>2`
        have "eq a' (\<rho>1 x) (\<rho>2 x)" by (auto elim: eq\<rho>E)
        thus ?thesis by simp
      qed
    qed
  qed
  hence "eq\<rho> (Aexp e\<cdot>a) (\<lbrace>\<Gamma>\<rbrace>\<rho>1) (\<lbrace>\<Gamma>\<rbrace>\<rho>2)" by (rule eq\<rho>_mono[OF Aexp_body_below_Aheap])
  hence "eq a (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>1\<^esub>) (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>2\<^esub>)" by (rule Let(2)[simplified])
  thus ?case by simp
qed

lemma ESem_ignores_fresh[simp]: "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(fresh_var e := v)\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
  by (metis ESem_fresh_cong env_restr_fun_upd_other fresh_var_not_free)

lemma eq_Aeta_expand: "eq a (\<lbrakk> Aeta_expand a e \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>)"
  apply (induction a arbitrary: e \<rho>  rule: Arity_ind[case_names 0 inc])
  apply simp
  apply (fastforce simp add: eq_inc_simp elim: eq_trans)
  done

lemma Arity_transformation_correct: "eq a (\<lbrakk> \<T>\<^bsub>a\<^esub> e \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)"
proof(induction a e arbitrary: \<rho> rule: transform.induct[case_names App Lam Var Let Bool IfThenElse])
  case Var
  show ?case by simp
next
  case (App a e x)
  from this[where \<rho> =\<rho> ]
  show ?case
    by (auto elim: eq.cases)
next
  case (Lam x e)
  thus ?case
    by (auto intro: eq_FnI)
next
  case (Bool b)
  show ?case by simp
next
  case (IfThenElse a e e\<^sub>1 e\<^sub>2)
  thus ?case by (cases "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>") auto
next
  case (Let a \<Gamma> e)

  have "eq a (\<lbrakk> transform a (Let \<Gamma> e) \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk> transform a e \<rbrakk>\<^bsub>\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>\<^esub>)"
    by simp
  also have "eq a \<dots> (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>\<^esub>)"
    using Let(2) by simp
  also have "eq a \<dots> (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)"
  proof (rule Aexp_correct)
    have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>) (\<lbrace>\<Gamma>\<rbrace>\<rho>)"
    proof(induction rule: parallel_HSem_ind[case_names adm bottom step])
      case adm thus ?case by (intro eq\<rho>_adm cont2cont)
    next
      case bottom show ?case by simp
    next
      case (step \<rho>1 \<rho>2)
      have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) (\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
      proof(rule eq\<rho>I)
        fix x a'
        assume ass: "(Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'"
        show "eq a' ((\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) x) ((\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>) x)"
        proof(cases "x \<in> domA \<Gamma>")
          case [simp]: True
          then obtain e' where [simp]: "map_of \<Gamma> x = Some e'" by (metis domA_map_of_Some_the)
          from ass have ass': "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'" by simp

          have "(\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) x =
            \<lbrakk>Aeta_expand a' (transform a' e')\<rbrakk>\<^bsub>\<rho>1\<^esub>"
           by (simp add: lookupEvalHeap' map_of_map_transform ass')
          also have "eq a' \<dots> (\<lbrakk>transform a' e'\<rbrakk>\<^bsub>\<rho>1\<^esub>)"
            by (rule eq_Aeta_expand)
          also have "eq a' \<dots> (\<lbrakk>e'\<rbrakk>\<^bsub>\<rho>1\<^esub>)"
            by (rule Let(1)[OF map_of_SomeD[OF `map_of _ _ = _`]])
          also have "eq a' \<dots> (\<lbrakk>e'\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
          proof (rule Aexp_correct)
            from ass' `map_of _ _ = _`
            have "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a" by (rule Aexp_heap_below_Aheap)
            thus "eq\<rho> (Aexp e'\<cdot>a') \<rho>1 \<rho>2" using step by (rule eq\<rho>_mono)
          qed
          also have "\<dots> = (\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>) x"
           by (simp add: lookupEvalHeap')
          finally
          show ?thesis.
        next
          case False thus ?thesis by simp
        qed
      qed
      thus ?case
        by (simp add: env_restr_useless  order_trans[OF  edom_evalHeap_subset] del: fun_meet_simp eq\<rho>_join)
    qed
    thus "eq\<rho> (Aexp e\<cdot>a) (\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>) (\<lbrace>\<Gamma>\<rbrace>\<rho>)"
        by (rule eq\<rho>_mono[OF Aexp_body_below_Aheap])
  qed
  also have "\<dots> = \<lbrakk> Let \<Gamma> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
    by simp
  finally show ?case.
qed

corollary Arity_transformation_correct':
  "\<lbrakk> \<T>\<^bsub>0\<^esub> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
  using Arity_transformation_correct[where a = 0] by simp

end
end