~jack/misc

misc/bunkplan/Bunkplan.hs -rw-r--r-- 9.3 KiB
008ecc90Jack Kelly Add functional-images to default.nix/ci 25 days ago
                                                                                
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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
-- bunkplan.ml - Generate (crappy) HTML bunkplans from CSV
-- Copyright (C) 2012  Jack Kelly
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <https://www.gnu.org/licenses/>.

{-# LANGUAGE LambdaCase #-}

import Data.Char
import Data.Foldable (traverse_)
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import System.Exit
import System.FilePath
import System.Environment
import Text.CSV hiding (csv)
import Text.Html (Html, (!), (<<), (+++))
import qualified Text.Html as Html
import Text.ParserCombinators.Parsec.Error
import Text.Printf

data Crew = Captain
          | Chef
          | Mate Int
          | Passenger
          | WatchAssistant
          | WatchLeader deriving Show

data Watch = Red | White | Blue deriving Show

watchLabel :: Watch -> Html
watchLabel = Html.toHtml . map toUpper . show

watchLabelColor :: Watch -> Html
watchLabelColor w = colorize $ watchLabel w where
    colorize = case w of
                 Red -> (! [Html.color Html.red]) . Html.font
                 White -> id
                 Blue -> (! [Html.color Html.blue]) . Html.font

data Sex = Male | Female deriving Show

data BunkDefinition = BunkDefinition {
      _number :: String, -- Yes, string, to handle bunk 9A and so on.
      _cabin :: String,
      _bunkName :: String
    } deriving Show

data BunkAssignment = BunkAssignment {
      _musterNumber :: Int,
      _crewType :: Crew,
      _watch :: Watch,
      _name :: String,
      _sex :: Sex,
      _bunkNumber :: String,
      _liferaft :: String,
      _emergencyStation :: String
    } deriving Show

data BunkPlan = BunkPlan {
      _assignment :: [BunkAssignment],
      _bunks :: [BunkDefinition]
    } deriving Show

-- Split up the csv into assignments, bunks and excluded cabins (no parsing).
split :: CSV -> ([Record], [Record], [Record])
split rows = (assignments, bunks, excludes) where
    assignments = chunk rows "#BUNKPLAN"
    bunks = chunk rows "#BUNKS"
    excludes = chunk rows "#EXCLUDE"
    chunk list mark = takeWhile notHash $ tail $ dropWhile notMark list where
                                            notHash = (/= '#') . head . head
                                            notMark = (/= mark) . head

-- Parsing Functions.
parseCrew :: String -> Crew
parseCrew "CO" = Captain
parseCrew "CH" = Chef
parseCrew "M1" = Mate 1
parseCrew "M2" = Mate 2
parseCrew "M3" = Mate 3
parseCrew "WA" = WatchAssistant
parseCrew "WL" = WatchLeader
parseCrew "" = Passenger
parseCrew _ = error "Invalid passenger type."

parseWatch :: String -> Watch
parseWatch "R" = Red
parseWatch "W" = White
parseWatch "B" = Blue
parseWatch _ = error "Invalid Watch."

parseSex :: String -> Sex
parseSex "M" = Male
parseSex "F" = Female
parseSex _ = error "Invalid Sex."

parseAssignments :: [Record] -> [BunkAssignment]
parseAssignments = iter [] where
    iter acc [] = reverse acc
    iter acc ([num,
               crew,
               watch,
               name,
               sex,
               bunk,
               liferaft,
               emergencyStation]:rs) = iter (assign:acc) rs where
                           assign = BunkAssignment {
                                      _musterNumber = read num,
                                      _crewType = parseCrew crew,
                                      _watch = parseWatch watch,
                                      _name = name,
                                      _sex = parseSex sex,
                                      _bunkNumber = bunk,
                                      _liferaft = liferaft,
                                      _emergencyStation = emergencyStation
                                    }
    iter _ _ = error "Format error in watchbill."

parseDefinitions :: [Record] -> [BunkDefinition]
parseDefinitions = iter [] where
    iter acc [] = reverse acc
    iter acc ([num, cabin, name]:rs) = iter (def:acc) rs where
                           def = BunkDefinition {
                                   _number = num,
                                   _cabin = cabin,
                                   _bunkName = name
                                 }
    iter _ _ = error "Format error in bunk definition."

-- Trim a CSV file: remove empty columns on the left, empty rows at
-- top or bottom and empty cells at the end of the row.

trimCSV :: CSV -> CSV
trimCSV = trimRight . trimLeft . trimBottom . trimTop where
    trimRight = map $ reverse . dropWhile (== "") . reverse
    trimLeft csv =
      let margin = minimum $ map (length . takeWhile (== "")) csv
      in map (drop margin) csv
    trimTop = dropWhile (all (== ""))
    trimBottom = reverse . trimTop . reverse

-- Non-structural fixups on the CSV.
tidy :: CSV -> CSV
tidy = upper . trimCells where
    upper = map $ map $ map toUpper
    trimCells = map . map $ (reverse . dropWhile isSpace . reverse)

-- Read the CSV, parse everything.
readBunkPlan :: FilePath -> IO ([BunkAssignment], [BunkDefinition], [String])
readBunkPlan f =
    parseCSVFromFile f >>= \case
      Left err -> error $ concatMap messageString $ errorMessages err
      Right records -> do
                   let records' = filter (not . null) $ trimCSV records
                       (assignments, bunks, excludes) = split $ tidy records'
                       watchbill = parseAssignments assignments
                       bunkDefs = parseDefinitions bunks
                       excludes' = concat excludes
                   return (watchbill, bunkDefs, excludes')

-- Turn the input filename into an output filename.
makeFileName :: FilePath -> String -> FilePath
makeFileName template inName = dropExtension template ++ "-" ++ inName ++ ".html"

-- Print one cabin plan
printCabin :: FilePath
           -> Map.Map String BunkDefinition
           -> String
           -> [BunkAssignment]
           -> IO ()
printCabin template bunks name cabin =
    if null cabin
    then return ()
    else do
      let doctype = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n"
          filename = makeFileName template name
          size = length cabin
          smallCabin = size <= 5
          fontSize = if smallCabin then "6" else "5"

          title = printf "BUNK PLAN %s" name :: String
          theHead = Html.header << Html.thetitle << title
          theH1 = (Html.h1 << title) ! [Html.align "center"]

          headingCell label = Html.th
            << Html.center
            << (Html.font << Html.underline << label) ! [Html.color Html.navy]
          headingRow = foldl1 (+++) $ map headingCell ["BUNK", "WATCH", "NAME"]
          cell label = Html.td << Html.center << label
          bunk assign = _bunkName $ bunks Map.! _bunkNumber assign
          row assign = Html.tr << (cell (bunk assign)
                              +++ cell (watchLabelColor $ _watch assign)
                              +++ cell (_name assign))
          theRows = map row $ sortBy (compare `on` _bunkNumber) cabin
          theTable = (Html.table << (headingRow +++ theRows)) !
            [Html.cellpadding 5, Html.cellspacing 40]
          content = Html.center << ((Html.font << Html.bold << theTable)
                               ! [Html.size fontSize])
          theBody = Html.body << (theH1 +++ content)
      writeFile filename $
        doctype ++ Html.prettyHtml (Html.thehtml << (theHead +++ theBody))

-- Build the cabin structures and print plans.
makeCabins :: FilePath
           -> ([BunkAssignment], [BunkDefinition], [String])
           -> IO ()
makeCabins filename (watchbill, bunks, excludes) = do
  -- Build a map of the watchbill, by bunk.
  let watchbillByBunk =
          foldl (\m assign ->
                     Map.insert (_bunkNumber assign) assign m)
                Map.empty watchbill

  -- And a map of the bunks by bunk number.
  let bunksByNumber =
          foldl (\m def ->
                     Map.insert (_number def) def m) Map.empty bunks

  -- And a map of the cabins, by cabin name.
  let bunksByCabin =
          Map.map reverse $
             foldl (\m def -> Map.insertWith (++) (_cabin def) [def] m)
                   Map.empty bunks

  -- And now a map of the people in each cabin, except the excludes
  let cabins =
          Map.filterWithKey (\cabin _ -> cabin `notElem` excludes) $
          Map.map (mapMaybe
                   (\bunk -> Map.lookup (_number bunk) watchbillByBunk))
          bunksByCabin

  -- Now print everything!
  traverse_ (uncurry $ printCabin filename bunksByNumber) $
            Map.toList cabins

-- Parse and print everything.
makeBunkPlan :: FilePath -> IO ()
makeBunkPlan fileName = readBunkPlan fileName >>= makeCabins fileName

-- Let's go!
main :: IO ()
main = do
  args <- getArgs
  if length args /= 1
    then do
      putStrLn "Must have a single filename argument."
      exitFailure
    else makeBunkPlan $ head args