repl.it
@pyelias/

memoize

Haskell

No description

fork
loading
Files
  • main.hs
main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
{-# LANGUAGE TypeFamilies #-}

class Mappable k where
  data Map k :: * -> *

  get :: k -> Map k v -> v
  apply :: (a -> b) -> Map k a -> Map k b
  replace :: k -> v -> Map k v -> Map k v
  identity :: Map k k
  fill :: a -> Map k a

  from :: (k -> v) -> Map k v
  from f = apply f identity

instance Mappable Bool where
  data Map Bool v = BMap v v

  get True (BMap t f) = t
  get False (BMap t f) = f

  apply m (BMap t f) = BMap (m t) (m f)
  
  replace True v (BMap _ f) = BMap v f
  replace False v (BMap t _) = BMap t v
  
  identity = BMap True False
  fill v = BMap v v

instance Mappable Integer where
  data Map Integer v = IMap v
                            (Map Integer v)
                            (Map Integer v)

  get k (IMap z o e)
    | k == 0 = z
    | odd k = get ((k - 1) `div` 2) o
    | otherwise = get (k `div` 2 - 1) e
  
  apply m (IMap z o e) = IMap (m z)
                              (apply m o)
                              (apply m e)
  
  replace k v (IMap z o e)
    | k == 0 = (IMap v o e)
    | odd k = replace ((k - 1) `div` 2) v o
    | otherwise = replace (k `div` 2 - 1) v e
  
  identity = tree 0 1 where
             tree start step = IMap
               start
               (tree (start + step) (2 * step))
               (tree (start + 2 * step) (2 * step))
  
  fill v = IMap v (fill v) (fill v)

instance Mappable a => Mappable [a] where
  data Map [a] v = LMap v (Map a (Map [a] v))

  get [] (LMap v _) = v
  get (k : ks) (LMap _ vs) = get ks (get k vs)

  apply m (LMap v vs) = LMap (m v) (apply (apply m) vs)

  replace [] v (LMap _ vs) = LMap v vs
  replace (k : ks) v (LMap f vs) =
    let v' = replace ks v (get k vs) in
    LMap f (replace k v' vs)

  identity = LMap [] (from (\v -> apply (v:) identity))

  fill v = LMap v (fill (fill v))

mem :: Mappable a => (a -> b) -> (a -> b)
mem f = (\a -> get a t) where t = from f

fib_ :: Integer -> Integer
fib_ n 
  | n < 2 = n
  | otherwise = fib (n - 1) + fib (n - 2)
fib = mem fib_

f_ :: [Integer] -> Integer
f_ _ = 42
f = mem f_

main = print (f [1])
GHCi, version 8.6.5
?