Fix conflict with newly exported 'empty' from Prelude.
[nofib.git] / spectral / calendar / Main.hs
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 import System.IO
6 import Data.List
7 import Data.Char
8
9 import System.Environment
10 import Control.Monad
11
12 -- To keep it backward compatible with pre-Haskell 98 compilers..
13 #define fail ioError
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 emptyPic :: (Int,Int) -> Picture
34 emptyPic (h,w) = copy h (copy w ' ')
35
36 block, blockT :: Int -> [Picture] -> Picture
37 block n = stack . map spread . groop n
38 blockT n = spread . map stack . groop n
39
40 groop :: Int -> [a] -> [[a]]
41 groop n [] = []
42 groop n xs = take n xs : groop n (drop n xs)
43
44 lframe :: (Int,Int) -> Picture -> Picture
45 lframe (m,n) p = (p `beside` emptyPic (h,n-w)) `above` emptyPic (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 (copy 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` emptyPic (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 = emptyPic (8,2)
98 end = emptyPic (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 main = do
110 (year:n:_) <- getArgs
111 replicateM_ (read n) (calFor year)
112
113 calFor year | illFormed = fail (userError "Bad argument")
114 | otherwise = print (length (cal yr))
115 -- SDM: changed to print the length, otherwise
116 -- stdout file is too huge.
117 where illFormed = null ds || not (null rs)
118 (ds,rs) = span isDigit year
119 yr = atoi ds
120 atoi s = foldl (\a d -> 10*a+d) 0 (map toDigit s)
121 toDigit d = fromEnum d - fromEnum '0'
122
123
124 -- End of calendar program
125
126 -- tacked on by partain
127 copy :: Int -> a -> [a]
128 copy n x = take n (repeat x)
129
130 cjustify, ljustify, rjustify :: Int -> String -> String
131
132 cjustify n s = space halfm ++ s ++ space (m - halfm)
133 where m = n - length s
134 halfm = m `div` 2
135 ljustify n s = s ++ space (n - length s)
136 rjustify n s = space (n - length s) ++ s
137
138 space :: Int -> String
139 space n = copy n ' '
140 -- end of tack