「人を呪えば穴ふたつ」の論理を Haskell で実装したら居るはずのない死者が増え続けていく結果になった

呪い.hs

module Main where

type People = Int -- 人間
type Grave  = (Int, Int) -- 墓穴

呪う :: (People, People, Grave) -> (People, People, Grave)

呪う (0, 0, n) = (0, 0, n) -- 人間がいない

呪う (0, 1, (i, j)) = (0, 0, (i + 1, j + 1)) -- 死んでいくのみ
呪う (1, 0, (i, j)) = (0, 0, (i + 1, j + 1)) -- 死んでいくのみ

呪う (1, 1, (i, j)) = (0, 0, (i + 2, j + 2)) -- 「人を呪えば穴2つ」

呪う (k, 0, (i, j)) = 呪う (k - 1,     0, (i + 1, j + 1)) -- 死んでいくのみ
呪う (0, h, (i, j)) = 呪う (    0, h - 1, (i + 1, j + 1)) -- 死んでいくのみ

呪う (k, 1, (i, j)) = 呪う (k - 1,     1, (i + 1, j + 1)) -- 死んでいくのみ
呪う (1, h, (i, j)) = 呪う (    1, h - 1, (i + 1, j + 1)) -- 死んでいくのみ

呪う (k, h, (i, j)) = -- 互いに呪い続けた結果
  let l = min k h
      m = max k h
  in 呪う (0, 0, (i + m, j + l + m))

無 :: Grave
無 = (0,0)

示す :: (People, People, Grave) -> IO ()
示す (k, h, n) =
  let
    (_, _, (i, j)) = 呪う (k, h, n)
    幾つ
      | i == j = show i ++ "つ"
      | otherwise = show i ++ "〜" ++ show j ++ "つ"
  in
    putStrLn $ "現実、それは " ++
    show k ++ "人が、" ++
    show h ++ "人呪えば、穴" ++ 幾つ

main :: IO ()
main = 続く
  where
  聞く   = getLine >>= return . read
  問う s = putStr s >> 聞く >>= return
  続く = do
    怨嗟 <- 問う "何人呪ってる? > "
    悲哀 <- 問う "何人呪われてる? > "

    示す (怨嗟, 悲哀, 無)
    続く