convertImage

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
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
module ConvertImage(
      ImageString
    , Blueprint
    , Position
    , Phase(..)
    , header
    , phrases
    , convertpngs
    ) where

import Data.Typeable(Typeable)
import Data.Data(Data)
import Codec.Picture.Types
import Data.List(unzip,intercalate,intersperse)
import Data.Maybe(isNothing,fromJust)
import Data.Either(partitionEithers)

import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Vector.Storable as V

import Config

type ImageString = String
type Blueprint = L.ByteString
type Position = Maybe (Int,Int)

-- string to put in empty cells, quickfort accepts an empty string or "#" here
emptyCell = "#"

-- This header goes at the top of each Blueprint and tells
-- quickfort where to start and in what mode to run
header :: Position -> Int -> Phase -> String
header pos w p = '#':mode ++ start ++ empties
  where empties = replicate (w) ','
        start | pos == Nothing = ""
              | otherwise = " start" ++ show (fromJust pos)

        mode  | p == Dig = "dig"
              | p == Build = "build"
              | p == Place = "place"
              | otherwise = "query"


convertpngs :: Int -> Position -> [DynamicImage] -> String -> CommandDictionary -> [Either String Blueprint]
convertpngs r pos imgs phases dict | null err = convertImage
                                   | otherwise = map Left err
  where convertImage = map (\phase -> pngconvert r pos imgs phase dict) p
        (err,images) = partitionEithers convertImage
        p = parsePhases phases

-- convert a list of images into a blueprint
pngconvert :: Int -> Position -> [DynamicImage] -> Phase -> CommandDictionary -> Either String Blueprint
pngconvert r pos imgs phase dict | null errs == False = Left (intercalate "\n" errs)
                               | any (w/=) width || any (h/=) height = Left
                               "Error: not all images have the same dimensions"
                               | otherwise = Right $ toCSV r pos w phase images
  where (errs,images) = partitionEithers csvList
        w = head width
        h = head height
        (width,height) = unzip $ map extractDims imgs
        extractDims i = (dynamicMap imageWidth i,dynamicMap imageHeight i)
        csvList = map (imageToList (translate dict phase)) imgs


-- concat a list of ImageStrings into a single csv Blueprint
toCSV :: Int -> Position -> Int -> Phase -> [ImageString] -> Blueprint
toCSV r s w p imgs = L.pack $ header s w p ++ intercalate uplevel repeatedImgs
  where uplevel = "\n#>" ++ replicate w ','
        repeatedImgs = take (r * (length imgs)) (cycle imgs)

-- convert a RGBA8 image to a list of lists of strings
imageToList :: (PixelRGBA8 -> String) -> DynamicImage -> Either String ImageString
imageToList dict (ImageRGBA8 img) = Right $ convertVector (imageData img)
  where convertVector = csvify (width) . (map ((++ ",") . dict)) . (toPixelList . V.toList)
        width = imageWidth img

        -- convert list of Word8 values into a list of RGBA8 Pixels
        toPixelList [] = []
        toPixelList (a:b:c:d:pixels) = (PixelRGBA8 a b c d) : toPixelList pixels
--catch non RGBA8 images and give an error message
imageToList _ _ = Left "Error: one or more images are not encoded in RGBA8 color, \
                       \did you remember to add an alpha channel?"


-- take a list of comma delimited strings and return a string with newlines added
csvify :: (Int) -> [String] -> String
csvify _ [] = ""
-- we add a header to the csv later, and the last line of the file doesn't
-- need a newline, so we can prepend it for a small savings
csvify i ls = '\n' : (concat row) ++ csvify i rest
  where (row,rest) = splitAt i ls


parsePhases :: String -> [Phase]
parsePhases ""    = []
parsePhases "All" = [Dig,Build,Place,Query]
parsePhases s     = map read (phrases s)

-- same as words, but cuts on commas instead of spaces
phrases :: String -> [String]
phrases s = case dropWhile {-partain:Char.-}isComma s of
                 "" -> []
                 s' -> w : phrases s''
                       where (w,s'') =
                              break {-partain:Char.-} isComma s'

isComma :: Char -> Bool
isComma ',' = True
isComma _   = False

data Phase = Dig
           | Build
           | Place
           | Query
    deriving (Typeable, Data, Eq, Read, Show)


translate :: CommandDictionary -> Phase -> PixelRGBA8 -> String
translate dict Dig   key = M.findWithDefault emptyCell key (des dict)
translate dict Build key = M.findWithDefault emptyCell key (bld dict)
translate dict Place key = M.findWithDefault emptyCell key (plc dict)
translate dict Query key = M.findWithDefault emptyCell key (qry dict)


{--------------------------------------------------------------------}


{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}
module Config (
    CommandDictionary(..),
    constructDict
    ) where

import qualified Data.Map.Strict as M
import Control.Applicative((<$>),(<*>))
import qualified Data.ByteString.Lazy as L
import Data.List(unlines)
import Data.Maybe
import Data.Either(partitionEithers)
import Data.Tuple
import Data.Word(Word8(..))
import Numeric(readHex)
import Control.Monad(mzero,liftM,mapM)
import Data.Aeson
import Codec.Picture.Types
import Text.Regex.Posix((=~))

-- the CommandDictionary describes a mapping from pixels to strings
-- it is accessed via the translate function
data CommandDictionary = CommandDictionary {
                         des :: M.Map PixelRGBA8 String
                       , bld :: M.Map PixelRGBA8 String
                       , plc :: M.Map PixelRGBA8 String
                       , qry :: M.Map PixelRGBA8 String }
    deriving(Eq,Show)


data ConfigLists = ConfigLists { designate :: M.Map String [String]
                               , build     :: M.Map String [String]
                               , place     :: M.Map String [String]
                               , query     :: M.Map String [String] }

configTup :: ConfigLists -> (M.Map String [String],M.Map String [String],
                             M.Map String [String],M.Map String [String])
configTup cl = (designate cl,
                build cl,
                place cl,
                query cl)

instance FromJSON ConfigLists where
    parseJSON (Object v) = ConfigLists <$>
                          v .: "designate" <*>
                          v .: "build" <*>
                          v .: "place" <*>
                          v .: "query"
    parseJSON _          = mzero


deriving instance Ord PixelRGBA8


constructDict :: L.ByteString -> L.ByteString -> Either String CommandDictionary
constructDict alias config = do
    aliasLists <- eitherDecode alias :: Either String ConfigLists
    commands   <- eitherDecode config :: Either String ConfigLists
    buildCommandDict aliasLists commands
  where 
    buildCommandDict :: ConfigLists -> ConfigLists -> Either String CommandDictionary
    buildCommandDict al cs =
        buildCommandDict' (tmap4 (expandList . M.toList) altup)
                          (tmap4 (expandPixelList . M.toList) cstup)
            where altup = configTup al
                  cstup = configTup cs
    buildCommandDict' (a,b,c,d) (w,x,y,z) = do 
       designate' <- genMap a w
       build'     <- genMap b x
       place'     <- genMap c y
       query'     <- genMap d z
       Right (CommandDictionary designate' build' place' query')


-- map a function over a 4 tuple
tmap4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b)
tmap4 f (t1,t2,t3,t4) = (f t1,f t2,f t3,f t4)


genMap :: [(String,String)] -> [(Either String PixelRGBA8,String)]
                            -> Either String (M.Map PixelRGBA8 String)
genMap _ []  = Right M.empty
genMap [] _  = Right M.empty
genMap al cs | not (null errorList) = Left (unlines errorList)
             | length (filter pred genList) == 0  = Right (M.fromList $ map noMaybe genList) 
             | otherwise =
                Left "Error generating pixel-string map: an alias is referenced\
                      \ in pngconfig.json that is not present in alias.json"
  where 
    (errorList,genList) = partitionEithers $ map (checkEither . doLookup) cs
    doLookup (pix,str) = (pix,M.lookup str dict)
    -- checkEither extracts the Either state from a tuple
    checkEither (Right p,s) = Right (p,s)
    checkEither (Left e,s) = Left e
    dict = M.fromList al

    pred (_,a) = isNothing a

    noMaybe (a,b) = (a,fromJust b)


expandList :: [(String,[String])] -> [(String,String)]
expandList = concatMap (expand . swap)

expandPixelList :: [(String,[String])] -> [(Either String PixelRGBA8,String)]
expandPixelList = map (toPixel) . expandList

-- expand a tuple holding a list of keys and a value into a list of key value pairs    
expand :: ([String],String) -> [(String,String)]
expand ([],_) = []
expand ((k:ks),val) = (k,val) : expand (ks,val)

-- TODO: need to make these check for malformed strings
toPixel :: (String,String) ->(Either String PixelRGBA8,String)
toPixel (key,val) = (keyToPixel key,val)

-- color representations:
-- base ten: <val>:<val>:<val>:<val>
-- hex: #<val><val><val><val> or 0x<val><val><val><val>
keyToPixel :: String -> Either String PixelRGBA8
keyToPixel = (liftM listToPixel) . keyToPixel'
  where keyToPixel' key | key               == "" = Left (fErr "attempted to pass null key string")
                        | fst hexResults    /= "" = Right $ parseHex (snd hexResults)
                        | fst base10Results /= "" = parse10 (snd base10Results)
                        | otherwise               = Left (fErr $ "malformed key: " ++ key)
          where matchHex      = key =~ hexPattern :: (String,String,String,[String])
                matchBaseTen  = key =~ baseTenPattern :: (String,String,String,[String])
                hexResults    = results matchHex
                base10Results = results matchBaseTen
                results (_,match,_,substrs) = (match,substrs)
                fErr s = "Error in keyToPixel: " ++ s



-- parse a list of hex strings to Word8 values
-- we're guaranteed that the list will look like [<hex prefix>,<val>,<val>,<val>]
-- from the pattern match that calls parseHex
parseHex :: [String] -> [Word8]
parseHex = (map toHex) . tail 
  where toHex = fst . head . readHex

parse10 :: [String] -> Either String [Word8]
parse10  = mapM (readWithBounds)
    -- readWithBounds will either return the String as a Word8 or
    -- throw an error if the value is larger than 255
    where readWithBounds :: String -> Either String Word8
          readWithBounds s | val > 255 = Left ("key value too large: " ++ s)
                           | otherwise = Right (fromInteger val)
            where val = read s :: Integer

-- listToPixel can't fail on an input of Right, the pattern matching in keyToPixel'
-- guarentees that parseHex and parse10 will return a list of the correct size
listToPixel :: [Word8] -> PixelRGBA8
listToPixel (r:g:b:a:[]) = PixelRGBA8 r g b a

hexPattern :: String
hexPattern = "^(0x|#)([[:xdigit:]]{2,2})([[:xdigit:]]{2,2})([[:xdigit:]]{2,2})([[:xdigit:]]{2,2})"

baseTenPattern :: String
baseTenPattern = "^([0-9]{1,3}):([0-9]{1,3}):([0-9]{1,3}):([0-9]{1,3})"