beer/beer.hs

vape :: [a] -> ([a] -> [a])
vape (x:xs) = (x:) . (vape xs)
vape [] = id 

conk :: Eq a => [[a]] -> ([a] -> [a]) -> ([a] -> [a])
conk (x:xs) f = (vape x) . (sep xs f) . (conk xs f)
   where
      sep x l = if (x == []) then id else l
conk [] _ = id

lyrc'b'o :: Integer -> ((Integer -> String) -> String)
lyrc'b'o x
   | (x == 0) = (\_ -> "no more bottles")
   | (x == 1) = cenk "bottle" x
   | otherwise = cenk "bottles" x
   where
      cenk s x = (\f -> conk [(f x), s] (' ':) $ [])

lyrc's'o :: String -> ((Integer -> String) -> String)
lyrc's'o s = (\_ -> s)

lyrc's :: (((Integer -> String) -> String), ((Integer -> String) -> String))
lyrc's = (
      lyrc's'o "take one down",
      lyrc's'o "pass it around"
   )

shic ::  Integer ->
         (Integer -> ((Integer -> String) -> String)) ->
         String ->
         ((Integer -> String) -> String)
shic x l w = (\f -> conk [l x $ f, w] (' ':) $[])

lyrc'b :: Integer -> ((Integer -> String) -> String)
lyrc'b x = shic x lyrc'b'o "of beer"

lyrc'w :: Integer -> ((Integer -> String) -> String)
lyrc'w x = shic x lyrc'b "on the wall"

lyrc :: Integer -> [((Integer -> String) -> String)]
lyrc x = [
      lyrc'w x,
      lyrc'b x,
      fst stic,
      snd stic,
      lyrc'w (x-1)
   ]
   where
      stic = lyrc's

thap :: (Integer -> String) -> ((Integer -> String) -> String) -> String
thap f x = x f

thop :: (Integer -> String) -> [((Integer -> String) -> String)] -> [String]
thop f l = map (thap f) l

--TO DO
--edit this function to convert digits to english words
tran :: Integer -> String
tran = show

beer :: Integer -> [String]
beer x = thop (tran) (lyrc x)

runSong :: Integer -> IO ()
runSong 0 = return ()
runSong x
   | x <= 0 = runSong 0
   | otherwise = do
      mapM_ putStrLn (beer x)
      putStrLn ""
      runSong (x-1)

main :: IO ()
main = runSong 10