124 lines
2.5 KiB
Haskell
124 lines
2.5 KiB
Haskell
module Main (main) where
|
|
|
|
ordinals :: [ String ]
|
|
ordinals = [
|
|
"second",
|
|
"third",
|
|
"fourth",
|
|
"fifth",
|
|
"sixth",
|
|
"seventh",
|
|
"eighth",
|
|
"ninth",
|
|
"tenth",
|
|
"eleventh",
|
|
"twelfth"
|
|
]
|
|
|
|
signatures :: [ ( Int, Int, Int, Int) ]
|
|
signatures = [
|
|
( 3, 6, 5, 0 ),
|
|
( 5, 6, 4, 1 ),
|
|
( 4, 7, 5, 1 ),
|
|
( 4, 4, 5, 5 ),
|
|
( 3, 5, 8, 8 ),
|
|
( 5, 5, 10, 5 ),
|
|
( 5, 5, 9, 20 ),
|
|
( 4, 6, 7, 10 ),
|
|
( 3, 5, 9, 23 ),
|
|
( 6, 6, 6, 3 ),
|
|
( 6, 8, 8, 3 )
|
|
]
|
|
|
|
cardinals :: [ String ]
|
|
cardinals = [
|
|
"Two",
|
|
"Three",
|
|
"Four",
|
|
"Five",
|
|
"Six",
|
|
"Seven",
|
|
"Eight",
|
|
"Nine",
|
|
"Ten",
|
|
"Eleven",
|
|
"Twelve"
|
|
]
|
|
|
|
|
|
gifta :: [ String ]
|
|
gifta = [
|
|
"turtle",
|
|
"French",
|
|
"calling",
|
|
"gold",
|
|
"geese",
|
|
"swans",
|
|
"maids",
|
|
"ladies",
|
|
"lords",
|
|
"pipers",
|
|
"drummers"
|
|
]
|
|
|
|
giftb :: [ String ]
|
|
giftb = [
|
|
"doves",
|
|
"hens",
|
|
"birds",
|
|
"rings",
|
|
"a-laying",
|
|
"a-swimming",
|
|
"a-milking",
|
|
"dancing",
|
|
"a-leaping",
|
|
"piping",
|
|
"drumming"
|
|
]
|
|
|
|
gifts :: [ ( String, String, String ) ]
|
|
gifts = [ ( c, a, b ) | c <- cardinals, a <- gifta, b <- giftb ]
|
|
|
|
matchGifts :: ( Int, Int, Int ) -> [ ( String, String, String ) ]
|
|
matchGifts ( i, j, k ) = filter match gifts
|
|
where
|
|
match ( c, a, b ) = (length c == i) && (length a == j) && (length b == k)
|
|
|
|
giftStr :: ( String, String, String ) -> String
|
|
giftStr (c, a, b) = c ++ " " ++ a ++ " " ++ b
|
|
|
|
wrapGift :: ( Int, Int, Int, Int ) -> String
|
|
wrapGift (i, j, k, l) = gs !! l
|
|
where
|
|
gs = map giftStr $ matchGifts (i, j, k)
|
|
|
|
concatLines :: [ String ] -> String
|
|
concatLines ls = foldr (\a b -> a ++ "\n" ++ b) "" ls
|
|
|
|
opening :: String -> String
|
|
opening o = "On the " ++ o ++ " day of Christmas my true love gave to me\n"
|
|
|
|
partridge :: String
|
|
partridge = "partridge in a pear tree"
|
|
|
|
makeVerse :: String -> [ String ] -> String
|
|
makeVerse o [] = (opening o) ++ "A " ++ partridge
|
|
makeVerse o gs = (opening o) ++ (concatLines gs) ++ "And a " ++ partridge
|
|
|
|
allGifts :: [ String ]
|
|
allGifts = map wrapGift $ reverse signatures
|
|
|
|
recurseVerse :: [ ( String, String ) ] -> [ String ]
|
|
recurseVerse [] = [ makeVerse "first" [] ]
|
|
recurseVerse (t:ts) = [ (makeVerse ord gs) ] ++ (recurseVerse ts)
|
|
where
|
|
ord = fst t
|
|
gs = [(snd t)] ++ (map snd ts)
|
|
|
|
tuples :: [ ( String, String ) ]
|
|
tuples = zip (reverse ordinals) allGifts
|
|
|
|
|
|
main :: IO ()
|
|
main = putStrLn $ foldr (\a b -> a ++ "\n\n" ++ b) "" $ reverse $ recurseVerse tuples
|