theory Prelude_ListNoNumbers_E4
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"Comp1\", \"IdDef\", \"FlipDef\", \"FstDef\", \"SndDef\",
     \"CurryDef\", \"UncurryDef\", \"NotFalse\", \"NotTrue\",
     \"AndFalse\", \"AndTrue\", \"AndSym\", \"OrDef\", \"OtherwiseDef\",
     \"NotFalse1\", \"NotTrue1\", \"notNot1\", \"notNot2\",
     \"EqualTDef\", \"EqualSymDef\", \"EqualReflex\", \"EqualTransT\",
     \"DiffDef\", \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\",
     \"TE2\", \"TE3\", \"TE4\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IUE1\", \"IUE2\",
     \"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\", \"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\", \"IUO01\", \"IUO02\", \"IUO03\",
     \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"NotDefHead\",
     \"HeadDef\", \"NotDefTail\", \"TailDef\", \"FoldrNil\",
     \"FoldrCons\", \"FoldlNil\", \"FoldlCons\", \"MapNil\",
     \"MapCons\", \"XPlusXPlusNil\", \"XPlusXPlusCons\", \"FilterNil\",
     \"FilterConsT\", \"FilterConsF\", \"ZipNil\", \"ZipConsNil\",
     \"ZipConsCons\", \"UnzipNil\", \"UnzipCons\", \"ILE02\", \"ILO05\",
     \"ILO06\", \"ILO07\", \"ILE01\", \"ILO01\", \"ILO02\", \"ILO03\",
     \"ILO04\", \"ILO08\", \"ILO09\", \"ILO10\", \"ILO11\", \"ILO12\",
     \"ILO13\", \"ILO14\", \"ILO15\", \"ILO16\", \"ILO17\", \"ILO18\",
     \"ILO19\", \"ILO20\", \"ILO21\", \"ILO22\", \"FoldlDecomp\",
     \"MapDecomp\", \"MapFunctor\", \"FilterProm\"]"

typedecl Unit

datatype Bool = X_False ("False''") | X_True ("True''")
datatype Ordering = EQ | GT | LT
datatype 'a List = X_Cons 'a "'a List" | X_Nil ("Nil''")

consts
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a => 'a => Bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a => 'a => Bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a => 'a => Bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a => 'a => Bool" ("(_/ <''/ _)" [54,54] 52)
X__XPlusXPlus__X :: "'a List => 'a List => 'a List" ("(_/ ++''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X__o__X :: "('b => 'c) * ('a => 'b) => 'a => 'c"
X_curry :: "('a * 'b => 'c) => 'a => 'b => 'c"
X_filter :: "('a => Bool) => 'a List => 'a List"
X_flip :: "('a => 'b => 'c) => 'b => 'a => 'c"
X_foldl :: "('a => 'b => 'a) => 'a => 'b List => 'a"
X_foldr :: "('a => 'b => 'b) => 'b => 'a List => 'b"
X_fst :: "'a => 'b => 'a" ("fst''/'(_,/ _')" [3,3] 999)
X_head :: "'a List => 'a partial" ("head/'(_')" [3] 999)
X_id :: "'a => 'a" ("id''/'(_')" [3] 999)
X_map :: "('a => 'b) => 'a List => 'b List"
X_max :: "'a => 'a => 'a"
X_min :: "'a => 'a => 'a"
X_snd :: "'a => 'b => 'b" ("snd''/'(_,/ _')" [3,3] 999)
X_tail :: "'a List => 'a List partial" ("tail/'(_')" [3] 999)
X_unzip :: "('a * 'b) List => 'a List * 'b List" ("unzip/'(_')" [3] 999)
X_zip :: "'a List => 'b List => ('a * 'b) List"
compare :: "'a => 'a => Ordering"
otherwiseH :: "Bool"
uncurry :: "('a => 'b => 'c) => 'a * 'b => 'c"

axioms
Comp1 [rule_format] :
"ALL f. ALL g. ALL y. X__o__X (f, g) y = f (g y)"

IdDef [rule_format] : "ALL x. id'(x) = x"

FlipDef [rule_format] : "ALL f. ALL x. ALL y. X_flip f y x = f x y"

FstDef [rule_format] : "ALL x. ALL y. fst'(x, y) = x"

SndDef [rule_format] : "ALL x. ALL y. snd'(x, y) = y"

CurryDef [rule_format] :
"ALL g. ALL x. ALL y. X_curry g x y = g (x, y)"

UncurryDef [rule_format] :
"ALL f. ALL x. ALL y. uncurry f (x, y) = f x y"

NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

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 = True'"

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

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

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

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

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

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

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

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

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 = True' = (Not' (x ==' y) = True')"

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

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

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

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

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

IBE1 [rule_format] : "True' ==' True' = True'"

IBE2 [rule_format] : "False' ==' False' = True'"

IBE3 [rule_format] : "False' ==' True' = False'"

IBE4 [rule_format] : "True' ==' False' = False'"

IBE5 [rule_format] : "True' /= False' = True'"

IBE6 [rule_format] : "False' /= True' = True'"

IBE7 [rule_format] : "Not' (True' ==' False') = True'"

IBE8 [rule_format] : "Not' Not' (True' ==' False') = False'"

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

IUE2 [rule_format] : "() /= () = False'"

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

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

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

IOE04 [rule_format] : "LT ==' EQ = False'"

IOE05 [rule_format] : "LT ==' GT = False'"

IOE06 [rule_format] : "EQ ==' GT = False'"

IOE07 [rule_format] : "LT /= EQ = True'"

IOE08 [rule_format] : "LT /= GT = True'"

IOE09 [rule_format] : "EQ /= GT = True'"

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

LeTAsymmetry [rule_format] :
"ALL x. ALL y. x <' y = True' --> y <' x = False'"

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

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

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

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

GeTAsymmetry [rule_format] :
"ALL x. ALL y. x >' y = True' --> y >' x = False'"

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

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

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

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

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

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 = True'"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' 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 = True' | x <' y = True') = (x <=' y = True')"

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

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

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

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

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

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

IOO13 [rule_format] : "LT <' EQ = True'"

IOO14 [rule_format] : "EQ <' GT = True'"

IOO15 [rule_format] : "LT <' GT = True'"

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

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

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

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

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

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

IOO22 [rule_format] : "EQ >' LT = True'"

IOO23 [rule_format] : "GT >' EQ = True'"

IOO24 [rule_format] : "GT >' LT = True'"

IOO25 [rule_format] : "X_max LT EQ ==' EQ = True'"

IOO26 [rule_format] : "X_max EQ GT ==' GT = True'"

IOO27 [rule_format] : "X_max LT GT ==' GT = True'"

IOO28 [rule_format] : "X_min LT EQ ==' LT = True'"

IOO29 [rule_format] : "X_min EQ GT ==' EQ = True'"

IOO30 [rule_format] : "X_min LT GT ==' LT = True'"

IOO31 [rule_format] : "compare LT LT ==' EQ = True'"

IOO32 [rule_format] : "compare EQ EQ ==' EQ = True'"

IOO33 [rule_format] : "compare GT GT ==' EQ = True'"

IBO5 [rule_format] : "False' <' True' = True'"

IBO6 [rule_format] : "False' >=' True' = False'"

IBO7 [rule_format] : "True' >=' False' = True'"

IBO8 [rule_format] : "True' <' False' = False'"

IBO9 [rule_format] : "X_max False' True' ==' True' = True'"

IBO10 [rule_format] : "X_min False' True' ==' False' = True'"

IBO11 [rule_format] : "compare True' True' ==' EQ = True'"

IBO12 [rule_format] : "compare False' False' ==' EQ = True'"

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

IUO02 [rule_format] : "() <' () = False'"

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

IUO04 [rule_format] : "() >' () = False'"

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

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

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

NotDefHead [rule_format] : "~ defOp (head(Nil'))"

HeadDef [rule_format] :
"ALL x. ALL xs. head(X_Cons x xs) = makePartial x"

NotDefTail [rule_format] : "~ defOp (tail(Nil'))"

TailDef [rule_format] :
"ALL x. ALL xs. tail(X_Cons x xs) = makePartial xs"

FoldrNil [rule_format] : "ALL f. ALL s. X_foldr f s Nil' = s"

FoldrCons [rule_format] :
"ALL f.
 ALL s.
 ALL x. ALL xs. X_foldr f s (X_Cons x xs) = f x (X_foldr f s xs)"

FoldlNil [rule_format] : "ALL g. ALL t. X_foldl g t Nil' = t"

FoldlCons [rule_format] :
"ALL g.
 ALL t.
 ALL z. ALL zs. X_foldl g t (X_Cons z zs) = X_foldl g (g t z) zs"

MapNil [rule_format] : "ALL h. X_map h Nil' = Nil'"

MapCons [rule_format] :
"ALL h.
 ALL x. ALL xs. X_map h (X_Cons x xs) = X_Cons (h x) (X_map h xs)"

XPlusXPlusNil [rule_format] : "ALL l. Nil' ++' l = l"

XPlusXPlusCons [rule_format] :
"ALL l. ALL x. ALL xs. X_Cons x xs ++' l = X_Cons x (xs ++' l)"

FilterNil [rule_format] : "ALL p. X_filter p Nil' = Nil'"

FilterConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' -->
 X_filter p (X_Cons x xs) = X_Cons x (X_filter p xs)"

FilterConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs. p x = False' --> X_filter p (X_Cons x xs) = X_filter p xs"

ZipNil [rule_format] : "ALL l. X_zip Nil' l = Nil'"

ZipConsNil [rule_format] :
"ALL l. ALL x. ALL xs. l = Nil' --> X_zip (X_Cons x xs) l = Nil'"

ZipConsCons [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 l = X_Cons y ys -->
 X_zip (X_Cons x xs) l = X_Cons (x, y) (X_zip xs ys)"

UnzipNil [rule_format] : "unzip(Nil') = (Nil', Nil')"

UnzipCons [rule_format] :
"ALL ps.
 ALL x.
 ALL z.
 unzip(X_Cons (x, z) ps) =
 (let (ys, zs) = unzip(ps) in (X_Cons x ys, X_Cons z zs))"

ILE02 [rule_format] :
"ALL x.
 ALL xs.
 ALL y.
 ALL ys. X_Cons x xs ==' X_Cons y ys = (x ==' y) && (xs ==' ys)"

ILO05 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs. z <' w = True' --> X_Cons z zs <' X_Cons w ws = True'"

ILO06 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs. z ==' w = True' --> X_Cons z zs <' X_Cons w ws = zs <' ws"

ILO07 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 z <' w = False' & z ==' w = False' -->
 X_Cons z zs <' X_Cons w ws = False'"

declare Comp1 [simp]
declare IdDef [simp]
declare FlipDef [simp]
declare FstDef [simp]
declare SndDef [simp]
declare CurryDef [simp]
declare UncurryDef [simp]
declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [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 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 IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare NotDefHead [simp]
declare HeadDef [simp]
declare NotDefTail [simp]
declare TailDef [simp]
declare FoldrNil [simp]
declare FoldlNil [simp]
declare MapNil [simp]
declare XPlusXPlusNil [simp]
declare FilterNil [simp]
declare FilterConsF [simp]
declare ZipNil [simp]
declare ILO05 [simp]
declare ILO06 [simp]

theorem ILE01 : "Nil' ==' Nil' = True'"
by (auto)

ML "Header.record \"ILE01\""

theorem ILO01 : "Nil' <' Nil' = False'"
by (auto)

ML "Header.record \"ILO01\""

theorem ILO02 : "Nil' <=' Nil' = True'"
by (auto)

ML "Header.record \"ILO02\""

theorem ILO03 : "Nil' >' Nil' = False'"
by (auto)

ML "Header.record \"ILO03\""

theorem ILO04 : "Nil' >=' Nil' = True'"
by (auto)

ML "Header.record \"ILO04\""

theorem ILO08 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons z zs <=' X_Cons w ws =
 (X_Cons z zs <' X_Cons w ws) || (X_Cons z zs ==' X_Cons w ws)"
apply(rule allI)+
apply(simp only: LeqDef)
done

ML "Header.record \"ILO08\""

theorem ILO09 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs. X_Cons z zs >' X_Cons w ws = X_Cons w ws <' X_Cons z zs"
apply(rule allI)+
apply(case_tac "X_Cons z zs >' X_Cons w ws")
apply(simp only: GeFLeFRel)
apply(simp only: GeTLeTRel)
done

ML "Header.record \"ILO09\""

theorem ILO10 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons z zs >=' X_Cons w ws =
 (X_Cons z zs >' X_Cons w ws) || (X_Cons z zs ==' X_Cons w ws)"
apply(rule allI)+
apply(simp only: GeqDef)
done

ML "Header.record \"ILO10\""

theorem ILO11 : "compare Nil' Nil' ==' EQ = Nil' ==' Nil'"
by (auto)

ML "Header.record \"ILO11\""

theorem ILO12 : "compare Nil' Nil' ==' LT = Nil' <' Nil'"
by (auto)

ML "Header.record \"ILO12\""

theorem ILO13 : "compare Nil' Nil' ==' GT = Nil' >' Nil'"
by (auto)

ML "Header.record \"ILO13\""

theorem ILO14 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (X_Cons z zs) (X_Cons w ws) ==' EQ =
 X_Cons z zs ==' X_Cons w ws"
apply(rule allI)+
apply(simp only: CmpEQDef)
done

ML "Header.record \"ILO14\""

theorem ILO15 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (X_Cons z zs) (X_Cons w ws) ==' LT =
 X_Cons z zs <' X_Cons w ws"
apply(rule allI)+
apply(simp only: CmpLTDef)
done

ML "Header.record \"ILO15\""

theorem ILO16 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (X_Cons z zs) (X_Cons w ws) ==' GT =
 X_Cons z zs >' X_Cons w ws"
apply(rule allI)+
apply(simp only: CmpGTDef)
done

ML "Header.record \"ILO16\""

theorem ILO17 : "X_max Nil' Nil' ==' Nil' = Nil' <=' Nil'"
by (auto)

ML "Header.record \"ILO17\""

theorem ILO18 : "X_min Nil' Nil' ==' Nil' = Nil' <=' Nil'"
by (auto)

ML "Header.record \"ILO18\""

theorem ILO19 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons z zs <=' X_Cons w ws =
 X_max (X_Cons z zs) (X_Cons w ws) ==' X_Cons w ws"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO19\""

theorem ILO20 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons w ws <=' X_Cons z zs =
 X_max (X_Cons z zs) (X_Cons w ws) ==' X_Cons z zs"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO20\""

theorem ILO21 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons z zs <=' X_Cons w ws =
 X_min (X_Cons z zs) (X_Cons w ws) ==' X_Cons z zs"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO21\""

theorem ILO22 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 X_Cons w ws <=' X_Cons z zs =
 X_min (X_Cons z zs) (X_Cons w ws) ==' X_Cons w ws"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO22\""

theorem FoldlDecomp :
"ALL e.
 ALL i.
 ALL ts.
 ALL ys. X_foldl i e (ys ++' ts) = X_foldl i (X_foldl i e ys) ts"
apply(auto)
apply(case_tac "ys ++' ts")
apply(auto)
apply(simp add: FoldlCons)
apply(induct_tac List)
apply(simp add: FoldlCons)
oops

ML "Header.record \"FoldlDecomp\""

theorem MapDecomp :
"ALL f.
 ALL xs. ALL zs. X_map f (xs ++' zs) = X_map f xs ++' X_map f zs"
apply(auto)
apply(induct_tac xs)
apply(auto)
apply(simp add: MapCons XPlusXPlusCons)
done

ML "Header.record \"MapDecomp\""

theorem MapFunctor :
"ALL f.
 ALL g. ALL xs. X_map (X__o__X (g, f)) xs = X_map g (X_map f xs)"
apply(auto)
apply(induct_tac xs)
apply(auto)
apply(simp add: MapNil MapCons Comp1)
done

ML "Header.record \"MapFunctor\""

theorem FilterProm :
"ALL f.
 ALL p.
 ALL xs.
 X_filter p (X_map f xs) = X_map f (X_filter (X__o__X (p, f)) xs)"
apply(auto)
apply(induct_tac xs)
apply(auto)
apply(case_tac "p(f a)")
apply(auto)
apply(simp add: MapCons)
apply(simp add: FilterConsT)
apply(simp add: MapCons)
apply(simp add: FilterConsT)
done

ML "Header.record \"FilterProm\""

end


section \<open> Simple UTP Test \<close>

theory utp_hello_world
  imports "UTP.utp_easy_parser"
begin

text \<open> Create a basic state space with one variable \<close>

alphabet state =
  x :: int

text \<open> Prove a simple relational equality \<close>

theorem hello_world: "(x := 1 ;; x := x + 2) = (x := 3)"
  by (rel_auto)

end


theory Eval_FO
  imports Infinite FO
begin

datatype 'a eval_res = Fin "'a table" | Infin | Wf_error

locale eval_fo =
  fixes wf :: "('a :: infinite, 'b) fo_fmla \<Rightarrow> ('b \<times> nat \<Rightarrow> 'a list set) \<Rightarrow> 't \<Rightarrow> bool"
    and abs :: "('a fo_term) list \<Rightarrow> 'a table \<Rightarrow> 't"
    and rep :: "'t \<Rightarrow> 'a table"
    and res :: "'t \<Rightarrow> 'a eval_res"
    and eval_bool :: "bool \<Rightarrow> 't"
    and eval_eq :: "'a fo_term \<Rightarrow> 'a fo_term \<Rightarrow> 't"
    and eval_neg :: "nat list \<Rightarrow> 't \<Rightarrow> 't"
    and eval_conj :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
    and eval_ajoin :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
    and eval_disj :: "nat list \<Rightarrow> 't \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
    and eval_exists :: "nat \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
    and eval_forall :: "nat \<Rightarrow> nat list \<Rightarrow> 't \<Rightarrow> 't"
  assumes fo_rep: "wf \<phi> I t \<Longrightarrow> rep t = proj_sat \<phi> I"
  and fo_res_fin: "wf \<phi> I t \<Longrightarrow> finite (rep t) \<Longrightarrow> res t = Fin (rep t)"
  and fo_res_infin: "wf \<phi> I t \<Longrightarrow> \<not>finite (rep t) \<Longrightarrow> res t = Infin"
  and fo_abs: "finite (I (r, length ts)) \<Longrightarrow> wf (Pred r ts) I (abs ts (I (r, length ts)))"
  and fo_bool: "wf (Bool b) I (eval_bool b)"
  and fo_eq: "wf (Eqa trm trm') I (eval_eq trm trm')"
  and fo_neg: "wf \<phi> I t \<Longrightarrow> wf (Neg \<phi>) I (eval_neg (fv_fo_fmla_list \<phi>) t)"
  and fo_conj: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi> I t\<psi> \<Longrightarrow> (case \<psi> of Neg \<psi>' \<Rightarrow> False | _ \<Rightarrow> True) \<Longrightarrow>
    wf (Conj \<phi> \<psi>) I (eval_conj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
  and fo_ajoin: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi>' I t\<psi>' \<Longrightarrow>
    wf (Conj \<phi> (Neg \<psi>')) I (eval_ajoin (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>') t\<psi>')"
  and fo_disj: "wf \<phi> I t\<phi> \<Longrightarrow> wf \<psi> I t\<psi> \<Longrightarrow>
    wf (Disj \<phi> \<psi>) I (eval_disj (fv_fo_fmla_list \<phi>) t\<phi> (fv_fo_fmla_list \<psi>) t\<psi>)"
  and fo_exists: "wf \<phi> I t \<Longrightarrow> wf (Exists i \<phi>) I (eval_exists i (fv_fo_fmla_list \<phi>) t)"
  and fo_forall: "wf \<phi> I t \<Longrightarrow> wf (Forall i \<phi>) I (eval_forall i (fv_fo_fmla_list \<phi>) t)"
begin

fun eval_fmla :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 't" where
  "eval_fmla (Pred r ts) I = abs ts (I (r, length ts))"
| "eval_fmla (Bool b) I = eval_bool b"
| "eval_fmla (Eqa t t') I = eval_eq t t'"
| "eval_fmla (Neg \<phi>) I = eval_neg (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"
| "eval_fmla (Conj \<phi> \<psi>) I = (let ns\<phi> = fv_fo_fmla_list \<phi>; ns\<psi> = fv_fo_fmla_list \<psi>;
    X\<phi> = eval_fmla \<phi> I in
  case \<psi> of Neg \<psi>' \<Rightarrow> let X\<psi>' = eval_fmla \<psi>' I in
    eval_ajoin ns\<phi> X\<phi> (fv_fo_fmla_list \<psi>') X\<psi>'
  | _ \<Rightarrow> eval_conj ns\<phi> X\<phi> ns\<psi> (eval_fmla \<psi> I))"
| "eval_fmla (Disj \<phi> \<psi>) I = eval_disj (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)
    (fv_fo_fmla_list \<psi>) (eval_fmla \<psi> I)"
| "eval_fmla (Exists i \<phi>) I = eval_exists i (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"
| "eval_fmla (Forall i \<phi>) I = eval_forall i (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)"

lemma eval_fmla_correct:
  fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
  assumes "wf_fo_intp \<phi> I"
  shows "wf \<phi> I (eval_fmla \<phi> I)"
  using assms
proof (induction \<phi> I rule: eval_fmla.induct)
  case (1 r ts I)
  then show ?case
    using fo_abs
    by auto
next
  case (2 b I)
  then show ?case
    using fo_bool
    by auto
next
  case (3 t t' I)
  then show ?case
    using fo_eq
    by auto
next
  case (4 \<phi> I)
  then show ?case
    using fo_neg
    by auto
next
  case (5 \<phi> \<psi> I)
  have fins: "wf_fo_intp \<phi> I" "wf_fo_intp \<psi> I"
    using 5(10)
    by auto
  have eval\<phi>: "wf \<phi> I (eval_fmla \<phi> I)"
    using 5(1)[OF _ _ fins(1)]
    by auto
  show ?case
  proof (cases "\<exists>\<psi>'. \<psi> = Neg \<psi>'")
    case True
    then obtain \<psi>' where \<psi>_def: "\<psi> = Neg \<psi>'"
      by auto
    have fin: "wf_fo_intp \<psi>' I"
      using fins(2)
      by (auto simp: \<psi>_def)
    have eval\<psi>': "wf \<psi>' I (eval_fmla \<psi>' I)"
      using 5(5)[OF _ _ _ \<psi>_def fin]
      by auto
    show ?thesis
      unfolding \<psi>_def
      using fo_ajoin[OF eval\<phi> eval\<psi>']
      by auto
  next
    case False
    then have eval\<psi>: "wf \<psi> I (eval_fmla \<psi> I)"
      using 5 fins(2)
      by (cases \<psi>) auto
    have eval: "eval_fmla (Conj \<phi> \<psi>) I = eval_conj (fv_fo_fmla_list \<phi>) (eval_fmla \<phi> I)
      (fv_fo_fmla_list \<psi>) (eval_fmla \<psi> I)"
      using False
      by (auto simp: Let_def split: fo_fmla.splits)
    show "wf (Conj \<phi> \<psi>) I (eval_fmla (Conj \<phi> \<psi>) I)"
      using fo_conj[OF eval\<phi> eval\<psi>, folded eval] False
      by (auto split: fo_fmla.splits)
  qed
next
  case (6 \<phi> \<psi> I)
  then show ?case
    using fo_disj
    by auto
next
  case (7 i \<phi> I)
  then show ?case
    using fo_exists
    by auto
next
  case (8 i \<phi> I)
  then show ?case
    using fo_forall
    by auto
qed

definition eval :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a eval_res" where
  "eval \<phi> I = (if wf_fo_intp \<phi> I then res (eval_fmla \<phi> I) else Wf_error)"

lemma eval_fmla_proj_sat:
  fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
  assumes "wf_fo_intp \<phi> I"
  shows "rep (eval_fmla \<phi> I) = proj_sat \<phi> I"
  using eval_fmla_correct[OF assms]
  by (auto simp: fo_rep)

lemma eval_sound:
  fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
  assumes "eval \<phi> I = Fin Z"
  shows "Z = proj_sat \<phi> I"
proof -
  have "wf \<phi> I (eval_fmla \<phi> I)"
    using eval_fmla_correct assms
    by (auto simp: eval_def split: if_splits)
  then show ?thesis
    using assms fo_res_fin fo_res_infin
    by (fastforce simp: eval_def fo_rep split: if_splits)
qed

lemma eval_complete:
  fixes \<phi> :: "('a :: infinite, 'b) fo_fmla"
  assumes "eval \<phi> I = Infin"
  shows "infinite (proj_sat \<phi> I)"
proof -
  have "wf \<phi> I (eval_fmla \<phi> I)"
    using eval_fmla_correct assms
    by (auto simp: eval_def split: if_splits)
  then show ?thesis
    using assms fo_res_fin
    by (auto simp: eval_def fo_rep split: if_splits)
qed

end

end


(* author: Thiemann *)
section \<open>Homomorphisms of Gauss-Jordan Elimination, Kernel and More\<close>
theory Hom_Gauss_Jordan
  imports Jordan_Normal_Form.Matrix_Kernel
   Jordan_Normal_Form.Jordan_Normal_Form_Uniqueness
begin

lemma (in comm_ring_hom) similar_mat_wit_hom: assumes
  "similar_mat_wit A B C D"
shows "similar_mat_wit (mat\<^sub>h A) (mat\<^sub>h B) (mat\<^sub>h C) (mat\<^sub>h D)"
proof -
  obtain n where n: "n = dim_row A" by auto
  note * = similar_mat_witD[OF n assms]
  from * have [simp]: "dim_row C = n" by auto
  note C = *(6) note D = *(7)
  note id = mat_hom_mult[OF C D] mat_hom_mult[OF D C]
  note ** = *(1-3)[THEN arg_cong[of _ _ "mat\<^sub>h"], unfolded id]
  note mult = mult_carrier_mat[of _ n n]
  note hom_mult = mat_hom_mult[of _ n n _ n]
  show ?thesis unfolding similar_mat_wit_def Let_def unfolding **(3) using **(1,2)
    by (auto simp: n[symmetric] hom_mult simp: *(4-) mult)
qed

lemma (in comm_ring_hom) similar_mat_hom:
  "similar_mat A B \<Longrightarrow> similar_mat (mat\<^sub>h A) (mat\<^sub>h B)"
  using similar_mat_wit_hom[of A B C D for C D]
  by (smt similar_mat_def)

context field_hom
begin
lemma hom_swaprows: "i < dim_row A \<Longrightarrow> j < dim_row A \<Longrightarrow>
  swaprows i j (mat\<^sub>h A) = mat\<^sub>h (swaprows i j A)"
  unfolding mat_swaprows_def by (rule eq_matI, auto)

lemma hom_gauss_jordan_main: "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc2 \<Longrightarrow>
  gauss_jordan_main (mat\<^sub>h A) (mat\<^sub>h B) i j =
  map_prod mat\<^sub>h mat\<^sub>h (gauss_jordan_main A B i j)"
proof (induct A B i j rule: gauss_jordan_main.induct)
  case (1 A B i j)
  note IH = 1(1-4)
  note AB = 1(5-6)
  from AB have dim: "dim_row A = nr" "dim_col A = nc" by auto
  let ?h = "mat\<^sub>h"
  let ?hp = "map_prod mat\<^sub>h mat\<^sub>h"
  show ?case unfolding gauss_jordan_main.simps[of A B i j] gauss_jordan_main.simps[of "?h A" _ i j]
    index_map_mat Let_def if_distrib[of ?hp] dim
  proof (rule if_cong[OF refl], goal_cases)
    case 1
    note IH = IH[OF dim[symmetric] 1 refl]
    from 1 have ij: "i < nr" "j < nc" by auto
    hence hij: "(?h A) $$ (i,j) = hom (A $$ (i,j))" using AB by auto
    define ixs where "ixs = concat (map (\<lambda>i'. if A $$ (i', j) \<noteq> 0 then [i'] else []) [Suc i..<nr])"
    have id: "map (\<lambda>i'. if mat\<^sub>h A $$ (i', j) \<noteq> 0 then [i'] else []) [Suc i..<nr] =
       map (\<lambda>i'. if A $$ (i', j) \<noteq> 0 then [i'] else []) [Suc i..<nr]"
      by (rule map_cong[OF refl], insert ij AB, auto)
    show ?case unfolding hij hom_0_iff hom_1_iff id ixs_def[symmetric]
    proof (rule if_cong[OF refl _ if_cong[OF refl]], goal_cases)
      case 1
      note IH = IH(1,2)[OF 1, folded ixs_def]
      show ?case
      proof (cases ixs)
        case Nil
        show ?thesis unfolding Nil using IH(1)[OF Nil AB] by auto
      next
        case (Cons I ix)
        hence "I \<in> set ixs" by auto
        hence I: "I < nr" unfolding ixs_def by auto
        from AB have swap: "swaprows i I A \<in> carrier_mat nr nc" "swaprows i I B \<in> carrier_mat nr nc2"
          by auto
        show ?thesis unfolding Cons list.simps IH(2)[OF Cons swap,symmetric] using AB ij I
          by (auto simp: hom_swaprows)
      qed
    next
      case 2
      from AB have elim: "eliminate_entries (\<lambda>i. A $$ (i, j)) A i j \<in> carrier_mat nr nc"
          "eliminate_entries (\<lambda>i. A $$ (i, j)) B i j \<in> carrier_mat nr nc2"
        unfolding eliminate_entries_gen_def by auto
      show ?case unfolding IH(3)[OF 2 refl elim, symmetric]
        by (rule arg_cong2[of _ _ _ _ "\<lambda> x y. gauss_jordan_main x y (Suc i) (Suc j)"];
        intro eq_matI, insert AB ij, auto simp: eliminate_entries_gen_def hom_minus hom_mult)
    next
      case 3
      from AB have mult: "multrow i (inverse (A $$ (i, j))) A \<in> carrier_mat nr nc"
        "multrow i (inverse (A $$ (i, j))) B \<in> carrier_mat nr nc2" by auto
      show ?case unfolding IH(4)[OF 3 refl mult, symmetric]
        by (rule arg_cong2[of _ _ _ _ "\<lambda> x y. gauss_jordan_main x y i j"];
        intro eq_matI, insert AB ij, auto simp: hom_inverse hom_mult)
    qed
  qed auto
qed

lemma hom_gauss_jordan: "A \<in> carrier_mat nr nc \<Longrightarrow> B \<in> carrier_mat nr nc2 \<Longrightarrow>
  gauss_jordan (mat\<^sub>h A) (mat\<^sub>h B) = map_prod mat\<^sub>h mat\<^sub>h (gauss_jordan A B)"
  unfolding gauss_jordan_def using hom_gauss_jordan_main by blast

lemma hom_gauss_jordan_single[simp]: "gauss_jordan_single (mat\<^sub>h A) = mat\<^sub>h (gauss_jordan_single A)"
proof -
  let ?nr = "dim_row A" let ?nc = "dim_col A"
  have 0: "0\<^sub>m ?nr 0 \<in> carrier_mat ?nr 0" by auto
  have dim: "dim_row (mat\<^sub>h A) = ?nr" by auto
  have hom0: "mat\<^sub>h (0\<^sub>m ?nr 0) = 0\<^sub>m ?nr 0" by auto
  have A: "A \<in> carrier_mat ?nr ?nc" by auto
  from hom_gauss_jordan[OF A 0] A
  show ?thesis unfolding gauss_jordan_single_def dim hom0 by (metis fst_map_prod)
qed

lemma hom_pivot_positions_main_gen: assumes A: "A \<in> carrier_mat nr nc"
  shows "pivot_positions_main_gen 0 (mat\<^sub>h A) nr nc i j = pivot_positions_main_gen 0 A nr nc i j"
proof (induct rule: pivot_positions_main_gen.induct[of nr nc A 0])
  case (1 i j)
  note IH = this
  show ?case unfolding pivot_positions_main_gen.simps[of _ _ nr nc i j]
  proof (rule if_cong[OF refl if_cong[OF refl _ refl] refl], goal_cases)
    case 1
    with A have id: "(mat\<^sub>h A) $$ (i,j) = hom (A $$ (i,j))" by simp
    note IH = IH[OF 1]
    show ?case unfolding id hom_0_iff
      by (rule if_cong[OF refl IH(1)], force, subst IH(2), auto)
  qed
qed

lemma hom_pivot_positions[simp]: "pivot_positions (mat\<^sub>h A) = pivot_positions A"
  unfolding pivot_positions_def by (subst hom_pivot_positions_main_gen, auto)

lemma hom_kernel_dim[simp]: "kernel_dim (mat\<^sub>h A) = kernel_dim A"
  unfolding kernel_dim_code by simp

lemma hom_char_matrix: assumes A: "A \<in> carrier_mat n n"
  shows "char_matrix (mat\<^sub>h A) (hom x) = mat\<^sub>h (char_matrix A x)"
  unfolding char_matrix_def
  by (rule eq_matI, insert A, auto simp: hom_minus)

lemma hom_dim_gen_eigenspace: assumes A: "A \<in> carrier_mat n n"
  shows "dim_gen_eigenspace (mat\<^sub>h A) (hom x) = dim_gen_eigenspace A x"
proof (intro ext)
  fix k
  show "dim_gen_eigenspace (mat\<^sub>h A) (hom x) k = dim_gen_eigenspace A x k"
    unfolding dim_gen_eigenspace_def hom_char_matrix[OF A]
      mat_hom_pow[OF char_matrix_closed[OF A], symmetric] by simp
qed
end
end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2005-2008  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Equivalence relations\<close>

theory EquivClass1 imports ZF.EquivClass func_ZF ZF1

begin

text\<open>In this theory file we extend the  work on equivalence relations
  done in the standard Isabelle's EquivClass theory. That development
  is very good and all, but we really would prefer an approach contained within
  the a standard ZF set theory, without extensions specific to Isabelle.
  That is why this theory is written.
\<close>

subsection\<open>Congruent functions and projections on the quotient\<close>

text\<open>Suppose we have a set $X$ with a relation
  $r\subseteq X\times X$ and a function $f: X\rightarrow X$.
  The function $f$ can be compatible (congruent) with $r$ in the sense that
  if two elements $x,y$ are related then the values $f(x), f(x)$
  are also related. This is especially useful if $r$ is an
  equivalence relation as it allows to "project" the function
  to the quotient space $X/r$ (the set of equivalence classes of $r$)
  and create a new function $F$ that satifies the formula
  $F([x]_r) = [f(x)]_r$. When $f$ is congruent with respect
  to $r$ such definition of the value of $F$ on the equivalence class
  $[x]_r$ does not depend on which $x$ we choose to represent the class.
  In this section we also consider binary operations that are congruent
  with respect to a relation. These are important in algebra - the
  congruency condition allows to project the operation
  to obtain the operation on the quotient space.
\<close>

text\<open>First we define the notion of function that maps equivalent
  elements to equivalent values. We use similar names as
  in the Isabelle's standard \<open>EquivClass\<close> theory to indicate
  the conceptual correspondence of the notions.\<close>

definition
  "Congruent(r,f) \<equiv>
  (\<forall>x y. \<langle>x,y\<rangle> \<in> r  \<longrightarrow> \<langle>f`(x),f`(y)\<rangle> \<in> r)"

text\<open>Now we will define the projection of
  a function onto the quotient space. In standard math the equivalence class
  of $x$ with respect to relation $r$ is usually denoted $[x]_r$. Here we reuse
  notation $r\{ x\}$ instead. This means the image of the set $\{ x\}$
  with respect to the relation, which, for equivalence relations is
  exactly its equivalence class if you think about it.\<close>

definition
  "ProjFun(A,r,f) \<equiv>
  {\<langle>c,\<Union>x\<in>c. r``{f`(x)}\<rangle>. c \<in> (A//r)}"

text\<open>Elements of equivalence classes belong to the set.\<close>

lemma EquivClass_1_L1:
  assumes A1: "equiv(A,r)" and A2: "C \<in> A//r" and A3: "x\<in>C"
  shows "x\<in>A"
proof -
  from A2 have "C \<subseteq> \<Union> (A//r)" by auto
  with A1 A3 show "x\<in>A"
    using Union_quotient by auto
qed

text\<open>The image of a subset of $X$ under projection is a subset
  of $A/r$.\<close>

lemma EquivClass_1_L1A:
  assumes "A\<subseteq>X" shows "{r``{x}. x\<in>A} \<subseteq> X//r"
  using assms quotientI by auto

text\<open>If an element belongs to an equivalence class, then its image
  under relation is this equivalence class.\<close>

lemma EquivClass_1_L2:
  assumes A1: "equiv(A,r)"  "C \<in> A//r" and A2: "x\<in>C"
  shows "r``{x} = C"
proof -
  from A1 A2 have "x \<in> r``{x}"
    using EquivClass_1_L1  equiv_class_self by simp
  with A2 have I: "r``{x}\<inter>C \<noteq> 0" by auto
  from A1 A2 have "r``{x} \<in> A//r"
    using EquivClass_1_L1 quotientI by simp
  with A1 I show ?thesis
    using quotient_disj by blast
qed

text\<open>Elements that belong to the same equivalence class are equivalent.\<close>

lemma EquivClass_1_L2A:
  assumes "equiv(A,r)"  "C \<in> A//r"  "x\<in>C"  "y\<in>C"
  shows "\<langle>x,y\<rangle> \<in> r"
  using assms EquivClass_1_L2 EquivClass_1_L1 equiv_class_eq_iff
  by simp

text\<open>Every $x$ is in the class of $y$, then they are equivalent.\<close>

lemma EquivClass_1_L2B:
  assumes A1: "equiv(A,r)" and A2: "y\<in>A" and A3: "x \<in> r``{y}"
  shows "\<langle>x,y\<rangle> \<in> r"
proof -
  from A2 have  "r``{y} \<in> A//r"
    using quotientI by simp
  with A1 A3 show ?thesis using
    EquivClass_1_L1 equiv_class_self equiv_class_nondisjoint by blast
qed

text\<open>If a function is congruent then the equivalence classes of the values
  that come from the arguments from the same class are the same.\<close>

lemma EquivClass_1_L3:
  assumes A1: "equiv(A,r)" and A2: "Congruent(r,f)"
  and A3: "C \<in> A//r"  "x\<in>C"  "y\<in>C"
  shows "r``{f`(x)} = r``{f`(y)}"
proof -
  from A1 A3 have "\<langle>x,y\<rangle> \<in> r"
    using EquivClass_1_L2A by simp
  with A2 have  "\<langle>f`(x),f`(y)\<rangle> \<in> r"
    using Congruent_def by simp
  with A1 show ?thesis using equiv_class_eq by simp
qed

text\<open>The values of congruent functions are in the space.\<close>

lemma EquivClass_1_L4:
  assumes A1: "equiv(A,r)" and A2: "C \<in> A//r"  "x\<in>C"
  and A3: "Congruent(r,f)"
  shows "f`(x) \<in> A"
proof -
  from A1 A2 have "x\<in>A"
    using EquivClass_1_L1 by simp
  with A1 have "\<langle>x,x\<rangle> \<in> r"
    using equiv_def refl_def by simp
  with A3 have  "\<langle>f`(x),f`(x)\<rangle> \<in> r"
    using Congruent_def by simp
  with A1 show ?thesis using equiv_type by auto
qed

text\<open>Equivalence classes are not empty.\<close>

lemma EquivClass_1_L5:
  assumes A1: "refl(A,r)" and A2: "C \<in> A//r"
  shows "C\<noteq>0"
proof -
  from A2 obtain x where I: "C = r``{x}" and "x\<in>A"
    using quotient_def by auto
  from A1 \<open>x\<in>A\<close> have "x \<in> r``{x}" using refl_def by auto
  with I show ?thesis by auto
qed

text\<open>To avoid using an axiom of choice, we define the projection using
  the expression $\bigcup _{x\in C} r(\{f(x)\})$.
  The next lemma shows that for
  congruent function this is in the quotient space $A/r$.\<close>

lemma EquivClass_1_L6:
  assumes A1: "equiv(A,r)" and A2: "Congruent(r,f)"
  and A3: "C \<in> A//r"
  shows "(\<Union>x\<in>C. r``{f`(x)}) \<in> A//r"
proof -
  from A1 have "refl(A,r)" unfolding equiv_def by simp
  with A3 have "C\<noteq>0" using EquivClass_1_L5 by simp
  moreover from A2 A3 A1 have "\<forall>x\<in>C. r``{f`(x)} \<in> A//r"
    using EquivClass_1_L4 quotientI by auto
  moreover from A1 A2 A3 have
    "\<forall>x y. x\<in>C \<and> y\<in>C \<longrightarrow> r``{f`(x)} = r``{f`(y)}"
    using EquivClass_1_L3 by blast
  ultimately show ?thesis by (rule ZF1_1_L2)
qed

text\<open>Congruent functions can be projected.\<close>

lemma EquivClass_1_T0:
  assumes "equiv(A,r)"  "Congruent(r,f)"
  shows "ProjFun(A,r,f) : A//r \<rightarrow> A//r"
  using assms EquivClass_1_L6 ProjFun_def ZF_fun_from_total
  by simp

text\<open>We now define congruent functions of two variables (binary funtions).
  The predicate \<open>Congruent2\<close> corresponds to \<open>congruent2\<close>
  in Isabelle's standard \<open>EquivClass\<close> theory,
  but uses ZF-functions rather than meta-functions.\<close>

definition
  "Congruent2(r,f) \<equiv>
  (\<forall>x\<^sub>1 x\<^sub>2 y\<^sub>1 y\<^sub>2. \<langle>x\<^sub>1,x\<^sub>2\<rangle> \<in> r \<and> \<langle>y\<^sub>1,y\<^sub>2\<rangle> \<in> r  \<longrightarrow>
  \<langle>f`\<langle>x\<^sub>1,y\<^sub>1\<rangle>, f`\<langle>x\<^sub>2,y\<^sub>2\<rangle> \<rangle> \<in> r)"

text\<open>Next we define the notion of projecting a binary operation
  to the quotient space. This is a very important concept that
  allows to define quotient groups, among other things.\<close>

definition
  "ProjFun2(A,r,f) \<equiv>
  {\<langle>p,\<Union> z \<in> fst(p)\<times>snd(p). r``{f`(z)}\<rangle>. p \<in> (A//r)\<times>(A//r) }"

text\<open>The following lemma is a two-variables equivalent
  of \<open>EquivClass_1_L3\<close>.\<close>

lemma EquivClass_1_L7:
  assumes A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "C\<^sub>1 \<in> A//r"  "C\<^sub>2 \<in> A//r"
  and A4: "z\<^sub>1 \<in> C\<^sub>1\<times>C\<^sub>2"  "z\<^sub>2 \<in> C\<^sub>1\<times>C\<^sub>2"
  shows "r``{f`(z\<^sub>1)} = r``{f`(z\<^sub>2)}"
proof -
  from A4 obtain x\<^sub>1 y\<^sub>1 x\<^sub>2 y\<^sub>2 where
    "x\<^sub>1\<in>C\<^sub>1" and "y\<^sub>1\<in>C\<^sub>2" and "z\<^sub>1 = \<langle>x\<^sub>1,y\<^sub>1\<rangle>" and
    "x\<^sub>2\<in>C\<^sub>1" and "y\<^sub>2\<in>C\<^sub>2" and "z\<^sub>2 = \<langle>x\<^sub>2,y\<^sub>2\<rangle>"
    by auto
  with A1 A3 have "\<langle>x\<^sub>1,x\<^sub>2\<rangle> \<in> r" and "\<langle>y\<^sub>1,y\<^sub>2\<rangle> \<in> r"
    using EquivClass_1_L2A by auto
  with A2 have "\<langle>f`\<langle>x\<^sub>1,y\<^sub>1\<rangle>,f`\<langle>x\<^sub>2,y\<^sub>2\<rangle>\<rangle> \<in> r"
    using Congruent2_def by simp
  with A1 \<open>z\<^sub>1 = \<langle>x\<^sub>1,y\<^sub>1\<rangle>\<close> \<open>z\<^sub>2 = \<langle>x\<^sub>2,y\<^sub>2\<rangle>\<close> show ?thesis
    using equiv_class_eq by simp
qed

text\<open>The values of congruent functions of two variables are in the space.\<close>

lemma EquivClass_1_L8:
  assumes A1: "equiv(A,r)" and A2: "C\<^sub>1 \<in> A//r" and A3: "C\<^sub>2 \<in> A//r"
  and A4: "z \<in> C\<^sub>1\<times>C\<^sub>2" and A5: "Congruent2(r,f)"
  shows "f`(z) \<in> A"
proof -
  from A4 obtain x y where "x\<in>C\<^sub>1" and "y\<in>C\<^sub>2" and "z = \<langle>x,y\<rangle>"
    by auto
  with A1 A2 A3 have "x\<in>A" and "y\<in>A"
    using EquivClass_1_L1 by auto
  with A1 A4 have "\<langle>x,x\<rangle> \<in> r" and "\<langle>y,y\<rangle> \<in> r"
    using equiv_def refl_def by auto
  with A5 have "\<langle>f`\<langle>x,y\<rangle>, f`\<langle>x,y\<rangle> \<rangle> \<in> r"
    using Congruent2_def by simp
  with A1 \<open>z = \<langle>x,y\<rangle>\<close> show ?thesis using equiv_type by auto
qed

text\<open>The values of congruent functions are in the space. Note that
  although this lemma is intended to be used with functions, we don't
  need to assume that $f$ is a function.\<close>

lemma EquivClass_1_L8A:
  assumes A1: "equiv(A,r)" and A2: "x\<in>A"  "y\<in>A"
  and A3: "Congruent2(r,f)"
  shows "f`\<langle>x,y\<rangle> \<in> A"
proof -
  from A1 A2 have "r``{x} \<in> A//r" "r``{y} \<in> A//r"
    "\<langle>x,y\<rangle> \<in> r``{x}\<times>r``{y}"
    using equiv_class_self quotientI by auto
  with A1 A3 show ?thesis using EquivClass_1_L8 by simp
qed

text\<open>The following lemma is a two-variables equivalent of
  \<open>EquivClass_1_L6\<close>.\<close>

lemma EquivClass_1_L9:
  assumes A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "p \<in> (A//r)\<times>(A//r)"
  shows "(\<Union> z \<in> fst(p)\<times>snd(p). r``{f`(z)}) \<in> A//r"
proof -
  from A3 have "fst(p) \<in> A//r" and "snd(p) \<in> A//r"
    by auto
  with A1 A2 have
    I: "\<forall>z \<in> fst(p)\<times>snd(p). f`(z) \<in> A"
    using EquivClass_1_L8 by simp
  from A3 A1 have "fst(p)\<times>snd(p) \<noteq> 0"
    using equiv_def EquivClass_1_L5 Sigma_empty_iff
    by auto
  moreover from A1 I have
    "\<forall>z \<in> fst(p)\<times>snd(p). r``{f`(z)} \<in> A//r"
    using quotientI by simp
  moreover from A1 A2 \<open>fst(p) \<in> A//r\<close> \<open>snd(p) \<in> A//r\<close> have
    "\<forall>z\<^sub>1 z\<^sub>2. z\<^sub>1 \<in> fst(p)\<times>snd(p) \<and> z\<^sub>2 \<in> fst(p)\<times>snd(p) \<longrightarrow>
    r``{f`(z\<^sub>1)} = r``{f`(z\<^sub>2)}"
    using EquivClass_1_L7 by blast
   ultimately show ?thesis by (rule ZF1_1_L2)
qed

text\<open>Congruent functions of two variables can be projected.\<close>

theorem EquivClass_1_T1:
  assumes "equiv(A,r)"  "Congruent2(r,f)"
  shows "ProjFun2(A,r,f) : (A//r)\<times>(A//r) \<rightarrow> A//r"
  using assms EquivClass_1_L9 ProjFun2_def ZF_fun_from_total
  by simp

(*text{*We define the projection on the quotient space as a function that takes
  an element of $A$ and assigns its equivalence class in $A/r$.*}

constdefs
  "Proj(A,r) \<equiv> {<x,c> \<in> A\<times>(A//r). r``{x} = c}"*)

text\<open>The projection diagram commutes. I wish I knew how to draw this diagram
  in LaTeX.\<close>

lemma EquivClass_1_L10:
  assumes A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "x\<in>A"  "y\<in>A"
  shows "ProjFun2(A,r,f)`\<langle>r``{x},r``{y}\<rangle> = r``{f`\<langle>x,y\<rangle>}"
proof -
  from A3 A1 have "r``{x} \<times> r``{y} \<noteq> 0"
    using quotientI equiv_def EquivClass_1_L5 Sigma_empty_iff
    by auto
  moreover have
    "\<forall>z \<in> r``{x}\<times>r``{y}.  r``{f`(z)} = r``{f`\<langle>x,y\<rangle>}"
  proof
    fix z assume A4: "z \<in> r``{x}\<times>r``{y}"
    from A1 A3 have
      "r``{x} \<in> A//r" "r``{y} \<in> A//r"
      "\<langle>x,y\<rangle> \<in> r``{x}\<times>r``{y}"
      using quotientI equiv_class_self by auto
    with A1 A2 A4 show
      "r``{f`(z)} = r``{f`\<langle>x,y\<rangle>}"
      using EquivClass_1_L7 by blast
  qed
  ultimately have
    "(\<Union>z \<in> r``{x}\<times>r``{y}. r``{f`(z)}) =  r``{f`\<langle>x,y\<rangle>}"
    by (rule ZF1_1_L1)
  moreover have
    "ProjFun2(A,r,f)`\<langle>r``{x},r``{y}\<rangle> = (\<Union>z \<in> r``{x}\<times>r``{y}. r``{f`(z)})"
    proof -
      from assms have
	"ProjFun2(A,r,f) : (A//r)\<times>(A//r) \<rightarrow> A//r"
	"\<langle>r``{x},r``{y}\<rangle> \<in> (A//r)\<times>(A//r)"
	using EquivClass_1_T1 quotientI by auto
      then show ?thesis using ProjFun2_def ZF_fun_from_tot_val
	by auto
    qed
  ultimately show ?thesis by simp
qed

subsection\<open>Projecting commutative, associative and distributive operations.\<close>

text\<open>In this section we show that if the operations are congruent with
  respect to an equivalence relation then the projection to the quotient
  space preserves commutativity, associativity and distributivity.\<close>

text\<open>The projection of commutative operation is commutative.\<close>

lemma EquivClass_2_L1: assumes
  A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "f {is commutative on} A"
  and A4: "c1 \<in> A//r"  "c2 \<in> A//r"
  shows "ProjFun2(A,r,f)`\<langle>c1,c2\<rangle> = ProjFun2(A,r,f)`\<langle>c2,c1\<rangle>"
proof -
  from A4 obtain x y where D1:
    "c1 = r``{x}"  "c2 = r``{y}"
    "x\<in>A"  "y\<in>A"
    using quotient_def by auto
  with A1 A2 have "ProjFun2(A,r,f)`\<langle>c1,c2\<rangle> = r``{f`\<langle>x,y\<rangle>}"
    using EquivClass_1_L10 by simp
  also from A3 D1 have
    "r``{f`\<langle>x,y\<rangle>} = r``{f`\<langle>y,x\<rangle>}"
    using IsCommutative_def by simp
  also from A1 A2 D1 have
    "r``{f`\<langle>y,x\<rangle>} = ProjFun2(A,r,f)` \<langle>c2,c1\<rangle>"
    using EquivClass_1_L10 by simp
  finally show ?thesis by simp
qed

text\<open>The projection of commutative operation is commutative.\<close>

theorem EquivClass_2_T1:
  assumes "equiv(A,r)" and "Congruent2(r,f)"
  and "f {is commutative on} A"
  shows "ProjFun2(A,r,f) {is commutative on} A//r"
  using assms IsCommutative_def EquivClass_2_L1 by simp

text\<open>The projection of an associative operation is associative.\<close>

lemma EquivClass_2_L2:
  assumes A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "f {is associative on} A"
  and A4: "c1 \<in> A//r"  "c2 \<in> A//r"  "c3 \<in> A//r"
  and A5: "g = ProjFun2(A,r,f)"
  shows "g`\<langle>g`\<langle>c1,c2\<rangle>,c3\<rangle> = g`\<langle>c1,g`\<langle>c2,c3\<rangle>\<rangle>"
proof -
  from A4 obtain x y z where D1:
    "c1 = r``{x}"  "c2 = r``{y}"  "c3 = r``{z}"
    "x\<in>A"  "y\<in>A"  "z\<in>A"
    using quotient_def by auto
  with A3 have T1:"f`\<langle>x,y\<rangle> \<in> A"  "f`\<langle>y,z\<rangle> \<in> A"
    using IsAssociative_def apply_type by auto
  with A1 A2 D1 A5 have
    "g`\<langle>g`\<langle>c1,c2\<rangle>,c3\<rangle> =  r``{f`\<langle>f`\<langle>x,y\<rangle>,z\<rangle>}"
    using EquivClass_1_L10 by simp
  also from D1 A3 have
    "\<dots> = r``{f`\<langle>x,f`\<langle>y,z\<rangle> \<rangle>}"
    using IsAssociative_def by simp
  also from T1 A1 A2 D1 A5 have
    "\<dots> = g`\<langle>c1,g`\<langle>c2,c3\<rangle>\<rangle>"
    using EquivClass_1_L10 by simp
  finally show ?thesis by simp
qed

text\<open>The projection of an associative operation is associative on the
  quotient.\<close>

theorem EquivClass_2_T2:
  assumes A1: "equiv(A,r)" and A2: "Congruent2(r,f)"
  and A3: "f {is associative on} A"
  shows "ProjFun2(A,r,f) {is associative on} A//r"
proof -
  let ?g = "ProjFun2(A,r,f)"
  from A1 A2 have
    "?g \<in> (A//r)\<times>(A//r) \<rightarrow> A//r"
    using EquivClass_1_T1 by simp
  moreover from A1 A2 A3 have
    "\<forall>c1 \<in> A//r.\<forall>c2 \<in> A//r.\<forall>c3 \<in> A//r.
    ?g`\<langle>?g`\<langle>c1,c2\<rangle>,c3\<rangle> = ?g`\<langle>c1,?g`\<langle>c2,c3\<rangle>\<rangle>"
    using EquivClass_2_L2 by simp
  ultimately show ?thesis
    using IsAssociative_def by simp
qed

text\<open>The essential condition to show that distributivity is preserved by
  projections to quotient spaces, provided both operations are congruent
  with respect to the equivalence relation.\<close>

lemma EquivClass_2_L3:
  assumes A1: "IsDistributive(X,A,M)"
  and A2: "equiv(X,r)"
  and A3: "Congruent2(r,A)" "Congruent2(r,M)"
  and A4: "a \<in> X//r"  "b \<in> X//r"  "c \<in> X//r"
  and A5: "A\<^sub>p = ProjFun2(X,r,A)" "M\<^sub>p = ProjFun2(X,r,M)"
  shows "M\<^sub>p`\<langle>a,A\<^sub>p`\<langle>b,c\<rangle>\<rangle> = A\<^sub>p`\<langle> M\<^sub>p`\<langle>a,b\<rangle>,M\<^sub>p`\<langle>a,c\<rangle>\<rangle> \<and>
  M\<^sub>p`\<langle> A\<^sub>p`\<langle>b,c\<rangle>,a \<rangle> = A\<^sub>p`\<langle> M\<^sub>p`\<langle>b,a\<rangle>, M\<^sub>p`\<langle>c,a\<rangle>\<rangle>"
proof
  from A4 obtain x y z where "x\<in>X"  "y\<in>X"  "z\<in>X"
    "a = r``{x}"  "b = r``{y}"  "c = r``{z}"
    using quotient_def by auto
  with A1 A2 A3 A5 show
    "M\<^sub>p`\<langle>a,A\<^sub>p`\<langle>b,c\<rangle>\<rangle> = A\<^sub>p`\<langle> M\<^sub>p`\<langle>a,b\<rangle>,M\<^sub>p`\<langle>a,c\<rangle>\<rangle>" and
    "M\<^sub>p`\<langle> A\<^sub>p`\<langle>b,c\<rangle>,a \<rangle> = A\<^sub>p`\<langle> M\<^sub>p`\<langle>b,a\<rangle>, M\<^sub>p`\<langle>c,a\<rangle>\<rangle>"
    using EquivClass_1_L8A EquivClass_1_L10 IsDistributive_def
    by auto
qed

text\<open>Distributivity is preserved by
  projections to quotient spaces, provided both operations are congruent
  with respect to the equivalence relation.\<close>

lemma EquivClass_2_L4: assumes A1: "IsDistributive(X,A,M)"
  and A2: "equiv(X,r)"
  and A3: "Congruent2(r,A)" "Congruent2(r,M)"
  shows "IsDistributive(X//r,ProjFun2(X,r,A),ProjFun2(X,r,M))"
proof-
 let ?A\<^sub>p = "ProjFun2(X,r,A)"
 let ?M\<^sub>p = "ProjFun2(X,r,M)"
 from A1 A2 A3 have
   "\<forall>a\<in>X//r.\<forall>b\<in>X//r.\<forall>c\<in>X//r.
   ?M\<^sub>p`\<langle>a,?A\<^sub>p`\<langle>b,c\<rangle>\<rangle> = ?A\<^sub>p`\<langle>?M\<^sub>p`\<langle>a,b\<rangle>,?M\<^sub>p`\<langle>a,c\<rangle>\<rangle> \<and>
   ?M\<^sub>p`\<langle>?A\<^sub>p`\<langle>b,c\<rangle>,a\<rangle> = ?A\<^sub>p`\<langle>?M\<^sub>p`\<langle>b,a\<rangle>,?M\<^sub>p`\<langle>c,a\<rangle>\<rangle>"
   using EquivClass_2_L3 by simp
 then show ?thesis using IsDistributive_def by simp
qed

subsection\<open>Saturated sets\<close>

text\<open>In this section we consider sets that are saturated
  with respect to an equivalence
  relation. A set $A$ is saturated with respect to a relation
  $r$ if $A=r^{-1}(r(A))$.
  For equivalence relations saturated sets are unions of equivalence classes.
  This makes them useful as a tool to define subsets of
  the quotient space using properties
  of representants. Namely, we often define a set
  $B\subseteq X/r$ by saying that
  $[x]_r \in B$ iff $x\in A$.
  If $A$ is a saturated set, this definition is consistent in
  the sense that it does not depend on the choice of $x$ to
  represent $[x]_r$.\<close>

text\<open>The following defines the notion of a saturated set.
  Recall that in Isabelle
  \<open>r-``(A)\<close> is the inverse image of $A$ with respect to relation $r$.
  This definition is not specific to equivalence relations.\<close>

definition
  "IsSaturated(r,A) \<equiv> A = r-``(r``(A))"

text\<open>For equivalence relations a set is saturated iff it is an image
  of itself.\<close>

lemma EquivClass_3_L1: assumes A1: "equiv(X,r)"
  shows "IsSaturated(r,A) \<longleftrightarrow> A = r``(A)"
proof
  assume "IsSaturated(r,A)"
  then have "A = (converse(r) O r)``(A)"
    using IsSaturated_def vimage_def image_comp
    by simp
  also from A1 have "\<dots> = r``(A)"
    using equiv_comp_eq by simp
  finally show "A = r``(A)" by simp
next assume "A = r``(A)"
  with A1 have "A = (converse(r) O r)``(A)"
    using equiv_comp_eq by simp
  also have "\<dots> =  r-``(r``(A))"
    using vimage_def image_comp by simp
  finally have "A =  r-``(r``(A))" by simp
  then show "IsSaturated(r,A)" using IsSaturated_def
    by simp
qed

text\<open>For equivalence relations sets are contained in their images.\<close>

lemma EquivClass_3_L2: assumes A1: "equiv(X,r)" and A2: "A\<subseteq>X"
  shows "A \<subseteq> r``(A)"
proof
  fix a assume "a\<in>A"
  with A1 A2 have "a \<in> r``{a}"
    using equiv_class_self by auto
  with \<open>a\<in>A\<close> show "a \<in> r``(A)" by auto
qed

text\<open>The next lemma shows that if "$\sim$"
  is an equivalence relation and a set
  $A$ is such that $a\in A$ and $a\sim b$ implies $b\in A$, then
  $A$ is saturated with respect to the relation.\<close>

lemma EquivClass_3_L3: assumes A1: "equiv(X,r)"
  and A2: "r \<subseteq> X\<times>X" and A3: "A\<subseteq>X"
  and A4: "\<forall>x\<in>A. \<forall>y\<in>X. \<langle>x,y\<rangle> \<in> r \<longrightarrow> y\<in>A"
  shows "IsSaturated(r,A)"
proof -
  from A2 A4 have "r``(A) \<subseteq> A"
    using image_iff by blast
  moreover from A1 A3 have "A \<subseteq> r``(A)"
    using EquivClass_3_L2 by simp
  ultimately have "A = r``(A)" by auto
  with A1 show "IsSaturated(r,A)" using EquivClass_3_L1
    by simp
qed

text\<open>If $A\subseteq X$ and $A$ is saturated and $x\sim y$, then $x\in A$ iff
  $y\in A$. Here we show only one direction.\<close>

lemma EquivClass_3_L4: assumes A1: "equiv(X,r)"
  and A2: "IsSaturated(r,A)" and A3: "A\<subseteq>X"
  and A4: "\<langle>x,y\<rangle> \<in> r"
  and A5: "x\<in>X"  "y\<in>A"
  shows "x\<in>A"
proof -
  from A1 A5 have "x \<in> r``{x}"
    using equiv_class_self by simp
  with A1 A3 A4 A5 have "x \<in> r``(A)"
    using equiv_class_eq equiv_class_self
    by auto
  with A1 A2 show "x\<in>A"
    using EquivClass_3_L1 by simp
qed

text\<open>If $A\subseteq X$ and $A$ is saturated and $x\sim y$, then $x\in A$ iff
  $y\in A$.\<close>

lemma EquivClass_3_L5: assumes A1: "equiv(X,r)"
  and A2: "IsSaturated(r,A)" and A3: "A\<subseteq>X"
  and A4: "x\<in>X"  "y\<in>X"
  and A5: "\<langle>x,y\<rangle> \<in> r"
  shows "x\<in>A \<longleftrightarrow> y\<in>A"
proof
  assume "y\<in>A"
  with assms show "x\<in>A" using EquivClass_3_L4
    by simp
next assume "x\<in>A"
  from A1 A5 have "\<langle>y,x\<rangle> \<in> r"
    using equiv_is_sym by blast
  with A1 A2 A3 A4 \<open>x\<in>A\<close> show "y\<in>A"
    using EquivClass_3_L4 by simp
qed

text\<open>If $A$ is saturated then $x\in A$ iff its class is in the projection
  of $A$.\<close>

lemma EquivClass_3_L6: assumes A1: "equiv(X,r)"
  and A2: "IsSaturated(r,A)" and A3: "A\<subseteq>X" and A4: "x\<in>X"
  and A5: "B = {r``{x}. x\<in>A}"
  shows "x\<in>A \<longleftrightarrow> r``{x} \<in> B"
proof
  assume "x\<in>A"
  with A5 show "r``{x} \<in> B" by auto
next assume "r``{x} \<in> B"
  with A5 obtain y where "y \<in> A" and "r``{x} = r``{y}"
    by auto
  with A1 A3 have "\<langle>x,y\<rangle> \<in> r"
    using eq_equiv_class by auto
  with A1 A2 A3 A4  \<open>y \<in> A\<close> show "x\<in>A"
    using EquivClass_3_L4 by simp
qed

text\<open>A technical lemma involving a projection of a saturated set and a
  logical epression with exclusive or. Note that we don't really care
  what \<open>Xor\<close> is here, this is true for any predicate.\<close>

lemma EquivClass_3_L7: assumes "equiv(X,r)"
  and "IsSaturated(r,A)" and "A\<subseteq>X"
  and "x\<in>X"  "y\<in>X"
  and "B = {r``{x}. x\<in>A}"
  and "(x\<in>A) Xor (y\<in>A)"
  shows "(r``{x} \<in> B)  Xor (r``{y} \<in> B)"
  using assms EquivClass_3_L6 by simp

end


(*  Title:      Continuations.thy
    Author:     Peter Gammie
*)

section \<open>Relating direct and continuation semantics\<close>
(*<*)
theory Continuations
imports
  PCF
begin

(*>*)
text\<open>

\label{sec:continuations}

This is a fairly literal version of
\citet{DBLP:conf/icalp/Reynolds74}, adapted to untyped PCF. A more
abstract account has been given by
\citet{DBLP:journals/tcs/Filinski07} in terms of a monadic meta
language, which is difficult to model in Isabelle (but see
\citet{Huffman:MonadTransformers:2012}).

We begin by giving PCF a continuation semantics following the modern
account of \citet{wadler92:_essence_of_funct_progr}.  We use the
symmetric function space \<open>('o ValK, 'o) K \<rightarrow> ('o ValK, 'o) K\<close>
as our language includes call-by-name.

\<close>

type_synonym ('a, 'o) K = "('a \<rightarrow> 'o) \<rightarrow> 'o"

domain 'o ValK
  = ValKF (lazy appKF :: "('o ValK, 'o) K \<rightarrow> ('o ValK, 'o) K")
  | ValKTT | ValKFF
  | ValKN (lazy "nat")

type_synonym 'o ValKM = "('o ValK, 'o) K"
(*<*)

lemma ValK_case_ID [simp]:
  "ValK_case\<cdot>ValKF\<cdot>ValKTT\<cdot>ValKFF\<cdot>ValKN = ID"
  apply (rule cfun_eqI)
  apply (case_tac x)
  apply simp_all
  done

lemma below_monic_ValKF [iff]:
  "below_monic_cfun ValKF"
  by (rule below_monicI) simp

lemma below_monic_ValKN [iff]:
  "below_monic_cfun ValKN"
  by (rule below_monicI) simp

(*>*)
text\<open>

We use the standard continuation monad to ease the semantic
definition.

\<close>

definition unitK :: "'o ValK \<rightarrow> 'o ValKM" where
  "unitK \<equiv> \<Lambda> a. \<Lambda> c. c\<cdot>a"

definition bindK :: "'o ValKM \<rightarrow> ('o ValK \<rightarrow> 'o ValKM) \<rightarrow> 'o ValKM" where
  "bindK \<equiv> \<Lambda> m k. \<Lambda> c. m\<cdot>(\<Lambda> a. k\<cdot>a\<cdot>c)"

definition appKM :: "'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM" where
  "appKM \<equiv> \<Lambda> fK xK. bindK\<cdot>fK\<cdot>(\<Lambda> (ValKF\<cdot>f). f\<cdot>xK)"
(*<*)

lemma unitK_simps [simp]:
  "unitK\<cdot>v\<cdot>c = c\<cdot>v"
  unfolding unitK_def by simp

lemma bindK_strict:
  "bindK\<cdot>\<bottom> = \<bottom>"
  unfolding bindK_def by (simp add: eta_cfun)

lemma bindK_unitl:
  "bindK\<cdot>(unitK\<cdot>e)\<cdot>f = f\<cdot>e"
  unfolding bindK_def unitK_def by (simp add: eta_cfun)

lemma bindK_unitr:
  "bindK\<cdot>e\<cdot>unitK = e"
  unfolding bindK_def unitK_def by (simp add: eta_cfun)

lemma bindK_assoc:
  "bindK\<cdot>(bindK\<cdot>f\<cdot>g)\<cdot>h = bindK\<cdot>f\<cdot>(\<Lambda> v. bindK\<cdot>(g\<cdot>v)\<cdot>h)"
  unfolding bindK_def unitK_def by simp

lemmas bindK_simps[simp] = bindK_strict bindK_unitl bindK_unitr bindK_assoc

(*>*)
text\<open>The interpretations of the constants.\<close>

definition
  condK :: "'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM"
where
  "condK \<equiv> \<Lambda> iK tK eK. bindK\<cdot>iK\<cdot>(\<Lambda> i. case i of
                ValKF\<cdot>f \<Rightarrow> \<bottom> | ValKTT \<Rightarrow> tK | ValKFF \<Rightarrow> eK | ValKN\<cdot>n \<Rightarrow> \<bottom>)"

definition succK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "succK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). unitK\<cdot>(ValKN\<cdot>(n + 1)))"

definition predK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "predK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). case n of 0 \<Rightarrow> \<bottom> | Suc n \<Rightarrow> unitK\<cdot>(ValKN\<cdot>n))"

definition isZeroK :: "'o ValKM \<rightarrow> 'o ValKM" where
  "isZeroK \<equiv> \<Lambda> nK. bindK\<cdot>nK\<cdot>(\<Lambda> (ValKN\<cdot>n). unitK\<cdot>(if n = 0 then ValKTT else ValKFF))"

text \<open>

A continuation semantics for PCF. If we had defined our direct
semantics using a monad then the correspondence would be more
syntactically obvious.

\<close>

type_synonym 'o EnvK = "'o ValKM Env"

primrec
  evalK :: "expr \<Rightarrow> 'o EnvK \<rightarrow> 'o ValKM"
where
  "evalK (Var v) = (\<Lambda> \<rho>. \<rho>\<cdot>v)"
| "evalK (App f x) = (\<Lambda> \<rho>. appKM\<cdot>(evalK f\<cdot>\<rho>)\<cdot>(evalK x\<cdot>\<rho>))"
| "evalK (AbsN v e) = (\<Lambda> \<rho>. unitK\<cdot>(ValKF\<cdot>(\<Lambda> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))))"
| "evalK (AbsV v e) = (\<Lambda> \<rho>. unitK\<cdot>(ValKF\<cdot>(\<Lambda> x c. x\<cdot>(\<Lambda> x'. evalK e\<cdot>(env_ext\<cdot>v\<cdot>(unitK\<cdot>x')\<cdot>\<rho>)\<cdot>c))))"
| "evalK (Diverge) = (\<Lambda> \<rho>. \<bottom>)"
| "evalK (Fix v e) = (\<Lambda> \<rho>. \<mu> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))"
| "evalK (tt) = (\<Lambda> \<rho>. unitK\<cdot>ValKTT)"
| "evalK (ff) = (\<Lambda> \<rho>. unitK\<cdot>ValKFF)"
| "evalK (Cond i t e) = (\<Lambda> \<rho>. condK\<cdot>(evalK i\<cdot>\<rho>)\<cdot>(evalK t\<cdot>\<rho>)\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (Num n) = (\<Lambda> \<rho>. unitK\<cdot>(ValKN\<cdot>n))"
| "evalK (Succ e) = (\<Lambda> \<rho>. succK\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (Pred e) = (\<Lambda> \<rho>. predK\<cdot>(evalK e\<cdot>\<rho>))"
| "evalK (IsZero e) = (\<Lambda> \<rho>. isZeroK\<cdot>(evalK e\<cdot>\<rho>))"

text\<open>

To establish the chain completeness (admissibility) of our logical
relation, we need to show that @{term "unitK"} is an \emph{order
monic}, i.e., if @{term "unitK\<cdot>x \<sqsubseteq> unitK\<cdot>y"} then @{term "x \<sqsubseteq>
y"}. This is an order-theoretic version of injectivity.

In order to define a continuation that witnesses this, we need to be
able to distinguish converging and diverging computations. We
therefore require our observation domain to contain at least two
elements:

\<close>

locale at_least_two_elements =
  fixes some_non_bottom_element :: "'o::domain"
  assumes some_non_bottom_element: "some_non_bottom_element \<noteq> \<bottom>"

text\<open>

Following \citet{DBLP:conf/icalp/Reynolds74} and \citet[Remark
47]{DBLP:journals/tcs/Filinski07} we use the following continuation:

\<close>

lemma cont_below [simp, cont2cont]:
  "cont (\<lambda>x::'a::pcpo. if x \<sqsubseteq> d then \<bottom> else c)"
(*<*)
proof(rule contI2)
  show "monofun (\<lambda>x. if x \<sqsubseteq> d then \<bottom> else c)"
    apply (rule monofunI)
    apply clarsimp
    apply (cut_tac x=x and y=y and z=d in below_trans)
    apply auto
    done
next
  fix Y :: "nat \<Rightarrow> 'a::pcpo"
  assume Y: "chain Y"
  assume "chain (\<lambda>i. if Y i \<sqsubseteq> d then \<bottom> else c)"
  show "(if (\<Squnion> i. Y i) \<sqsubseteq> d then \<bottom> else c) \<sqsubseteq> (\<Squnion> i. if Y i \<sqsubseteq> d then \<bottom> else c)"
  proof(cases "\<forall>i. Y i \<sqsubseteq> d")
    case True hence "Lub Y \<sqsubseteq> d"
      using lub_below_iff[OF Y] by simp
    thus ?thesis by simp
  next
    case False
    let ?f = "\<lambda>i. if Y i \<sqsubseteq> d then \<bottom> else c"
    from False have LubY: "\<not> Lub Y \<sqsubseteq> d"
      using lub_below_iff[OF Y] by simp
    from False have F: "chain ?f"
      apply -
      apply (rule chainI)
      apply clarsimp
      apply (cut_tac i=i and j="Suc i" in chain_mono[OF Y])
      apply clarsimp
      apply (cut_tac x="Y i" and y="Y (Suc i)" and z=d in below_trans)
      apply simp_all
      done
    from False obtain i where Yi: "\<not> Y i \<sqsubseteq> d" by blast
    hence M: "max_in_chain i ?f"
      apply -
      apply (rule max_in_chainI)
      apply clarsimp
      apply (drule chain_mono[OF Y])
      apply (cut_tac x="Y i" and y="Y j" and z=d in below_trans)
      apply simp_all
      done
    from LubY Yi show ?thesis
      using iffD1[OF maxinch_is_thelub, OF F M] by simp
  qed
qed
(*>*)
text\<open>\<close>

lemma (in at_least_two_elements) below_monic_unitK [intro, simp]:
  "below_monic_cfun (unitK :: 'o ValK \<rightarrow> 'o ValKM)"
proof(rule below_monicI)
  fix v v' :: "'o ValK"
  assume vv': "unitK\<cdot>v \<sqsubseteq> unitK\<cdot>v'"
  let ?k = "\<Lambda> x. if x \<sqsubseteq> v' then \<bottom> else some_non_bottom_element"
  from vv' have "unitK\<cdot>v\<cdot>?k \<sqsubseteq> unitK\<cdot>v'\<cdot>?k" by (rule monofun_cfun_fun)
  hence "?k\<cdot>v \<sqsubseteq> ?k\<cdot>v'" by (simp add: unitK_def)
  with some_non_bottom_element show "v \<sqsubseteq> v'" by (auto split: if_split_asm)
qed

subsection\<open>Logical relation\<close>

text\<open>

We follow \citet{DBLP:conf/icalp/Reynolds74} by simultaneously
defining a pair of relations over values and functions. Both are
bottom-reflecting, in contrast to the situation for computational
adequacy in \S\ref{sec:compad}.  \citet{DBLP:journals/tcs/Filinski07}
differs by assuming that values are always defined, and relates values
and monadic computations.

\<close>

type_synonym 'o lfr = "(ValD, 'o ValKM, ValD \<rightarrow> ValD, 'o ValKM \<rightarrow> 'o ValKM) lf_pair_rep"
type_synonym 'o lflf = "(ValD, 'o ValKM, ValD \<rightarrow> ValD, 'o ValKM \<rightarrow> 'o ValKM) lf_pair"

context at_least_two_elements
begin

abbreviation lr_eta_rep_N where
  "lr_eta_rep_N \<equiv> { (e, e') .
       (e = \<bottom> \<and> e' = \<bottom>)
     \<or> (e = ValTT \<and> e' = unitK\<cdot>ValKTT)
     \<or> (e = ValFF \<and> e' = unitK\<cdot>ValKFF)
     \<or> (\<exists>n. e = ValN\<cdot>n \<and> e' = unitK\<cdot>(ValKN\<cdot>n)) }"

abbreviation lr_eta_rep_F where
  "lr_eta_rep_F \<equiv> \<lambda>(rm, rp). { (e, e') .
       (e = \<bottom> \<and> e' = \<bottom>)
     \<or> (\<exists>f f'. e = ValF\<cdot>f \<and> e' = unitK\<cdot>(ValKF\<cdot>f') \<and> (f, f') \<in> unlr (snd rp)) }"

definition lr_eta_rep where
  "lr_eta_rep \<equiv> \<lambda>r. lr_eta_rep_N \<union> lr_eta_rep_F r"

definition lr_theta_rep where
  "lr_theta_rep \<equiv> \<lambda>(rm, rp). { (f, f') .
     (\<forall>(x, x') \<in> unlr (fst (undual rm)). (f\<cdot>x, f'\<cdot>x') \<in> unlr (fst rp)) }"

definition lr_rep :: "'o lfr" where
  "lr_rep \<equiv> \<lambda>r. (lr_eta_rep r, lr_theta_rep r)"

abbreviation lr :: "'o lflf" where
  "lr \<equiv> \<lambda>r. (mklr (fst (lr_rep r)), mklr (snd (lr_rep r)))"
(*<*)
text\<open>

Properties of the logical relation.

\<close>

lemma admS_eta_rep [intro, simp]:
  "fst (lr_rep r) \<in> admS"
  unfolding lr_rep_def lr_eta_rep_def
  apply simp
  apply rule
  apply (auto intro!: adm_disj simp: split_def)
   using adm_below_monic_exists[OF _ below_monic_pair[OF below_monic_ValN below_monic_cfcomp2[OF below_monic_unitK below_monic_ValKN]], where P="\<lambda>_. True"]
   apply (simp add: prod_eq_iff)
  using adm_below_monic_exists[OF _ below_monic_pair_split[OF below_monic_ValF below_monic_cfcomp2[OF below_monic_unitK below_monic_ValKF]], where P="\<lambda>x. x \<in> unlr (snd (snd r))"]
  apply (simp add: prod_eq_iff)
  done

lemma admS_theta_rep [intro, simp]:
  "snd (lr_rep r) \<in> admS"
proof
  show "\<bottom> \<in> snd (lr_rep r)"
    unfolding lr_rep_def lr_theta_rep_def
    by (cases r) simp
next
  show "adm (\<lambda>x. x \<in> snd (lr_rep r))"
    apply (rule admI)
    unfolding lr_rep_def lr_theta_rep_def
    apply (clarsimp simp: split_def)
    apply (rule admD)
      apply (rule adm_subst)
      apply force+
    done
qed

lemma mono_lr:
  shows "mono (lr :: 'o lflf)"
  apply (rule monoI)
  apply simp
  apply (simp add: lr_rep_def)
  apply (rule conjI)
   apply (force simp: lr_eta_rep_def split_def dual_less_eq_iff unlr_leq[symmetric])
  (* FIXME stuck with the projections on the product *)
  apply (auto simp: lr_theta_rep_def split_def dual_less_eq_iff unlr_leq[symmetric])
  apply (drule_tac x="(ae, bc)" in bspec)
   apply (case_tac a)
   apply (case_tac ab)
   apply (auto simp: unlr_leq[symmetric])
  done

(*>*)
end (* context at_least_two_elements *)

text\<open>

It takes some effort to set up the minimal invariant relating the two
pairs of domains. One might hope this would be easier using deflations
(which might compose) rather than ``copy'' functions (which certainly
don't).

We elide these as they are tedious.

\<close>
(*<*)

primrec
  ValD_copy_i :: "nat \<Rightarrow> ValD \<rightarrow> ValD"
where
  "ValD_copy_i 0 = \<bottom>"
| "ValD_copy_i (Suc n) = (\<Lambda> v. case v of ValF\<cdot>f \<Rightarrow> ValF\<cdot>(ValD_copy_i n oo f oo ValD_copy_i n) | ValTT \<Rightarrow> ValTT | ValFF \<Rightarrow> ValFF | ValN\<cdot>m \<Rightarrow> ValN\<cdot>m)"

abbreviation
  "ValD_copy_lub \<equiv> (\<Squnion>i. ValD_copy_i i)"

lemma ValD_copy_chain [intro, simp]:
  "chain ValD_copy_i"
proof(rule chainI)
  fix i show "ValD_copy_i i \<sqsubseteq> ValD_copy_i (Suc i)"
  proof(induct i)
    case (Suc i)
    { fix x
      have "ValD_copy_i (Suc i)\<cdot>x \<sqsubseteq> ValD_copy_i (Suc (Suc i))\<cdot>x"
      proof(cases x)
        case (ValF f) with Suc show ?thesis
          by (clarsimp simp: cfcomp1 cfun_below_iff monofun_cfun)
      qed simp_all }
    thus ?case by (simp add: cfun_below_iff)
  qed simp
qed

lemma ValD_copy_lub_ID:
  "ValD_copy_lub = ID"
proof -
  { fix x :: ValD
    fix i :: nat
    have "ValD_take i\<cdot>(ValD_copy_i i\<cdot>(ValD_take i\<cdot>x)) = ValD_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) thus ?case
        by (cases x) (simp_all add: cfun_map_def)
    qed simp }
  hence "\<And>x :: ValD. (\<Squnion>i. ValD_take i\<cdot>(ValD_copy_i i\<cdot>(ValD_take i\<cdot>x))) = (\<Squnion>i. ValD_take i\<cdot>x)"
    by (blast intro: lub_eq)
  thus ?thesis by (simp add: lub_distribs ValD.lub_take cfun_eq_iff)
qed

text\<open>

Continuations: we need to ensure the observation type is always the
same.

\<close>

definition
  KM_map :: "('o ValK \<rightarrow> 'o ValK) \<rightarrow> 'o ValKM \<rightarrow> 'o ValKM"
where
  "KM_map \<equiv> \<Lambda> f. cfun_map\<cdot>(cfun_map\<cdot>f\<cdot>ID)\<cdot>ID"

lemma KM_map_id [intro, simp]:
  "KM_map\<cdot>ID = ID"
  unfolding KM_map_def by (simp add: cfun_map_ID)

lemma KM_map_strict [intro, simp]:
  "KM_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
  unfolding KM_map_def by (simp add: cfun_map_def)

primrec
  ValK_copy_i :: "nat \<Rightarrow> 'o ValK \<rightarrow> 'o ValK"
where
  "ValK_copy_i 0 = \<bottom>"
| "ValK_copy_i (Suc n) = (\<Lambda> v. case v of ValKF\<cdot>f \<Rightarrow> ValKF\<cdot>(cfun_map\<cdot>(KM_map\<cdot>(ValK_copy_i n))\<cdot>(KM_map\<cdot>(ValK_copy_i n))\<cdot>f) | ValKTT \<Rightarrow> ValKTT | ValKFF \<Rightarrow> ValKFF | ValKN\<cdot>m \<Rightarrow> ValKN\<cdot>m)"

abbreviation
  "ValK_copy \<equiv> (\<Squnion>i. ValK_copy_i i)"

lemma ValK_copy_chain [intro, simp]:
  "chain (ValK_copy_i :: nat \<Rightarrow> 'o ValK \<rightarrow> 'o ValK)"
proof(rule chainI)
  fix i show "ValK_copy_i i \<sqsubseteq> (ValK_copy_i (Suc i) :: 'o ValK \<rightarrow> 'o ValK)"
  proof(induct i)
    case (Suc i)
    { fix x :: "'o ValK"
      have "ValK_copy_i (Suc i)\<cdot>x \<sqsubseteq> ValK_copy_i (Suc (Suc i))\<cdot>x"
      proof(cases x)
        case (ValKF f) with Suc show ?thesis by (clarsimp simp: monofun_cfun KM_map_def)
      qed simp_all }
    thus ?case by (simp add: cfun_below_iff)
  qed simp
qed

lemma ValK_copy_fix:
  "ValK_copy = (ID :: 'o ValK \<rightarrow> 'o ValK)"
proof -
  { fix x :: "'o ValK"
    fix i :: nat
    have "ValK_take i\<cdot>(ValK_copy_i i\<cdot>(ValK_take i\<cdot>x)) = ValK_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) thus ?case
        by (cases x) (simp_all add: KM_map_def cfun_map_def)
    qed simp }
  hence "\<And>x :: 'o ValK. (\<Squnion>i. ValK_take i\<cdot>(ValK_copy_i i\<cdot>(ValK_take i\<cdot>x))) = (\<Squnion>i. ValK_take i\<cdot>x)"
    by (blast intro: lub_eq)
  thus ?thesis by (simp add: lub_distribs ValK.lub_take cfun_eq_iff)
qed

lemma ValK_strict [intro, simp]:
  "ValK_copy\<cdot>\<bottom> = \<bottom>"
  by (simp add: ValK_copy_fix)

text\<open>

We need to respect the purported domain structure, and positive and
negative occurrences.

\<close>

fixrec
  ValD_copy_rec :: "((ValD \<rightarrow> ValD) \<times> ((ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)))
                  \<rightarrow> ((ValD \<rightarrow> ValD) \<times> ((ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)))"
where
  "ValD_copy_rec\<cdot>r =
     (\<Lambda> v. case v of ValF\<cdot>f \<Rightarrow> ValF\<cdot>(snd r\<cdot>f) | ValTT \<Rightarrow> ValTT | ValFF \<Rightarrow> ValFF | ValN\<cdot>n \<Rightarrow> ValN\<cdot>n,
      \<Lambda> f. cfun_map\<cdot>(strictify\<cdot>(fst r))\<cdot>(strictify\<cdot>(fst r))\<cdot>f)"

abbreviation
  ValD_copy_eta :: "nat \<Rightarrow> ValD \<rightarrow> ValD"
where
  "ValD_copy_eta i \<equiv> fst (iterate i\<cdot>ValD_copy_rec\<cdot>\<bottom>)"

abbreviation
  ValD_copy_theta :: "nat \<Rightarrow> (ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)"
where
  "ValD_copy_theta i \<equiv> snd (iterate i\<cdot>ValD_copy_rec\<cdot>\<bottom>)"

lemma ValD_copy_eta_theta_strict [intro, simp]:
  "ValD_copy_eta n\<cdot>\<bottom> = \<bottom>"
  "ValD_copy_theta n\<cdot>\<bottom> = \<bottom>"
  by (induct n) (simp_all add: cfun_map_def)

lemma ValD_copy_fix_strict [simp]:
  "fst (fix\<cdot>ValD_copy_rec)\<cdot>\<bottom> = \<bottom>"
  "snd (fix\<cdot>ValD_copy_rec)\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq, simp add: cfun_map_def)+

lemma ValD_copy_rec_ValD_copy_lub:
  "fix\<cdot>ValD_copy_rec = (ValD_copy_lub, cfun_map\<cdot>ValD_copy_lub\<cdot>ValD_copy_lub)" (is "?lhs = ?rhs")
proof(rule below_antisym)
  show "?lhs \<sqsubseteq> ?rhs"
    apply (rule fix_least)
    apply (simp add: eta_cfun strictify_cancel ValD_copy_lub_ID cfun_map_def ID_def)
    done
next
  { fix i have "ValD_copy_i i \<sqsubseteq> fst (fix\<cdot>ValD_copy_rec)"
    proof(induct i)
      case (Suc i) thus ?case
        apply -
        apply (subst fix_eq)
        apply (subst fix_eq)
        apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def)
        apply (intro monofun_cfun_fun monofun_cfun_arg)
        apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def cfun_below_iff)
        done
    qed simp }
  hence D: "ValD_copy_lub \<sqsubseteq> fst (fix\<cdot>ValD_copy_rec)" by (simp add: lub_below_iff)
  moreover
  from D
  have "cfun_map\<cdot>ValD_copy_lub\<cdot>ValD_copy_lub \<sqsubseteq> snd (fix\<cdot>ValD_copy_rec)"
    by (subst fix_eq) (simp add: eta_cfun strictify_cancel monofun_cfun)
  ultimately show "?rhs \<sqsubseteq> ?lhs" by (simp add: prod_belowI)
qed

lemma fix_ValD_copy_rec_ID:
  "fix\<cdot>ValD_copy_rec = (ID, ID)"
  using ValD_copy_rec_ValD_copy_lub ValD_copy_lub_ID cfun_map_ID
  by simp

fixrec
  ValK_copy_rec :: "(('o ValKM \<rightarrow> 'o ValKM) \<times> (('o ValKM \<rightarrow> 'o ValKM) \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM)))
                  \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM) \<times> (('o ValKM \<rightarrow> 'o ValKM) \<rightarrow> ('o ValKM \<rightarrow> 'o ValKM))"
where
  "ValK_copy_rec\<cdot>r =
     (\<Lambda> vm. KM_map\<cdot>(\<Lambda> v. case v of ValKF\<cdot>f \<Rightarrow> ValKF\<cdot>(snd r\<cdot>f) | ValKTT \<Rightarrow> ValKTT | ValKFF \<Rightarrow> ValKFF | ValKN\<cdot>a \<Rightarrow> ValKN\<cdot>a)\<cdot>vm,
      \<Lambda> f. cfun_map\<cdot>(strictify\<cdot>(fst r))\<cdot>(strictify\<cdot>(fst r))\<cdot>f)"

abbreviation
  ValK_copy_eta
where
  "ValK_copy_eta i \<equiv> fst (iterate i\<cdot>ValK_copy_rec\<cdot>\<bottom>)"

abbreviation
  ValK_copy_theta
where
  "ValK_copy_theta i \<equiv> snd (iterate i\<cdot>ValK_copy_rec\<cdot>\<bottom>)"

lemma ValK_copy_strict [intro, simp]:
  "ValK_copy_eta n\<cdot>\<bottom> = (\<bottom> :: 'o ValKM)"
  "ValK_copy_theta n\<cdot>\<bottom> = (\<bottom> :: 'o ValKM \<rightarrow> 'o ValKM)"
  by (induct n) (simp_all add: cfun_map_def)

lemma ValK_copy_fix_strict [simp]:
  "fst (fix\<cdot>ValK_copy_rec)\<cdot>\<bottom> = \<bottom>"
  "snd (fix\<cdot>ValK_copy_rec)\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq, simp add: cfun_map_def)+

lemma ValK_copy_rec_ValK_copy:
  "fix\<cdot>ValK_copy_rec
  = (KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK),
     cfun_map\<cdot>(KM_map\<cdot>ValK_copy)\<cdot>(KM_map\<cdot>ValK_copy))" (is "?lhs = ?rhs")
proof(rule below_antisym)
  show "?lhs \<sqsubseteq> ?rhs"
    apply (rule fix_least)
    apply (simp add: eta_cfun strictify_cancel cfun_map_def ID_def)
    apply (intro cfun_eqI)
    apply (simp add: KM_map_def cfun_map_def ValK_copy_fix eta_cfun)
    done
next
  { fix i
    have "KM_map\<cdot>(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
     and "(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> ValK_case\<cdot>(\<Lambda> f. ValKF\<cdot>(snd (fix\<cdot>ValK_copy_rec)\<cdot>f))\<cdot>ValKTT\<cdot>ValKFF\<cdot>ValKN"
    proof(induct i)
      case 0
      { case 1 show ?case
          apply (subst fix_eq)
          apply (auto iff: cfun_below_iff intro!: monofun_cfun_arg simp: KM_map_def cfun_map_def eta_cfun)
          done }
      { case 2 show ?case by simp }
    next
      case (Suc i)
      { case 1 from Suc show ?case
          apply -
          apply (subst fix_eq)
          apply (subst fix_eq)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro monofun_cfun_arg)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def)
          apply (intro monofun_cfun_arg)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 cfun_map_def)
          apply (intro cfun_belowI)
          apply (subst fix_eq)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 KM_map_def cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (subst fix_eq)
          apply (intro cfun_belowI)
          apply (simp add: eta_cfun strictify_cancel monofun_cfun cfcomp1 KM_map_def cfun_map_def)
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply simp
          apply (intro monofun_cfun)
          apply simp_all
          apply (intro cfun_belowI)
          apply simp
          apply (intro monofun_cfun)
          apply simp_all
          done }
      { case 2 from Suc show ?case
          apply -
          apply (subst fix_eq)
          apply (subst fix_eq)
          apply (auto simp: eta_cfun strictify_cancel cfcomp1 cfun_map_def KM_map_def cfun_below_iff intro!: monofun_cfun)
          done }
    qed }
  hence "(\<Squnion>i. KM_map\<cdot>(ValK_copy_i i :: 'o ValK \<rightarrow> 'o ValK)) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
    by (simp add: lub_below_iff)
  hence D: "KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK) \<sqsubseteq> fst (fix\<cdot>ValK_copy_rec)"
    by (simp add: contlub_cfun_arg[symmetric])
  from D
  have E: "cfun_map\<cdot>(KM_map\<cdot>(ValK_copy :: 'o ValK \<rightarrow> 'o ValK))\<cdot>(KM_map\<cdot>ValK_copy) \<sqsubseteq> snd (fix\<cdot>ValK_copy_rec)"
    apply (subst fix_eq)
    apply (simp add: eta_cfun strictify_cancel KM_map_def)
    apply (intro monofun_cfun)
    apply simp_all
    done
  show "?rhs \<sqsubseteq> ?lhs" by (simp add: prod_belowI D E)
qed

lemma fix_ValK_copy_rec_ID:
  "fix\<cdot>ValK_copy_rec = (ID, ID)"
  by (simp add: ValK_copy_rec_ValK_copy ValK_copy_fix cfun_map_ID)

lemma (in at_least_two_elements) min_inv_lr:
  assumes "fst ea\<cdot>\<bottom> = \<bottom>"
  assumes "fst eb\<cdot>\<bottom> = \<bottom>"
  assumes "eRSP ea eb R S"
  shows "eRSP (ValD_copy_rec\<cdot>ea) (ValK_copy_rec\<cdot>eb) (dual ((lr :: 'o lflf) (dual S, undual R))) (lr (R, S))"
  using assms some_non_bottom_element
  apply (simp add: split_def)
  apply (auto simp: split_def lr_rep_def lr_eta_rep_def lr_theta_rep_def KM_map_def cfun_map_def unitK_def)
  apply (force simp: cfun_map_def strictify_cancel unitK_def) (* FIXME obvious but auto misses it *)
  done

(*>*)
sublocale at_least_two_elements < F: DomSolP lr ValD_copy_rec ValK_copy_rec
  apply standard
         apply (rule mono_lr)
        apply (rule fix_ValD_copy_rec_ID)
       apply (rule fix_ValK_copy_rec_ID)
      apply (simp_all add: cfun_map_def)[4]
  apply (erule (2) min_inv_lr)
  done

subsection\<open>A retraction between the two definitions\<close>

text\<open>

We can use the relation to establish a strong connection between the
direct and continuation semantics.  All results depend on the
observation type being rich enough.

\<close>

context at_least_two_elements
begin

abbreviation mrel ("\<eta>: _ \<mapsto> _" [50, 51] 50) where
  "\<eta>: x \<mapsto> x' \<equiv> (x, x') \<in> unlr (fst F.delta)"

abbreviation vrel ("\<theta>: _ \<mapsto> _" [50, 51] 50) where
  "\<theta>: y \<mapsto> y' \<equiv> (y, y') \<in> unlr (snd F.delta)"
(*<*)
lemma F_bottom_triv [intro, simp]:
  "\<eta>: \<bottom> \<mapsto> \<bottom>"
  "\<theta>: \<bottom> \<mapsto> \<bottom>"
  by simp_all

lemma etaI [intro, simp]:
  "\<eta>: ValTT \<mapsto> unitK\<cdot>ValKTT"
  "\<eta>: ValFF \<mapsto> unitK\<cdot>ValKFF"
  "\<eta>: ValN\<cdot>n \<mapsto> unitK\<cdot>(ValKN\<cdot>n)"
  by (subst F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)+

lemma eta_F:
  "\<theta>: f \<mapsto> f' \<Longrightarrow> \<eta>: ValF\<cdot>f \<mapsto> unitK\<cdot>(ValKF\<cdot>f')"
apply (subst F.delta_sol)
apply simp
apply (subst lr_rep_def)
apply (fastforce simp: lr_eta_rep_def split_def)
done

lemma theta_F:
  "(\<And>x x'. \<eta>: x \<mapsto> x' \<Longrightarrow> \<eta>: f\<cdot>x \<mapsto> f'\<cdot>x') \<Longrightarrow> \<theta>: f \<mapsto> f'"
apply (subst F.delta_sol)
apply simp
apply (subst lr_rep_def)
apply (simp add: lr_theta_rep_def split_def)
done

lemma eta_induct[case_names bottom N F, consumes 1]:
  "\<lbrakk> \<eta>: x \<mapsto> x';
     \<lbrakk> x = \<bottom>; x' = \<bottom> \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValTT; x' = unitK\<cdot>ValKTT \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValFF; x' = unitK\<cdot>ValKFF \<rbrakk> \<Longrightarrow> P x x';
     \<And>n. \<lbrakk> x = ValN\<cdot>n; x' = unitK\<cdot>(ValKN\<cdot>n) \<rbrakk> \<Longrightarrow> P x x';
     \<And>f f'. \<lbrakk> x = ValF\<cdot>f; x' = unitK\<cdot>(ValKF\<cdot>f'); \<theta>: f \<mapsto> f' \<rbrakk> \<Longrightarrow> P x x'
   \<rbrakk> \<Longrightarrow> P x x'"
  apply (cases x)
      apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
     defer
     apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
    apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
   apply (subst (asm) F.delta_sol, simp, simp add: lr_rep_def lr_eta_rep_def)
  apply simp
  apply (subst (asm) F.delta_sol)
  apply simp
  apply (subst (asm) lr_rep_def)
  apply (subst (asm) lr_eta_rep_def)
  apply clarsimp
  done

lemma theta_induct[case_names F, consumes 1]:
  "\<lbrakk> \<theta>: f \<mapsto> f';
     (\<And>x x'. \<eta>: x \<mapsto> x' \<Longrightarrow> \<eta>: f\<cdot>x \<mapsto> f'\<cdot>x') \<Longrightarrow> P f f'
   \<rbrakk> \<Longrightarrow> P f f'"
  apply (subst (asm) F.delta_sol)
  apply simp
  apply (subst (asm) lr_rep_def)
  apply (subst (asm) lr_theta_rep_def)
  apply fastforce
  done

(*>*)
text\<open>

Theorem 1 from \citet{DBLP:conf/icalp/Reynolds74}.

\<close>

lemma AbsV_aux:
  assumes "\<eta>: ValF\<cdot>f \<mapsto> unitK\<cdot>(ValKF\<cdot>f')"
  shows "\<eta>: ValF\<cdot>(strictify\<cdot>f) \<mapsto> unitK\<cdot>(ValKF\<cdot>(\<Lambda> x c. x\<cdot>(\<Lambda> x'. f'\<cdot>(unitK\<cdot>x')\<cdot>c)))"
(*<*)
  apply (rule eta_F)
  apply (rule theta_F)
  using assms
  apply (rule eta_induct) (* FIXME special rule would help *)
  apply simp_all
  apply (drule injD[OF below_monic_inj[OF below_monic_unitK]])
  apply clarsimp
  apply (erule theta_induct)
  apply (erule eta_induct)
  apply (simp_all add: eta_cfun eta_F)
  done

(*>*)
text\<open>\<close>

theorem Theorem1:
  assumes "\<forall>v. \<eta>: \<rho>\<cdot>v \<mapsto> \<rho>'\<cdot>v"
  shows "\<eta>: evalD e\<cdot>\<rho> \<mapsto> evalK e\<cdot>\<rho>'"
(*<*)
using assms
proof(induct e arbitrary: \<rho> \<rho>')
  case App show ?case
    apply simp
    apply (simp add: appKM_def bindK_def)
    using App.hyps(1)[OF App(3)]
    apply (rule eta_induct)
      apply simp_all
    apply (simp add: eta_cfun)
    apply (erule theta_induct)
    using App.hyps(2)[OF App(3)]
    apply simp
    done
next
  case AbsN show ?case
    apply simp
    apply (rule eta_F)
    apply (rule theta_F)
    apply simp
    apply (rule AbsN.hyps)
    using AbsN(2)
    unfolding env_ext_def
    apply simp
    done
next
  case (AbsV v e \<rho> \<rho>')
  have "\<eta>: ValF\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>)) \<mapsto> unitK\<cdot>(ValKF\<cdot>(\<Lambda> x. evalK e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>')))"
    apply (rule eta_F)
    apply (rule theta_F)
    apply simp
    apply (rule AbsV.hyps)
    using AbsV(2)
    unfolding env_ext_def
    apply simp
    done
  thus ?case by (fastforce dest: AbsV_aux)
next
  case Fix thus ?case
    apply simp
    apply (rule parallel_fix_ind)
    apply (simp_all add: env_ext_def)
    done
next
  case Cond thus ?case
    apply (simp add: cond_def condK_def eta_cfun)
    using Cond(1)[OF Cond(4)]
    apply (rule eta_induct)
    apply simp_all
    done
next
  case Succ thus ?case
    apply (simp add: succ_def succK_def eta_cfun)
    using Succ(1)[OF Succ(2)]
    apply (rule eta_induct)
    apply simp_all
    done
next
  case Pred thus ?case
    apply (simp add: pred_def predK_def eta_cfun)
    using Pred(1)[OF Pred(2)]
    apply (rule eta_induct)
    apply (simp_all split: nat.split)
    done
next
  case IsZero thus ?case
    apply (simp add: isZero_def isZeroK_def eta_cfun)
    using IsZero(1)[OF IsZero(2)]
    apply (rule eta_induct)
    apply (simp_all split: nat.split)
    done
qed simp_all
(*>*)

end

text\<open>

The retraction between the two value and monadic value spaces.

Note we need to work with an observation type that can represent the
``explicit values'', i.e. @{typ "'o ValK"}.

\<close>

locale value_retraction =
  fixes VtoO :: "'o ValK \<rightarrow> 'o"
  fixes OtoV :: "'o \<rightarrow> 'o ValK"
  assumes OV: "OtoV oo VtoO = ID"

sublocale value_retraction < at_least_two_elements "VtoO\<cdot>(ValKN\<cdot>0)"
using OV by - (standard, simp add: injection_defined cfcomp1 cfun_eq_iff)

context value_retraction
begin

fun
  DtoKM_i :: "nat \<Rightarrow> ValD \<rightarrow> 'o ValKM"
and
  KMtoD_i :: "nat \<Rightarrow> 'o ValKM \<rightarrow> ValD"
where
  "DtoKM_i 0 = \<bottom>"
| "DtoKM_i (Suc n) = (\<Lambda> v. case v of
     ValF\<cdot>f \<Rightarrow> unitK\<cdot>(ValKF\<cdot>(cfun_map\<cdot>(KMtoD_i n)\<cdot>(DtoKM_i n)\<cdot>f))
   | ValTT \<Rightarrow> unitK\<cdot>ValKTT
   | ValFF \<Rightarrow> unitK\<cdot>ValKFF
   | ValN\<cdot>m \<Rightarrow> unitK\<cdot>(ValKN\<cdot>m))"

| "KMtoD_i 0 = \<bottom>"
| "KMtoD_i (Suc n) = (\<Lambda> v. case OtoV\<cdot>(v\<cdot>VtoO) of
     ValKF\<cdot>f \<Rightarrow> ValF\<cdot>(cfun_map\<cdot>(DtoKM_i n)\<cdot>(KMtoD_i n)\<cdot>f)
   | ValKTT \<Rightarrow> ValTT
   | ValKFF \<Rightarrow> ValFF
   | ValKN\<cdot>m \<Rightarrow> ValN\<cdot>m)"

abbreviation "DtoKM \<equiv> (\<Squnion>i. DtoKM_i i)"
abbreviation "KMtoD \<equiv> (\<Squnion>i. KMtoD_i i)"
(*<*)

lemma DtoKM_KMtoD_chain [intro, simp]:
  "chain DtoKM_i"
  "chain KMtoD_i"
proof -
  let ?C = "\<lambda>i. (DtoKM_i i, KMtoD_i i)"
  have "chain ?C"
  proof(rule chainI)
    fix i show "?C i \<sqsubseteq> ?C (Suc i)"
    proof(induct i)
      case (Suc i) show ?case
      proof(rule monofun_pair)
        show "DtoKM_i (Suc i) \<sqsubseteq> DtoKM_i (Suc (Suc i))"
        proof(rule cfun_belowI)
          fix x from Suc show "DtoKM_i (Suc i)\<cdot>x \<sqsubseteq> DtoKM_i (Suc (Suc i))\<cdot>x"
            by (cases x) (auto intro!: monofun_cfun simp: cfun_map_def cfun_below_iff)
        qed
        show "KMtoD_i (Suc i) \<sqsubseteq> KMtoD_i (Suc (Suc i))"
        proof(rule cfun_belowI)
          fix x from Suc show "KMtoD_i (Suc i)\<cdot>x \<sqsubseteq> KMtoD_i (Suc (Suc i))\<cdot>x"
            apply (simp add: eta_cfun)
            apply (intro monofun_cfun_fun monofun_cfun_arg)
            apply (intro cfun_belowI)
            apply (auto intro: monofun_cfun)
            done
        qed
      qed
    qed simp
  qed
  then show "chain DtoKM_i" "chain KMtoD_i"
    by (auto dest: ch2ch_fst ch2ch_snd)
qed
(*>*)

text\<open>

Lemma 1 from \citet{DBLP:conf/icalp/Reynolds74}.

\<close>

lemma Lemma1:
  "\<eta>: x \<mapsto> DtoKM\<cdot>x"
  "\<eta>: x \<mapsto> x' \<Longrightarrow> x = KMtoD\<cdot>x'"
(*<*)
proof -
  have K: "\<eta>: ValD_copy_i i\<cdot>x \<mapsto> DtoKM_i i\<cdot>x"
   and L: "\<eta>: x \<mapsto> x' \<Longrightarrow> ValD_copy_i i\<cdot>x = KMtoD_i i\<cdot>x'" for x x' i
  proof(induct i arbitrary: x x')
    case (Suc i)
    { case 1 show ?case
        apply (cases x)
          apply simp_all
        apply (rule eta_F)
        apply (rule theta_F)
        using Suc
        apply simp
        done }
    { case 2 thus ?case
        apply (induct rule: eta_induct)
          using OV
          apply (simp_all add: cfun_eq_iff retraction_strict)
        apply (clarsimp simp: cfun_eq_iff)
        apply (erule theta_induct)
        using Suc
        apply simp
        done }
  qed simp_all
  let ?C1 = "\<lambda>i. (ValD_copy_i i, DtoKM_i i)"
  let ?P1 = "\<lambda>f. \<eta>: (fst f)\<cdot>x \<mapsto> (snd f)\<cdot>x"
  have "adm ?P1" by (rule adm_subst) simp_all
  with K
  have "?P1 (\<Squnion>i. ValD_copy_i i, \<Squnion>i. DtoKM_i i)"
    using admD[where P="?P1" and Y="?C1"] lub_prod[where S="?C1"] by simp
  moreover
  { fix x :: ValD
    fix x' :: "'o ValKM"
    let ?C2 = "\<lambda>i. (ValD_copy_i i, KMtoD_i i)"
    let ?P2 = "\<lambda>f. (fst f)\<cdot>x = (snd f)\<cdot>x'"
    have "adm (\<lambda>f. ?P2 f)" by simp
    with L have "\<eta>: x \<mapsto> x' \<Longrightarrow> ?P2 (\<Squnion>i. ValD_copy_i i, \<Squnion>i. KMtoD_i i)"
      using admD[where P="?P2" and Y="?C2"] lub_prod[where S="?C2"]
      by simp }
  ultimately show
    "\<eta>: x \<mapsto> DtoKM\<cdot>x"
    "\<eta>: x \<mapsto> x' \<Longrightarrow> x = KMtoD\<cdot>x'"
      by (simp_all add: ValD_copy_lub_ID)
qed

(*>*)
text\<open>

Theorem 2 from \citet{DBLP:conf/icalp/Reynolds74}.

\<close>

theorem Theorem2: "evalD e\<cdot>\<rho> = KMtoD\<cdot>(evalK e\<cdot>(DtoKM oo \<rho>))"
using Lemma1(2)[OF Theorem1] Lemma1(1) by (simp add: cfcomp1)

end

text\<open>

\citet[Remark~48]{DBLP:journals/tcs/Filinski07} observes that there
will not be a retraction between direct and continuation semantics for
languages with richer notions of effects.

It should be routine to extend the above approach to the higher-order
backtracking language of \citet{DBLP:conf/icfp/WandV04}.

I wonder if it is possible to construct continuation semantics from
direct semantics as proposed by
\citet{DBLP:journals/jacm/SethiT80}. Roughly we might hope to lift a
retraction between two value domains to a retraction at higher types
by synthesising a suitable logical relation.

\<close>
(*<*)

end
(*>*)