@anonymous/

UnwelcomeLightblueUnix

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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
import Data.IORef
import Data.Foldable (for_)
import Data.Time (getCurrentTime, diffUTCTime)

import Data.Map (Map)
import qualified Data.Map as Map

type Memo = Map (Int, Int) Integer


combination :: Int -> Int -> State Memo Integer
_ `combination` 0 = pure 1
n `combination` k
  | n == k        = pure 1
  | n `div` 2 < k = combination n (n - k)
  | otherwise     = do
      m <- get
      case {-# SCC "combination:Map.lookup" #-} Map.lookup (n, k) m of
        Just a  -> pure a
        Nothing -> do
          a1 <- combination (n-1) (k-1)
          a2 <- combination (n-1) k
          let a = a1 + a2
          modify $ {-# SCC "combination:Map.insert" #-} Map.insert (n, k) a
          pure a


-- | パスカルの三角形の半分
pascalHalf :: Int -> State Memo [Integer]
pascalHalf upper = sequence [combination n k | n <- [1..upper], k <- [1..n `div` 2]]

-- | パスカルの三角形の真ん中
pascalCenter :: Int -> State Memo [Integer]
pascalCenter upper = sequence [combination n (n `div` 2 + 1) | n <- [1..upper], n `mod` 2 == 1]


-- | パスカルの三角形の中に与えられた数以下の数が出現する回数の辞書を計算する
occurrence :: Int -> Map Integer Int
occurrence 1 = error "occurrence can't take 1"
occurrence a = flip evalState Map.empty $ do
  half   <- pascalHalf a
  center <- pascalCenter a
  let halfMap = foldr go Map.empty half
      centerMap = foldr go Map.empty center
      result = Map.unionWith (+) centerMap $ Map.map (*2) halfMap
  pure result
  where
    a'   = fromIntegral a
    go x = if x <= a' then Map.insertWith (+) x 1 else id


-- | 与えられたアクションの実行に掛かった時間を表示する
showElapsedTime :: IO a -> IO a
showElapsedTime action = do
  start <- getCurrentTime
  a     <- action
  end   <- getCurrentTime
  print $ end `diffUTCTime` start
  pure a


main :: IO ()
main = showElapsedTime $ do
  let result = occurrence 500
  for_ [2..500] $ \a ->
    let n = result Map.! a
     in putStrLn $ "N(" ++ show a ++ ") = " ++ show n


---------------------------
-- State Monad
---------------------------


newtype State s a = State { runState :: s -> (a, s)}

instance Functor (State s) where
  fmap f (State g) = State $ \s ->
    let (a, s') = g s
     in (f a, s')

instance Applicative (State s) where
  pure a = State $ \s -> (a, s)
  (State f) <*> (State g) = State $ \s ->
    let (h, s')  = f s
        (a, s'') = g s'
     in (h a, s'')

instance Monad (State s) where
  (State f) >>= k = State $ \s ->
    let (a, s') = f s
        State g = k a
     in g s'

get :: State s s
get = State $ \s -> (s, s)

put :: s -> State s ()
put s = State $ \_ -> ((), s)

modify :: (s -> s) -> State s ()
modify f = State $ \s -> ((), f s)

evalState :: State s a -> s -> a
evalState (State f) = fst . f
  
GHCi, version 8.6.5