home *** CD-ROM | disk | FTP | other *** search
/ back2roots/padua / padua.7z / padua / lang / gofer223.lha / demos / calendar < prev    next >
Encoding:
Text File  |  1991-11-19  |  3.6 KB  |  97 lines
  1. -- This is a modification of the calendar program described in section 4.5
  2. -- of Bird and Wadler's ``Introduction to functional programming'', with
  3. -- two ways of printing the calendar ... as in B+W, or like UNIX `cal':
  4.  
  5. -- Picture handling:
  6.  
  7. infixr 5 `above`, `beside`
  8.  
  9. type Picture   =  [[Char]]
  10.  
  11. height, width :: Picture -> Int
  12. height p       = length p
  13. width  p       = length (head p)
  14.  
  15. above, beside :: Picture -> Picture -> Picture
  16. above          = (++)
  17. beside         = zipWith (++)
  18.  
  19. stack, spread :: [Picture] -> Picture
  20. stack          = foldr1 above
  21. spread         = foldr1 beside
  22.  
  23. empty         :: (Int,Int) -> Picture
  24. empty (h,w)    = copy h (copy w ' ')
  25.  
  26. block, blockT :: Int -> [Picture] -> Picture
  27. block n        = stack . map spread . group n
  28. blockT n       = spread . map stack . group n
  29.  
  30. group         :: Int -> [a] -> [[a]]
  31. group n []     = []
  32. group n xs     = take n xs : group n (drop n xs)
  33.  
  34. lframe        :: (Int,Int) -> Picture -> Picture
  35. lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
  36.          where h = height p
  37.                        w = width p
  38.  
  39. -- Information about the months in a year:
  40.  
  41. monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
  42.                     where feb | leap year = 29
  43.                               | otherwise = 28
  44.  
  45. leap year         = if year`mod`100 == 0 then year`mod`400 == 0
  46.                                          else year`mod`4   == 0
  47.  
  48. monthNames        = ["January","February","March","April",
  49.              "May","June","July","August",
  50.              "September","October","November","December"]
  51.  
  52. jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
  53.                     where last = year - 1
  54.  
  55. firstDays year    = take 12
  56.                          (map (`mod`7)
  57.                               (scanl (+) (jan1st year) (monthLengths year)))
  58.  
  59. -- Producing the information necessary for one month:
  60.  
  61. dates fd ml = map (date ml) [1-fd..42-fd]
  62.               where date ml d | d<1 || ml<d  = ["   "]
  63.                               | otherwise    = [rjustify 3 (show d)]
  64.  
  65. -- The original B+W calendar:
  66.  
  67. calendar = unlines . block 3 . map picture . months
  68.            where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
  69.                  title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
  70.                  table fd ml    = lframe (8,25)
  71.                                          (daynames `beside` entries fd ml)
  72.                  daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
  73.                  entries fd ml  = blockT 7 (dates fd ml)
  74.                  months year    = zip4 monthNames
  75.                                        (copy 12 year)
  76.                                        (firstDays year)
  77.                                        (monthLengths year)
  78.  
  79. -- In a format somewhat closer to UNIX cal:
  80.  
  81. cal year = unlines (banner year `above` body year)
  82.            where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
  83.                  body           = block 3 . map (pad . pic) . months
  84.                  pic (mn,fd,ml) = title mn `above` table fd ml
  85.                  pad p          = (side`beside`p`beside`side)`above`end
  86.                  side           = empty (8,2)
  87.                  end            = empty (1,25)
  88.                  title mn       = [cjustify 21 mn]
  89.                  table fd ml    = daynames `above` entries fd ml
  90.                  daynames       = [" Su Mo Tu We Th Fr Sa"]
  91.                  entries fd ml  = block 7 (dates fd ml)
  92.                  months year    = zip3 monthNames
  93.                                        (firstDays year)
  94.                                        (monthLengths year)
  95.  
  96. -- End of calendar program
  97.