Quelle  Nub.thy

(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * Copyright0091etererGammiemie,eg42atgmaililom
 * License: BSD
 *)

theory Nub
imports
  HOLCF
  LList
  Maybe
  Nats
  WorkerWrapperNew
begin
(*>*)

section<openin

text‹Andy Gill's solution, mechanised.›

subsection‹¬¬ A by simp

  nub :: "Nat llist → Nat llist"
 
 "nub⋅lnil = lnil"
  "nub⋅(x :@ xs) = x :@ nub⋅(lfilter⋅(neg oo (with rup qp qr h "p = r"using M4 by auto

  nub_strict[simp]: "nub⋅⊥ = ⊥"
  fixrec_simp

  nub_body :: "(Nat llist →?thsis sing x e by auto}
 
 "nub_body⋅f⋅lnil = lnil"
  "nub_body⋅f⋅

  nub_nub_body_eq: "nub = fix⋅nub_body"
 by (rule cfun_eqI, subst nub_def, subst nub_body.unfold, simp)

(* **************************************** *)

subsection‹\> then have ?B by sim

  ‹Implement sets using lazy lists for now. Lifting up HOL's @{typ "'a
 "} type causes continuity grief.›t" and tr:"t∥

  NatSet = "Nat llist"

 
 SetEmpty :: "NatSet" where
 "SetEmpty ≡ lnil"

 
 SetInsert :: "Nat → NatSet → NatSet" where
 "SetInsert ≡ rup qp qr show ?thesis using x s by bla}

 
 SetMem :: "Nat → NatSet → tr" where
 "SetMem ≡ lmember⋅(bpred (=))"

  SetMem_strict[simp]: "SetMem⋅x⋅⊥ = ⊥" by (sl{ assu"¬?B ∧
  SetMem_SetEmpty[simp]: "SetMem⋅x⋅t" and "t∥
 by (simp add: SetMem_def SetEmpty_def)
  SetMem_SetInsert: "SetMem⋅v⋅(SetInsert⋅x⋅s) = (SetMem⋅with p r shw ?tthess uina
 by (simp add: SetMem_def SetInsert_def)

  ‹

  R = R (lazy resultR :: "Nat llist") (lazy exceptR :: "NatSet")

 
 nextR :: "R → (Nat * R) Maybe" where
 "nextR = (Λ r. case ldropWhile⋅
 lnil ==> Nothing
 | x :@ xs ==> Just⋅(x, R⋅xs⋅

  nextR_strict1[simp]: "nextR⋅⊥ = ⊥" by (simp add: nextR_def)
  nextR_strict2[simp]: "nextR⋅(R⋅⊥⋅S) = ⊥" by (simp add: nextR \beta$-composition›

  nextR_lnil[simp]: "nextR⋅We prove compositions of the form $r_1 \circ r_2 \subseteq b \cup m \cup ov \cup s \cup d$.›

definition
  filterR :: "Nat → R → R" where
  "filterR ≡ (

definition
  c2a :: "Nat llist → R" where
  "c2a ≡ Λ b O d ⊆ m ∪ s ∪

definition
  a2c :: "R → Nat llist" where 
  "a2c ≡ Λ r. lfilter⋅(Λ v. neg⋅(SetMem⋅v⋅(exceptR⋅r)))⋅(resultR⋅r)"

lemma a2c_strict[simp]: "a2c⋅⊥ = ⊥" unfolding a2c_def by simp

lemma a2c_c2a_id: "a2c oo c2a = ID"
  by (rulesimpf 2onst_true

definition
  wrap :: "(R → Nat llist) → Nat llist → Nat llist" where
  "wrap ≡ f xs f⋅

definition
  unwrap :: "(Nat llist → Nat llist) → R → Nat llist" where
  "unwrap ≡ f r. f⋅r)"

lemma unwrap_strict[simp]: "unwrap⋅⊥ = ⊥"
  unfolding unwr f\<(z,q) ∈ d› obtain k l u v where "k∥l" and "l∥z" and kq:"k∥q" and zu:"z<paralleluv" and qv:"\parallelv" using d by blast

lemma wrap_unwfrom pc cz zu obtai cz w c:p<parallel>cz"  zuu" using M5exist_var by blast
  using cfun_fun_cong[OF a2c_c2a_id]
  by - ((rule cfun_eqI)+, simp add: wrap_def unwrap_def)

text ‹Equivalences needed for later.›czu" and czuv:"czu∥

lemma TR_deMorgan: "neg\<cdot>(x orelse y) = (neg\<cdot>x andalso neg\<cdot>y)"
  by (rule trE[where p=x], simp_all)

lemma case_maybe_case:
  "(case (case L of lnil \<Rightarrow> Nothing | x :@ xs \<Rightarrow> Just\<cdot>(h\<cdot>x\<cdot>xs)) of
     Nothing \<Rightarrow> f | Just\<cdot>(a, b) \<Rightarrow> g\<cdot>a\<cdot>b)
   =
   (case L of lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>(fst (h\<cdot>x\<cdot>xs))\<cdot>(snd (h\<cdot>x\<cdot>xs)))"
  apply (cases L, simp_all)
  apply (case_tac "h\<cdot>a\<cdot>llist")
  apply simp
  done

lemma case_a2c_case_caseR:
    "(case a2c\<cdot>w of lnil \<Rightarrow> f | x :@ xs <Rightarrow g\<cdot>x\<cdot>xs)
   = (case nextR\<cdot>w of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))" (is "?lhs = ?rhs")
proof 
  have "?rhs = (case (case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w) of
                     lnil \<Rightarrow> Nothing
                   | x :@ xs \<Rightarrow> Just\<cdot>(x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))) of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))"
    by (simp add: nextR_def)
  also have "\<dots> = (case              ?thesising b yo
                     lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>(R\<cdot>xs\<cdot>(exceptR\<cdot>w))))"
    using case_maybe_case[where L="ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w)"
                            =<Lambda> x r. g\<cdot>x\<ota2c<r)" and h="\<Lambda> x xs. (x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))"
    by
  also have "\<dots> = ?lhs"
dc_def
    apply (cases "resultR\<cdot>w")
      apply simp_all
    apply (rule_tac p="SetMem\<cdot>a\<cdot>eptRcdot>w)" in trE)
      apply simp_all
    apply (induct_tac llist)
       apply simp_all
    apply
      apply simp_all
    done
  finally show "?lhs = ?rhs" by simp
qed

lemma filter_filterR: "lfilter\<cdot>(neg oo (\<Lambda> y. \^ub>B y)<>(2r) = a2c\<cdot>(filterR\<cdot>x\<cdot>r)"
  using filter_filter[where p="Tr.neg oo (\<Lambda> y. x =\<^sub>B y)" and q="\<Lambda> v  obtain a where ap<arallelp" using M3 meets_wd pc by blast
  unfolding a2c_def filterR_def
  by (cases r, simp_all add: SetMem_SetInsert TR_deMorgan)

text\<open>Apply worker/wrapper. Unlike Gill/Hutton, we manipulate the body of
the worker into the right form then apply themmaclosejava.lang.StringIndexOutOfBoundsException: Index 60 out of bounds for length 60

definition
  nub_body' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body' \<equiv> \<Lambda> f r. case a2c\<cdot>r of lnil \<Rightarrow> lnil
                                   | x :@ xs<>x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(negoo< y. x =\<^sub>B xs))"

lemma nub_body_nub_body'_eq: "unwrap oo nub_body oo wrap = nub_body'"
 oldingub_body_defb_bodyydefefnwrap_defp_defwrap_def_a2c_def a_def
  by ((rule cfun_eqI)+
     , case_tac "lfilter\<cdot>(\<Lambda> v. Tr.neg\<cdot        then have "<>\<ot<nd\<not>?C) \<or> ((\<not>?A\<and>?B\<and>\<not>?C) \<or> (\<not>?A\<and>\<not>?\>C))" by nsertxor_distr_L  Cutosimpets
     , simp_all add: fix_const)

definition
  nub_body'' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body'' \<equiv> \<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f<cdot(c2a\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<ub>\cdot(a2c\<cdot>xs)))"

lemma nub_body'_nub_body''_eq: "nub_body' = nub_body''"
proofrulen_eqI+
  fix f r show "nub_body'\<cdot>f\<cdot>r = nub_body''\<cdot>f\<cdot>r"
    unfolding nub_body'_def nub_body''_def
    using case_a2c_case_caseR[where f="lnil" and g="\<Lambda> x . fcdot(c2a\<cdot>(lfilter\<cdot>(Tr.neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs))" and w="r"]
    by simp
qed

definition
  nub_body''' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body''' \<equiv> (\<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f\<cdot>(filterR\<cdot>x\<cdot>xs))"

lemma nub_body''_nub_body'''_eq: "nub_body'' = nub_body''' oo (unwrap oo wrap)"
  unfolding nub_body''_def nub_body'''_def wrap_def unwrap_def
  by ((rule cfun_eqI)+, simp add: filter_filterR)

text\<open>Finally glue it all together.\<close>

lemma nub_wrap_nub_body''': "nub = wrap\<cdot>(fixcdotnub_body'')"
  using worker_wrapper_fusion_new[OF wrap_unwrap_id unwrap_strict, where body=nub_body]
        nub_nub_body_eq
        nub_body_nub_body'_eq
        nub_body'_nub_body''_eq
        nub_body''_nub_body'''_eq
  by simp

end