theory tp67
imports Main  "~~/src/HOL/Library/Code_Target_Int" "~~/src/HOL/Library/Code_Char"
begin

(* Types des expressions, conditions et programmes (statement) *)
datatype expression= Constant int | Variable string | Sum expression expression | Sub expression expression

datatype condition= Eq expression expression

datatype statement= Seq statement statement |
                    Aff string expression |
                    Read string |
                    Print expression |
                    Exec expression |
                    If condition statement statement |
                    Skip
(* Un exemple d'expression *)

(* expr1= (x-10) *)
definition "expr1= (Sub (Variable ''x'') (Constant 10))"

(* Des exemples de programmes *)

(* p1= exec(0) *)
definition "p1= Exec (Constant 0)"

(* p2= {
        print(10)
        exec(0+0)
       }
*)

definition "p2= (Seq (Print (Constant 10)) (Exec (Sum (Constant 0) (Constant 0))))"

(* p3= {
         x:=0
         exec(x)
       }
*)

definition "p3= (Seq (Aff ''x'' (Constant 0)) (Exec (Variable ''x'')))"

(* p4= {
         read(x)
         print(x+1)
       }
*)
definition "p4= (Seq (Read ''x'') (Print (Sum (Variable ''x'') (Constant 1))))"

(* Le type des evenements soit X: execute, soit P: print *)
datatype event= X int | P int

(* les flux de sortie, d'entree et les tables de symboles *)

type_synonym outchan= "event list"
definition "el1= [X 1, P 10, X 0, P 20]"                   (* Un exemple de flux de sortie *)

type_synonym inchan= "int list"
definition "il1= [1,-2,10]"                                (* Un exemple de flux d'entree [1,-2,10]              *)

type_synonym symTable= "(string * int) list"
definition "(st1::symTable)= [(''x'',10),(''y'',12)]"      (* Un exemple de table de symbole *)

(* La fonction (partielle) de recherche dans une liste de couple, par exemple une table de symbole *)
datatype 'a option= None | Some 'a

fun assoc:: "'a \<Rightarrow> ('a * 'b) list \<Rightarrow> 'b option"
where
"assoc _ [] = None" |
"assoc x1 ((x,y)#xs)= (if x=x1 then Some(y) else (assoc x1 xs))"

fun change:: "('a * 'b) \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list"
where
"change _ [] = []" |
"change (x1,val1) ((x,y)#xs)= (if x=x1 then ((x1,val1)#xs) else (x,y)#(change (x1,val1) xs))"

(* Exemples de recherche dans une table de symboles *)

value "assoc ''x'' st1"     (* quand la variable est dans la table st1 *)
value "assoc ''z'' st1"     (* quand la variable n'est pas dans la table st1 *)

(* Evaluation des expressions par rapport a une table de symboles *)
fun evalE:: "expression \<Rightarrow> symTable \<Rightarrow> int"
where
"evalE (Constant s) e = s" |
"evalE (Variable s) e= (case (assoc s e) of None \<Rightarrow> -1 | Some(y) \<Rightarrow> y)" |
"evalE (Sum e1 e2) e= ((evalE e1 e) + (evalE e2 e))" |
"evalE (Sub e1 e2) e= ((evalE e1 e) - (evalE e2 e))"

(* Exemple d'évaluation d'expression *)

value "evalE expr1 st1"

(* Evaluation des conditions par rapport a une table de symboles *)
fun evalC:: "condition \<Rightarrow> symTable \<Rightarrow> bool"
where
"evalC (Eq e1 e2) t= ((evalE e1 t) = (evalE e2 t))"

value "evalC (Eq (Variable ''x'') (Constant 10)) st1"

(* Evaluation d'un programme par rapport a une table des symboles, a un flux d'entree et un flux de sortie.
   Rend un triplet: nouvelle table des symboles, nouveaux flux d'entree et sortie *)
fun evalS:: "statement \<Rightarrow> (symTable * inchan * outchan) \<Rightarrow> (symTable * inchan * outchan)"
where
"evalS Skip x=x" |
"evalS (Aff s e)  (t,inch,outch)=  (((s,(evalE e t))#t),inch,outch)" |
"evalS (If c s1 s2)  (t,inch,outch)=  (if (evalC c t) then (evalS s1 (t,inch,outch)) else (evalS s2 (t,inch,outch)))" |
"evalS (Seq s1 s2) (t,inch,outch)=
    (let (t2,inch2,outch2)= (evalS s1 (t,inch,outch)) in
        evalS s2 (t2,inch2,outch2))" |
"evalS (Read _) (t,[],outch)= (t,[],outch)" |
"evalS (Read s) (t,(x#xs),outch)= (((s,x)#t),xs,outch)" |
"evalS (Print e) (t,inch,outch)= (t,inch,((P (evalE e t))#outch))" |
"evalS (Exec e) (t,inch,outch)=
  (let res= evalE e t in
   (t,inch,((X res)#outch)))"

(* Exemples d'évaluation de programmes *)
(* Les programmes p1, p2, p3, p4 ont été définis plus haut *)
(* p1= exec(0) *)

value "evalS p1 (st1,il1,el1)" (* bad *)

(* ------------------------------------ *)
(* p2= {
        print(10)
        exec(0+0)
       }
*)

value "evalS p2 ([],[],[])" (* bad *)

(* ------------------------------------ *)
(* p3= {
         x:=0
         exec(x)
       }
*)

value "evalS p3 ([],[],[])" (* bad *)

(* ------------------------------------ *)
(* p4= {
         read(x)
         print(x+1)
       }
*)

value "evalS p4 ([],[10],[])"

definition "bad1= (Exec (Constant 0))"
definition "bad2= (Exec (Sub (Constant 2) (Constant 2)))"
definition "bad3= (Seq (Aff ''x'' (Constant 1)) (Seq (Print (Variable ''x'')) (Exec (Sub (Variable ''x'') (Constant 1)))))"
definition "bad4= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) Skip (Aff ''y'' (Constant 1))) (Exec (Sum (Variable ''y'') (Constant 1)))))" (*demande*)
definition "bad5= (Seq (Read ''x'') (Seq (Aff ''y'' (Sum (Variable ''x'') (Constant 2))) (Seq (If (Eq (Variable ''x'') (Sub (Constant 0) (Constant 1))) (Seq (Aff ''x'' (Sum (Variable ''x'') (Constant 2))) (Aff ''y'' (Sub (Variable ''y'') (Variable ''x'')))) (Seq (Aff ''x'' (Sub (Variable ''x'') (Constant 2))) (Aff ''y'' (Sub (Variable ''y'') (Variable ''x''))))) (Exec (Variable ''y'')))))"
definition "bad6= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''z'' (Constant 1)) (Aff ''z'' (Constant 0))) (Exec (Variable ''z''))))"
definition "bad7= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''z'' (Constant 0)) (Aff ''z'' (Constant 1))) (Exec (Variable ''z''))))"
definition "bad8= (Seq (Read ''x'') (Seq (Read ''y'') (If (Eq (Variable ''x'') (Variable ''y'')) (Exec (Constant 1)) (Exec (Constant 0)))))"
definition "ok0= (Seq (Aff ''x'' (Constant 1)) (Seq (Read ''y'') (Seq (If (Eq (Variable ''y'') (Constant 0)) (Seq (Print (Sum (Variable ''y'') (Variable ''x'')))
(Print (Variable ''x''))
) (Print (Variable ''y''))
) (Seq (Aff ''x'' (Constant 1)) (Seq (Print (Variable ''x''))
 (Seq (Aff ''x'' (Constant 2)) (Seq (Print (Variable ''x''))
 (Seq (Aff ''x'' (Constant 3)) (Seq (Print (Variable ''x''))
 (Seq (Read ''y'') (Seq (If (Eq (Variable ''y'') (Constant 0)) (Aff ''z'' (Sum (Variable ''x'') (Variable ''x''))) (Aff ''z'' (Sub (Variable ''x'') (Variable ''y'')))) (Print (Variable ''z''))
)))))))))))"
definition "ok1= (Seq (Aff ''x'' (Constant 1)) (Seq (Print (Sum (Variable ''x'') (Variable ''x'')))
 (Seq (Exec (Constant 10)) (Seq (Read ''y'') (If (Eq (Variable ''y'') (Constant 0)) (Exec (Constant 1)) (Exec (Constant 2)))))))"
definition "ok2= (Exec (Variable ''y''))"
definition "ok3= (Seq (Read ''x'') (Exec (Sum (Variable ''y'') (Constant 2))))"
definition "ok4= (Seq (Aff ''x'' (Constant 0)) (Seq (Aff ''x'' (Sum (Variable ''x'') (Constant 20))) (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''z'' (Constant 0)) (Aff ''z'' (Constant 4))) (Seq (Exec (Variable ''z'')) (Exec (Variable ''x''))))))"
definition "ok5= (Seq (Read ''x'') (Seq (Aff ''x'' (Constant 4)) (Exec (Variable ''x''))))"
definition "ok6= (Seq (If (Eq (Constant 1) (Constant 2)) (Aff ''x'' (Constant 0)) (Aff ''x'' (Constant 1))) (Exec (Variable ''x'')))"
definition "ok7= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''x'' (Constant 1)) (If (Eq (Variable ''x'') (Constant 4)) (Aff ''x'' (Constant 1)) (Aff ''x'' (Constant 1)))) (Exec (Variable ''x''))))"
definition "ok8= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''x'' (Constant 1)) (Aff ''x'' (Constant 2))) (Exec (Sub (Variable ''x'') (Constant 3)))))"
definition "ok9= (Seq (Read ''x'') (Seq (Read ''y'') (If (Eq (Sum (Variable ''x'') (Variable ''y'')) (Constant 0)) (Exec (Constant 1)) (Exec (Sum (Variable ''x'') (Sum (Variable ''y'') (Sum (Variable ''y'') (Variable ''x''))))))))"
definition "ok10= (Seq (Read ''x'') (If (Eq (Variable ''x'') (Constant 0)) (Exec (Constant 1)) (Exec (Variable ''x''))))"
definition "ok11= (Seq (Read ''x'') (Seq (If (Eq (Variable ''x'') (Constant 0)) (Aff ''x'' (Sum (Variable ''x'') (Constant 1))) Skip) (Exec (Variable ''x''))))"
definition "ok12= (Seq (Aff ''x'' (Constant 1)) (Seq (Read ''z'') (If (Eq (Variable ''z'') (Constant 0)) (Exec (Variable ''y'')) (Exec (Variable ''z'')))))"
definition "ok13= (Seq (Aff ''z'' (Constant 4)) (Seq (Aff ''x'' (Constant 1)) (Seq (Read ''y'') (Seq (Aff ''x'' (Sum (Variable ''x'') (Sum (Variable ''z'') (Variable ''x'')))) (Seq (Aff ''z'' (Sum (Variable ''z'') (Variable ''x''))) (Seq (If (Eq (Variable ''y'') (Constant 1)) (Aff ''x'' (Sub (Variable ''x'') (Variable ''y''))) Skip) (Seq (If (Eq (Variable ''y'') (Constant 0)) (Seq (Aff ''y'' (Sum (Variable ''y'') (Constant 1))) (Exec (Variable ''x''))) Skip) (Exec (Variable ''y'')))))))))"
definition "ok14= (Seq (Read ''x'') (Seq (Read ''y'') (If (Eq (Sum (Variable ''x'') (Variable ''y'')) (Constant 0)) (Exec (Constant 1)) (Exec (Sum (Variable ''x'') (Variable ''y''))))))"

definition "ok15= (Seq (Read ''x'') (Seq (Read ''y'') (If (Eq (Sum (Variable ''x'') (Variable ''y'')) (Constant 0)) (Exec (Constant 1)) (Exec (Sum (Variable ''x'') (Variable ''y''))))))"

(* Le TP commence ici! *)

fun BAD:: "(symTable * inchan * outchan ) \<Rightarrow> bool"
where
"BAD (t , inch , outch) = (List.member  outch (X 0))"

fun san1 :: "statement \<Rightarrow> bool"
where
 "san1 (Exec e) = False"
|"san1 (If _ s1 s2)  =( (san1 s1) \<and> (san1 s2))"
|"san1 (Seq s1 s2) =( (san1 s1) \<and> (san1 s2)) "
|"san1 _ = True"

lemma "(san1 sta) \<longrightarrow> (\<forall> (inch::inchan). \<not>(BAD (evalS sta ([],inch,[]))))"
(*quickcheck [tester=narrowing,timeout=18000]*)
sorry

fun san2 :: "statement \<Rightarrow> bool"
where
 "san2 (Exec (Constant a))  =(if( ( a) = (0::int)) then False else True)"
|"san2 (Exec e)  =False"
|"san2 (If _ s1 s2)  =( (san2 s1) \<and> (san2 s2))"
|"san2 (Seq s1 s2) =( (san2 s1) \<and> (san2 s2)) "
|"san2 _ = True"

lemma "(san2 sta) \<longrightarrow> (\<forall> (inch::inchan). \<not>(BAD (evalS sta ([],inch,[]))))"
(*quickcheck [tester=narrowing,timeout=18000]*)
sorry

datatype absInt = Integer int|Any
datatype absCond = Ok|Ko|Unk
type_synonym symTableAbs= "(string * absInt  ) list"

(*
Valeur X sur Rien \<longrightarrow> Valeur X
Valeur X sur Valeur Y \<longrightarrow>  Any
Valeur X sur Valeur X \<longrightarrow> Valeur X
Any sur Valeur X \<longrightarrow> Any
Valeur X sur Any \<longrightarrow> Any

Politique d'ajout des variables dans une sta lors d'une fusion de deux sta pour un if
*)
fun ajoutVarFusion:: "(string*absInt) \<Rightarrow> symTableAbs  \<Rightarrow> symTableAbs "
where
 "ajoutVarFusion (x,v) [] = [(x,v)]"
|"ajoutVarFusion (x1,v1) ((x2,v2) # va) = (if(x1=x2) then (if( v2 = v1) then ((x2,v2)#va)else ((x2,Any)#va) ) else ( (x2,v2)#(ajoutVarFusion (x1,v1) va) ))"

lemma avf1:"\<exists> w.(assoc x  (ajoutVarFusion (x,c) stv)) = Some(w) "
apply (induct stv)
apply auto
done

lemma avf2:"(assoc x  (ajoutVarFusion (x,Any) stv)) = Some(Any) "
apply (induct stv)
apply auto
done

lemma avf3:"((assoc (x) stv) = Some(Integer v)) \<longrightarrow> ((assoc x  (ajoutVarFusion (x,(Integer v)) stv )) = Some(Integer v) )"
apply (induct stv)
apply auto
done

lemma avf4:"((assoc (x) stv) = Some(Integer v1)) \<and> (v1\<noteq>v2) \<longrightarrow> ((assoc x  (ajoutVarFusion (x,(Integer v2)) stv )) = Some(Any) )"
apply (induct stv)
apply auto
by (smt absInt.inject assoc.simps(2) tp67.option.inject)

(*  le sta2 demande à la sta1 ce qui lui manque*)
fun preFusionTable:: "symTableAbs \<Rightarrow> symTableAbs \<Rightarrow> symTableAbs"
where
"preFusionTable ((x1,v1)#xs) stv = (case (assoc x1 stv) of None \<Rightarrow> preFusionTable xs (ajoutVarFusion (x1,(Integer (-1))) stv) | Some(y) \<Rightarrow> preFusionTable xs stv )"|
"preFusionTable [] b = b"

lemma pft1:"\<exists> w.((assoc x stv1) = Some(w) \<or> (assoc x stv2) = Some(w))  \<longrightarrow> (assoc x (preFusionTable stv1 stv2) = Some(w)) \<and> ( assoc x (preFusionTable stv2 stv1) = Some(w))"
nitpick
sorry

lemma pft2:"((assoc x (stv1) = None) \<and> (assoc x (stv2) = Some(w) )) \<longrightarrow>assoc x (preFusionTable stv2 stv1) = Some(Integer (-1))  "
(*quickcheck[tester=narrowing,timeout=3600]*)
sorry

(* fusion les tables lors d'un if*)
fun fusionTable:: "symTableAbs \<Rightarrow> symTableAbs \<Rightarrow> symTableAbs"
where
"fusionTable ((x,e1)#xs) b =(ajoutVarFusion ( x,e1) (fusionTable (xs) b) )"|
"fusionTable [] b = b"

(* main prépare les sta avant de les fusionner lors d'un if*)
fun ifsymTableAbs ::"symTableAbs \<Rightarrow> symTableAbs \<Rightarrow> symTableAbs"
where
"ifsymTableAbs a b = fusionTable (preFusionTable a b ) (preFusionTable b a)"

lemma "\<exists> w.(((assoc x stv1) = Some(w) \<or> (assoc x stv2) = Some(w))\<longrightarrow>  ((assoc x (ifsymTableAbs stv1 stv2)) = Some(w)) \<and>  ((assoc x (ifsymTableAbs stv2 stv1)) = Some(w))  ) "
nitpick
sorry

fun absPlus::" absInt \<Rightarrow> absInt \<Rightarrow> absInt"
where
 "absPlus Any _ = Any "
|"absPlus _ Any = Any "
|"absPlus (Integer i1) (Integer i2)  = (Integer (i1+i2))  "

fun absMoins::" absInt \<Rightarrow> absInt \<Rightarrow> absInt"
where
 "absMoins Any _ = Any "
|"absMoins _ Any = Any "
|"absMoins (Integer i1) (Integer i2)  = (Integer (i1-i2))  "

fun absExpression ::"expression \<Rightarrow> symTableAbs \<Rightarrow>  absInt"
where
 "absExpression (Constant i1) _ = (Integer (i1)) "
|"absExpression (Variable v) s = (case (assoc v s) of None \<Rightarrow> (Integer (-1)) | Some(y) \<Rightarrow> y)"
|"absExpression (Sum v va) s =  (absPlus (absExpression v s) (absExpression va s))"
|"absExpression (Sub v va) s = (absMoins (absExpression v s) (absExpression va s))"

(* savoir si une condition peut etre verifier ou pas*)
fun absCondition ::"condition \<Rightarrow>symTableAbs \<Rightarrow> absCond"
where
 "absCondition (Eq x y) t = (if( ( (absExpression x t) = Any)  \<or>  ((absExpression y t) = Any)) then Unk else (if ((absExpression x t) = (absExpression y t)) then Ok else Ko)) "

fun san3 :: "statement \<Rightarrow> symTableAbs \<Rightarrow> (symTableAbs*bool)"
where
"san3 Skip t =(t, True)"
|"san3 (Seq s1 s2) t =( let (t1,bol) = (san3 s1 t) in (if(bol)then (san3 s2 t1) else (t1,False)) ) "
|"san3 (Aff v e) t =   ((v,(absExpression e t))#t,True) "
|"san3 (Print v) t = (t,True) "
|"san3 (Read s ) t =  ((s,Any)#t,True) "
|"san3 (If c s1 s2) t =(if((absCondition c t) = Unk) then (( let (t1,bol1) = (san3 s1 t) in (let (t2,bol2) = (san3 s2 t) in((ifsymTableAbs t1 t2,bol1 \<and> bol2) ))))else  (if((absCondition c t) = Ko) then (san3 s2 t) else (san3 s1 t)) )"
|"san3 (Exec e) t = (if(( (absExpression e t) = Integer 0) \<or> (absExpression e t) = Any) then (t,False) else  (t,True)) "

fun san:: "statement \<Rightarrow> bool"
where
"san s= (let (_,b) = san3 s [] in b)"

lemma "(san sta) \<longrightarrow> (\<forall> inch. \<not>(BAD (evalS sta ([],inch,[]))))"
(*quickcheck [tester=narrowing,timeout=18000]*)(* ne sert à rien*)
sorry

(* ----- Restriction de l'export Scala (Isabelle 2014) -------*)
(* ! ! !  NE PAS MODIFIER ! ! ! *)
(* Suppression de l'export des abstract datatypes (Isabelle 2014) *)

code_reserved Scala
  expression condition statement
code_printing
  type_constructor expression \<rightharpoonup> (Scala) "expression"
  | constant Constant \<rightharpoonup> (Scala) "Constant"
  | constant Variable \<rightharpoonup> (Scala) "Variable"
  | constant Sum \<rightharpoonup> (Scala) "Sum"
  | constant Sub \<rightharpoonup> (Scala) "Sub"

  | type_constructor condition \<rightharpoonup> (Scala) "condition"
  | constant Eq \<rightharpoonup> (Scala) "Eq"

  | type_constructor statement \<rightharpoonup> (Scala) "statement"
  | constant Seq \<rightharpoonup> (Scala) "Seq"
  | constant Aff \<rightharpoonup> (Scala) "Aff"
  | constant Read \<rightharpoonup> (Scala) "Read"
  | constant Print \<rightharpoonup> (Scala) "Print"
  | constant Exec \<rightharpoonup> (Scala) "Exec"
  | constant If \<rightharpoonup> (Scala) "If"
  | constant Skip \<rightharpoonup> (Scala) "Skip"
  | code_module "" \<rightharpoonup> (Scala)

{*// Code generated by Isabelle
package tp67

import utilities.Datatype._
// automatic conversion of utilities.Datatype.Int.int to Int.int
object AutomaticConversion{
	implicit def int2int(i:utilities.Datatype.Int.int):Int.int =
			i match {
			case utilities.Datatype.Int.int_of_integer(i)=>Int.int_of_integer(i)
	}
}
import AutomaticConversion._
*}

(* Directive pour l'exportation de l'analyseur *)
export_code san in Scala
 file "/home/kwodhan/workspace/san.scala"   (* à adapter en fonction du chemin de votre projet TP67 *)

end


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

section{*Booleans in Zermelo-Fraenkel Set Theory*}

theory Bool imports pair begin

abbreviation
  one  ("1") where
  "1 == succ(0)"

abbreviation
  two  ("2") where
  "2 == succ(1)"

text{*2 is equal to bool, but is used as a number rather than a type.*}

definition "bool == {0,1}"

definition "cond(b,c,d) == if(b=1,c,d)"

definition "not(b) == cond(b,0,1)"

definition
  "and"       :: "[i,i]=>i"      (infixl "and" 70)  where
    "a and b == cond(a,b,0)"

definition
  or          :: "[i,i]=>i"      (infixl "or" 65)  where
    "a or b == cond(a,1,b)"

definition
  xor         :: "[i,i]=>i"      (infixl "xor" 65) where
    "a xor b == cond(a,not(b),b)"

lemmas bool_defs = bool_def cond_def

lemma singleton_0: "{0} = 1"
by (simp add: succ_def)

(* Introduction rules *)

lemma bool_1I [simp,TC]: "1 \<in> bool"
by (simp add: bool_defs )

lemma bool_0I [simp,TC]: "0 \<in> bool"
by (simp add: bool_defs)

lemma one_not_0: "1\<noteq>0"
by (simp add: bool_defs )

(** 1=0 ==> R **)
lemmas one_neq_0 = one_not_0 [THEN notE]

lemma boolE:
    "[| c: bool;  c=1 ==> P;  c=0 ==> P |] ==> P"
by (simp add: bool_defs, blast)

(** cond **)

(*1 means true*)
lemma cond_1 [simp]: "cond(1,c,d) = c"
by (simp add: bool_defs )

(*0 means false*)
lemma cond_0 [simp]: "cond(0,c,d) = d"
by (simp add: bool_defs )

lemma cond_type [TC]: "[| b: bool;  c: A(1);  d: A(0) |] ==> cond(b,c,d): A(b)"
by (simp add: bool_defs, blast)

(*For Simp_tac and Blast_tac*)
lemma cond_simple_type: "[| b: bool;  c: A;  d: A |] ==> cond(b,c,d): A"
by (simp add: bool_defs )

lemma def_cond_1: "[| !!b. j(b)==cond(b,c,d) |] ==> j(1) = c"
by simp

lemma def_cond_0: "[| !!b. j(b)==cond(b,c,d) |] ==> j(0) = d"
by simp

lemmas not_1 = not_def [THEN def_cond_1, simp]
lemmas not_0 = not_def [THEN def_cond_0, simp]

lemmas and_1 = and_def [THEN def_cond_1, simp]
lemmas and_0 = and_def [THEN def_cond_0, simp]

lemmas or_1 = or_def [THEN def_cond_1, simp]
lemmas or_0 = or_def [THEN def_cond_0, simp]

lemmas xor_1 = xor_def [THEN def_cond_1, simp]
lemmas xor_0 = xor_def [THEN def_cond_0, simp]

lemma not_type [TC]: "a:bool ==> not(a) \<in> bool"
by (simp add: not_def)

lemma and_type [TC]: "[| a:bool;  b:bool |] ==> a and b \<in> bool"
by (simp add: and_def)

lemma or_type [TC]: "[| a:bool;  b:bool |] ==> a or b \<in> bool"
by (simp add: or_def)

lemma xor_type [TC]: "[| a:bool;  b:bool |] ==> a xor b \<in> bool"
by (simp add: xor_def)

lemmas bool_typechecks = bool_1I bool_0I cond_type not_type and_type
                         or_type xor_type

subsection{*Laws About 'not' *}

lemma not_not [simp]: "a:bool ==> not(not(a)) = a"
by (elim boolE, auto)

lemma not_and [simp]: "a:bool ==> not(a and b) = not(a) or not(b)"
by (elim boolE, auto)

lemma not_or [simp]: "a:bool ==> not(a or b) = not(a) and not(b)"
by (elim boolE, auto)

subsection{*Laws About 'and' *}

lemma and_absorb [simp]: "a: bool ==> a and a = a"
by (elim boolE, auto)

lemma and_commute: "[| a: bool; b:bool |] ==> a and b = b and a"
by (elim boolE, auto)

lemma and_assoc: "a: bool ==> (a and b) and c  =  a and (b and c)"
by (elim boolE, auto)

lemma and_or_distrib: "[| a: bool; b:bool; c:bool |] ==>
       (a or b) and c  =  (a and c) or (b and c)"
by (elim boolE, auto)

subsection{*Laws About 'or' *}

lemma or_absorb [simp]: "a: bool ==> a or a = a"
by (elim boolE, auto)

lemma or_commute: "[| a: bool; b:bool |] ==> a or b = b or a"
by (elim boolE, auto)

lemma or_assoc: "a: bool ==> (a or b) or c  =  a or (b or c)"
by (elim boolE, auto)

lemma or_and_distrib: "[| a: bool; b: bool; c: bool |] ==>
           (a and b) or c  =  (a or c) and (b or c)"
by (elim boolE, auto)

definition
  bool_of_o :: "o=>i" where
   "bool_of_o(P) == (if P then 1 else 0)"

lemma [simp]: "bool_of_o(False) = 0"
by (simp add: bool_of_o_def)

lemma [simp,TC]: "bool_of_o(P) \<in> bool"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 1) \<longleftrightarrow> P"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 0) \<longleftrightarrow> ~P"
by (simp add: bool_of_o_def)

end


theory EigbyzDefs
imports "../HOModel"
begin

section \<open>Verification of the \eigbyz{} Consensus Algorithm\<close>

text \<open>
  Lynch~\<^cite>\<open>"lynch:distributed"\<close> presents \eigbyz{}, a version of
  the \emph{exponential information gathering} algorithm tolerating
  Byzantine faults, that works in $f$ rounds, and that was originally
  introduced in~\<^cite>\<open>"bar-noy:shifting-gears"\<close>.

  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm is parameterized by $f$, which represents the number of
  rounds and the height of the tree data structure (see below).
\<close>

axiomatization f::nat
where f: "f < N"
(* NB: couldn't turn this into a locale, since f is used in the typedef below *)

subsection \<open>Tree Data Structure\<close>

text \<open>
  The algorithm relies on propagating information about the initially proposed
  values among all the processes. This information is stored in trees whose
  branches are labeled by lists of (distinct) processes. For example, the
  interpretation of an entry \<open>[p,q] \<mapsto> Some v\<close> is that the current
  process heard from process \<open>q\<close> that it had heard from process \<open>p\<close>
  that its proposed value is \<open>v\<close>. The value initially proposed by the process
  itself is stored at the root of the tree.

  We introduce the type of \emph{labels}, which encapsulate lists of distinct
  process identifiers and whose length is at most \<open>f+1\<close>.
\<close>

definition "Label = {xs::Proc list. length xs \<le> Suc f \<and> distinct xs}"
typedef Label = Label
  by (auto simp: Label_def intro: exI[where x= "[]"])  \<comment> \<open>the empty list is a label\<close>

text \<open>There is a finite number of different labels.\<close>

lemma finite_Label: "finite Label"
proof -
  have "Label \<subseteq> {xs. set xs \<subseteq> (UNIV::Proc set) \<and> length xs \<le> Suc f}"
    by (auto simp: Label_def)
  moreover
  have "finite {xs. set xs \<subseteq> (UNIV::Proc set) \<and> length xs \<le> Suc f}"
    by (rule finite_lists_length_le) auto
  ultimately
  show ?thesis by (auto elim: finite_subset)
qed

lemma finite_UNIV_Label: "finite (UNIV::Label set)"
proof -
  from finite_Label have "finite (Abs_Label ` Label)" by simp
  moreover
  {
    fix l::Label
    have "l \<in> Abs_Label ` Label"
      by (rule Abs_Label_cases) auto
  }
  hence "(UNIV::Label set) = (Abs_Label ` Label)" by auto
  ultimately show ?thesis by simp
qed

lemma finite_Label_set [iff]: "finite (S :: Label set)"
  using finite_UNIV_Label by (auto intro: finite_subset)

text \<open>Utility functions on labels.\<close>

definition root_node where
  "root_node \<equiv> Abs_Label []"

definition length_lbl where
  "length_lbl l \<equiv> length (Rep_Label l)"
(* Don't declare the following [simp] because it would then be simplified away from
   hypotheses, whereas it can be useful for arithmetic reasoning. *)
lemma length_lbl [intro]: "length_lbl l \<le> Suc f"
  unfolding length_lbl_def using Label_def Rep_Label by auto

definition is_leaf where
 "is_leaf l \<equiv> length_lbl l = Suc f"

definition last_lbl where
  "last_lbl l \<equiv> last (Rep_Label l)"

definition butlast_lbl where
  "butlast_lbl l \<equiv> Abs_Label (butlast (Rep_Label l))"

definition set_lbl where
  "set_lbl l = set (Rep_Label l)"

text \<open>
  The children of a non-leaf label are all possible extensions of that label.
\<close>
(**
definition children where
  "children t \<equiv> { s . s \<noteq> root_node \<and> t = butlast_lbl s }"
**)

definition children where
  "children l \<equiv>
   if is_leaf l
   then {}
   else { Abs_Label (Rep_Label l @ [p]) | p . p \<notin> set_lbl l }"

subsection \<open>Model of the Algorithm\<close>

text \<open>
  The following record models the local state of a process.
\<close>

record 'val pstate =
  vals :: "Label \<Rightarrow> 'val option"
  newvals :: "Label \<Rightarrow> 'val"
  decide :: "'val option"

text \<open>
  Initially, no values are assigned to non-root labels, and an arbitrary value
  is assigned to the root: that value is interpreted as the initial proposal of
  the process. No decision has yet been taken, and the \<open>newvals\<close> field
  is unconstrained.
\<close>

definition EIG_initState (*::"Proc \<Rightarrow> 'val pstate \<Rightarrow> bool"*) where
  "EIG_initState p st \<equiv>
     (\<forall>l. (vals st l = None) = (l \<noteq> root_node))
   \<and> decide st = None"

type_synonym 'val Msg = "Label \<Rightarrow> 'val option"

text \<open>
  At every round, every process sends its current \<open>vals\<close> tree to all processes.
  In fact, only the level of the tree corresponding to the round number
  is used (cf. definition of \<open>extend_vals\<close> below).
\<close>

definition EIG_sendMsg (*:: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val Msg"*) where
  "EIG_sendMsg r p q st \<equiv> vals st"

text \<open>
  During the first \<open>f-1\<close> rounds, every process extends its
  tree \<open>vals\<close> according to the values received in the round.
  No decision is taken.
\<close>

definition extend_vals where
  "extend_vals r p st msgs st' \<equiv>
   vals st' = (\<lambda> l.
      if length_lbl l = Suc r \<and> msgs (last_lbl l) \<noteq> None
      then (the (msgs (last_lbl l))) (butlast_lbl l)
      else if length_lbl l = Suc r \<and> msgs (last_lbl l) = None then None
      else vals st l)"

definition next_main where
  "next_main r p st msgs st' \<equiv> extend_vals r p st msgs st' \<and> decide st' = None"

text \<open>
  In the final round, in addition to extending the tree as described previously,
  processes construct the tree \<open>newvals\<close>, starting
  at the leaves. The values at the leaves are copied from \<open>vals\<close>,
  except that missing values \<open>None\<close> are replaced by the default value
  \<open>undefined\<close>. Moving up, if there exists a majority value among the
  children, it is assigned to the parent node, otherwise the parent node
  receives the default value \<open>undefined\<close>. The decision is set to the
  value computed for the root of the tree.
\<close>

fun fixupval :: "'val option \<Rightarrow> 'val" where
  "fixupval None = undefined"
| "fixupval (Some v) = v"

definition has_majority :: "'val \<Rightarrow> ('a \<Rightarrow> 'val) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "has_majority v g S \<equiv> card {e \<in> S. g e = v} > (card S) div 2"

definition check_newvals :: "'val pstate \<Rightarrow> bool" where
  "check_newvals st \<equiv>
   \<forall>l. is_leaf l \<and> newvals st l = fixupval (vals st l)
     \<or> \<not>(is_leaf l) \<and>
       ( (\<exists>w. has_majority w (newvals st) (children l) \<and> newvals st l = w)
       \<or> (\<not>(\<exists>w. has_majority w (newvals st) (children l))
             \<and> newvals st l = undefined))"

definition next_end where
  "next_end r p st msgs st' \<equiv>
     extend_vals r p st msgs st'
   \<and> check_newvals st'
   \<and> decide st' = Some (newvals st' root_node)"

text \<open>
  The overall next-state relation is defined such that every process applies
  \<open>nextMain\<close> during rounds \<open>0\<close>, \ldots, \<open>f-1\<close>, and applies
  \<open>nextEnd\<close> during round \<open>f\<close>. After that, the algorithm terminates
  and nothing changes anymore.
\<close>
definition EIG_nextState where
  "EIG_nextState r \<equiv>
   if r < f then next_main r
   else if r = f then next_end r
   else (\<lambda>p st msgs st'. st' = st)"

subsection \<open>Communication Predicate for \eigbyz\<close>

text \<open>
  The secure kernel \<open>SKr\<close> w.r.t. given HO and SHO collections consists
  of the process from which every process receives the correct message.
\<close>

definition SKr :: "Proc HO \<Rightarrow> Proc HO \<Rightarrow> Proc set" where
  "SKr HO SHO \<equiv> { q . \<forall>p. q \<in> HO p \<inter> SHO p}"

text \<open>
  The secure kernel \<open>SK\<close> of an entire execution (i.e., for sequences of
  HO and SHO collections) is the intersection of the secure kernels for
  all rounds. Obviously, only the first \<open>f\<close> rounds really matter,
  since the algorithm terminates after that.
\<close>

definition SK :: "(nat \<Rightarrow> Proc HO) \<Rightarrow> (nat \<Rightarrow> Proc HO) \<Rightarrow> Proc set" where
  "SK HOs SHOs \<equiv> {q. \<forall>r. q \<in> SKr (HOs r) (SHOs r)}"

text \<open>
  The round-by-round predicate requires that the secure kernel at every round
  contains more than \<open>(N+f) div 2\<close> processes.
\<close>

definition EIG_commPerRd where
  "EIG_commPerRd HO SHO \<equiv> card (SKr HO SHO) > (N + f) div 2"

text \<open>
  The global predicate requires that the secure kernel for the entire
  execution contains at least \<open>N-f\<close> processes. Messages from these
  processes are always correctly received by all processes.
\<close>

definition EIG_commGlobal where
  "EIG_commGlobal HOs SHOs \<equiv> card (SK HOs SHOs) \<ge> N - f"

text \<open>
  The above communication predicates differ from Lynch's presentation of
  \eigbyz{}. In fact, the algorithm was originally designed for synchronous
  systems with reliable links and at most \<open>f\<close> faulty processes.
  In such a system, every process receives the correct message from at least
  the non-faulty processes at every round, and therefore the global predicate
  \<open>EIG_commGlobal\<close> is satisfied. The standard correctness
  proof assumes that $N>3f$, and therefore $N - f > (N + f) \div 2$.
  Since moreover, for any $r$, we obviously have
  \[
   \bigg(\bigcap_{p \in \Pi, r' \in \nat}\!\!\!\! SHO(p,r')\bigg)
   \ \subseteq\ \bigg(\bigcap_{p \in \Pi} SHO(p,r)\bigg),
  \]
  it follows that any execution of \eigbyz{} where $N>3f$ also satisfies
  \<open>EIG_commPerRd\<close> at any round. The standard correctness hypotheses thus imply
  our communication predicates.

  However, our proof shows that \eigbyz{} can indeed tolerate more
  transient faults than the standard bound can express. For example, consider the
  case where $N=5$ and $f=2$. Our predicates are satisfied in
  executions where two processes exhibit transient faults, but never fail
  simultaneously. Indeed, in such an execution, every process receives four
  correct messages at every round, hence \<open>EIG_commPerRd\<close> always holds.
  Also, \<open>EIG_commGlobal\<close> is satisfied because there are
  three processes from which every process receives the correct messages at all
  rounds. By our correctness proof, it follows that $EIGByz_f$ then
  achieves Consensus, unlike what one could expect from the standard correctness
  predicate. This observation underlines the interest of expressing assumptions
  about transient faults, as in the HO model.
\<close>

subsection \<open>The \eigbyz{} Heard-Of Machine\<close>

text \<open>
  We now define the non-coordinated SHO machine for \eigbyz{} by assembling
  the algorithm definition and its communication-predicate.
\<close>

definition EIG_SHOMachine where
  "EIG_SHOMachine = \<lparr>
    CinitState =  (\<lambda> p st crd. EIG_initState p st),
    sendMsg =  EIG_sendMsg,
    CnextState = (\<lambda> r p st msgs crd st'. EIG_nextState r p st msgs st'),
    SHOcommPerRd = EIG_commPerRd,
    SHOcommGlobal = EIG_commGlobal
   \<rparr>"

abbreviation "EIG_M \<equiv> (EIG_SHOMachine::(Proc, 'val pstate, 'val Msg) SHOMachine)"

end  (* theory EIGbyzDefs *)


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section "Language Primitives"

theory Primitives imports "../pGCL" begin

text \<open>Programs in pGCL are probabilistic automata.  They can do anything a traditional program
can, plus, they may make truly probabilistic choices.\<close>

subsection \<open>The Basics\<close>

text \<open>Imagine flipping a pair of fair coins: @{term a} and @{term b}. Using a record type for the
state allows a number of syntactic niceties, which we describe shortly:\<close>

datatype coin = Heads | Tails

record coins =
  a :: coin
  b :: coin

text \<open>The primitive state operation is @{term Apply}, which takes a state transformer as an
argument, constructs the pGCL equivalent. Thus @{term "Apply (\<lambda>s. s\<lparr> a := Heads \<rparr>)"} sets the value
of coin @{term a} to @{term Heads}. As records are so common as state types, we introduce syntax to
make these update neater: The same program may be defined more simply as @{term "a := (\<lambda>s. Heads)"}
(note that the syntax translation involved does not apply to Latex output, and thus this lemma
appears trivial):
\<close>

lemma
  "Apply (\<lambda>s. s \<lparr> a := Heads \<rparr>) = (a := (\<lambda>s. Heads))"
  by(simp)

text \<open>We can treat the record's fields as the names of \emph{variables}. Note that the right-hand
side of an assignment is always a function of the current state. Thus we may use a record accessor
directly, for example @{term "a := b"}, which updates @{term a} with the current value of @{term b}.
If we wish to formally establish that the previous statement is correct i.e. that in the final
state, @{term a} really will have whatever value @{term b} had in the initial state, we must first
introduce the assertion language.\<close>

subsection \<open>Assertion and Annotation\<close>

text \<open>Assertions in pGCL are real-valued functions of the state, which are often interpreted as a
probability distribution over possible outcomes. These functions are termed \emph{expectations}, for
reasons which shortly be clear. Initially, however, we need only consider \emph{standard}
expectations: those derived from a binary predicate. A predicate @{term_type "P::'s \<Rightarrow> bool"} is
embedded as @{term_type "\<guillemotleft>P::'s \<Rightarrow> bool\<guillemotright>"}, such that @{term "P s \<longrightarrow> \<guillemotleft>P\<guillemotright> s = 1 \<and> \<not> P s \<longrightarrow> \<guillemotleft>P\<guillemotright> s = 0"}.

  An annotation consists of an assertion on the initial state and one on the final state, which for
  standard expectations may be interpreted as `if @{term P} holds in the initial state, then @{term
  Q} will hold in the final state'. These are in weakest-precondition form: we assert that the
  precondition implies the \emph{weakest precondition}: the weakest assertion on the initial state,
  which implies that the postcondition must hold on the final state. So far, this is identical to
  the standard approach. Remember, however, that we are working with \emph{real-valued} assertions.
  For standard expectations, the logic is nevertheless identical, if the implication @{term "\<forall>s. P s
  \<longrightarrow> Q s"} is substituted with the equivalent expectation entailment @{term "\<guillemotleft>P\<guillemotright> \<tturnstile> \<guillemotleft>Q\<guillemotright>"}, @{thm
  entails_implies}. Thus a valid specification of @{term "a := b"} is:\<close>

lemma
  "\<And>x. \<guillemotleft>\<lambda>s. b s = x\<guillemotright> \<tturnstile> wp (a := b) \<guillemotleft>\<lambda>s. a s = x\<guillemotright>"
  by(pvcg, simp add:o_def)

text \<open>Any ordinary computation and its associated annotation can be expressed in this form.\<close>

subsection \<open>Probability\<close>

text \<open>Next, we introduce the syntax @{term "x ;; y"} for the sequential composition of @{term x}
and @{term y}, and also demonstrate that one can operate directly on a real-valued (and thus
infinite) state space:\<close>

lemma
  "\<guillemotleft>\<lambda>s::real. s \<noteq> 0\<guillemotright> \<tturnstile> wp (Apply ((*) 2) ;; Apply (\<lambda>s. s / s)) \<guillemotleft>\<lambda>s. s = 1\<guillemotright>"
  by(pvcg, simp add:o_def)

text \<open>So far, we haven't done anything that required probabilities, or expectations other than 0
and 1. As an example of both, we show that a single coin toss is fair. We introduce the syntax
@{term "x \<^bsub>p\<^esub>\<oplus> y"} for a probabilistic choice between @{term x} and @{term y}. This program behaves
as @{term x} with probability @{term p}, and as @{term y} with probability @{term "1-p"}. The
probability may depend on the state, and is therefore of type @{typ "'s \<Rightarrow> real"}. The following
annotation states that the probability of heads is exactly 1/2:\<close>

definition
  flip_a :: "real \<Rightarrow> coins prog"
where
  "flip_a p = a := (\<lambda>_. Heads) \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> a := (\<lambda>_. Tails)"

lemma
  "(\<lambda>s. 1/2) = wp (flip_a (1/2)) \<guillemotleft>\<lambda>s. a s = Heads\<guillemotright>"
  unfolding flip_a_def
  txt \<open>Sufficiently small problems can be handled by the simplifier, by symbolic evaluation.\<close>
  by(simp add:wp_eval o_def)

subsection \<open>Nondeterminism\<close>

text \<open>We can also under-specify a program, using the \emph{nondeterministic choice} operator,
@{term "x \<Sqinter> y"}. This is interpreted demonically, giving the pointwise \emph{minimum} of the
pre-expectations for @{term x} and @{term y}: the chance of seeing heads, if your opponent is
allowed choose between a pair of coins, one biased 2/3 heads and one 2/3 tails, and then flips it,
is \emph{at least} 1/3, but we can make no stronger statement:\<close>

lemma
  "\<lambda>s. 1/3 \<tturnstile> wp (flip_a (2/3) \<Sqinter> flip_a (1/3)) \<guillemotleft>\<lambda>s. a s = Heads\<guillemotright>"
  unfolding flip_a_def
  by(pvcg, simp add:o_def le_funI)

subsection \<open>Properties of Expectations\<close>

text \<open>The probabilities of independent events combine as usual, by multiplying: The chance
of getting heads on two separate coins is @{term "1/4"}.\<close>

definition
  flip_b :: "real \<Rightarrow> coins prog"
where
  "flip_b p = b := (\<lambda>_. Heads) \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b := (\<lambda>_. Tails)"

lemma
  "(\<lambda>s. 1/4) = wp (flip_a (1/2) ;; flip_b (1/2))
                  \<guillemotleft>\<lambda>s. a s = Heads \<and> b s = Heads\<guillemotright>"
  unfolding flip_a_def flip_b_def
  by(simp add:wp_eval o_def)

text \<open>If, rather than two coins, we use two dice, we can make some slightly more involved
calculations.  We see that the weakest pre-expectation of the value on the face of the die after
rolling is its \emph{expected value} in the initial state, which justifies the use of the term
expectation.
\<close>

record dice =
  red  :: nat
  blue :: nat

definition Puniform :: "'a set \<Rightarrow> ('a \<Rightarrow> real)"
where "Puniform S = (\<lambda>x. if x \<in> S then 1 / card S else 0)"

lemma Puniform_out:
  "x \<notin> S \<Longrightarrow> Puniform S x = 0"
  by(simp add:Puniform_def)

lemma supp_Puniform:
  "finite S \<Longrightarrow> supp (Puniform S) = S"
  by(auto simp:Puniform_def supp_def)

text \<open>The expected value of a roll of a six-sided die is @{term "7/2"}:\<close>

lemma
  "(\<lambda>s. 7/2) = wp (bind v at (\<lambda>s. Puniform {1..6} v) in red := (\<lambda>_. v)) red"
  by(simp add:wp_eval supp_Puniform sum.atLeast_Suc_atMost Puniform_in)

text \<open>The expectations of independent variables add:\<close>

lemma
  "(\<lambda>s. 7) = wp ((bind v at (\<lambda>s. Puniform {1..6} v) in red := (\<lambda>s. v)) ;;
                 (bind v at (\<lambda>s. Puniform {1..6} v) in blue := (\<lambda>s. v)))
                (\<lambda>s. red s + blue s)"
  by(simp add:wp_eval supp_Puniform sum.atLeast_Suc_atMost Puniform_in)

end


(* Title:      Fixpoints
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Fixpoints\<close>

text \<open>
This theory develops a fixpoint calculus based on partial orders.
Besides fixpoints we consider least prefixpoints and greatest postfixpoints of functions on a partial order.
We do not assume that the underlying structure is complete or that all functions are continuous or isotone.
Assumptions about the existence of fixpoints and necessary properties of the involved functions will be stated explicitly in each theorem.
This way, the results can be instantiated by various structures, such as complete lattices and Kleene algebras, which impose different kinds of restriction.
See, for example, \<^cite>\<open>"AartsBackhouseBoitenDoornbosGasterenGeldropHoogendijkVoermansWoude1995" and "DaveyPriestley2002"\<close> for fixpoint calculi in complete lattices.
Our fixpoint calculus contains similar rules, in particular:
\begin{itemize}
\item unfold rule,
\item fixpoint operators preserve isotonicity,
\item square rule,
\item rolling rule,
\item various fusion rules,
\item exchange rule and
\item diagonal rule.
\end{itemize}
All of our rules are based on existence rather than completeness of the underlying structure.
We have applied results from this theory in \<^cite>\<open>"Guttmann2012c"\<close> and subsequent papers for unifying and reasoning about the semantics of recursion in various relational and matrix-based computation models.
\<close>

theory Fixpoints

imports Stone_Algebras.Lattice_Basics

begin

text \<open>
The whole calculus is based on partial orders only.
\<close>

context order
begin

text \<open>
We first define when an element $x$ is a least/greatest (pre/post)fixpoint of a given function $f$.
\<close>

definition is_fixpoint               :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_fixpoint              f x \<equiv> f x = x"
definition is_prefixpoint            :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_prefixpoint           f x \<equiv> f x \<le> x"
definition is_postfixpoint           :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_postfixpoint          f x \<equiv> f x \<ge> x"
definition is_least_fixpoint         :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_least_fixpoint        f x \<equiv> f x = x \<and> (\<forall>y . f y = y \<longrightarrow> x \<le> y)"
definition is_greatest_fixpoint      :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_greatest_fixpoint     f x \<equiv> f x = x \<and> (\<forall>y . f y = y \<longrightarrow> x \<ge> y)"
definition is_least_prefixpoint      :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_least_prefixpoint     f x \<equiv> f x \<le> x \<and> (\<forall>y . f y \<le> y \<longrightarrow> x \<le> y)"
definition is_greatest_postfixpoint  :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_greatest_postfixpoint f x \<equiv> f x \<ge> x \<and> (\<forall>y . f y \<ge> y \<longrightarrow> x \<ge> y)"

text \<open>
Next follows the existence of the corresponding fixpoints for a given function $f$.
\<close>

definition has_fixpoint              :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_fixpoint              f \<equiv> \<exists>x . is_fixpoint f x"
definition has_prefixpoint           :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_prefixpoint           f \<equiv> \<exists>x . is_prefixpoint f x"
definition has_postfixpoint          :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_postfixpoint          f \<equiv> \<exists>x . is_postfixpoint f x"
definition has_least_fixpoint        :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_least_fixpoint        f \<equiv> \<exists>x . is_least_fixpoint f x"
definition has_greatest_fixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_greatest_fixpoint     f \<equiv> \<exists>x . is_greatest_fixpoint f x"
definition has_least_prefixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_least_prefixpoint     f \<equiv> \<exists>x . is_least_prefixpoint f x"
definition has_greatest_postfixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_greatest_postfixpoint f \<equiv> \<exists>x . is_greatest_postfixpoint f x"

text \<open>
The actual least/greatest (pre/post)fixpoints of a given function $f$ are extracted by the following operators.
\<close>

definition the_least_fixpoint        :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<mu> _"  [201] 200) where "\<mu>  f = (THE x . is_least_fixpoint f x)"
definition the_greatest_fixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<nu> _"  [201] 200) where "\<nu>  f = (THE x . is_greatest_fixpoint f x)"
definition the_least_prefixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<mu> _" [201] 200) where "p\<mu> f = (THE x . is_least_prefixpoint f x)"
definition the_greatest_postfixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<nu> _" [201] 200) where "p\<nu> f = (THE x . is_greatest_postfixpoint f x)"

text \<open>
We start with basic consequences of the above definitions.
\<close>

lemma least_fixpoint_unique:
  "has_least_fixpoint f \<Longrightarrow> \<exists>!x . is_least_fixpoint f x"
  using has_least_fixpoint_def is_least_fixpoint_def order.antisym by auto

lemma greatest_fixpoint_unique:
  "has_greatest_fixpoint f \<Longrightarrow> \<exists>!x . is_greatest_fixpoint f x"
  using has_greatest_fixpoint_def is_greatest_fixpoint_def order.antisym by auto

lemma least_prefixpoint_unique:
  "has_least_prefixpoint f \<Longrightarrow> \<exists>!x . is_least_prefixpoint f x"
  using has_least_prefixpoint_def is_least_prefixpoint_def order.antisym by auto

lemma greatest_postfixpoint_unique:
  "has_greatest_postfixpoint f \<Longrightarrow> \<exists>!x . is_greatest_postfixpoint f x"
  using has_greatest_postfixpoint_def is_greatest_postfixpoint_def order.antisym by auto

lemma least_fixpoint:
  "has_least_fixpoint f \<Longrightarrow> is_least_fixpoint f (\<mu> f)"
  by (simp add: least_fixpoint_unique theI' the_least_fixpoint_def)

lemma greatest_fixpoint:
  "has_greatest_fixpoint f \<Longrightarrow> is_greatest_fixpoint f (\<nu> f)"
  by (simp add: greatest_fixpoint_unique theI' the_greatest_fixpoint_def)

lemma least_prefixpoint:
  "has_least_prefixpoint f \<Longrightarrow> is_least_prefixpoint f (p\<mu> f)"
  by (simp add: least_prefixpoint_unique theI' the_least_prefixpoint_def)

lemma greatest_postfixpoint:
  "has_greatest_postfixpoint f \<Longrightarrow> is_greatest_postfixpoint f (p\<nu> f)"
  by (simp add: greatest_postfixpoint_unique theI' the_greatest_postfixpoint_def)

lemma least_fixpoint_same:
  "is_least_fixpoint f x \<Longrightarrow> x = \<mu> f"
  by (simp add: is_least_fixpoint_def order.antisym the_equality the_least_fixpoint_def)

lemma greatest_fixpoint_same:
  "is_greatest_fixpoint f x \<Longrightarrow> x = \<nu> f"
  using greatest_fixpoint greatest_fixpoint_unique has_greatest_fixpoint_def by auto

lemma least_prefixpoint_same:
  "is_least_prefixpoint f x \<Longrightarrow> x = p\<mu> f"
  using has_least_prefixpoint_def least_prefixpoint least_prefixpoint_unique by blast

lemma greatest_postfixpoint_same:
  "is_greatest_postfixpoint f x \<Longrightarrow> x = p\<nu> f"
  using greatest_postfixpoint greatest_postfixpoint_unique has_greatest_postfixpoint_def by auto

lemma least_fixpoint_char:
  "is_least_fixpoint f x \<longleftrightarrow> has_least_fixpoint f \<and> x = \<mu> f"
  using has_least_fixpoint_def least_fixpoint_same by auto

lemma least_prefixpoint_char:
  "is_least_prefixpoint f x \<longleftrightarrow> has_least_prefixpoint f \<and> x = p\<mu> f"
  using has_least_prefixpoint_def least_prefixpoint_same by auto

lemma greatest_fixpoint_char:
  "is_greatest_fixpoint f x \<longleftrightarrow> has_greatest_fixpoint f \<and> x = \<nu> f"
  using greatest_fixpoint_same has_greatest_fixpoint_def by auto

lemma greatest_postfixpoint_char:
  "is_greatest_postfixpoint f x \<longleftrightarrow> has_greatest_postfixpoint f \<and> x = p\<nu> f"
  using greatest_postfixpoint_same has_greatest_postfixpoint_def by auto

text \<open>
Next come the unfold rules for least/greatest (pre/post)fixpoints.
\<close>

lemma mu_unfold:
  "has_least_fixpoint f \<Longrightarrow> f (\<mu> f) = \<mu> f"
  using is_least_fixpoint_def least_fixpoint by auto

lemma pmu_unfold:
  "has_least_prefixpoint f \<Longrightarrow> f (p\<mu> f) \<le> p\<mu> f"
  using is_least_prefixpoint_def least_prefixpoint by blast

lemma nu_unfold:
  "has_greatest_fixpoint f \<Longrightarrow> \<nu> f = f (\<nu> f)"
  by (metis is_greatest_fixpoint_def greatest_fixpoint)

lemma pnu_unfold:
  "has_greatest_postfixpoint f \<Longrightarrow> p\<nu> f \<le> f (p\<nu> f)"
  using greatest_postfixpoint is_greatest_postfixpoint_def by auto

text \<open>
Pre-/postfixpoints of isotone functions are fixpoints.
\<close>

lemma least_prefixpoint_fixpoint:
  "has_least_prefixpoint f \<Longrightarrow> isotone f \<Longrightarrow> is_least_fixpoint f (p\<mu> f)"
  using is_least_fixpoint_def is_least_prefixpoint_def least_prefixpoint order.antisym isotone_def by auto

lemma pmu_mu:
  "has_least_prefixpoint f \<Longrightarrow> isotone f \<Longrightarrow> p\<mu> f = \<mu> f"
  by (simp add: least_fixpoint_same least_prefixpoint_fixpoint)

lemma greatest_postfixpoint_fixpoint:
  "has_greatest_postfixpoint f \<Longrightarrow> isotone f \<Longrightarrow> is_greatest_fixpoint f (p\<nu> f)"
  using greatest_postfixpoint is_greatest_fixpoint_def is_greatest_postfixpoint_def order.antisym isotone_def by auto

lemma pnu_nu:
  "has_greatest_postfixpoint f \<Longrightarrow> isotone f \<Longrightarrow> p\<nu> f = \<nu> f"
  by (simp add: greatest_fixpoint_same greatest_postfixpoint_fixpoint)

text \<open>
The fixpoint operators preserve isotonicity.
\<close>

lemma pmu_isotone:
  "has_least_prefixpoint f \<Longrightarrow> has_least_prefixpoint g \<Longrightarrow> f \<le>\<le> g \<Longrightarrow> p\<mu> f \<le> p\<mu> g"
  by (metis is_least_prefixpoint_def least_prefixpoint order_trans lifted_less_eq_def)

lemma mu_isotone:
  "has_least_prefixpoint f \<Longrightarrow> has_least_prefixpoint g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f \<le>\<le> g \<Longrightarrow> \<mu> f \<le> \<mu> g"
  using pmu_isotone pmu_mu by fastforce

lemma pnu_isotone:
  "has_greatest_postfixpoint f \<Longrightarrow> has_greatest_postfixpoint g \<Longrightarrow> f \<le>\<le> g \<Longrightarrow> p\<nu> f \<le> p\<nu> g"
  by (metis greatest_postfixpoint is_greatest_postfixpoint_def order_trans lifted_less_eq_def)

lemma nu_isotone:
  "has_greatest_postfixpoint f \<Longrightarrow> has_greatest_postfixpoint g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f \<le>\<le> g \<Longrightarrow> \<nu> f \<le> \<nu> g"
  using pnu_isotone pnu_nu by fastforce

text \<open>
The square rule for fixpoints of a function applied twice.
\<close>

lemma mu_square:
  "isotone f \<Longrightarrow> has_least_fixpoint f \<Longrightarrow> has_least_fixpoint (f \<circ> f) \<Longrightarrow> \<mu> f = \<mu> (f \<circ> f)"
  by (metis (no_types, opaque_lifting) order.antisym is_least_fixpoint_def isotone_def least_fixpoint_char least_fixpoint_unique o_apply)

lemma nu_square:
  "isotone f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> has_greatest_fixpoint (f \<circ> f) \<Longrightarrow> \<nu> f = \<nu> (f \<circ> f)"
  by (metis (no_types, opaque_lifting) order.antisym is_greatest_fixpoint_def isotone_def greatest_fixpoint_char greatest_fixpoint_unique o_apply)

text \<open>
The rolling rule for fixpoints of the composition of two functions.
\<close>

lemma mu_roll:
  assumes "isotone g"
      and "has_least_fixpoint (f \<circ> g)"
      and "has_least_fixpoint (g \<circ> f)"
    shows "\<mu> (g \<circ> f) = g (\<mu> (f \<circ> g))"
proof (rule order.antisym)
  show "\<mu> (g \<circ> f) \<le> g (\<mu> (f \<circ> g))"
    by (metis assms(2-3) comp_apply is_least_fixpoint_def least_fixpoint)
next
  have "is_least_fixpoint (g \<circ> f) (\<mu> (g \<circ> f))"
    by (simp add: assms(3) least_fixpoint)
  thus "g (\<mu> (f \<circ> g)) \<le> \<mu> (g \<circ> f)"
    by (metis (no_types) assms(1-2) comp_def is_least_fixpoint_def least_fixpoint isotone_def)
qed

lemma nu_roll:
  assumes "isotone g"
      and "has_greatest_fixpoint (f \<circ> g)"
      and "has_greatest_fixpoint (g \<circ> f)"
    shows "\<nu> (g \<circ> f) = g (\<nu> (f \<circ> g))"
proof (rule order.antisym)
  have 1: "is_greatest_fixpoint (f \<circ> g) (\<nu> (f \<circ> g))"
    by (simp add: assms(2) greatest_fixpoint)
  have "is_greatest_fixpoint (g \<circ> f) (\<nu> (g \<circ> f))"
    by (simp add: assms(3) greatest_fixpoint)
  thus "\<nu> (g \<circ> f) \<le> g (\<nu> (f \<circ> g))"
    using 1 by (metis (no_types) assms(1) comp_def is_greatest_fixpoint_def isotone_def)
next
  show "g (\<nu> (f \<circ> g)) \<le> \<nu> (g \<circ> f)"
    by (metis assms(2-3) comp_apply greatest_fixpoint is_greatest_fixpoint_def)
qed

text \<open>
Least (pre)fixpoints are below greatest (post)fixpoints.
\<close>

lemma mu_below_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> \<mu> f \<le> \<nu> f"
  using greatest_fixpoint is_greatest_fixpoint_def mu_unfold by auto

lemma pmu_below_pnu_fix:
  "has_fixpoint f \<Longrightarrow> has_least_prefixpoint f \<Longrightarrow> has_greatest_postfixpoint f \<Longrightarrow> p\<mu> f \<le> p\<nu> f"
  by (metis greatest_postfixpoint has_fixpoint_def is_fixpoint_def is_greatest_postfixpoint_def is_least_prefixpoint_def least_prefixpoint order_refl order_trans)

lemma pmu_below_pnu_iso:
  "isotone f \<Longrightarrow> has_least_prefixpoint f \<Longrightarrow> has_greatest_postfixpoint f \<Longrightarrow> p\<mu> f \<le> p\<nu> f"
  using greatest_postfixpoint_fixpoint is_greatest_fixpoint_def is_least_fixpoint_def least_prefixpoint_fixpoint by auto

text \<open>
Several variants of the fusion rule for fixpoints follow.
\<close>

lemma mu_fusion_1:
  assumes "galois l u"
      and "isotone h"
      and "has_least_prefixpoint g"
      and "has_least_fixpoint h"
      and "l (g (u (\<mu> h))) \<le> h (l (u (\<mu> h)))"
    shows "l (p\<mu> g) \<le> \<mu> h"
proof -
  have "l (g (u (\<mu> h))) \<le> \<mu> h"
    by (metis assms(1,2,4,5) galois_char isotone_def order_lesseq_imp mu_unfold)
  thus "l (p\<mu> g) \<le> \<mu> h"
  using assms(1,3) is_least_prefixpoint_def least_prefixpoint galois_def by auto
qed

lemma mu_fusion_2:
  "galois l u \<Longrightarrow> isotone h \<Longrightarrow> has_least_prefixpoint g \<Longrightarrow> has_least_fixpoint h \<Longrightarrow> l \<circ> g \<le>\<le> h \<circ> l \<Longrightarrow> l (p\<mu> g) \<le> \<mu> h"
  by (simp add: mu_fusion_1 lifted_less_eq_def)

lemma mu_fusion_equal_1:
  "galois l u \<Longrightarrow> isotone g \<Longrightarrow> isotone h \<Longrightarrow> has_least_prefixpoint g \<Longrightarrow> has_least_fixpoint h \<Longrightarrow> l (g (u (\<mu> h))) \<le> h(l(u(\<mu> h))) \<Longrightarrow> l (g (p\<mu> g)) = h (l (p\<mu> g)) \<Longrightarrow> \<mu> h = l (p\<mu> g) \<and> \<mu> h = l (\<mu> g)"
  by (metis order.antisym least_fixpoint least_prefixpoint_fixpoint is_least_fixpoint_def mu_fusion_1 pmu_mu)

lemma mu_fusion_equal_2:
  "galois l u \<Longrightarrow> isotone h \<Longrightarrow> has_least_prefixpoint g \<Longrightarrow> has_least_prefixpoint h \<Longrightarrow> l (g (u (\<mu> h))) \<le> h (l (u (\<mu> h))) \<and> l (g (p\<mu> g)) = h (l (p\<mu> g)) \<longrightarrow> p\<mu> h = l (p\<mu> g) \<and> \<mu> h = l (p\<mu> g)"
  by (metis is_least_prefixpoint_def least_fixpoint_char least_prefixpoint least_prefixpoint_fixpoint order.antisym galois_char isotone_def mu_fusion_1)

lemma mu_fusion_equal_3:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_least_prefixpoint g"
      and "has_least_fixpoint h"
      and "l \<circ> g = h \<circ> l"
    shows "\<mu> h = l (p\<mu> g)"
      and "\<mu> h = l (\<mu> g)"
proof -
  have "\<forall>x . l (g x) = h (l x)"
    using assms(6) comp_eq_elim by blast
  thus "\<mu> h = l (p\<mu> g)"
    using assms(1-5) mu_fusion_equal_1 by auto
  thus "\<mu> h = l (\<mu> g)"
    by (simp add: assms(2,4) pmu_mu)
qed

lemma mu_fusion_equal_4:
  assumes "galois l u"
      and "isotone h"
      and "has_least_prefixpoint g"
      and "has_least_prefixpoint h"
      and "l \<circ> g = h \<circ> l"
    shows "p\<mu> h = l (p\<mu> g)"
      and "\<mu> h = l (p\<mu> g)"
proof -
  have "\<forall>x . l (g x) = h (l x)"
    using assms(5) comp_eq_elim by blast
  thus "p\<mu> h = l (p\<mu> g)"
    using assms(1-4) mu_fusion_equal_2 by auto
  thus "\<mu> h = l (p\<mu> g)"
    by (simp add: assms(2,4) pmu_mu)
qed

lemma nu_fusion_1:
  assumes "galois l u"
      and "isotone h"
      and "has_greatest_postfixpoint g"
      and "has_greatest_fixpoint h"
      and "h (u (l (\<nu> h))) \<le> u (g (l (\<nu> h)))"
    shows "\<nu> h \<le> u (p\<nu> g)"
proof -
  have "\<nu> h \<le> u (g (l (\<nu> h)))"
    by (metis assms(1,2,4,5) order_trans galois_char isotone_def nu_unfold)
  thus "\<nu> h \<le> u (p\<nu> g)"
    by (metis assms(1,3) greatest_postfixpoint is_greatest_postfixpoint_def ord.galois_def)
qed

lemma nu_fusion_2:
  "galois l u \<Longrightarrow> isotone h \<Longrightarrow> has_greatest_postfixpoint g \<Longrightarrow> has_greatest_fixpoint h \<Longrightarrow> h \<circ> u \<le>\<le> u \<circ> g \<Longrightarrow> \<nu> h \<le> u (p\<nu> g)"
  by (simp add: nu_fusion_1 lifted_less_eq_def)

lemma nu_fusion_equal_1:
  "galois l u \<Longrightarrow> isotone g \<Longrightarrow> isotone h \<Longrightarrow> has_greatest_postfixpoint g \<Longrightarrow> has_greatest_fixpoint h \<Longrightarrow> h (u (l (\<nu> h))) \<le> u (g (l (\<nu> h))) \<Longrightarrow> h (u (p\<nu> g)) = u (g (p\<nu> g)) \<Longrightarrow> \<nu> h = u (p\<nu> g) \<and> \<nu> h = u (\<nu> g)"
  by (metis greatest_fixpoint_char greatest_postfixpoint_fixpoint is_greatest_fixpoint_def order.antisym nu_fusion_1)

lemma nu_fusion_equal_2:
  "galois l u \<Longrightarrow> isotone h \<Longrightarrow> has_greatest_postfixpoint g \<Longrightarrow> has_greatest_postfixpoint h \<Longrightarrow> h (u (l (\<nu> h))) \<le> u (g (l (\<nu> h))) \<and> h (u (p\<nu> g)) = u (g (p\<nu> g)) \<Longrightarrow> p\<nu> h = u (p\<nu> g) \<and> \<nu> h = u (p\<nu> g)"
  by (metis greatest_fixpoint_char greatest_postfixpoint greatest_postfixpoint_fixpoint is_greatest_postfixpoint_def order.antisym galois_char nu_fusion_1 isotone_def)

lemma nu_fusion_equal_3:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_greatest_postfixpoint g"
      and "has_greatest_fixpoint h"
      and "h \<circ> u = u \<circ> g"
    shows "\<nu> h = u (p\<nu> g)"
      and "\<nu> h = u (\<nu> g)"
proof -
  have "\<forall>x . u (g x) = h (u x)"
    using assms(6) comp_eq_dest by fastforce
  thus "\<nu> h = u (p\<nu> g)"
    using assms(1-5) nu_fusion_equal_1 by auto
  thus "\<nu> h = u (\<nu> g)"
    by (simp add: assms(2-4) pnu_nu)
qed

text \<open>
Next come the exchange rules for replacing the first/second function in a composition.
\<close>

lemma mu_exchange_1:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_least_prefixpoint (l \<circ> h)"
      and "has_least_prefixpoint (h \<circ> g)"
      and "has_least_fixpoint (g \<circ> h)"
      and "l \<circ> h \<circ> g \<le>\<le> g \<circ> h \<circ> l"
    shows "\<mu> (l \<circ> h) \<le> \<mu> (g \<circ> h)"
proof -
  have 1: "l \<circ> (h \<circ> g) \<le>\<le> (g \<circ> h) \<circ> l"
    by (simp add: assms(7) rewriteL_comp_comp)
  have "(l \<circ> h) (\<mu> (g \<circ> h)) = l (\<mu> (h \<circ> g))"
    by (metis assms(2,3,5,6) comp_apply least_fixpoint_char least_prefixpoint_fixpoint isotone_def mu_roll)
  also have "... \<le> \<mu> (g \<circ> h)"
    using 1 by (metis assms(1-3,5,6) comp_apply least_fixpoint_char least_prefixpoint_fixpoint isotone_def mu_fusion_2)
  finally have "p\<mu> (l \<circ> h) \<le> \<mu> (g \<circ> h)"
    using assms(4) is_least_prefixpoint_def least_prefixpoint by blast
  thus "\<mu> (l \<circ> h) \<le> \<mu> (g \<circ> h)"
    by (metis assms(1,3,4) galois_char isotone_def least_fixpoint_char least_prefixpoint_fixpoint o_apply)
qed

lemma mu_exchange_2:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_least_prefixpoint (l \<circ> h)"
      and "has_least_prefixpoint (h \<circ> l)"
      and "has_least_prefixpoint (h \<circ> g)"
      and "has_least_fixpoint (g \<circ> h)"
      and "has_least_fixpoint (h \<circ> g)"
      and "l \<circ> h \<circ> g \<le>\<le> g \<circ> h \<circ> l"
    shows "\<mu> (h \<circ> l) \<le> \<mu> (h \<circ> g)"
proof -
  have "\<mu> (h \<circ> l) = h (\<mu> (l \<circ> h))"
    by (metis (no_types, lifting) assms(1,3-5) galois_char isotone_def least_fixpoint_char least_prefixpoint_fixpoint mu_roll o_apply)
  also have "... \<le> h (\<mu> (g \<circ> h))"
    using assms(1-4,6,7,9) isotone_def mu_exchange_1 by blast
  also have "... = \<mu> (h \<circ> g)"
    by (simp add: assms(3,7,8) mu_roll)
  finally show ?thesis
    .
qed

lemma mu_exchange_equal:
  assumes "galois l u"
      and "galois k t"
      and "isotone h"
      and "has_least_prefixpoint (l \<circ> h)"
      and "has_least_prefixpoint (h \<circ> l)"
      and "has_least_prefixpoint (k \<circ> h)"
      and "has_least_prefixpoint (h \<circ> k)"
      and "l \<circ> h \<circ> k = k \<circ> h \<circ> l"
    shows "\<mu> (l \<circ> h) = \<mu> (k \<circ> h)"
      and "\<mu> (h \<circ> l) = \<mu> (h \<circ> k)"
proof -
  have 1: "has_least_fixpoint (k \<circ> h)"
    using assms(2,3,6) least_fixpoint_char least_prefixpoint_fixpoint galois_char isotone_def by auto
  have 2: "has_least_fixpoint (h \<circ> k)"
    using assms(2,3,7) least_fixpoint_char least_prefixpoint_fixpoint galois_char isotone_def by auto
  have 3: "has_least_fixpoint (l \<circ> h)"
    using assms(1,3,4) least_fixpoint_char least_prefixpoint_fixpoint galois_char isotone_def by auto
  have 4: "has_least_fixpoint (h \<circ> l)"
    using assms(1,3,5) least_fixpoint_char least_prefixpoint_fixpoint galois_char isotone_def by auto
  show "\<mu> (h \<circ> l) = \<mu> (h \<circ> k)"
    using 1 2 3 4 assms order.antisym galois_char lifted_reflexive mu_exchange_2 by auto
  show "\<mu> (l \<circ> h) = \<mu> (k \<circ> h)"
    using 1 2 3 4 assms order.antisym galois_char lifted_reflexive mu_exchange_1 by auto
qed

lemma nu_exchange_1:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_greatest_postfixpoint (u \<circ> h)"
      and "has_greatest_postfixpoint (h \<circ> g)"
      and "has_greatest_fixpoint (g \<circ> h)"
      and "g \<circ> h \<circ> u \<le>\<le> u \<circ> h \<circ> g"
    shows "\<nu> (g \<circ> h) \<le> \<nu> (u \<circ> h)"
proof -
  have "(g \<circ> h) \<circ> u \<le>\<le> u \<circ> (h \<circ> g)"
    by (simp add: assms(7) o_assoc)
  hence "\<nu> (g \<circ> h) \<le> u (\<nu> (h \<circ> g))"
    by (metis assms(1-3,5,6) greatest_fixpoint_char greatest_postfixpoint_fixpoint isotone_def nu_fusion_2 o_apply)
  also have "... = (u \<circ> h) (\<nu> (g \<circ> h))"
    by (metis assms(2,3,5,6) greatest_fixpoint_char greatest_postfixpoint_fixpoint isotone_def nu_roll o_apply)
  finally have "\<nu> (g \<circ> h) \<le> p\<nu> (u \<circ> h)"
    using assms(4) greatest_postfixpoint is_greatest_postfixpoint_def by blast
  thus "\<nu> (g \<circ> h) \<le> \<nu> (u \<circ> h)"
    using assms(1,3,4) galois_char greatest_fixpoint_char greatest_postfixpoint_fixpoint isotone_def by auto
qed

lemma nu_exchange_2:
  assumes "galois l u"
      and "isotone g"
      and "isotone h"
      and "has_greatest_postfixpoint (u \<circ> h)"
      and "has_greatest_postfixpoint (h \<circ> u)"
      and "has_greatest_postfixpoint (h \<circ> g)"
      and "has_greatest_fixpoint (g \<circ> h)"
      and "has_greatest_fixpoint (h \<circ> g)"
      and "g \<circ> h \<circ> u \<le>\<le> u \<circ> h \<circ> g"
    shows "\<nu> (h \<circ> g) \<le> \<nu> (h \<circ> u)"
proof -
  have "\<nu> (h \<circ> g) = h (\<nu> (g \<circ> h))"
    by (simp add: assms(3,7,8) nu_roll)
  also have "... \<le> h (\<nu> (u \<circ> h))"
    using assms(1-4,6,7,9) isotone_def nu_exchange_1 by blast
  also have "... = \<nu> (h \<circ> u)"
    by (metis (no_types, lifting) assms(1,3-5) galois_char greatest_fixpoint_char greatest_postfixpoint_fixpoint isotone_def nu_roll o_apply)
  finally show "\<nu> (h \<circ> g) \<le> \<nu> (h \<circ> u)"
    .
qed

lemma nu_exchange_equal:
  assumes "galois l u"
      and "galois k t"
      and "isotone h"
      and "has_greatest_postfixpoint (u \<circ> h)"
      and "has_greatest_postfixpoint (h \<circ> u)"
      and "has_greatest_postfixpoint (t \<circ> h)"
      and "has_greatest_postfixpoint (h \<circ> t)"
      and "u \<circ> h \<circ> t = t \<circ> h \<circ> u"
    shows "\<nu> (u \<circ> h) = \<nu> (t \<circ> h)"
      and "\<nu> (h \<circ> u) = \<nu> (h \<circ> t)"
proof -
  have 1: "has_greatest_fixpoint (u \<circ> h)"
    using assms(1,3,4) greatest_fixpoint_char greatest_postfixpoint_fixpoint galois_char isotone_def by auto
  have 2: "has_greatest_fixpoint (h \<circ> u)"
    using assms(1,3,5) greatest_fixpoint_char greatest_postfixpoint_fixpoint galois_char isotone_def by auto
  have 3: "has_greatest_fixpoint (t \<circ> h)"
    using assms(2,3,6) greatest_fixpoint_char greatest_postfixpoint_fixpoint galois_char isotone_def by auto
  have 4: "has_greatest_fixpoint (h \<circ> t)"
    using assms(2,3,7) greatest_fixpoint_char greatest_postfixpoint_fixpoint galois_char isotone_def by auto
  show "\<nu> (u \<circ> h) = \<nu> (t \<circ> h)"
    using 1 2 3 4 assms order.antisym galois_char lifted_reflexive nu_exchange_1 by auto
  show "\<nu> (h \<circ> u) = \<nu> (h \<circ> t)"
    using 1 2 3 4 assms order.antisym galois_char lifted_reflexive nu_exchange_2 by auto
qed

text \<open>
The following results generalise parts of \<^cite>\<open>\<open>Exercise 8.27\<close> in "DaveyPriestley2002"\<close> from continuous functions on complete partial orders to the present setting.
\<close>

lemma mu_commute_fixpoint_1:
  "isotone f \<Longrightarrow> has_least_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> is_fixpoint f (\<mu> (f \<circ> g))"
  by (metis is_fixpoint_def mu_roll)

lemma mu_commute_fixpoint_2:
  "isotone g \<Longrightarrow> has_least_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> is_fixpoint g (\<mu> (f \<circ> g))"
  by (simp add: mu_commute_fixpoint_1)

lemma mu_commute_least_fixpoint:
  "isotone f \<Longrightarrow> isotone g \<Longrightarrow> has_least_fixpoint f \<Longrightarrow> has_least_fixpoint g \<Longrightarrow> has_least_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> \<mu> (f \<circ> g) = \<mu> f \<Longrightarrow> \<mu> g \<le> \<mu> f"
  by (metis is_least_fixpoint_def least_fixpoint mu_roll)

text \<open>
The converse of the preceding result is claimed for continuous $f$, $g$ on a complete partial order; it is unknown whether it holds without these additional assumptions.
\<close>

lemma nu_commute_fixpoint_1:
  "isotone f \<Longrightarrow> has_greatest_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> is_fixpoint f (\<nu>(f \<circ> g))"
  by (metis is_fixpoint_def nu_roll)

lemma nu_commute_fixpoint_2:
  "isotone g \<Longrightarrow> has_greatest_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> is_fixpoint g (\<nu>(f \<circ> g))"
  by (simp add: nu_commute_fixpoint_1)

lemma nu_commute_greatest_fixpoint:
  "isotone f \<Longrightarrow> isotone g \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> has_greatest_fixpoint g \<Longrightarrow> has_greatest_fixpoint (f \<circ> g) \<Longrightarrow> f \<circ> g = g \<circ> f \<Longrightarrow> \<nu> (f \<circ> g) = \<nu> f \<Longrightarrow> \<nu> f \<le> \<nu> g"
  by (metis greatest_fixpoint is_greatest_fixpoint_def nu_roll)

text \<open>
Finally, we show a number of versions of the diagonal rule for functions with two arguments.
\<close>

lemma mu_diagonal_1:
  assumes "isotone (\<lambda>x . \<mu> (\<lambda>y . f x y))"
      and "\<forall>x . has_least_fixpoint (\<lambda>y . f x y)"
      and "has_least_prefixpoint (\<lambda>x . \<mu> (\<lambda>y . f x y))"
    shows "\<mu> (\<lambda>x . f x x) = \<mu> (\<lambda>x . \<mu> (\<lambda>y . f x y))"
proof -
  let ?g = "\<lambda>x . \<mu> (\<lambda>y . f x y)"
  have 1: "is_least_prefixpoint ?g (\<mu> ?g)"
    using assms(1,3) least_prefixpoint pmu_mu by fastforce
  have "f (\<mu> ?g) (\<mu> ?g) = \<mu> ?g"
    by (metis (no_types, lifting) assms is_least_fixpoint_def least_fixpoint_char least_prefixpoint_fixpoint)
  hence "is_least_fixpoint (\<lambda>x . f x x) (\<mu> ?g)"
    using 1 assms(2) is_least_fixpoint_def is_least_prefixpoint_def least_fixpoint by auto
  thus ?thesis
    using least_fixpoint_same by simp
qed

lemma mu_diagonal_2:
  "\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_least_prefixpoint (\<lambda>y . f x y) \<Longrightarrow> has_least_prefixpoint (\<lambda>x . \<mu> (\<lambda>y . f x y)) \<Longrightarrow> \<mu> (\<lambda>x . f x x) = \<mu> (\<lambda>x . \<mu> (\<lambda>y . f x y))"
  apply (rule mu_diagonal_1)
  using isotone_def lifted_less_eq_def mu_isotone apply simp
  using has_least_fixpoint_def least_prefixpoint_fixpoint apply blast
  by simp

lemma nu_diagonal_1:
  assumes "isotone (\<lambda>x . \<nu> (\<lambda>y . f x y))"
      and "\<forall>x . has_greatest_fixpoint (\<lambda>y . f x y)"
      and "has_greatest_postfixpoint (\<lambda>x . \<nu> (\<lambda>y . f x y))"
    shows "\<nu> (\<lambda>x . f x x) = \<nu> (\<lambda>x . \<nu> (\<lambda>y . f x y))"
proof -
  let ?g = "\<lambda>x . \<nu> (\<lambda>y . f x y)"
  have 1: "is_greatest_postfixpoint ?g (\<nu> ?g)"
    using assms(1,3) greatest_postfixpoint pnu_nu by fastforce
  have "f (\<nu> ?g) (\<nu> ?g) = \<nu> ?g"
    by (metis (no_types, lifting) assms is_greatest_fixpoint_def greatest_fixpoint_char greatest_postfixpoint_fixpoint)
  hence "is_greatest_fixpoint (\<lambda>x . f x x) (\<nu> ?g)"
    using 1 assms(2) is_greatest_fixpoint_def is_greatest_postfixpoint_def greatest_fixpoint by auto
  thus ?thesis
    using greatest_fixpoint_same by simp
qed

lemma nu_diagonal_2:
  "\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_greatest_postfixpoint (\<lambda>y . f x y) \<Longrightarrow> has_greatest_postfixpoint (\<lambda>x . \<nu> (\<lambda>y . f x y)) \<Longrightarrow> \<nu> (\<lambda>x . f x x) = \<nu> (\<lambda>x . \<nu> (\<lambda>y . f x y))"
  apply (rule nu_diagonal_1)
  using isotone_def lifted_less_eq_def nu_isotone apply simp
  using has_greatest_fixpoint_def greatest_postfixpoint_fixpoint apply blast
  by simp

end

end


(*  Title:      FOL/ex/Intuitionistic.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* Intuitionistic First-Order Logic *}

theory Intuitionistic
imports IFOL
begin

(*
Single-step ML commands:
by (IntPr.step_tac 1)
by (biresolve_tac safe_brls 1);
by (biresolve_tac haz_brls 1);
by (assume_tac 1);
by (IntPr.safe_tac 1);
by (IntPr.mp_tac 1);
by (IntPr.fast_tac @{context} 1);
*)

text{*Metatheorem (for \emph{propositional} formulae):
  $P$ is classically provable iff $\neg\neg P$ is intuitionistically provable.
  Therefore $\neg P$ is classically provable iff it is intuitionistically
  provable.

Proof: Let $Q$ be the conjuction of the propositions $A\vee\neg A$, one for
each atom $A$ in $P$.  Now $\neg\neg Q$ is intuitionistically provable because
$\neg\neg(A\vee\neg A)$ is and because double-negation distributes over
conjunction.  If $P$ is provable classically, then clearly $Q\rightarrow P$ is
provable intuitionistically, so $\neg\neg(Q\rightarrow P)$ is also provable
intuitionistically.  The latter is intuitionistically equivalent to $\neg\neg
Q\rightarrow\neg\neg P$, hence to $\neg\neg P$, since $\neg\neg Q$ is
intuitionistically provable.  Finally, if $P$ is a negation then $\neg\neg P$
is intuitionstically equivalent to $P$.  [Andy Pitts] *}

lemma "~~(P&Q) <-> ~~P & ~~Q"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "~~ ((~P --> Q) --> (~P --> ~Q) --> P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*Double-negation does NOT distribute over disjunction*}

lemma "~~(P-->Q)  <-> (~~P --> ~~Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "~~~P <-> ~P"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "~~((P --> Q | R)  -->  (P-->Q) | (P-->R))"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "(P<->Q) <-> (Q<->P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "((P --> (Q | (Q-->R))) --> R) --> R"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "(((G-->A) --> J) --> D --> E) --> (((H-->B)-->I)-->C-->J)
      --> (A-->H) --> F --> G --> (((C-->B)-->I)-->D)-->(A-->C)
      --> (((F-->A)-->B) --> I) --> E"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*Lemmas for the propositional double-negation translation*}

lemma "P --> ~~P"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "~~(~~P --> P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "~~P & ~~(P --> Q) --> ~~Q"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*The following are classically but not constructively valid.
      The attempt to prove them terminates quickly!*}
lemma "((P-->Q) --> P)  -->  P"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

lemma "(P&Q-->R)  -->  (P-->R) | (Q-->R)"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

subsection{*de Bruijn formulae*}

text{*de Bruijn formula with three predicates*}
lemma "((P<->Q) --> P&Q&R) &
               ((Q<->R) --> P&Q&R) &
               ((R<->P) --> P&Q&R) --> P&Q&R"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*de Bruijn formula with five predicates*}
lemma "((P<->Q) --> P&Q&R&S&T) &
               ((Q<->R) --> P&Q&R&S&T) &
               ((R<->S) --> P&Q&R&S&T) &
               ((S<->T) --> P&Q&R&S&T) &
               ((T<->P) --> P&Q&R&S&T) --> P&Q&R&S&T"
by (tactic{*IntPr.fast_tac @{context} 1*})

(*** Problems from of Sahlin, Franzen and Haridi,
     An Intuitionistic Predicate Logic Theorem Prover.
     J. Logic and Comp. 2 (5), October 1992, 619-656.
***)

text{*Problem 1.1*}
lemma "(ALL x. EX y. ALL z. p(x) & q(y) & r(z)) <->
      (ALL z. EX y. ALL x. p(x) & q(y) & r(z))"
by (tactic{*IntPr.best_dup_tac @{context} 1*})  --{*SLOW*}

text{*Problem 3.1*}
lemma "~ (EX x. ALL y. mem(y,x) <-> ~ mem(x,x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*Problem 4.1: hopeless!*}
lemma "(ALL x. p(x) --> p(h(x)) | p(g(x))) & (EX x. p(x)) & (ALL x. ~p(h(x)))
      --> (EX x. p(g(g(g(g(g(x)))))))"
oops

subsection{*Intuitionistic FOL: propositional problems based on Pelletier.*}

text{*~~1*}
lemma "~~((P-->Q)  <->  (~Q --> ~P))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~2*}
lemma "~~(~~P  <->  P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*3*}
lemma "~(P-->Q) --> (Q-->P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~4*}
lemma "~~((~P-->Q)  <->  (~Q --> P))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~5*}
lemma "~~((P|Q-->P|R) --> P|(Q-->R))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~6*}
lemma "~~(P | ~P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~7*}
lemma "~~(P | ~~~P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~8.  Peirce's law*}
lemma "~~(((P-->Q) --> P)  -->  P)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*9*}
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*10*}
lemma "(Q-->R) --> (R-->P&Q) --> (P-->(Q|R)) --> (P<->Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

subsection{*11.  Proved in each direction (incorrectly, says Pelletier!!) *}
lemma "P<->P"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~12.  Dijkstra's law  *}
lemma "~~(((P <-> Q) <-> R)  <->  (P <-> (Q <-> R)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "((P <-> Q) <-> R)  -->  ~~(P <-> (Q <-> R))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*13.  Distributive law*}
lemma "P | (Q & R)  <-> (P | Q) & (P | R)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~14*}
lemma "~~((P <-> Q) <-> ((Q | ~P) & (~Q|P)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~15*}
lemma "~~((P --> Q) <-> (~P | Q))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~16*}
lemma "~~((P-->Q) | (Q-->P))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~17*}
lemma "~~(((P & (Q-->R))-->S) <-> ((~P | Q | S) & (~P | ~R | S)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*Dijkstra's "Golden Rule"*}
lemma "(P&Q) <-> P <-> Q <-> (P|Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

subsection{*****Examples with quantifiers*****}

subsection{*The converse is classical in the following implications...*}

lemma "(EX x. P(x)-->Q)  -->  (ALL x. P(x)) --> Q"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "((ALL x. P(x))-->Q) --> ~ (ALL x. P(x) & ~Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "((ALL x. ~P(x))-->Q)  -->  ~ (ALL x. ~ (P(x)|Q))"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "(ALL x. P(x)) | Q  -->  (ALL x. P(x) | Q)"
by (tactic{*IntPr.fast_tac @{context} 1*})

lemma "(EX x. P --> Q(x)) --> (P --> (EX x. Q(x)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

subsection{*The following are not constructively valid!*}
text{*The attempt to prove them terminates quickly!*}

lemma "((ALL x. P(x))-->Q) --> (EX x. P(x)-->Q)"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

lemma "(P --> (EX x. Q(x))) --> (EX x. P-->Q(x))"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

lemma "(ALL x. P(x) | Q) --> ((ALL x. P(x)) | Q)"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

lemma "(ALL x. ~~P(x)) --> ~~(ALL x. P(x))"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

text{*Classically but not intuitionistically valid.  Proved by a bug in 1986!*}
lemma "EX x. Q(x) --> (ALL x. Q(x))"
apply (tactic{*IntPr.fast_tac @{context} 1*} | -)
apply (rule asm_rl) --{*Checks that subgoals remain: proof failed.*}
oops

subsection{*Hard examples with quantifiers*}

text{*The ones that have not been proved are not known to be valid!
  Some will require quantifier duplication -- not currently available*}

text{*~~18*}
lemma "~~(EX y. ALL x. P(y)-->P(x))"
oops  --{*NOT PROVED*}

text{*~~19*}
lemma "~~(EX x. ALL y z. (P(y)-->Q(z)) --> (P(x)-->Q(x)))"
oops  --{*NOT PROVED*}

text{*20*}
lemma "(ALL x y. EX z. ALL w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (EX x y. P(x) & Q(y)) --> (EX z. R(z))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*21*}
lemma "(EX x. P-->Q(x)) & (EX x. Q(x)-->P) --> ~~(EX x. P<->Q(x))"
oops --{*NOT PROVED; needs quantifier duplication*}

text{*22*}
lemma "(ALL x. P <-> Q(x))  -->  (P <-> (ALL x. Q(x)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~23*}
lemma "~~ ((ALL x. P | Q(x))  <->  (P | (ALL x. Q(x))))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*24*}
lemma "~(EX x. S(x)&Q(x)) & (ALL x. P(x) --> Q(x)|R(x)) &
     (~(EX x. P(x)) --> (EX x. Q(x))) & (ALL x. Q(x)|R(x) --> S(x))
    --> ~~(EX x. P(x)&R(x))"
txt{*Not clear why @{text fast_tac}, @{text best_tac}, @{text ASTAR} and
    @{text ITER_DEEPEN} all take forever*}
apply (tactic{* IntPr.safe_tac @{context}*})
apply (erule impE)
apply (tactic{*IntPr.fast_tac @{context} 1*})
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*25*}
lemma "(EX x. P(x)) &
        (ALL x. L(x) --> ~ (M(x) & R(x))) &
        (ALL x. P(x) --> (M(x) & L(x))) &
        ((ALL x. P(x)-->Q(x)) | (EX x. P(x)&R(x)))
    --> (EX x. Q(x)&P(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~26*}
lemma "(~~(EX x. p(x)) <-> ~~(EX x. q(x))) &
      (ALL x. ALL y. p(x) & q(y) --> (r(x) <-> s(y)))
  --> ((ALL x. p(x)-->r(x)) <-> (ALL x. q(x)-->s(x)))"
oops  --{*NOT PROVED*}

text{*27*}
lemma "(EX x. P(x) & ~Q(x)) &
              (ALL x. P(x) --> R(x)) &
              (ALL x. M(x) & L(x) --> P(x)) &
              ((EX x. R(x) & ~ Q(x)) --> (ALL x. L(x) --> ~ R(x)))
          --> (ALL x. M(x) --> ~L(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~28.  AMENDED*}
lemma "(ALL x. P(x) --> (ALL x. Q(x))) &
        (~~(ALL x. Q(x)|R(x)) --> (EX x. Q(x)&S(x))) &
        (~~(EX x. S(x)) --> (ALL x. L(x) --> M(x)))
    --> (ALL x. P(x) & L(x) --> M(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*29.  Essentially the same as Principia Mathematica *11.71*}
lemma "(EX x. P(x)) & (EX y. Q(y))
    --> ((ALL x. P(x)-->R(x)) & (ALL y. Q(y)-->S(y))   <->
         (ALL x y. P(x) & Q(y) --> R(x) & S(y)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~30*}
lemma "(ALL x. (P(x) | Q(x)) --> ~ R(x)) &
        (ALL x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (ALL x. ~~S(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*31*}
lemma "~(EX x. P(x) & (Q(x) | R(x))) &
        (EX x. L(x) & P(x)) &
        (ALL x. ~ R(x) --> M(x))
    --> (EX x. L(x) & M(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*32*}
lemma "(ALL x. P(x) & (Q(x)|R(x))-->S(x)) &
        (ALL x. S(x) & R(x) --> L(x)) &
        (ALL x. M(x) --> R(x))
    --> (ALL x. P(x) & M(x) --> L(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*~~33*}
lemma "(ALL x. ~~(P(a) & (P(x)-->P(b))-->P(c)))  <->
      (ALL x. ~~((~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c))))"
apply (tactic{*IntPr.best_tac @{context} 1*})
done

text{*36*}
lemma "(ALL x. EX y. J(x,y)) &
      (ALL x. EX y. G(x,y)) &
      (ALL x y. J(x,y) | G(x,y) --> (ALL z. J(y,z) | G(y,z) --> H(x,z)))
  --> (ALL x. EX y. H(x,y))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*37*}
lemma "(ALL z. EX w. ALL x. EX y.
           ~~(P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (EX u. Q(u,w)))) &
        (ALL x z. ~P(x,z) --> (EX y. Q(y,z))) &
        (~~(EX x y. Q(x,y)) --> (ALL x. R(x,x)))
    --> ~~(ALL x. EX y. R(x,y))"
oops  --{*NOT PROVED*}

text{*39*}
lemma "~ (EX x. ALL y. F(y,x) <-> ~F(y,y))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*40.  AMENDED*}
lemma "(EX y. ALL x. F(x,y) <-> F(x,x)) -->
              ~(ALL x. EX y. ALL z. F(z,y) <-> ~ F(z,x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*44*}
lemma "(ALL x. f(x) -->
              (EX y. g(y) & h(x,y) & (EX y. g(y) & ~ h(x,y))))  &
              (EX x. j(x) & (ALL y. g(y) --> h(x,y)))
              --> (EX x. j(x) & ~f(x))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*48*}
lemma "(a=b | c=d) & (a=c | b=d) --> a=d | b=c"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*51*}
lemma "(EX z w. ALL x y. P(x,y) <->  (x=z & y=w)) -->
     (EX z. ALL x. EX w. (ALL y. P(x,y) <-> y=w) <-> x=z)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*52*}
text{*Almost the same as 51. *}
lemma "(EX z w. ALL x y. P(x,y) <->  (x=z & y=w)) -->
     (EX w. ALL y. EX z. (ALL x. P(x,y) <-> x=z) <-> y=w)"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*56*}
lemma "(ALL x. (EX y. P(y) & x=f(y)) --> P(x)) <-> (ALL x. P(x) --> P(f(x)))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*57*}
lemma "P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) &
     (ALL x y z. P(x,y) & P(y,z) --> P(x,z))    -->   P(f(a,b), f(a,c))"
by (tactic{*IntPr.fast_tac @{context} 1*})

text{*60*}
lemma "ALL x. P(x,f(x)) <-> (EX y. (ALL z. P(z,y) --> P(z,f(x))) & P(x,y))"
by (tactic{*IntPr.fast_tac @{context} 1*})

end


subsection\<open>ROBDDs and Formulas\<close>
theory ROBDD_PPS_Formulas
imports "ROBDD.Level_Collapse" "Propositional_Proof_Systems.Sema"
begin

primrec frm_to_bdd where
"frm_to_bdd \<bottom> s = fci s" |
"frm_to_bdd (Atom a) s = litci a s" |
"frm_to_bdd (Not F) s = do {
  (n,s) \<leftarrow> frm_to_bdd F s;
  notci n s
}" |
"frm_to_bdd (And F G) s = do {
  (f,s) \<leftarrow> frm_to_bdd F s;
  (g,s) \<leftarrow> frm_to_bdd G s;
  andci f g s
}" |
"frm_to_bdd (Or F G) s = do {
  (f,s) \<leftarrow> frm_to_bdd F s;
  (g,s) \<leftarrow> frm_to_bdd G s;
  orci f g s
}" |
"frm_to_bdd (Imp F G) s = do {
  (f,s) \<leftarrow> frm_to_bdd F s;
  (n,s) \<leftarrow> notci f s;
  (g,s) \<leftarrow> frm_to_bdd G s;
  orci n g s
}"

lemma frm_to_bdd_sep[sep_heap_rules]: "
<bdd_relator R s>
  frm_to_bdd F s
<\<lambda>(r,s'). bdd_relator (insert (\<lambda>\<A>. \<A> \<Turnstile> F, r) R) s'>\<^sub>t"
  by(induction F arbitrary: R s; sep_auto simp add: fun_eq_iff bf_lit_def)

theorem "<emp> do {
  s \<leftarrow> emptyci;
  (f,s) \<leftarrow> frm_to_bdd F s;
  tautci f s
} <\<lambda>r. \<up>(r \<longleftrightarrow> \<Turnstile> F)>\<^sub>t"
  by(sep_auto simp add: fun_eq_iff)

end