Up to index of Isabelle/HOLCF
theory Fixrec(* Title: HOLCF/Fixrec.thy ID: $Id: Fixrec.thy,v 1.26 2008/02/07 02:30:32 huffman Exp $ Author: Amber Telfer and Brian Huffman *) header "Package for defining recursive functions in HOLCF" theory Fixrec imports Sprod Ssum Up One Tr Fix uses ("Tools/fixrec_package.ML") begin subsection {* Maybe monad type *} defaultsort cpo pcpodef (open) 'a maybe = "UNIV::(one ++ 'a u) set" by simp constdefs fail :: "'a maybe" "fail ≡ Abs_maybe (sinl·ONE)" constdefs return :: "'a -> 'a maybe" where "return ≡ Λ x. Abs_maybe (sinr·(up·x))" definition maybe_when :: "'b -> ('a -> 'b) -> 'a maybe -> 'b::pcpo" where "maybe_when = (Λ f r m. sscase·(Λ x. f)·(fup·r)·(Rep_maybe m))" lemma maybeE: "[|p = ⊥ ==> Q; p = fail ==> Q; !!x. p = return·x ==> Q|] ==> Q" apply (unfold fail_def return_def) apply (cases p, rename_tac r) apply (rule_tac p=r in ssumE, simp add: Abs_maybe_strict) apply (rule_tac p=x in oneE, simp, simp) apply (rule_tac p=y in upE, simp, simp add: cont_Abs_maybe) done lemma return_defined [simp]: "return·x ≠ ⊥" by (simp add: return_def cont_Abs_maybe Abs_maybe_defined) lemma fail_defined [simp]: "fail ≠ ⊥" by (simp add: fail_def Abs_maybe_defined) lemma return_eq [simp]: "(return·x = return·y) = (x = y)" by (simp add: return_def cont_Abs_maybe Abs_maybe_inject) lemma return_neq_fail [simp]: "return·x ≠ fail" "fail ≠ return·x" by (simp_all add: return_def fail_def cont_Abs_maybe Abs_maybe_inject) lemma maybe_when_rews [simp]: "maybe_when·f·r·⊥ = ⊥" "maybe_when·f·r·fail = f" "maybe_when·f·r·(return·x) = r·x" by (simp_all add: return_def fail_def maybe_when_def cont_Rep_maybe cont_Abs_maybe Abs_maybe_inverse Rep_maybe_strict) translations "case m of fail => t1 | return·x => t2" == "CONST maybe_when·t1·(Λ x. t2)·m" subsubsection {* Monadic bind operator *} definition bind :: "'a maybe -> ('a -> 'b maybe) -> 'b maybe" where "bind = (Λ m f. case m of fail => fail | return·x => f·x)" text {* monad laws *} lemma bind_strict [simp]: "bind·⊥·f = ⊥" by (simp add: bind_def) lemma bind_fail [simp]: "bind·fail·f = fail" by (simp add: bind_def) lemma left_unit [simp]: "bind·(return·a)·k = k·a" by (simp add: bind_def) lemma right_unit [simp]: "bind·m·return = m" by (rule_tac p=m in maybeE, simp_all) lemma bind_assoc: "bind·(bind·m·k)·h = bind·m·(Λ a. bind·(k·a)·h)" by (rule_tac p=m in maybeE, simp_all) subsubsection {* Run operator *} definition run:: "'a maybe -> 'a::pcpo" where "run = maybe_when·⊥·ID" text {* rewrite rules for run *} lemma run_strict [simp]: "run·⊥ = ⊥" by (simp add: run_def) lemma run_fail [simp]: "run·fail = ⊥" by (simp add: run_def) lemma run_return [simp]: "run·(return·x) = x" by (simp add: run_def) subsubsection {* Monad plus operator *} definition mplus :: "'a maybe -> 'a maybe -> 'a maybe" where "mplus = (Λ m1 m2. case m1 of fail => m2 | return·x => m1)" abbreviation mplus_syn :: "['a maybe, 'a maybe] => 'a maybe" (infixr "+++" 65) where "m1 +++ m2 == mplus·m1·m2" text {* rewrite rules for mplus *} lemma mplus_strict [simp]: "⊥ +++ m = ⊥" by (simp add: mplus_def) lemma mplus_fail [simp]: "fail +++ m = m" by (simp add: mplus_def) lemma mplus_return [simp]: "return·x +++ m = return·x" by (simp add: mplus_def) lemma mplus_fail2 [simp]: "m +++ fail = m" by (rule_tac p=m in maybeE, simp_all) lemma mplus_assoc: "(x +++ y) +++ z = x +++ (y +++ z)" by (rule_tac p=x in maybeE, simp_all) subsubsection {* Fatbar combinator *} definition fatbar :: "('a -> 'b maybe) -> ('a -> 'b maybe) -> ('a -> 'b maybe)" where "fatbar = (Λ a b x. a·x +++ b·x)" abbreviation fatbar_syn :: "['a -> 'b maybe, 'a -> 'b maybe] => 'a -> 'b maybe" (infixr "\<parallel>" 60) where "m1 \<parallel> m2 == fatbar·m1·m2" lemma fatbar1: "m·x = ⊥ ==> (m \<parallel> ms)·x = ⊥" by (simp add: fatbar_def) lemma fatbar2: "m·x = fail ==> (m \<parallel> ms)·x = ms·x" by (simp add: fatbar_def) lemma fatbar3: "m·x = return·y ==> (m \<parallel> ms)·x = return·y" by (simp add: fatbar_def) lemmas fatbar_simps = fatbar1 fatbar2 fatbar3 lemma run_fatbar1: "m·x = ⊥ ==> run·((m \<parallel> ms)·x) = ⊥" by (simp add: fatbar_def) lemma run_fatbar2: "m·x = fail ==> run·((m \<parallel> ms)·x) = run·(ms·x)" by (simp add: fatbar_def) lemma run_fatbar3: "m·x = return·y ==> run·((m \<parallel> ms)·x) = y" by (simp add: fatbar_def) lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3 subsection {* Case branch combinator *} constdefs branch :: "('a -> 'b maybe) => ('b -> 'c) -> ('a -> 'c maybe)" "branch p ≡ Λ r x. bind·(p·x)·(Λ y. return·(r·y))" lemma branch_rews: "p·x = ⊥ ==> branch p·r·x = ⊥" "p·x = fail ==> branch p·r·x = fail" "p·x = return·y ==> branch p·r·x = return·(r·y)" by (simp_all add: branch_def) lemma branch_return [simp]: "branch return·r·x = return·(r·x)" by (simp add: branch_def) subsection {* Case syntax *} nonterminals Case_syn Cases_syn syntax "_Case_syntax":: "['a, Cases_syn] => 'b" ("(Case _ of/ _)" 10) "_Case1" :: "['a, 'b] => Case_syn" ("(2_ =>/ _)" 10) "" :: "Case_syn => Cases_syn" ("_") "_Case2" :: "[Case_syn, Cases_syn] => Cases_syn" ("_/ | _") syntax (xsymbols) "_Case1" :: "['a, 'b] => Case_syn" ("(2_ =>/ _)" 10) translations "_Case_syntax x ms" == "CONST Fixrec.run·(ms·x)" "_Case2 m ms" == "m \<parallel> ms" text {* Parsing Case expressions *} syntax "_pat" :: "'a" "_var" :: "'a" "_noargs" :: "'a" translations "_Case1 p r" => "CONST branch (_pat p)·(_var p r)" "_var (_args x y) r" => "CONST csplit·(_var x (_var y r))" "_var _noargs r" => "CONST unit_when·r" parse_translation {* (* rewrites (_pat x) => (return) *) (* rewrites (_var x t) => (Abs_CFun (%x. t)) *) [("_pat", K (Syntax.const "Fixrec.return")), mk_binder_tr ("_var", "Abs_CFun")]; *} text {* Printing Case expressions *} syntax "_match" :: "'a" print_translation {* let fun dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax unit_when},_) $ t) = (Syntax.const "_noargs", t) | dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax csplit},_) $ t) = let val (v1, t1) = dest_LAM t; val (v2, t2) = dest_LAM t1; in (Syntax.const "_args" $ v1 $ v2, t2) end | dest_LAM (Const (@{const_syntax Abs_CFun},_) $ t) = let val abs = case t of Abs abs => abs | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0); val (x, t') = atomic_abs_tr' abs; in (Syntax.const "_var" $ x, t') end | dest_LAM _ = raise Match; (* too few vars: abort translation *) fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] = let val (v, t) = dest_LAM r; in Syntax.const "_Case1" $ (Syntax.const "_match" $ p $ v) $ t end; in [(@{const_syntax Rep_CFun}, Case1_tr')] end; *} translations "x" <= "_match Fixrec.return (_var x)" subsection {* Pattern combinators for data constructors *} types ('a, 'b) pat = "'a -> 'b maybe" definition cpair_pat :: "('a, 'c) pat => ('b, 'd) pat => ('a × 'b, 'c × 'd) pat" where "cpair_pat p1 p2 = (Λ〈x, y〉. bind·(p1·x)·(Λ a. bind·(p2·y)·(Λ b. return·〈a, b〉)))" definition spair_pat :: "('a, 'c) pat => ('b, 'd) pat => ('a::pcpo ⊗ 'b::pcpo, 'c × 'd) pat" where "spair_pat p1 p2 = (Λ(:x, y:). cpair_pat p1 p2·〈x, y〉)" definition sinl_pat :: "('a, 'c) pat => ('a::pcpo ⊕ 'b::pcpo, 'c) pat" where "sinl_pat p = sscase·p·(Λ x. fail)" definition sinr_pat :: "('b, 'c) pat => ('a::pcpo ⊕ 'b::pcpo, 'c) pat" where "sinr_pat p = sscase·(Λ x. fail)·p" definition up_pat :: "('a, 'b) pat => ('a u, 'b) pat" where "up_pat p = fup·p" definition TT_pat :: "(tr, unit) pat" where "TT_pat = (Λ b. If b then return·() else fail fi)" definition FF_pat :: "(tr, unit) pat" where "FF_pat = (Λ b. If b then fail else return·() fi)" definition ONE_pat :: "(one, unit) pat" where "ONE_pat = (Λ ONE. return·())" text {* Parse translations (patterns) *} translations "_pat (XCONST cpair·x·y)" => "CONST cpair_pat (_pat x) (_pat y)" "_pat (XCONST spair·x·y)" => "CONST spair_pat (_pat x) (_pat y)" "_pat (XCONST sinl·x)" => "CONST sinl_pat (_pat x)" "_pat (XCONST sinr·x)" => "CONST sinr_pat (_pat x)" "_pat (XCONST up·x)" => "CONST up_pat (_pat x)" "_pat (XCONST TT)" => "CONST TT_pat" "_pat (XCONST FF)" => "CONST FF_pat" "_pat (XCONST ONE)" => "CONST ONE_pat" text {* CONST version is also needed for constructors with special syntax *} translations "_pat (CONST cpair·x·y)" => "CONST cpair_pat (_pat x) (_pat y)" "_pat (CONST spair·x·y)" => "CONST spair_pat (_pat x) (_pat y)" text {* Parse translations (variables) *} translations "_var (XCONST cpair·x·y) r" => "_var (_args x y) r" "_var (XCONST spair·x·y) r" => "_var (_args x y) r" "_var (XCONST sinl·x) r" => "_var x r" "_var (XCONST sinr·x) r" => "_var x r" "_var (XCONST up·x) r" => "_var x r" "_var (XCONST TT) r" => "_var _noargs r" "_var (XCONST FF) r" => "_var _noargs r" "_var (XCONST ONE) r" => "_var _noargs r" translations "_var (CONST cpair·x·y) r" => "_var (_args x y) r" "_var (CONST spair·x·y) r" => "_var (_args x y) r" text {* Print translations *} translations "CONST cpair·(_match p1 v1)·(_match p2 v2)" <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)" "CONST spair·(_match p1 v1)·(_match p2 v2)" <= "_match (CONST spair_pat p1 p2) (_args v1 v2)" "CONST sinl·(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1" "CONST sinr·(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1" "CONST up·(_match p1 v1)" <= "_match (CONST up_pat p1) v1" "CONST TT" <= "_match (CONST TT_pat) _noargs" "CONST FF" <= "_match (CONST FF_pat) _noargs" "CONST ONE" <= "_match (CONST ONE_pat) _noargs" lemma cpair_pat1: "branch p·r·x = ⊥ ==> branch (cpair_pat p q)·(csplit·r)·〈x, y〉 = ⊥" apply (simp add: branch_def cpair_pat_def) apply (rule_tac p="p·x" in maybeE, simp_all) done lemma cpair_pat2: "branch p·r·x = fail ==> branch (cpair_pat p q)·(csplit·r)·〈x, y〉 = fail" apply (simp add: branch_def cpair_pat_def) apply (rule_tac p="p·x" in maybeE, simp_all) done lemma cpair_pat3: "branch p·r·x = return·s ==> branch (cpair_pat p q)·(csplit·r)·〈x, y〉 = branch q·s·y" apply (simp add: branch_def cpair_pat_def) apply (rule_tac p="p·x" in maybeE, simp_all) apply (rule_tac p="q·y" in maybeE, simp_all) done lemmas cpair_pat [simp] = cpair_pat1 cpair_pat2 cpair_pat3 lemma spair_pat [simp]: "branch (spair_pat p1 p2)·r·⊥ = ⊥" "[|x ≠ ⊥; y ≠ ⊥|] ==> branch (spair_pat p1 p2)·r·(:x, y:) = branch (cpair_pat p1 p2)·r·〈x, y〉" by (simp_all add: branch_def spair_pat_def) lemma sinl_pat [simp]: "branch (sinl_pat p)·r·⊥ = ⊥" "x ≠ ⊥ ==> branch (sinl_pat p)·r·(sinl·x) = branch p·r·x" "y ≠ ⊥ ==> branch (sinl_pat p)·r·(sinr·y) = fail" by (simp_all add: branch_def sinl_pat_def) lemma sinr_pat [simp]: "branch (sinr_pat p)·r·⊥ = ⊥" "x ≠ ⊥ ==> branch (sinr_pat p)·r·(sinl·x) = fail" "y ≠ ⊥ ==> branch (sinr_pat p)·r·(sinr·y) = branch p·r·y" by (simp_all add: branch_def sinr_pat_def) lemma up_pat [simp]: "branch (up_pat p)·r·⊥ = ⊥" "branch (up_pat p)·r·(up·x) = branch p·r·x" by (simp_all add: branch_def up_pat_def) lemma TT_pat [simp]: "branch TT_pat·(unit_when·r)·⊥ = ⊥" "branch TT_pat·(unit_when·r)·TT = return·r" "branch TT_pat·(unit_when·r)·FF = fail" by (simp_all add: branch_def TT_pat_def) lemma FF_pat [simp]: "branch FF_pat·(unit_when·r)·⊥ = ⊥" "branch FF_pat·(unit_when·r)·TT = fail" "branch FF_pat·(unit_when·r)·FF = return·r" by (simp_all add: branch_def FF_pat_def) lemma ONE_pat [simp]: "branch ONE_pat·(unit_when·r)·⊥ = ⊥" "branch ONE_pat·(unit_when·r)·ONE = return·r" by (simp_all add: branch_def ONE_pat_def) subsection {* Wildcards, as-patterns, and lazy patterns *} syntax "_as_pat" :: "[idt, 'a] => 'a" (infixr "\<as>" 10) "_lazy_pat" :: "'a => 'a" ("\<lazy> _" [1000] 1000) definition wild_pat :: "'a -> unit maybe" where "wild_pat = (Λ x. return·())" definition as_pat :: "('a -> 'b maybe) => 'a -> ('a × 'b) maybe" where "as_pat p = (Λ x. bind·(p·x)·(Λ a. return·〈x, a〉))" definition lazy_pat :: "('a -> 'b::pcpo maybe) => ('a -> 'b maybe)" where "lazy_pat p = (Λ x. return·(run·(p·x)))" text {* Parse translations (patterns) *} translations "_pat _" => "CONST wild_pat" "_pat (_as_pat x y)" => "CONST as_pat (_pat y)" "_pat (_lazy_pat x)" => "CONST lazy_pat (_pat x)" text {* Parse translations (variables) *} translations "_var _ r" => "_var _noargs r" "_var (_as_pat x y) r" => "_var (_args x y) r" "_var (_lazy_pat x) r" => "_var x r" text {* Print translations *} translations "_" <= "_match (CONST wild_pat) _noargs" "_as_pat x (_match p v)" <= "_match (CONST as_pat p) (_args (_var x) v)" "_lazy_pat (_match p v)" <= "_match (CONST lazy_pat p) v" text {* Lazy patterns in lambda abstractions *} translations "_cabs (_lazy_pat p) r" == "CONST Fixrec.run oo (_Case1 (_lazy_pat p) r)" lemma wild_pat [simp]: "branch wild_pat·(unit_when·r)·x = return·r" by (simp add: branch_def wild_pat_def) lemma as_pat [simp]: "branch (as_pat p)·(csplit·r)·x = branch p·(r·x)·x" apply (simp add: branch_def as_pat_def) apply (rule_tac p="p·x" in maybeE, simp_all) done lemma lazy_pat [simp]: "branch p·r·x = ⊥ ==> branch (lazy_pat p)·r·x = return·(r·⊥)" "branch p·r·x = fail ==> branch (lazy_pat p)·r·x = return·(r·⊥)" "branch p·r·x = return·s ==> branch (lazy_pat p)·r·x = return·s" apply (simp_all add: branch_def lazy_pat_def) apply (rule_tac [!] p="p·x" in maybeE, simp_all) done subsection {* Match functions for built-in types *} defaultsort pcpo definition match_UU :: "'a -> unit maybe" where "match_UU = (Λ x. fail)" definition match_cpair :: "'a::cpo × 'b::cpo -> ('a × 'b) maybe" where "match_cpair = csplit·(Λ x y. return·<x,y>)" definition match_spair :: "'a ⊗ 'b -> ('a × 'b) maybe" where "match_spair = ssplit·(Λ x y. return·<x,y>)" definition match_sinl :: "'a ⊕ 'b -> 'a maybe" where "match_sinl = sscase·return·(Λ y. fail)" definition match_sinr :: "'a ⊕ 'b -> 'b maybe" where "match_sinr = sscase·(Λ x. fail)·return" definition match_up :: "'a::cpo u -> 'a maybe" where "match_up = fup·return" definition match_ONE :: "one -> unit maybe" where "match_ONE = (Λ ONE. return·())" definition match_TT :: "tr -> unit maybe" where "match_TT = (Λ b. If b then return·() else fail fi)" definition match_FF :: "tr -> unit maybe" where "match_FF = (Λ b. If b then fail else return·() fi)" lemma match_UU_simps [simp]: "match_UU·x = fail" by (simp add: match_UU_def) lemma match_cpair_simps [simp]: "match_cpair·<x,y> = return·<x,y>" by (simp add: match_cpair_def) lemma match_spair_simps [simp]: "[|x ≠ ⊥; y ≠ ⊥|] ==> match_spair·(:x,y:) = return·<x,y>" "match_spair·⊥ = ⊥" by (simp_all add: match_spair_def) lemma match_sinl_simps [simp]: "x ≠ ⊥ ==> match_sinl·(sinl·x) = return·x" "x ≠ ⊥ ==> match_sinl·(sinr·x) = fail" "match_sinl·⊥ = ⊥" by (simp_all add: match_sinl_def) lemma match_sinr_simps [simp]: "x ≠ ⊥ ==> match_sinr·(sinr·x) = return·x" "x ≠ ⊥ ==> match_sinr·(sinl·x) = fail" "match_sinr·⊥ = ⊥" by (simp_all add: match_sinr_def) lemma match_up_simps [simp]: "match_up·(up·x) = return·x" "match_up·⊥ = ⊥" by (simp_all add: match_up_def) lemma match_ONE_simps [simp]: "match_ONE·ONE = return·()" "match_ONE·⊥ = ⊥" by (simp_all add: match_ONE_def) lemma match_TT_simps [simp]: "match_TT·TT = return·()" "match_TT·FF = fail" "match_TT·⊥ = ⊥" by (simp_all add: match_TT_def) lemma match_FF_simps [simp]: "match_FF·FF = return·()" "match_FF·TT = fail" "match_FF·⊥ = ⊥" by (simp_all add: match_FF_def) subsection {* Mutual recursion *} text {* The following rules are used to prove unfolding theorems from fixed-point definitions of mutually recursive functions. *} lemma cpair_equalI: "[|x ≡ cfst·p; y ≡ csnd·p|] ==> <x,y> ≡ p" by (simp add: surjective_pairing_Cprod2) lemma cpair_eqD1: "<x,y> = <x',y'> ==> x = x'" by simp lemma cpair_eqD2: "<x,y> = <x',y'> ==> y = y'" by simp text {* lemma for proving rewrite rules *} lemma ssubst_lhs: "[|t = s; P s = Q|] ==> P t = Q" by simp subsection {* Initializing the fixrec package *} use "Tools/fixrec_package.ML" hide (open) const return bind fail run end
lemma maybeE:
[| p = UU ==> Q; p = fail ==> Q; !!x. p = return·x ==> Q |] ==> Q
lemma return_defined:
return·x ≠ UU
lemma fail_defined:
fail ≠ UU
lemma return_eq:
(return·x = return·y) = (x = y)
lemma return_neq_fail:
return·x ≠ fail
fail ≠ return·x
lemma maybe_when_rews:
maybe_when·f·r·UU = UU
maybe_when·f·r·fail = f
maybe_when·f·r·(return·x) = r·x
lemma bind_strict:
bind·UU·f = UU
lemma bind_fail:
bind·fail·f = fail
lemma left_unit:
bind·(return·a)·k = k·a
lemma right_unit:
bind·m·return = m
lemma bind_assoc:
bind·(bind·m·k)·h = bind·m·(LAM a. bind·(k·a)·h)
lemma run_strict:
run·UU = UU
lemma run_fail:
run·fail = UU
lemma run_return:
run·(return·x) = x
lemma mplus_strict:
UU +++ m = UU
lemma mplus_fail:
fail +++ m = m
lemma mplus_return:
return·x +++ m = return·x
lemma mplus_fail2:
m +++ fail = m
lemma mplus_assoc:
(x +++ y) +++ z = x +++ y +++ z
lemma fatbar1:
m·x = UU ==> (m \<parallel> ms)·x = UU
lemma fatbar2:
m·x = fail ==> (m \<parallel> ms)·x = ms·x
lemma fatbar3:
m·x = return·y ==> (m \<parallel> ms)·x = return·y
lemma fatbar_simps:
m·x = UU ==> (m \<parallel> ms)·x = UU
m·x = fail ==> (m \<parallel> ms)·x = ms·x
m·x = return·y ==> (m \<parallel> ms)·x = return·y
lemma run_fatbar1:
m·x = UU ==> run·((m \<parallel> ms)·x) = UU
lemma run_fatbar2:
m·x = fail ==> run·((m \<parallel> ms)·x) = run·(ms·x)
lemma run_fatbar3:
m·x = return·y ==> run·((m \<parallel> ms)·x) = y
lemma run_fatbar_simps:
m·x = UU ==> run·((m \<parallel> ms)·x) = UU
m·x = fail ==> run·((m \<parallel> ms)·x) = run·(ms·x)
m·x = return·y ==> run·((m \<parallel> ms)·x) = y
lemma branch_rews:
p·x = UU ==> branch p·r·x = UU
p·x = fail ==> branch p·r·x = fail
p·x = return·y ==> branch p·r·x = return·(r·y)
lemma branch_return:
branch return·r·x = return·(r·x)
lemma cpair_pat1:
branch p·r·x = UU ==> branch (cpair_pat p q)·(csplit·r)·<x, y> = UU
lemma cpair_pat2:
branch p·r·x = fail ==> branch (cpair_pat p q)·(csplit·r)·<x, y> = fail
lemma cpair_pat3:
branch p·r·x = return·s
==> branch (cpair_pat p q)·(csplit·r)·<x, y> = branch q·s·y
lemma cpair_pat:
branch p·r·x = UU ==> branch (cpair_pat p q)·(csplit·r)·<x, y> = UU
branch p·r·x = fail ==> branch (cpair_pat p q)·(csplit·r)·<x, y> = fail
branch p·r·x = return·s
==> branch (cpair_pat p q)·(csplit·r)·<x, y> = branch q·s·y
lemma spair_pat:
branch (spair_pat p1.0 p2.0)·r·UU = UU
[| x ≠ UU; y ≠ UU |]
==> branch (spair_pat p1.0 p2.0)·r·(:x, y:) =
branch (cpair_pat p1.0 p2.0)·r·<x, y>
lemma sinl_pat:
branch (sinl_pat p)·r·UU = UU
x ≠ UU ==> branch (sinl_pat p)·r·(sinl·x) = branch p·r·x
y ≠ UU ==> branch (sinl_pat p)·r·(sinr·y) = fail
lemma sinr_pat:
branch (sinr_pat p)·r·UU = UU
x ≠ UU ==> branch (sinr_pat p)·r·(sinl·x) = fail
y ≠ UU ==> branch (sinr_pat p)·r·(sinr·y) = branch p·r·y
lemma up_pat:
branch (up_pat p)·r·UU = UU
branch (up_pat p)·r·(up·x) = branch p·r·x
lemma TT_pat:
(TT => r)·UU = UU
(TT => r)·TT = return·r
(TT => r)·FF = fail
lemma FF_pat:
(FF => r)·UU = UU
(FF => r)·TT = fail
(FF => r)·FF = return·r
lemma ONE_pat:
(ONE => r)·UU = UU
(ONE => r)·ONE = return·r
lemma wild_pat:
(_ => r)·x = return·r
lemma as_pat:
branch (as_pat p)·(csplit·r)·x = branch p·(r·x)·x
lemma lazy_pat:
branch p·r·x = UU ==> branch (lazy_pat p)·r·x = return·(r·UU)
branch p·r·x = fail ==> branch (lazy_pat p)·r·x = return·(r·UU)
branch p·r·x = return·s ==> branch (lazy_pat p)·r·x = return·s
lemma match_UU_simps:
match_UU·x = fail
lemma match_cpair_simps:
match_cpair·<x, y> = return·<x, y>
lemma match_spair_simps:
[| x ≠ UU; y ≠ UU |] ==> match_spair·(:x, y:) = return·<x, y>
match_spair·UU = UU
lemma match_sinl_simps:
x ≠ UU ==> match_sinl·(sinl·x) = return·x
x ≠ UU ==> match_sinl·(sinr·x) = fail
match_sinl·UU = UU
lemma match_sinr_simps:
x ≠ UU ==> match_sinr·(sinr·x) = return·x
x ≠ UU ==> match_sinr·(sinl·x) = fail
match_sinr·UU = UU
lemma match_up_simps:
match_up·(up·x) = return·x
match_up·UU = UU
lemma match_ONE_simps:
match_ONE·ONE = return·()
match_ONE·UU = UU
lemma match_TT_simps:
match_TT·TT = return·()
match_TT·FF = fail
match_TT·UU = UU
lemma match_FF_simps:
match_FF·FF = return·()
match_FF·TT = fail
match_FF·UU = UU
lemma cpair_equalI:
[| x == cfst·p; y == csnd·p |] ==> <x, y> == p
lemma cpair_eqD1:
<x, y> = <x', y'> ==> x = x'
lemma cpair_eqD2:
<x, y> = <x', y'> ==> y = y'
lemma ssubst_lhs:
[| t = s; P s = Q |] ==> P t = Q