Theory Redex

Up to index of Isabelle/ZF/Resid

theory Redex
imports Main

(*  Title:      ZF/Resid/Redex.thy
Author: Ole Rasmussen, University of Cambridge
*)


theory Redex imports Main begin
consts
redexes :: i


datatype
"redexes" = Var ("n ∈ nat")
| Fun ("t ∈ redexes")
| App ("b ∈ bool","f ∈ redexes", "a ∈ redexes")



consts
Ssub :: "i"
Scomp :: "i"
Sreg :: "i"


abbreviation
Ssub_rel (infixl "<==" 70) where
"a<==b == <a,b> ∈ Ssub"


abbreviation
Scomp_rel (infixl "~" 70) where
"a ~ b == <a,b> ∈ Scomp"


abbreviation
"regular(a) == a ∈ Sreg"


consts union_aux :: "i=>i"
primrec (*explicit lambda is required because both arguments of "un" vary*)
"union_aux(Var(n)) =
(λt ∈ redexes. redexes_case(%j. Var(n), %x. 0, %b x y.0, t))"


"union_aux(Fun(u)) =
(λt ∈ redexes. redexes_case(%j. 0, %y. Fun(union_aux(u)`y),
%b y z. 0, t))"


"union_aux(App(b,f,a)) =
(λt ∈ redexes.
redexes_case(%j. 0, %y. 0,
%c z u. App(b or c, union_aux(f)`z, union_aux(a)`u), t))"


definition
union (infixl "un" 70) where
"u un v == union_aux(u)`v"


notation (xsymbols)
union (infixl "\<squnion>" 70) and
Ssub_rel (infixl "\<Longleftarrow>" 70) and
Scomp_rel (infixl "∼" 70)



inductive
domains "Ssub" <= "redexes*redexes"
intros
Sub_Var: "n ∈ nat ==> Var(n)<== Var(n)"
Sub_Fun: "[|u<== v|]==> Fun(u)<== Fun(v)"
Sub_App1: "[|u1<== v1; u2<== v2; b ∈ bool|]==>
App(0,u1,u2)<== App(b,v1,v2)"

Sub_App2: "[|u1<== v1; u2<== v2|]==> App(1,u1,u2)<== App(1,v1,v2)"
type_intros redexes.intros bool_typechecks


inductive
domains "Scomp" <= "redexes*redexes"
intros
Comp_Var: "n ∈ nat ==> Var(n) ~ Var(n)"
Comp_Fun: "[|u ~ v|]==> Fun(u) ~ Fun(v)"
Comp_App: "[|u1 ~ v1; u2 ~ v2; b1 ∈ bool; b2 ∈ bool|]
==> App(b1,u1,u2) ~ App(b2,v1,v2)"

type_intros redexes.intros bool_typechecks


inductive
domains "Sreg" <= redexes
intros
Reg_Var: "n ∈ nat ==> regular(Var(n))"
Reg_Fun: "[|regular(u)|]==> regular(Fun(u))"
Reg_App1: "[|regular(Fun(u)); regular(v) |]==>regular(App(1,Fun(u),v))"
Reg_App2: "[|regular(u); regular(v) |]==>regular(App(0,u,v))"
type_intros redexes.intros bool_typechecks



declare redexes.intros [simp]

(* ------------------------------------------------------------------------- *)
(* Specialisation of comp-rules *)
(* ------------------------------------------------------------------------- *)

lemmas compD1 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas compD2 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas regD [simp] = Sreg.dom_subset [THEN subsetD]

(* ------------------------------------------------------------------------- *)
(* Equality rules for union *)
(* ------------------------------------------------------------------------- *)

lemma union_Var [simp]: "n ∈ nat ==> Var(n) un Var(n)=Var(n)"
by (simp add: union_def)

lemma union_Fun [simp]: "v ∈ redexes ==> Fun(u) un Fun(v) = Fun(u un v)"
by (simp add: union_def)

lemma union_App [simp]:
"[|b2 ∈ bool; u2 ∈ redexes; v2 ∈ redexes|]
==> App(b1,u1,v1) un App(b2,u2,v2)=App(b1 or b2,u1 un u2,v1 un v2)"

by (simp add: union_def)


lemma or_1_right [simp]: "a or 1 = 1"
by (simp add: or_def cond_def)

lemma or_0_right [simp]: "a ∈ bool ==> a or 0 = a"
by (simp add: or_def cond_def bool_def, auto)



declare Ssub.intros [simp]
declare bool_typechecks [simp]
declare Sreg.intros [simp]
declare Scomp.intros [simp]

declare Scomp.intros [intro]

inductive_cases [elim!]:
"regular(App(b,f,a))"
"regular(Fun(b))"
"regular(Var(b))"
"Fun(u) ~ Fun(t)"
"u ~ Fun(t)"
"u ~ Var(n)"
"u ~ App(b,t,a)"
"Fun(t) ~ v"
"App(b,f,a) ~ v"
"Var(n) ~ u"




(* ------------------------------------------------------------------------- *)
(* comp proofs *)
(* ------------------------------------------------------------------------- *)

lemma comp_refl [simp]: "u ∈ redexes ==> u ~ u"
by (erule redexes.induct, blast+)

lemma comp_sym: "u ~ v ==> v ~ u"
by (erule Scomp.induct, blast+)

lemma comp_sym_iff: "u ~ v <-> v ~ u"
by (blast intro: comp_sym)

lemma comp_trans [rule_format]: "u ~ v ==> ∀w. v ~ w-->u ~ w"
by (erule Scomp.induct, blast+)

(* ------------------------------------------------------------------------- *)
(* union proofs *)
(* ------------------------------------------------------------------------- *)

lemma union_l: "u ~ v ==> u <== (u un v)"
apply (erule Scomp.induct)
apply (erule_tac [3] boolE, simp_all)
done

lemma union_r: "u ~ v ==> v <== (u un v)"
apply (erule Scomp.induct)
apply (erule_tac [3] c = b2 in boolE, simp_all)
done

lemma union_sym: "u ~ v ==> u un v = v un u"
by (erule Scomp.induct, simp_all add: or_commute)

(* ------------------------------------------------------------------------- *)
(* regular proofs *)
(* ------------------------------------------------------------------------- *)

lemma union_preserve_regular [rule_format]:
"u ~ v ==> regular(u)-->regular(v)-->regular(u un v)"

by (erule Scomp.induct, auto)

end