-- This is a modification of the calendar program described in section 4.5
-- of Bird and Wadler's ``Introduction to functional programming'', with
-- two ways of printing the calendar ... as in B+W, or like UNIX `cal':
--
-- Use from within Yale Haskell:
--
-- Main> :l Calendar
-- Now in module Calendar.
-- Calendar> @ do cal 1992
-- Calendar> :e
--
-- ... Unix style calendar ...
--
-- Calendar> @ do calendar 1992
-- Calendar> :e
--
-- ... Bird and Wadler style calendar ...
--
-- Calendar>
module Calendar(cal,calendar) where
infixr 5 `above`, `beside`
do cal year = appendChan stdout (cal year) exit done
-- Picture handling:
type Picture = [[Char]]
height, width :: Picture -> Int
height p = length p
width p = length (head p)
above, beside :: Picture -> Picture -> Picture
above = (++)
beside = zipWith (++)
stack, spread :: [Picture] -> Picture
stack = foldr1 above
spread = foldr1 beside
empty :: (Int,Int) -> Picture
empty (h,w) = copy h (copy w ' ')
block, blockT :: Int -> [Picture] -> Picture
block n = stack . map spread . group n
blockT n = spread . map stack . group n
group :: Int -> [a] -> [[a]]
group n [] = []
group n xs = take n xs : group n (drop n xs)
lframe :: (Int,Int) -> Picture -> Picture
lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
where h = height p
w = width p
-- Information about the months in a year:
monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
where feb | leap year = 29
| otherwise = 28
leap year = if year`mod`100 == 0 then year`mod`400 == 0
else year`mod`4 == 0
monthNames = ["January","February","March","April",
"May","June","July","August",
"September","October","November","December"]
jan1st year = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
where last = year - 1
firstDays year = take 12
(map (`mod`7)
(scanl (+) (jan1st year) (monthLengths year)))
-- Producing the information necessary for one month:
dates fd ml = map (date ml) [1-fd..42-fd]
where date ml d | d<1 || ml<d = [" "]
| otherwise = [rjustify 3 (show d)]
-- The original B+W calendar:
calendar :: Int -> String
calendar = unlines . block 3 . map picture . months
where picture (mn,yr,fd,ml) = title mn yr `above` table fd ml
title mn yr = lframe (2,25) [mn ++ " " ++ show yr]
table fd ml = lframe (8,25)
(daynames `beside` entries fd ml)
daynames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
entries fd ml = blockT 7 (dates fd ml)
months year = zip4 monthNames
(copy 12 year)
(firstDays year)
(monthLengths year)
-- In a format somewhat closer to UNIX cal:
cal :: Int -> String
cal year = unlines (banner year `above` body year)
where banner yr = [cjustify 75 (show yr)] `above` empty (1,75)
body = block 3 . map (pad . pic) . months
pic (mn,fd,ml) = title mn `above` table fd ml
pad p = (side`beside`p`beside`side)`above`end
side = empty (8,2)
end = empty (1,25)
title mn = [cjustify 21 mn]
table fd ml = daynames `above` entries fd ml
daynames = [" Su Mo Tu We Th Fr Sa"]
entries fd ml = block 7 (dates fd ml)
months year = zip3 monthNames
(firstDays year)
(monthLengths year)
-- Additional (B+W)-isms: these really ought to go in a separate module,
-- in a spearate file. But for ease of packaging this simple application,
-- it doesn't seem worth the trouble!
copy :: Int -> a -> [a]
copy n x = take n (repeat x)
space :: Int -> String
space n = copy n ' '
-- Simple string formatting:
cjustify, ljustify, rjustify :: Int -> String -> String
cjustify n s = space halfm ++ s ++ space (m - halfm)
where m = n - length s
halfm = m `div` 2
ljustify n s = s ++ space (n - length s)
rjustify n s = space (n - length s) ++ s
-- End of calendar program