src/Ackermann.hs

   1
   2 -- import Debug.Trace
   3
   4 import Data.List
   5 import qualified Data.Map.Strict as M
   6 import Data.Map.Strict ((!))
   7 -- import Data.Maybe
   8
   9 import Control.Monad.State.Strict
  10 -- import Control.Monad.Reader
  11 -- import Control.Monad.Writer
  12 -- import Control.Monad.RWS.Strict
  13
  14 import Control.Parallel.Strategies
  15
  16
  17 type Memo = M.Map (Int, Int) Int
  18
  19 type MemoF = State Memo
  20
  21 main :: IO ()
  22 main =
  23   do let resultPairs = fmap evalAck [0 .. (2 ^ 15 - 1)] `using` parList rdeepseq
  24      let result = filter ((== 6) . snd) resultPairs
  25      print result
  26
  27 r7Gives6 :: Int -> Bool
  28 r7Gives6 r7 = result == 6
  29   where result = evalState (ackermann 4 1 r7) M.empty
  30
  31 evalAck :: Int -> (Int, Int)
  32 evalAck r7 = (r7, evalState (ackermann 4 1 r7) M.empty)
  33
  34
  35 ackermann :: Int -> Int -> Int -> MemoF Int
  36 ackermann r0 r1 r7 = do
  37   memoResult <- memoLookup r0 r1
  38   case memoResult of
  39     Just r -> return r
  40     Nothing ->
  41       do if r0 == 0
  42             then do let res = ((r1 + 1) `mod` (2 ^ 15))
  43                     memoStore r0 r1 res
  44                     return res
  45             else if r1 == 0
  46                     then do res <- ackermann (r0 - 1) r7 r7
  47                             memoStore r0 r1 res
  48                             return res
  49                     else do subResult <- ackermann r0 (r1 - 1) r7
  50                             res <- ackermann (r0 - 1) subResult r7
  51                             memoStore r0 r1 res
  52                             return res
  53
  54 memoLookup :: Int -> Int -> MemoF (Maybe Int)
  55 memoLookup r0 r1 =
  56   do table <- get
  57      return $ M.lookup (r0, r1) table
  58
  59 memoStore :: Int -> Int -> Int -> MemoF ()
  60 memoStore r0 r1 result =
  61   do table <- get
  62      let table' = M.insert (r0, r1) result table
  63      put table'
  64