1votos

Abstraer un calendario mensual en Haskell

por josejuan hace 4 años

Solución directa, se genera información de las celdas (anchura, tipo de contenido, etc...) y se aporta un helper para recorrerlas (plegar/fold) a la rasterización final.

Implementa una API para tu lenguaje preferido, que permita generar un calendario mensual de tal forma que tu API pueda ser utilizada para generar calendarios en cualquier soporte (texto, html, una API gráfica, etc...).

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
-- ==== El módulo: ~/Data/Dates/Render/Calendar.hs ================ 
module Data.Dates.Render.Calendar (Cell(..), renderCalendar, module Data.Dates) where 
 
import Data.Dates 
import Data.List.Split 
 
data Cell = VSeparator               -- Vertical separator 
          | HSeparator               -- Horizontal separator 
          | MonthHeader   DateTime   -- Month header (7 cells width) 
          | WeekDayHeader DateTime   -- Week day header 
          | JustDay       DateTime   -- Month day cell 
          | EmptyDay                 -- Month empty cell 
          deriving Show 
 
-- Un único mes. 
makeMonthCalendar :: DateTime -> WeekDay -> [[Cell]] 
makeMonthCalendar d weekday = [MonthHeader d] : weekDaysHeader : (chunksOf 7 $ take 42 $ monthDayA weekday) 
  where weekDaysHeader = map WeekDayHeader $ take 7 $ dropWhile ((/=weekday).dateWeekDay) $ iterate (flip addInterval $ Days 1) d 
        monthDayA wd | wd == dateWeekDay d = monthDayB d 
                     | otherwise           = EmptyDay : monthDayA (intToWeekday (1 + (weekdayNumber wd) `mod` 7)) 
        monthDayB q  | month q == month d  = JustDay q : monthDayB (addInterval q (Days 1)) 
                     | otherwise           = repeat EmptyDay 
 
-- Muchos meses 
makeCalendar :: Int -> Int -> DateTime -> WeekDay -> [[Cell]] 
makeCalendar cols rows idate weekday = 
  foldr1 (\a b -> a ++ s ++ b) $ 
  map (foldr1 $ \a b -> zipWith3 (\a b c -> a ++ b ++ c) a (repeat [VSeparator]) b) $ 
  chunksOf cols [makeMonthCalendar (addInterval idate (Months $ fromIntegral i)) weekday | i <- [0..cols * rows - 1]] 
  where s = [take (8 * cols - 1) (repeat HSeparator)] 
 
-- El helper 
renderCalendar :: ([b] -> t) -> ([Cell] -> b) -> Int -> Int -> Int -> Int -> WeekDay -> t 
renderCalendar joinRows renderCell cols rows year month weekday = 
  joinRows $ map renderCell $ makeCalendar cols rows (DateTime year month 1 0 0 0) weekday 
-- ==== Fin del módulo: ~/Data/Dates/Render/Calendar.hs ================ 
 
 
 
 
 
-- Ahora, para generar en modo texto, podríamos hacer: 
renderMonthRules cell = 
  case cell of 
    VSeparator      -> " | " 
    HSeparator      -> "---" 
    MonthHeader d   -> T.center       21 ' ' $ T.pack $ show (toEnum (month d) :: R.Month) ++ " - " ++ show (year d) 
    WeekDayHeader d -> T.justifyRight  3 ' ' $ T.pack $ take 2 $ show $ dateWeekDay d 
    JustDay d       -> T.justifyRight  3 ' ' $ T.pack $ show $ day d 
    EmptyDay        -> "   " 
 
renderCalendarAsText cols rows year month weeday = 
  renderCalendar sequence (putStrLn . T.unpack . T.concat . map renderMonthRules) cols rows year month weeday 
 
 
 
-- O bien para generar en HTML 
renderMonthRules cell = 
  case cell of 
    VSeparator      -> "<td class=s>&nbsp;</td>" 
    HSeparator      -> "<td class=s>&nbsp;</td>" 
    MonthHeader d   -> T.concat ["<td class=mh colspan=7>", T.pack $ show (toEnum (month d) :: R.Month) ++ " - " ++ show (year d), "</td>"] 
    WeekDayHeader d -> T.concat ["<td class=wd>", T.pack $ take 4 $ show $ dateWeekDay d, "</td>"] 
    JustDay d       -> T.concat ["<td class=dc>", T.pack $ show $ day d, "</td>"] 
    EmptyDay        -> "<td class=ec>&nbsp;</td>" 
 
renderCalendarAsHtml cols rows year month weeday = 
  renderCalendar T.concat (\cs -> T.concat ["<tr>", T.concat $ map renderMonthRules cs, "</tr>"]) cols rows year month weeday 
 
 
 
- O bien para generar en OpenGL (usando Gloss) 
renderMonthRules cell = 
  case cell of 
    VSeparator      -> (1, Blank) 
    HSeparator      -> (1, Blank) 
    MonthHeader d   -> (7, Translate 3 0 $ dText 7 2 blue white $ show (toEnum (month d) :: R.Month) ++ " - " ++ show (year d)) 
    WeekDayHeader d -> (1, dText 1 0.3 orange white $ take 2 $ show $ dateWeekDay d) 
    JustDay d       -> (1, dText 1 0.3 white black $ show $ day d) 
    EmptyDay        -> (1, dText 1 0.3 (greyN 0.7) white "") 
 
dText w x c f t = Pictures [ Color (dark c) $ rectangleSolid w 1 
                           , Color (light c) $ rectangleWire w 1 
                           , Color f $ Translate (-x) (-0.25) $ scale 0.004 0.004 $ text t] 
 
foldPics f = Pictures . snd . foldl f (0, []) 
 
renderCalendarAsGloss cols rows year month weeday = 
  renderCalendar (foldPics $ \(y, ps) xs -> (y - 1, Translate 0 y xs :ps)) 
                 (foldPics $ \(x, ps) c -> let (w, p) = renderMonthRules c in (x + w, Translate x 0 p :ps)) 
    cols rows year month weeday 
 
 
-- Para más detalles, se puede ver el repo completo en: 
--     https://github.com/josejuan/haskell-calendar 
1 comentario
0votos

Escrito por josejuan hace 4 años

El resultado en texto:
        August - 2014     |    September - 2014   |     October - 2014
     Su Mo Tu We Th Fr Sa |  Su Mo Tu We Th Fr Sa |  Su Mo Tu We Th Fr Sa
                     1  2 |      1  2  3  4  5  6 |            1  2  3  4
      3  4  5  6  7  8  9 |   7  8  9 10 11 12 13 |   5  6  7  8  9 10 11
     10 11 12 13 14 15 16 |  14 15 16 17 18 19 20 |  12 13 14 15 16 17 18
     17 18 19 20 21 22 23 |  21 22 23 24 25 26 27 |  19 20 21 22 23 24 25
     24 25 26 27 28 29 30 |  28 29 30             |  26 27 28 29 30 31
     31                   |                       |
    ---------------------------------------------------------------------
       November - 2014    |    December - 2014    |     January - 2015
     Su Mo Tu We Th Fr Sa |  Su Mo Tu We Th Fr Sa |  Su Mo Tu We Th Fr Sa
                        1 |      1  2  3  4  5  6 |               1  2  3
      2  3  4  5  6  7  8 |   7  8  9 10 11 12 13 |   4  5  6  7  8  9 10
      9 10 11 12 13 14 15 |  14 15 16 17 18 19 20 |  11 12 13 14 15 16 17
     16 17 18 19 20 21 22 |  21 22 23 24 25 26 27 |  18 19 20 21 22 23 24
     23 24 25 26 27 28 29 |  28 29 30 31          |  25 26 27 28 29 30 31
     30                   |                       |



En HTML

en html

En OpenGL (usando Gloss)

en opengl

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.