Fizz Buzz

fizz-buzz.hs

{-# LANGUAGE BlockArguments #-}

import Data.Foldable (for_)
import Data.Bifunctor (bimap, first)

fizzbuzz :: Int -> String
fizzbuzz n = (test 3 "fizz" . test 5 "buzz") id (show n)
  where

  test
    :: Int
    -> String
    -> (String -> String)
    -> (String -> String)
  test d s k v
    | n `mod` d == 0 = s ++ k ""
    | otherwise      =      k v


fizzbuzz_e :: Int -> String
fizzbuzz_e x =
  either id id . test 3 "fizz" . test 5 "buzz" $ Right (show x)
  where
  test n s
    | x `mod` n == 0 = first (s <>) . (>> Left "")
    | otherwise = id


fizzbuzz_mine :: Int -> String
fizzbuzz_mine x = uncurry (<>) . test 3 "fizz" . test 5 "buzz" $ ("", show x)
  where
  test n s
    | x `mod` n == 0 = bimap (s <>) (const "")
    | otherwise = id

--

data K a = K ((a -> a) -> (a -> a))

instance Semigroup (K a) where
  K f <> K g = K (f . g)

instance Monoid (K a) where
  mempty = K id

runK :: K a -> (a -> a)
runK (K k) = k id

fizzbuzz_K :: Int -> String
fizzbuzz_K n = runK (test 3 "fizz" <> test 5 "buzz") (show n)
  where

  test
    :: Int
    -> String
    -> K String
  test d s
    | n `mod` d == 0 = K (\k _ -> s ++ k "")
    | otherwise      = K (\k v ->       k v)

--

data S a = S (a -> a) (a -> a)

instance Semigroup (S a) where
  S fb fa <> S gb ga = S (gb . fb) (fa . ga)

instance Monoid (S a) where
  mempty = S id id

runS :: S a -> (a -> a)
runS (S b a) = a . b

fizzbuzz_S :: Int -> String
fizzbuzz_S n = runS (test 3 "fizz" <> test 5 "buzz") (show n)
  where

  test
    :: Int
    -> String
    -> S String
  test d s
    | n `mod` d == 0 = S (const "") (s ++)
    | otherwise      = mempty

--

data T a = T ((a, a) -> (a, a))

instance Semigroup a => Semigroup (T a) where
  T f <> T g = T (f . g)

instance Monoid a => Monoid (T a) where
  mempty = T id

runT :: T a -> ((a, a) -> (a, a))
runT (T f) = f

fizzbuzz_T :: Int -> String
fizzbuzz_T n = uncurry (<>) $ runT (test 3 "fizz" <> test 5 "buzz") ("", show n)
  where

  test
    :: Int
    -> String
    -> T String
  test d s
    | n `mod` d == 0 = T (bimap (++ s) (const ""))
    | otherwise      = mempty

--

tToK :: Monoid a => T a -> K a
tToK (T f) = K (\k x -> uncurry (<>) $ f (k x, mempty))  -- ???

fizzbuzz_TK :: Int -> String
fizzbuzz_TK n = (runK . tToK . mconcat) [test 3 "fizz", test 5 "buzz"] (show n)
  where

  test
    :: Int
    -> String
    -> T String
  test d s
    | n `mod` d == 0 = T (bimap (++ s) (const ""))
    | otherwise      = mempty

--

main = do
  let impl = fizzbuzz_e
  for_ [1..20] $ \x -> do
    putStrLn . impl $ x
  putStrLn ""