(* Title: CCL/Term.thy ID: $Id: Term.thy,v 1.18 2008/03/29 18:14:00 wenzelm Exp $ Author: Martin Coen Copyright 1993 University of Cambridge *) header {* Definitions of usual program constructs in CCL *} theory Term imports CCL begin consts one :: "i" "if" :: "[i,i,i]=>i" ("(3if _/ then _/ else _)" [0,0,60] 60) inl :: "i=>i" inr :: "i=>i" when :: "[i,i=>i,i=>i]=>i" split :: "[i,[i,i]=>i]=>i" fst :: "i=>i" snd :: "i=>i" thd :: "i=>i" zero :: "i" succ :: "i=>i" ncase :: "[i,i,i=>i]=>i" nrec :: "[i,i,[i,i]=>i]=>i" nil :: "i" ("([])") cons :: "[i,i]=>i" (infixr "$" 80) lcase :: "[i,i,[i,i]=>i]=>i" lrec :: "[i,i,[i,i,i]=>i]=>i" "let" :: "[i,i=>i]=>i" letrec :: "[[i,i=>i]=>i,(i=>i)=>i]=>i" letrec2 :: "[[i,i,i=>i=>i]=>i,(i=>i=>i)=>i]=>i" letrec3 :: "[[i,i,i,i=>i=>i=>i]=>i,(i=>i=>i=>i)=>i]=>i" syntax "@let" :: "[idt,i,i]=>i" ("(3let _ be _/ in _)" [0,0,60] 60) "@letrec" :: "[idt,idt,i,i]=>i" ("(3letrec _ _ be _/ in _)" [0,0,0,60] 60) "@letrec2" :: "[idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ be _/ in _)" [0,0,0,0,60] 60) "@letrec3" :: "[idt,idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ _ be _/ in _)" [0,0,0,0,0,60] 60) ML {* (** Quantifier translations: variable binding **) (* FIXME does not handle "_idtdummy" *) (* FIXME should use Syntax.mark_bound(T), Syntax.variant_abs' *) fun let_tr [Free(id,T),a,b] = Const("let",dummyT) $ a $ absfree(id,T,b); fun let_tr' [a,Abs(id,T,b)] = let val (id',b') = variant_abs(id,T,b) in Const("@let",dummyT) $ Free(id',T) $ a $ b' end; fun letrec_tr [Free(f,S),Free(x,T),a,b] = Const("letrec",dummyT) $ absfree(x,T,absfree(f,S,a)) $ absfree(f,S,b); fun letrec2_tr [Free(f,S),Free(x,T),Free(y,U),a,b] = Const("letrec2",dummyT) $ absfree(x,T,absfree(y,U,absfree(f,S,a))) $ absfree(f,S,b); fun letrec3_tr [Free(f,S),Free(x,T),Free(y,U),Free(z,V),a,b] = Const("letrec3",dummyT) $ absfree(x,T,absfree(y,U,absfree(z,U,absfree(f,S,a)))) $ absfree(f,S,b); fun letrec_tr' [Abs(x,T,Abs(f,S,a)),Abs(ff,SS,b)] = let val (f',b') = variant_abs(ff,SS,b) val (_,a'') = variant_abs(f,S,a) val (x',a') = variant_abs(x,T,a'') in Const("@letrec",dummyT) $ Free(f',SS) $ Free(x',T) $ a' $ b' end; fun letrec2_tr' [Abs(x,T,Abs(y,U,Abs(f,S,a))),Abs(ff,SS,b)] = let val (f',b') = variant_abs(ff,SS,b) val ( _,a1) = variant_abs(f,S,a) val (y',a2) = variant_abs(y,U,a1) val (x',a') = variant_abs(x,T,a2) in Const("@letrec2",dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ a' $ b' end; fun letrec3_tr' [Abs(x,T,Abs(y,U,Abs(z,V,Abs(f,S,a)))),Abs(ff,SS,b)] = let val (f',b') = variant_abs(ff,SS,b) val ( _,a1) = variant_abs(f,S,a) val (z',a2) = variant_abs(z,V,a1) val (y',a3) = variant_abs(y,U,a2) val (x',a') = variant_abs(x,T,a3) in Const("@letrec3",dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ Free(z',V) $ a' $ b' end; *} parse_translation {* [("@let", let_tr), ("@letrec", letrec_tr), ("@letrec2", letrec2_tr), ("@letrec3", letrec3_tr)] *} print_translation {* [("let", let_tr'), ("letrec", letrec_tr'), ("letrec2", letrec2_tr'), ("letrec3", letrec3_tr')] *} consts napply :: "[i=>i,i,i]=>i" ("(_ ^ _ ` _)" [56,56,56] 56) axioms one_def: "one == true" if_def: "if b then t else u == case(b,t,u,% x y. bot,%v. bot)" inl_def: "inl(a) == <true,a>" inr_def: "inr(b) == <false,b>" when_def: "when(t,f,g) == split(t,%b x. if b then f(x) else g(x))" split_def: "split(t,f) == case(t,bot,bot,f,%u. bot)" fst_def: "fst(t) == split(t,%x y. x)" snd_def: "snd(t) == split(t,%x y. y)" thd_def: "thd(t) == split(t,%x p. split(p,%y z. z))" zero_def: "zero == inl(one)" succ_def: "succ(n) == inr(n)" ncase_def: "ncase(n,b,c) == when(n,%x. b,%y. c(y))" nrec_def: " nrec(n,b,c) == letrec g x be ncase(x,b,%y. c(y,g(y))) in g(n)" nil_def: "[] == inl(one)" cons_def: "h$t == inr(<h,t>)" lcase_def: "lcase(l,b,c) == when(l,%x. b,%y. split(y,c))" lrec_def: "lrec(l,b,c) == letrec g x be lcase(x,b,%h t. c(h,t,g(t))) in g(l)" let_def: "let x be t in f(x) == case(t,f(true),f(false),%x y. f(<x,y>),%u. f(lam x. u(x)))" letrec_def: "letrec g x be h(x,g) in b(g) == b(%x. fix(%f. lam x. h(x,%y. f`y))`x)" letrec2_def: "letrec g x y be h(x,y,g) in f(g)== letrec g' p be split(p,%x y. h(x,y,%u v. g'(<u,v>))) in f(%x y. g'(<x,y>))" letrec3_def: "letrec g x y z be h(x,y,z,g) in f(g) == letrec g' p be split(p,%x xs. split(xs,%y z. h(x,y,z,%u v w. g'(<u,<v,w>>)))) in f(%x y z. g'(<x,<y,z>>))" napply_def: "f ^n` a == nrec(n,a,%x g. f(g))" lemmas simp_can_defs = one_def inl_def inr_def and simp_ncan_defs = if_def when_def split_def fst_def snd_def thd_def lemmas simp_defs = simp_can_defs simp_ncan_defs lemmas ind_can_defs = zero_def succ_def nil_def cons_def and ind_ncan_defs = ncase_def nrec_def lcase_def lrec_def lemmas ind_defs = ind_can_defs ind_ncan_defs lemmas data_defs = simp_defs ind_defs napply_def and genrec_defs = letrec_def letrec2_def letrec3_def subsection {* Beta Rules, including strictness *} lemma letB: "~ t=bot ==> let x be t in f(x) = f(t)" apply (unfold let_def) apply (erule rev_mp) apply (rule_tac t = "t" in term_case) apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam) done lemma letBabot: "let x be bot in f(x) = bot" apply (unfold let_def) apply (rule caseBbot) done lemma letBbbot: "let x be t in bot = bot" apply (unfold let_def) apply (rule_tac t = t in term_case) apply (rule caseBbot) apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam) done lemma applyB: "(lam x. b(x)) ` a = b(a)" apply (unfold apply_def) apply (simp add: caseBtrue caseBfalse caseBpair caseBlam) done lemma applyBbot: "bot ` a = bot" apply (unfold apply_def) apply (rule caseBbot) done lemma fixB: "fix(f) = f(fix(f))" apply (unfold fix_def) apply (rule applyB [THEN ssubst], rule refl) done lemma letrecB: "letrec g x be h(x,g) in g(a) = h(a,%y. letrec g x be h(x,g) in g(y))" apply (unfold letrec_def) apply (rule fixB [THEN ssubst], rule applyB [THEN ssubst], rule refl) done lemmas rawBs = caseBs applyB applyBbot ML {* local val letrecB = thm "letrecB" val rawBs = thms "rawBs" val data_defs = thms "data_defs" in fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s (fn _ => [stac letrecB 1, simp_tac (@{simpset} addsimps rawBs) 1]); fun mk_beta_rl s = raw_mk_beta_rl data_defs s; fun raw_mk_beta_rl defs s = prove_goalw (the_context ()) defs s (fn _ => [simp_tac (@{simpset} addsimps rawBs setloop (stac letrecB)) 1]); fun mk_beta_rl s = raw_mk_beta_rl data_defs s; end *} ML {* bind_thm ("ifBtrue", mk_beta_rl "if true then t else u = t"); bind_thm ("ifBfalse", mk_beta_rl "if false then t else u = u"); bind_thm ("ifBbot", mk_beta_rl "if bot then t else u = bot"); bind_thm ("whenBinl", mk_beta_rl "when(inl(a),t,u) = t(a)"); bind_thm ("whenBinr", mk_beta_rl "when(inr(a),t,u) = u(a)"); bind_thm ("whenBbot", mk_beta_rl "when(bot,t,u) = bot"); bind_thm ("splitB", mk_beta_rl "split(<a,b>,h) = h(a,b)"); bind_thm ("splitBbot", mk_beta_rl "split(bot,h) = bot"); bind_thm ("fstB", mk_beta_rl "fst(<a,b>) = a"); bind_thm ("fstBbot", mk_beta_rl "fst(bot) = bot"); bind_thm ("sndB", mk_beta_rl "snd(<a,b>) = b"); bind_thm ("sndBbot", mk_beta_rl "snd(bot) = bot"); bind_thm ("thdB", mk_beta_rl "thd(<a,<b,c>>) = c"); bind_thm ("thdBbot", mk_beta_rl "thd(bot) = bot"); bind_thm ("ncaseBzero", mk_beta_rl "ncase(zero,t,u) = t"); bind_thm ("ncaseBsucc", mk_beta_rl "ncase(succ(n),t,u) = u(n)"); bind_thm ("ncaseBbot", mk_beta_rl "ncase(bot,t,u) = bot"); bind_thm ("nrecBzero", mk_beta_rl "nrec(zero,t,u) = t"); bind_thm ("nrecBsucc", mk_beta_rl "nrec(succ(n),t,u) = u(n,nrec(n,t,u))"); bind_thm ("nrecBbot", mk_beta_rl "nrec(bot,t,u) = bot"); bind_thm ("lcaseBnil", mk_beta_rl "lcase([],t,u) = t"); bind_thm ("lcaseBcons", mk_beta_rl "lcase(x$xs,t,u) = u(x,xs)"); bind_thm ("lcaseBbot", mk_beta_rl "lcase(bot,t,u) = bot"); bind_thm ("lrecBnil", mk_beta_rl "lrec([],t,u) = t"); bind_thm ("lrecBcons", mk_beta_rl "lrec(x$xs,t,u) = u(x,xs,lrec(xs,t,u))"); bind_thm ("lrecBbot", mk_beta_rl "lrec(bot,t,u) = bot"); bind_thm ("letrec2B", raw_mk_beta_rl (thms "data_defs" @ [thm "letrec2_def"]) "letrec g x y be h(x,y,g) in g(p,q) = h(p,q,%u v. letrec g x y be h(x,y,g) in g(u,v))"); bind_thm ("letrec3B", raw_mk_beta_rl (thms "data_defs" @ [thm "letrec3_def"]) "letrec g x y z be h(x,y,z,g) in g(p,q,r) = h(p,q,r,%u v w. letrec g x y z be h(x,y,z,g) in g(u,v,w))"); bind_thm ("napplyBzero", mk_beta_rl "f^zero`a = a"); bind_thm ("napplyBsucc", mk_beta_rl "f^succ(n)`a = f(f^n`a)"); bind_thms ("termBs", [thm "letB", thm "applyB", thm "applyBbot", splitB,splitBbot, fstB,fstBbot,sndB,sndBbot,thdB,thdBbot, ifBtrue,ifBfalse,ifBbot,whenBinl,whenBinr,whenBbot, ncaseBzero,ncaseBsucc,ncaseBbot,nrecBzero,nrecBsucc,nrecBbot, lcaseBnil,lcaseBcons,lcaseBbot,lrecBnil,lrecBcons,lrecBbot, napplyBzero,napplyBsucc]); *} subsection {* Constructors are injective *} ML {* bind_thms ("term_injs", map (mk_inj_rl (the_context ()) [thm "applyB", thm "splitB", thm "whenBinl", thm "whenBinr", thm "ncaseBsucc", thm "lcaseBcons"]) ["(inl(a) = inl(a')) <-> (a=a')", "(inr(a) = inr(a')) <-> (a=a')", "(succ(a) = succ(a')) <-> (a=a')", "(a$b = a'$b') <-> (a=a' & b=b')"]) *} subsection {* Constructors are distinct *} ML {* bind_thms ("term_dstncts", mkall_dstnct_thms (the_context ()) (thms "data_defs") (thms "ccl_injs" @ thms "term_injs") [["bot","inl","inr"], ["bot","zero","succ"], ["bot","nil","cons"]]); *} subsection {* Rules for pre-order @{text "[="} *} ML {* local fun mk_thm s = prove_goalw (the_context ()) (thms "data_defs") s (fn _ => [simp_tac (@{simpset} addsimps (thms "ccl_porews")) 1]) in val term_porews = map mk_thm ["inl(a) [= inl(a') <-> a [= a'", "inr(b) [= inr(b') <-> b [= b'", "succ(n) [= succ(n') <-> n [= n'", "x$xs [= x'$xs' <-> x [= x' & xs [= xs'"] end; bind_thms ("term_porews", term_porews); *} subsection {* Rewriting and Proving *} ML {* bind_thms ("term_injDs", XH_to_Ds @{thms term_injs}); *} lemmas term_rews = termBs term_injs term_dstncts ccl_porews term_porews lemmas [simp] = term_rews lemmas [elim!] = term_dstncts [THEN notE] lemmas [dest!] = term_injDs end
lemma simp_can_defs:
one == true
inl(a) == <true,a>
inr(b) == <false,b>
and simp_ncan_defs:
if b then t else u == case(b, t, u, λx y. bot, λv. bot)
when(t, f, g) == split(t, λb x. if b then f(x) else g(x))
split(t, f) == case(t, bot, bot, f, λu. bot)
fst(t) == split(t, λx y. x)
snd(t) == split(t, λx y. y)
thd(t) == split(t, λx p. split(p, λy z. z))
lemma simp_defs:
one == true
inl(a) == <true,a>
inr(b) == <false,b>
if b then t else u == case(b, t, u, λx y. bot, λv. bot)
when(t, f, g) == split(t, λb x. if b then f(x) else g(x))
split(t, f) == case(t, bot, bot, f, λu. bot)
fst(t) == split(t, λx y. x)
snd(t) == split(t, λx y. y)
thd(t) == split(t, λx p. split(p, λy z. z))
lemma ind_can_defs:
zero == inl(one)
succ(n) == inr(n)
[] == inl(one)
h $ t == inr(<h,t>)
and ind_ncan_defs:
ncase(n, b, c) == when(n, λx. b, c)
nrec(n, b, c) == letrec g x be ncase(x, b, λy. c(y, g(y))) in g(n)
lcase(l, b, c) == when(l, λx. b, λy. split(y, c))
lrec(l, b, c) == letrec g x be lcase(x, b, λh t. c(h, t, g(t))) in g(l)
lemma ind_defs:
zero == inl(one)
succ(n) == inr(n)
[] == inl(one)
h $ t == inr(<h,t>)
ncase(n, b, c) == when(n, λx. b, c)
nrec(n, b, c) == letrec g x be ncase(x, b, λy. c(y, g(y))) in g(n)
lcase(l, b, c) == when(l, λx. b, λy. split(y, c))
lrec(l, b, c) == letrec g x be lcase(x, b, λh t. c(h, t, g(t))) in g(l)
lemma data_defs:
one == true
inl(a) == <true,a>
inr(b) == <false,b>
if b then t else u == case(b, t, u, λx y. bot, λv. bot)
when(t, f, g) == split(t, λb x. if b then f(x) else g(x))
split(t, f) == case(t, bot, bot, f, λu. bot)
fst(t) == split(t, λx y. x)
snd(t) == split(t, λx y. y)
thd(t) == split(t, λx p. split(p, λy z. z))
zero == inl(one)
succ(n) == inr(n)
[] == inl(one)
h $ t == inr(<h,t>)
ncase(n, b, c) == when(n, λx. b, c)
nrec(n, b, c) == letrec g x be ncase(x, b, λy. c(y, g(y))) in g(n)
lcase(l, b, c) == when(l, λx. b, λy. split(y, c))
lrec(l, b, c) == letrec g x be lcase(x, b, λh t. c(h, t, g(t))) in g(l)
f ^ n ` a == nrec(n, a, λx. f)
and genrec_defs:
letrec g x be h(x, g) in b(g) == b(op `(fix(λf. lam x. h(x, op `(f)))))
letrec g x y be h(x, y, g) in f(g) ==
letrec g' p be split(p, λx y. h(x, y, λu v. g'(<u,v>))) in f(λx y. g'(<x,y>))
letrec g x y z be h(x, y, z, g) in f(g) ==
letrec g' p be split(p, λx xs. split(xs, λy z.
h(x, y, z, λu v w. g'(<u,<v,w>>))))
in f(λx y z. g'(<x,<y,z>>))
lemma letB:
t ≠ bot ==> let x be t in f(x) = f(t)
lemma letBabot:
let x be bot in f(x) = bot
lemma letBbbot:
let x be t in bot = bot
lemma applyB:
(lam x. b(x)) ` a = b(a)
lemma applyBbot:
bot ` a = bot
lemma fixB:
fix(f) = f(fix(f))
lemma letrecB:
letrec g x be h(x, g) in g(a) = h(a, λy. letrec g x be h(x, g) in g(y))
lemma rawBs:
case(true, d, e, f, g) = d
case(false, d, e, f, g) = e
case(<a,b>, d, e, f, g) = f(a, b)
case(lam x. b(x), d, e, f, g) = g(b)
case(bot, d, e, f, g) = bot
(lam x. b(x)) ` a = b(a)
bot ` a = bot
lemma term_rews:
t ≠ bot ==> let x be t in f(x) = f(t)
(lam x. b(x)) ` a = b(a)
bot ` a = bot
split(<a,b>, h) = h(a, b)
split(bot, h) = bot
fst(<a,b>) = a
fst(bot) = bot
snd(<a,b>) = b
snd(bot) = bot
thd(<a,<b,c>>) = c
thd(bot) = bot
if true then t else u = t
if false then t else u = u
if bot then t else u = bot
when(inl(a), t, u) = t(a)
when(inr(a), t, u) = u(a)
when(bot, t, u) = bot
ncase(zero, t, u) = t
ncase(succ(n), t, u) = u(n)
ncase(bot, t, u) = bot
nrec(zero, t, u) = t
nrec(succ(n), t, u) = u(n, nrec(n, t, u))
nrec(bot, t, u) = bot
lcase([], t, u) = t
lcase(x $ xs, t, u) = u(x, xs)
lcase(bot, t, u) = bot
lrec([], t, u) = t
lrec(x $ xs, t, u) = u(x, xs, lrec(xs, t, u))
lrec(bot, t, u) = bot
f ^ zero ` a = a
f ^ succ(n) ` a = f(f ^ n ` a)
inl(a) = inl(a') <-> a = a'
inr(a) = inr(a') <-> a = a'
succ(a) = succ(a') <-> a = a'
a $ b = a' $ b' <-> a = a' ∧ b = b'
bot ≠ inl(ba)
inl(aa) ≠ bot
bot ≠ inr(ba)
inr(aa) ≠ bot
inl(aa) ≠ inr(ba)
inr(aa) ≠ inl(ba)
bot ≠ zero
zero ≠ bot
bot ≠ succ(ba)
succ(aa) ≠ bot
zero ≠ succ(ba)
succ(aa) ≠ zero
bot ≠ []
[] ≠ bot
bot ≠ ba $ bb
aa $ ab ≠ bot
[] ≠ ba $ bb
aa $ ab ≠ []
bot [= b
<a,b> [= <a',b'> <-> a [= a' ∧ b [= b'
lam x. f(x) [= lam x. f'(x) <-> (∀x. f(x) [= f'(x))
inl(a) [= inl(a') <-> a [= a'
inr(b) [= inr(b') <-> b [= b'
succ(n) [= succ(n') <-> n [= n'
x $ xs [= x' $ xs' <-> x [= x' ∧ xs [= xs'
lemma
t ≠ bot ==> let x be t in f(x) = f(t)
(lam x. b(x)) ` a = b(a)
bot ` a = bot
split(<a,b>, h) = h(a, b)
split(bot, h) = bot
fst(<a,b>) = a
fst(bot) = bot
snd(<a,b>) = b
snd(bot) = bot
thd(<a,<b,c>>) = c
thd(bot) = bot
if true then t else u = t
if false then t else u = u
if bot then t else u = bot
when(inl(a), t, u) = t(a)
when(inr(a), t, u) = u(a)
when(bot, t, u) = bot
ncase(zero, t, u) = t
ncase(succ(n), t, u) = u(n)
ncase(bot, t, u) = bot
nrec(zero, t, u) = t
nrec(succ(n), t, u) = u(n, nrec(n, t, u))
nrec(bot, t, u) = bot
lcase([], t, u) = t
lcase(x $ xs, t, u) = u(x, xs)
lcase(bot, t, u) = bot
lrec([], t, u) = t
lrec(x $ xs, t, u) = u(x, xs, lrec(xs, t, u))
lrec(bot, t, u) = bot
f ^ zero ` a = a
f ^ succ(n) ` a = f(f ^ n ` a)
inl(a) = inl(a') <-> a = a'
inr(a) = inr(a') <-> a = a'
succ(a) = succ(a') <-> a = a'
a $ b = a' $ b' <-> a = a' ∧ b = b'
bot ≠ inl(ba)
inl(aa) ≠ bot
bot ≠ inr(ba)
inr(aa) ≠ bot
inl(aa) ≠ inr(ba)
inr(aa) ≠ inl(ba)
bot ≠ zero
zero ≠ bot
bot ≠ succ(ba)
succ(aa) ≠ bot
zero ≠ succ(ba)
succ(aa) ≠ zero
bot ≠ []
[] ≠ bot
bot ≠ ba $ bb
aa $ ab ≠ bot
[] ≠ ba $ bb
aa $ ab ≠ []
bot [= b
<a,b> [= <a',b'> <-> a [= a' ∧ b [= b'
lam x. f(x) [= lam x. f'(x) <-> (∀x. f(x) [= f'(x))
inl(a) [= inl(a') <-> a [= a'
inr(b) [= inr(b') <-> b [= b'
succ(n) [= succ(n') <-> n [= n'
x $ xs [= x' $ xs' <-> x [= x' ∧ xs [= xs'
lemma
bot = inl(ba1) ==> R
inl(aa1) = bot ==> R
bot = inr(ba1) ==> R
inr(aa1) = bot ==> R
inl(aa1) = inr(ba1) ==> R
inr(aa1) = inl(ba1) ==> R
bot = zero ==> R
zero = bot ==> R
bot = succ(ba1) ==> R
succ(aa1) = bot ==> R
zero = succ(ba1) ==> R
succ(aa1) = zero ==> R
bot = [] ==> R
[] = bot ==> R
bot = ba1 $ bb1 ==> R
aa1 $ ab1 = bot ==> R
[] = ba1 $ bb1 ==> R
aa1 $ ab1 = [] ==> R
lemma
inl(a) = inl(a') ==> a = a'
inr(a) = inr(a') ==> a = a'
succ(a) = succ(a') ==> a = a'
a $ b = a' $ b' ==> a = a' ∧ b = b'