Theory Fixrec

Up to index of Isabelle/HOLCF

theory Fixrec
imports Sprod Ssum One Tr Fix
uses (Tools/fixrec_package.ML)
begin

(*  Title:      HOLCF/Fixrec.thy
    ID:         $Id: Fixrec.thy,v 1.25 2007/10/23 11:29:16 wenzelm 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"

translations
  "_Case1 p r" => "XCONST branch (_pat p)·(_var p r)"
  "_var (_args x y) r" => "XCONST csplit·(_var x (_var y r))"
  "_var () r" => "XCONST 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 @{const_syntax Unity}, 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)" => "XCONST cpair_pat (_pat x) (_pat y)"
  "_pat (XCONST spair·x·y)" => "XCONST spair_pat (_pat x) (_pat y)"
  "_pat (XCONST sinl·x)" => "XCONST sinl_pat (_pat x)"
  "_pat (XCONST sinr·x)" => "XCONST sinr_pat (_pat x)"
  "_pat (XCONST up·x)" => "XCONST up_pat (_pat x)"
  "_pat (XCONST TT)" => "XCONST TT_pat"
  "_pat (XCONST FF)" => "XCONST FF_pat"
  "_pat (XCONST ONE)" => "XCONST ONE_pat"

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 () r"
  "_var (XCONST FF) r" => "_var () r"
  "_var (XCONST ONE) r" => "_var () 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) ()"
  "CONST FF" <= "_match (CONST FF_pat) ()"
  "CONST ONE" <= "_match (CONST ONE_pat) ()"

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 _" => "XCONST wild_pat"
  "_pat (_as_pat x y)" => "XCONST as_pat (_pat y)"
  "_pat (_lazy_pat x)" => "XCONST lazy_pat (_pat x)"

text {* Parse translations (variables) *}
translations
  "_var _ r" => "_var () 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) ()"
  "_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

Maybe monad type

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

Monadic bind operator

lemma bind_strict:

  bind·UU·f = UU

lemma bind_fail:

  bind·fail·f = fail

lemma left_unit:

  bind·(return·ak = k·a

lemma right_unit:

  bind·m·return = m

lemma bind_assoc:

  bind·(bind·m·kh = bind·m·(LAM a. bind·(k·ah)

Run operator

lemma run_strict:

  run·UU = UU

lemma run_fail:

  run·fail = UU

lemma run_return:

  run·(return·x) = x

Monad plus operator

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

Fatbar combinator

lemma fatbar1:

  m·x = UU ==> (m \<parallel> msx = UU

lemma fatbar2:

  m·x = fail ==> (m \<parallel> msx = ms·x

lemma fatbar3:

  m·x = return·y ==> (m \<parallel> msx = return·y

lemma fatbar_simps:

  m·x = UU ==> (m \<parallel> msx = UU
  m·x = fail ==> (m \<parallel> msx = ms·x
  m·x = return·y ==> (m \<parallel> msx = return·y

lemma run_fatbar1:

  m·x = UU ==> run·((m \<parallel> msx) = UU

lemma run_fatbar2:

  m·x = fail ==> run·((m \<parallel> msx) = run·(ms·x)

lemma run_fatbar3:

  m·x = return·y ==> run·((m \<parallel> msx) = y

lemma run_fatbar_simps:

  m·x = UU ==> run·((m \<parallel> msx) = UU
  m·x = fail ==> run·((m \<parallel> msx) = run·(ms·x)
  m·x = return·y ==> run·((m \<parallel> msx) = y

Case branch combinator

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)

Case syntax

Pattern combinators for data constructors

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.0r·UU = UU
  [| x  UU; y  UU |]
  ==> branch (spair_pat p1.0 p2.0r·(:x, y:) =
      branch (cpair_pat p1.0 p2.0r·<x, y>

lemma sinl_pat:

  branch (sinl_pat pr·UU = UU
  x  UU ==> branch (sinl_pat pr·(sinl·x) = branch p·r·x
  y  UU ==> branch (sinl_pat pr·(sinr·y) = fail

lemma sinr_pat:

  branch (sinr_pat pr·UU = UU
  x  UU ==> branch (sinr_pat pr·(sinl·x) = fail
  y  UU ==> branch (sinr_pat pr·(sinr·y) = branch p·r·y

lemma up_pat:

  branch (up_pat pr·UU = UU
  branch (up_pat pr·(up·x) = branch p·r·x

lemma TT_pat:

  (TT => rUU = UU
  (TT => rTT = return·r
  (TT => rFF = fail

lemma FF_pat:

  (FF => rUU = UU
  (FF => rTT = fail
  (FF => rFF = return·r

lemma ONE_pat:

  (ONE => rUU = UU
  (ONE => r)·ONE = return·r

Wildcards, as-patterns, and lazy patterns

lemma wild_pat:

  (_ => rx = return·r

lemma as_pat:

  branch (as_pat p)·(csplit·rx = branch p·(r·xx

lemma lazy_pat:

  branch p·r·x = UU ==> branch (lazy_pat pr·x = return·(r·UU)
  branch p·r·x = fail ==> branch (lazy_pat pr·x = return·(r·UU)
  branch p·r·x = return·s ==> branch (lazy_pat pr·x = return·s

Match functions for built-in types

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

Mutual recursion

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

Initializing the fixrec package