home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / Calendar.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  4.8 KB  |  143 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. module Calendar( calendar, cal, calFor, calProg ) where
  10. import Gofer
  11. import List(zip4)
  12. import IO(hPutStr,stderr)
  13. import System( getArgs, getProgName, exitWith, ExitCode(..) )
  14.  
  15. -- Picture handling:
  16.  
  17. infixr 5 `above`, `beside`
  18.  
  19. type Picture   =  [[Char]]
  20.  
  21. height, width :: Picture -> Int
  22. height p       = length p
  23. width  p       = length (head p)
  24.  
  25. above, beside :: Picture -> Picture -> Picture
  26. above          = (++)
  27. beside         = zipWith (++)
  28.  
  29. stack, spread :: [Picture] -> Picture
  30. stack          = foldr1 above
  31. spread         = foldr1 beside
  32.  
  33. empty         :: (Int,Int) -> Picture
  34. empty (h,w)    = replicate h (replicate w ' ')
  35.  
  36. block, blockT :: Int -> [Picture] -> Picture
  37. block n        = stack . map spread . groupsOf n
  38. blockT n       = spread . map stack . groupsOf n
  39.  
  40. groupsOf      :: Int -> [a] -> [[a]]
  41. groupsOf n []  = []
  42. groupsOf n xs  = take n xs : groupsOf n (drop n xs)
  43.  
  44. lframe        :: (Int,Int) -> Picture -> Picture
  45. lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
  46.          where h = height p
  47.                        w = width p
  48.  
  49. -- Information about the months in a year:
  50.  
  51. monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
  52.                     where feb | leap year = 29
  53.                               | otherwise = 28
  54.  
  55. leap year         = if year`mod`100 == 0 then year`mod`400 == 0
  56.                                          else year`mod`4   == 0
  57.  
  58. monthNames        = ["January","February","March","April",
  59.              "May","June","July","August",
  60.              "September","October","November","December"]
  61.  
  62. jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
  63.                     where last = year - 1
  64.  
  65. firstDays year    = take 12
  66.                          (map (`mod`7)
  67.                               (scanl (+) (jan1st year) (monthLengths year)))
  68.  
  69. -- Producing the information necessary for one month:
  70.  
  71. dates fd ml = map (date ml) [1-fd..42-fd]
  72.               where date ml d | d<1 || ml<d  = ["   "]
  73.                               | otherwise    = [rjustify 3 (show d)]
  74.  
  75. -- The original B+W calendar:
  76.  
  77. calendar :: Int -> String
  78. calendar  = unlines . block 3 . map picture . months
  79.             where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
  80.                   title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
  81.                   table fd ml    = lframe (8,25)
  82.                                           (daynames `beside` entries fd ml)
  83.                   daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
  84.                   entries fd ml  = blockT 7 (dates fd ml)
  85.                   months year    = zip4 monthNames
  86.                                         (replicate 12 year)
  87.                                         (firstDays year)
  88.                                         (monthLengths year)
  89.  
  90. -- In a format somewhat closer to UNIX cal:
  91.  
  92. cal year = unlines (banner year `above` body year)
  93.            where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
  94.                  body           = block 3 . map (pad . pic) . months
  95.                  pic (mn,fd,ml) = title mn `above` table fd ml
  96.                  pad p          = (side`beside`p`beside`side)`above`end
  97.                  side           = empty (8,2)
  98.                  end            = empty (1,25)
  99.                  title mn       = [cjustify 21 mn]
  100.                  table fd ml    = daynames `above` entries fd ml
  101.                  daynames       = [" Su Mo Tu We Th Fr Sa"]
  102.                  entries fd ml  = block 7 (dates fd ml)
  103.                  months year    = zip3 monthNames
  104.                                        (firstDays year)
  105.                                        (monthLengths year)
  106.  
  107. -- For a standalone calendar program:
  108. --
  109. -- To use this with "runhugs" on Unix:
  110. --
  111. --   cat >cal
  112. --   #! /usr/local/bin/runhugs
  113. --   
  114. --   > module Main( main ) where
  115. --   > import Calendar
  116. --   > main = calProg
  117. --   <ctrl-D>
  118. --
  119. --   chmod 755 cal
  120. --
  121. --   ./cal 1997
  122.  
  123. calProg = do
  124.          args <- getArgs
  125.          case args of 
  126.          [year] -> calFor year
  127.          _      -> do
  128.                      putStr "Usage: "
  129.                      getProgName >>= putStr
  130.                      putStrLn " year" 
  131.                      exitWith (ExitFailure 1)
  132.  
  133. calFor year | illFormed = hPutStr stderr "Bad argument" >>
  134.                           exitWith (ExitFailure 1)
  135.             | otherwise = putStr (cal yr)
  136.               where illFormed = null ds || not (null rs)
  137.                     (ds,rs)   = span isDigit year
  138.                     yr        = atoi ds
  139.                     atoi s    = foldl (\a d -> 10*a+d) 0 (map digitToInt s)
  140.        
  141.  
  142. -- End of calendar program
  143.