1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
-- 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
|
