The month of October in 2010 has five Fridays, five Saturdays, and five Sundays.



Task

 Write a program to show all months that have this same characteristic of five full weekends from the year 1900 through 2100 (Gregorian calendar). 
 Show the number of months with this property (there should be 201).
 Show at least the first and last five dates, in order.

Algorithm suggestions

 Count the number of Fridays, Saturdays, and Sundays in every month.
 Find all of the 31-day months that begin on Friday.

Extra credit

Count and/or show all of the years which do not have at least one five-weekend month (there should be 29).



Related tasks
 Day of the week
 Last Friday of each month
 Find last sunday of each month


import Data.List (intercalate)
 
data DayOfWeek = Monday | Tuesday | Wednesday | Thursday | Friday |
    Saturday | Sunday
    deriving (Eq, Show)
 
-- the whole thing bases upon an infinite list of weeks
 
daysFrom1_1_1900 :: [DayOfWeek]
daysFrom1_1_1900 = concat $ repeat [Monday, Tuesday, Wednesday,
    Thursday, Friday, Saturday, Sunday]
 
data Month = January | February | March | April | May | June | July |
    August | September | October | November | December
    deriving (Show)
 
type Year = Int
type YearCalendar = (Year, [DayOfWeek])
type MonthlyCalendar = (Year, [(Month, [DayOfWeek])])
 
-- makes groups of 365 or 366 days for each year (infinite list)
 
yearsFrom :: [DayOfWeek] -> Year -> [YearCalendar]
yearsFrom s i = (i, yeardays) : yearsFrom rest (i + 1)
    where
        yeardays = take (leapOrNot i) s
        yearlen  = length yeardays
        rest    = drop yearlen s
        leapOrNot n = if isLeapYear n then 366 else 365
 
yearsFrom1900 :: [YearCalendar]
yearsFrom1900 = yearsFrom daysFrom1_1_1900 1900
 
-- makes groups of days for each month of the year
 
months :: YearCalendar -> MonthlyCalendar
months (y, d) = (y, [(January, january), (February, february),
    (March, march), (April, april), (May, may), (June, june),
    (July, july), (August, august), (September, september),
    (October, october), (November, november), (December, december)])
    where
        leapOrNot = if isLeapYear y then 29 else 28
        january = take 31 d
        february = take leapOrNot $ drop 31 d
        march = take 31 $ drop (31 + leapOrNot) d
        april = take 30 $ drop (62 + leapOrNot) d
        may = take 31 $ drop (92 + leapOrNot) d
        june = take 30 $ drop (123 + leapOrNot) d
        july = take 31 $ drop (153 + leapOrNot) d
        august = take 31 $ drop (184 + leapOrNot) d
        september = take 30 $ drop (215 + leapOrNot) d
        october = take 31 $ drop (245 + leapOrNot) d
        november = take 30 $ drop (276 + leapOrNot) d
        december = take 31 $ drop (306 + leapOrNot) d
 
-- see if a year is a leap year
 
isLeapYear n
    | n `mod` 100 == 0 = n `mod` 400 == 0
    | otherwise = n `mod` 4 == 0
 
-- make a list of the months of a year that have 5 weekends
-- (they must have 31 days and the first day must be Friday)
-- if the year doesn't contain any 5-weekended months, then
-- return the year and an empty list
 
whichFiveWeekends :: MonthlyCalendar -> (Year, [Month])
whichFiveWeekends (y, ms) = (y, map (\(m, _) -> m) found) -- extract the months & leave out their days
    where   found = filter (\(m, a@(d:ds)) -> and [length a == 31,
                d == Friday]) ms
 
-- take all days from 1900 until 2100, grouping them by years, then by
-- months, and calculating whether they have any 5-weekended months
-- or not
 
calendar :: [MonthlyCalendar]
calendar = map months $ yearsFrom1900
 
fiveWeekends1900To2100 :: [(Year, [Month])]
fiveWeekends1900To2100 = takeWhile (\(y, _) -> y <= 2100) $
    map whichFiveWeekends calendar
 
main = do
    -- count the number of years with 5 weekends
    let answer1 = foldl (\c (_, m) -> c + length m) 0 fiveWeekends1900To2100
    -- take only the years with 5-weekended months
        answer2 = filter (\(_, m) -> not $ null m) fiveWeekends1900To2100
    -- take only the years without 5-weekended months
        answer30 = filter (\(_, m) -> null m) fiveWeekends1900To2100
    -- count how many years without 5-weekended months there are
        answer31 = length answer30
    -- show the years without 5-weekended months
        answer32 = intercalate ", " $ map (\(y, m) -> show y) answer30
    putStrLn $ "There are " ++ show answer1 ++ " months with 5 weekends between 1900 and 2100."
    putStrLn "\nThe first ones are:"
    mapM_ (putStrLn . formatMonth) $ take 5 $ answer2
    putStrLn "\nThe last ones are:"
    mapM_ (putStrLn . formatMonth) $ reverse $ take 5 $ reverse answer2
    putStrLn $ "\n" ++ show answer31 ++ " years don't have at least one five-weekened month"
    putStrLn "\nThose are:"
    putStrLn answer32
 
formatMonth :: (Year, [Month]) -> String
formatMonth (y, m) = show y ++ ": " ++ intercalate ", " [ show x | x <- m ]