src/HOL/Corec_Examples/Paper_Examples.thy
changeset 63408 74c609115df0
parent 63406 32866eff1843
child 63468 cadd40a6cdec
equal deleted inserted replaced
63407:89dd1345a04f 63408:74c609115df0
    17 codatatype 'a stream = SCons (shd: 'a) (stl: "'a stream") (infixr "\<lhd>" 65)
    17 codatatype 'a stream = SCons (shd: 'a) (stl: "'a stream") (infixr "\<lhd>" 65)
    18 
    18 
    19 corec "natsFrom" :: "nat \<Rightarrow> nat stream" where
    19 corec "natsFrom" :: "nat \<Rightarrow> nat stream" where
    20   "natsFrom n = n \<lhd> natsFrom (n + 1)"
    20   "natsFrom n = n \<lhd> natsFrom (n + 1)"
    21 
    21 
    22 corec (friend) addOne :: "nat stream \<Rightarrow> nat stream"
    22 corec (friend) add1 :: "nat stream \<Rightarrow> nat stream"
    23 where "addOne n = (shd n + 1) \<lhd> addOne (stl n)"
    23 where "add1 n = (shd n + 1) \<lhd> add1 (stl n)"
    24 
    24 
    25 corec natsFrom' :: "nat \<Rightarrow> nat stream" where
    25 corec natsFrom' :: "nat \<Rightarrow> nat stream" where
    26   "natsFrom' n = n \<lhd> addOne (natsFrom' n)"
    26   "natsFrom' n = n \<lhd> add1 (natsFrom' n)"
    27 
       
    28 
    27 
    29 section \<open>Examples from section 3\<close>
    28 section \<open>Examples from section 3\<close>
    30 
    29 
    31 text \<open>We curry the example functions in this section because infix syntax works only for curried functions.\<close>
    30 text \<open>We curry the example functions in this section because infix syntax works only for curried functions.\<close>
    32 
    31 
    33 corec (friend) Plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infix "\<oplus>" 67) where
    32 corec (friend) Plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infix "\<oplus>" 67) where
    34   "x\<^sub>1 \<oplus> x\<^sub>2 = (shd x\<^sub>1 + shd x\<^sub>2) \<lhd> (stl x\<^sub>1 \<oplus> stl x\<^sub>2)"
    33   "x\<^sub>1 \<oplus> x\<^sub>2 = (shd x\<^sub>1 + shd x\<^sub>2) \<lhd> (stl x\<^sub>1 \<oplus> stl x\<^sub>2)"
    35 
    34 
    36 
       
    37 section \<open>Examples from section 4\<close>
    35 section \<open>Examples from section 4\<close>
    38 
    36 
    39 corec collatz :: "nat \<Rightarrow> nat stream" where
    37 codatatype 'a llist = LNil | LCons 'a "'a llist"
    40   "collatz n = (if even n \<and> n > 0 then collatz (n div 2) else n \<lhd> collatz (3 * n + 1))"
    38 
       
    39 corec collatz :: "nat \<Rightarrow> nat llist" where
       
    40   "collatz n = (if n \<le> 1 then LNil
       
    41      else if even n then collatz (n div 2)
       
    42      else LCons n (collatz (3 * n + 1)))"
    41 
    43 
    42 datatype 'a nelist = NEList (hd:'a) (tl:"'a list")
    44 datatype 'a nelist = NEList (hd:'a) (tl:"'a list")
    43 
    45 
    44 primrec (transfer) postpend :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a nelist" (infix "\<rhd>" 64) where
    46 primrec (transfer) snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a nelist" (infix "\<rhd>" 64) where
    45  "[] \<rhd> a = NEList a []"
    47  "[] \<rhd> a = NEList a []"
    46 |"(b # bs) \<rhd> a = NEList b (bs @ [a])"
    48 |"(b # bs) \<rhd> a = NEList b (bs @ [a])"
    47 
    49 
    48 corec (friend) inter :: "nat stream nelist \<Rightarrow> nat stream" where
    50 corec (friend) inter :: "nat stream nelist \<Rightarrow> nat stream" where
    49 "inter x = shd (hd x) \<lhd> inter (tl x \<rhd> stl (hd x))"
    51 "inter xss = shd (hd xss) \<lhd> inter (tl xss \<rhd> stl (hd xss))"
    50 
    52 
    51 corec (friend) inter2 :: "nat stream nelist \<Rightarrow> nat stream" where
    53 corec (friend) inter' :: "nat stream nelist \<Rightarrow> nat stream" where
    52 "inter2 x = (case hd x of n \<lhd> y \<Rightarrow> n \<lhd> inter2 (tl x \<rhd> y))"
    54 "inter' xss = (case hd xss of x \<lhd> xs \<Rightarrow> x \<lhd> inter' (tl xss \<rhd> xs))"
    53 
    55 
    54 corec zero :: "nat stream" where "zero = 0 \<lhd> zero"
    56 corec zero :: "nat stream" where "zero = 0 \<lhd> zero"
    55 
       
    56 corec (friend) inter3 :: "nat stream nelist \<Rightarrow> nat stream" where
       
    57 "inter3 x = shd (stl zero) \<lhd> inter3 ([hd x] \<rhd> stl (hd x))"
       
    58 
       
    59 
    57 
    60 section \<open>Examples from Blanchette et al. (ICFP 2015)\<close>
    58 section \<open>Examples from Blanchette et al. (ICFP 2015)\<close>
    61 
    59 
    62 corec oneTwos :: "nat stream" where "oneTwos = 1 \<lhd> 2 \<lhd> oneTwos"
    60 corec oneTwos :: "nat stream" where "oneTwos = 1 \<lhd> 2 \<lhd> oneTwos"
    63 
    61 
    89 
    87 
    90 corec (friend) tplus :: "tree \<Rightarrow> tree \<Rightarrow> tree"
    88 corec (friend) tplus :: "tree \<Rightarrow> tree \<Rightarrow> tree"
    91 where "tplus t u = Node (val t + val u) (map (\<lambda>(t', u'). tplus t' u') (zip (sub t) (sub u)))"
    89 where "tplus t u = Node (val t + val u) (map (\<lambda>(t', u'). tplus t' u') (zip (sub t) (sub u)))"
    92 
    90 
    93 corec (friend) ttimes :: "tree \<Rightarrow> tree \<Rightarrow> tree"
    91 corec (friend) ttimes :: "tree \<Rightarrow> tree \<Rightarrow> tree"
    94 where "ttimes t u = Node (val t * val u) (map (\<lambda>(t , u ). tplus (ttimes t u ) (ttimes t u)) (zip (sub t) (sub u)))"
    92 where "ttimes t u = Node (val t * val u)
       
    93   (map (\<lambda>(t, u). tplus (ttimes t u) (ttimes t u)) (zip (sub t) (sub u)))"
    95 
    94 
    96 corecursive primes :: "nat \<Rightarrow> nat \<Rightarrow> nat stream"
    95 corecursive primes :: "nat \<Rightarrow> nat \<Rightarrow> nat stream"
    97 where "primes m n =
    96 where "primes m n =
    98   (if (m = 0 \<and> n > 1) \<or> coprime m n then n \<lhd> primes (m * n) (n + 1) else primes m (n + 1))"
    97   (if (m = 0 \<and> n > 1) \<or> coprime m n then n \<lhd> primes (m * n) (n + 1) else primes m (n + 1))"
    99 apply (relation "measure (\<lambda>(m, n). if n = 0 then 1 else if coprime m n then 0 else m - n mod m)")
    98 apply (relation "measure (\<lambda>(m, n). if n = 0 then 1 else if coprime m n then 0 else m - n mod m)")