home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / hugs_1 / demos_hs_Calendar < prev    next >
Encoding:
Text File  |  1996-08-12  |  4.3 KB  |  123 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. -- Run using:  calFor "1996"
  6. --        or:  putStr (calendar 1996)
  7. --        or:  putStr (cal 1996)
  8.  
  9. import Gofer
  10. import List(zip4)
  11. import IO(hPutStr)
  12.  
  13. -- Picture handling:
  14.  
  15. infixr 5 `above`, `beside`
  16.  
  17. type Picture   =  [[Char]]
  18.  
  19. height, width :: Picture -> Int
  20. height p       = length p
  21. width  p       = length (head p)
  22.  
  23. above, beside :: Picture -> Picture -> Picture
  24. above          = (++)
  25. beside         = zipWith (++)
  26.  
  27. stack, spread :: [Picture] -> Picture
  28. stack          = foldr1 above
  29. spread         = foldr1 beside
  30.  
  31. empty         :: (Int,Int) -> Picture
  32. empty (h,w)    = replicate h (replicate w ' ')
  33.  
  34. block, blockT :: Int -> [Picture] -> Picture
  35. block n        = stack . map spread . groupsOf n
  36. blockT n       = spread . map stack . groupsOf n
  37.  
  38. groupsOf      :: Int -> [a] -> [[a]]
  39. groupsOf n []  = []
  40. groupsOf n xs  = take n xs : groupsOf n (drop n xs)
  41.  
  42. lframe        :: (Int,Int) -> Picture -> Picture
  43. lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
  44.          where h = height p
  45.                        w = width p
  46.  
  47. -- Information about the months in a year:
  48.  
  49. monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
  50.                     where feb | leap year = 29
  51.                               | otherwise = 28
  52.  
  53. leap year         = if year`mod`100 == 0 then year`mod`400 == 0
  54.                                          else year`mod`4   == 0
  55.  
  56. monthNames        = ["January","February","March","April",
  57.              "May","June","July","August",
  58.              "September","October","November","December"]
  59.  
  60. jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
  61.                     where last = year - 1
  62.  
  63. firstDays year    = take 12
  64.                          (map (`mod`7)
  65.                               (scanl (+) (jan1st year) (monthLengths year)))
  66.  
  67. -- Producing the information necessary for one month:
  68.  
  69. dates fd ml = map (date ml) [1-fd..42-fd]
  70.               where date ml d | d<1 || ml<d  = ["   "]
  71.                               | otherwise    = [rjustify 3 (show d)]
  72.  
  73. -- The original B+W calendar:
  74.  
  75. calendar :: Int -> String
  76. calendar  = unlines . block 3 . map picture . months
  77.             where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
  78.                   title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
  79.                   table fd ml    = lframe (8,25)
  80.                                           (daynames `beside` entries fd ml)
  81.                   daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
  82.                   entries fd ml  = blockT 7 (dates fd ml)
  83.                   months year    = zip4 monthNames
  84.                                         (replicate 12 year)
  85.                                         (firstDays year)
  86.                                         (monthLengths year)
  87.  
  88. -- In a format somewhat closer to UNIX cal:
  89.  
  90. cal year = unlines (banner year `above` body year)
  91.            where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
  92.                  body           = block 3 . map (pad . pic) . months
  93.                  pic (mn,fd,ml) = title mn `above` table fd ml
  94.                  pad p          = (side`beside`p`beside`side)`above`end
  95.                  side           = empty (8,2)
  96.                  end            = empty (1,25)
  97.                  title mn       = [cjustify 21 mn]
  98.                  table fd ml    = daynames `above` entries fd ml
  99.                  daynames       = [" Su Mo Tu We Th Fr Sa"]
  100.                  entries fd ml  = block 7 (dates fd ml)
  101.                  months year    = zip3 monthNames
  102.                                        (firstDays year)
  103.                                        (monthLengths year)
  104.  
  105. -- For a standalone calendar program:
  106.  
  107. {-
  108. main = getArgs exit (\strs ->
  109.        case strs of [year] -> calFor year
  110.                     _      -> appendChan stdout "Usage: cal year\n" exit done)
  111. -}
  112.  
  113. calFor year | illFormed = hPutStr stderr "Bad argument"
  114.             | otherwise = putStr (cal yr)
  115.               where illFormed = null ds || not (null rs)
  116.                     (ds,rs)   = span isDigit year
  117.                     yr        = atoi ds
  118.                     atoi s    = foldl (\a d -> 10*a+d) 0 (map toDigit s)
  119.                     toDigit d = ord d - ord '0'
  120.        
  121.  
  122. -- End of calendar program
  123.