├── .gitignore ├── BigPixel.cabal ├── LICENSE ├── README.md ├── Setup.hs ├── images └── BigPixel-Island.png └── src └── BigPixel.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | /dist/ 4 | BigPixel 5 | .DS_Store 6 | test.bmp 7 | -------------------------------------------------------------------------------- /BigPixel.cabal: -------------------------------------------------------------------------------- 1 | Name: BigPixel 2 | Version: 1.3.0 3 | License: BSD3 4 | License-File: LICENSE 5 | Copyright: Copyright (c) 2013 Manuel M T Chakravarty & Leon A Chakravarty 6 | Author: Manuel M T Chakravarty 7 | Maintainer: chak@justtesting.org 8 | Stability: Stable 9 | Homepage: https://github.com/mchakravarty/BigPixel 10 | Bug-Reports: https://github.com/mchakravarty/BigPixel/issues 11 | Synopsis: Image editor for pixel art 12 | Description: BigPixel is an image editor for pixel art. It is aimed at creating graphics assets for retro or 13 | Minecraft-style 2D games. It supports the creation of pixelated images with 8x8 big pixels in 14 | 256 colours including some with transparency. It is an OpenGL-based cross-platform application. 15 | BigPixel currently only supports the BMP image format. 16 | . 17 | As BigPixel is a plain OpenGL application without platform-specific GUI support, you need to start 18 | it as a command line program and supply it with the name of a BMP image file as its sole command 19 | line argument. If the file exists, it will be opened for editing; otherwise, a new file will be 20 | created. All changes made to an image are persistent — i.e., reflected in the on disk image without 21 | explicit saving. 22 | . 23 | > Left mouse button — draw with current colour 24 | > Left mouse button + Shift — erase with transparency 25 | > Left mouse button + Control — pick colour from image 26 | > Right mouse button — erase with transparency 27 | > 'W', 'S', 'A', 'D' - enlarge canvas to the top, bottom, left, and right, respectively 28 | > 'W', 'S', 'A', 'D' + Shift - shrink canvas from the top, bottom, left, and right, respectively 29 | . 30 | WARNING: There is currently no undo facility! Make copies of image files if you are unsure whether 31 | you like to keep the changes. (However, if you shrink the visible canvas, the removed content can 32 | be restored by simply enlarging the canvas again.) 33 | Category: Development 34 | Tested-With: GHC==7.6.1 35 | Cabal-Version: >= 1.6 36 | Build-Type: Simple 37 | 38 | Extra-Source-Files: 39 | README.md 40 | 41 | source-repository head 42 | type: git 43 | location: https://github.com/mchakravarty/BigPixel.git 44 | 45 | Executable BigPixel 46 | Build-Depends: array >= 0.3, 47 | base >= 4 && < 5, 48 | bmp >= 1.2.5.1 && < 2.0, 49 | bytestring > 0.10, 50 | gloss >= 1.7 && < 2.0 51 | 52 | hs-source-dirs: src 53 | main-is: BigPixel.hs 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) [2013] Manuel M T Chakravarty. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | * Redistributions of source code must retain the above copyright 6 | notice, this list of conditions and the following disclaimer. 7 | * Redistributions in binary form must reproduce the above copyright 8 | notice, this list of conditions and the following disclaimer in the 9 | documentation and/or other materials provided with the distribution. 10 | * Neither the names of the contributors nor of their affiliations may 11 | be used to endorse or promote products derived from this software 12 | without specific prior written permission. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY 15 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | BigPixel 2 | ======== 3 | 4 | BigPixel is an image editor for pixel art. It is aimed at creating graphics assets for retro or Minecraft-style 2D games. It supports the creation of pixelated images with 8x8 big pixels in 256 colours including some with transparency. It is an OpenGL-based cross-platform application. BigPixel currently only supports the BMP image format. 5 | 6 | As BigPixel is a plain OpenGL application without platform-specific GUI support, you need to start it as a command line program and supply it with the name of a BMP image file as its sole command line argument. If the file exists, it will be opened for editing; otherwise, a new file will be created. All changes made to an image are persistent — i.e., reflected in the on disk image without explicit saving. 7 | 8 | Left mouse button — draw with current colour 9 | Left mouse button + Shift — erase with transparency 10 | Left mouse button + Control — pick colour from image 11 | Right mouse button — erase with transparency 12 | 'W', 'S', 'A', 'D' — enlarge canvas to the top, bottom, left, and right, respectively 13 | 'W', 'S', 'A', 'D' + Shift — shrink canvas from the top, bottom, left, and right, respectively 14 | 15 | **WARNING:** There is currently no undo facility! Make copies of image files if you are unsure whether you like to keep the changes. (However, if you shrink the visible canvas, the removed content can be restored by simply enlarging the canvas again.) 16 | 17 | ![Screenshot of BigPixel](images/BigPixel-Island.png) 18 | 19 | Installation 20 | ------------ 21 | 22 | You need to have the Glasgow Haskell Compiler to compile from source. It is available as part of the [Haskell Platform](http://www.haskell.org/platform/). 23 | 24 | To install the current release of BigPixel from [Hackage](http://hackage.haskell.org/packages/hackage.html), simply execute 25 | 26 | % cabal install BigPixel 27 | 28 | To install the current version from GitHub, 29 | 30 | % git clone https://github.com/mchakravarty/BigPixel.git 31 | % cd BigPixel 32 | % cabal install 33 | 34 | Hacking 35 | ------- 36 | 37 | The Haskell code is relatively simple on purpose. It is part of an effort to teach programming to children. Contributions are most welcome, but please keep them in this spirit. 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /images/BigPixel-Island.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mchakravarty/BigPixel/dd3af731e9d1838ddf9f65ddeceb64038daf1718/images/BigPixel-Island.png -------------------------------------------------------------------------------- /src/BigPixel.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Main 3 | -- Copyright : [2013] Manuel M T Chakravarty & Leon A Chakravarty 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : Manuel M T Chakravarty 7 | -- Portability : haskell2011 8 | -- 9 | -- /Usage/ 10 | -- 11 | -- Provide the filename as the single command line argument. 12 | -- 13 | -- Left mouse button — draw with current colour 14 | -- Left mouse button + Shift — erase with transparency 15 | -- Right mouse button — erase with transparency 16 | -- 'W', 'S', 'A', 'D' - enlarge canvas to the top, bottom, left, and right, respectively 17 | -- 'W', 'S', 'A', 'D' + Shift - shrink canvas from the top, bottom, left, and right, respectively 18 | -- 19 | -- Canvas changes are automatically saved. 20 | 21 | import Codec.BMP 22 | 23 | import Data.ByteString (ByteString, pack, unpack) 24 | 25 | import Graphics.Gloss 26 | import Graphics.Gloss.Interface.IO.Game 27 | 28 | import Control.Exception as Exc 29 | import Control.Monad 30 | import Data.Array 31 | import Data.Word 32 | import System.Environment 33 | import System.Exit 34 | import System.IO.Error 35 | 36 | 37 | -- Constants 38 | -- --------- 39 | 40 | -- Frames per second 41 | -- 42 | fps :: Int 43 | fps = 60 44 | 45 | -- Minimum time (in seconds) between image writes. 46 | -- 47 | writeInterval :: Float 48 | writeInterval = 0.3 49 | 50 | -- How many physical pixel per pixel art block? 51 | -- 52 | pixelSize :: (Int, Int) 53 | pixelSize = (8, 8) 54 | 55 | -- Number of blocks on the initial canvas of an empty canvas (if not specified on the command line)? 56 | -- 57 | initialCanvasSize :: (Int, Int) 58 | initialCanvasSize = (16, 32) 59 | 60 | -- Padding to the window border. 61 | -- 62 | windowPadding :: Float 63 | windowPadding = 40 64 | 65 | -- Padding between window elements. 66 | -- 67 | elementPadding :: Float 68 | elementPadding = 50 69 | 70 | -- The height of the colour indicator strip. 71 | -- 72 | colourIndicatorHeight :: Float 73 | colourIndicatorHeight = fromIntegral (fst pixelSize) * 2 74 | 75 | -- The colour of the grid lines. 76 | -- 77 | gridColor :: Color 78 | gridColor = makeColor 0.8 0.8 0.8 1 79 | 80 | -- Fully transparent colour. 81 | -- 82 | transparent :: Color 83 | transparent = makeColor 0 0 0 0 84 | 85 | -- Nearly (25% opaque) transparent black. 86 | -- 87 | nearlytransparent :: Color 88 | nearlytransparent = makeColor 0 0 0 0.25 89 | 90 | -- Half (50% opaque) transparent black. 91 | -- 92 | halftransparent :: Color 93 | halftransparent = makeColor 0 0 0 0.5 94 | 95 | 96 | -- Application state 97 | -- ----------------- 98 | 99 | -- The colour grid that contains the drawing 100 | -- 101 | type Canvas = Array (Int, Int) Color 102 | 103 | -- The subarea of the canvas currently in use. 104 | -- 105 | type Area = ((Int, Int), (Int, Int)) 106 | 107 | -- Entire state of the applications 108 | -- 109 | data State 110 | = State 111 | { fname :: FilePath -- name of the image file 112 | , canvas :: Canvas -- the image canvas 113 | , area :: Area -- range of indices of the canvas used 114 | , image :: BMP -- BMP image version of the canvas 115 | , dirty :: Bool -- 'True' iff there are unsaved changes 116 | , timeSinceWrite :: Float -- seconds passed since last write to image file 117 | , penDown :: Maybe Color -- 'Just col' iff pen down with the given color 118 | , colour :: Color -- colour of the pen 119 | } 120 | 121 | initialState :: FilePath -> Canvas -> BMP -> State 122 | initialState name initialCanvas initialImage 123 | = State 124 | { fname = name 125 | , canvas = initialCanvas 126 | , area = bounds initialCanvas 127 | , image = initialImage 128 | , dirty = False 129 | , timeSinceWrite = 0 130 | , penDown = Nothing 131 | , colour = black 132 | } 133 | 134 | -- Yield the width and height of an area. 135 | -- 136 | areaSize :: Area -> (Int, Int) 137 | areaSize ((minX, minY), (maxX, maxY)) 138 | = (maxX - minX + 1, maxY - minY + 1) 139 | 140 | -- Check whether one area is completely contained in another. 141 | -- 142 | containedWithin :: Area -> Area -> Bool 143 | ((minX1, minY1), (maxX1, maxY1)) `containedWithin` ((minX2, minY2), (maxX2, maxY2)) 144 | = minX1 >= minX2 && minY1 >= minY2 && maxX1 <= maxX2 && maxY1 <= maxY2 145 | 146 | -- Compute the smallest area containing the two given ones. 147 | -- 148 | unionArea :: Area -> Area -> Area 149 | ((minX1, minY1), (maxX1, maxY1)) `unionArea` ((minX2, minY2), (maxX2, maxY2)) 150 | = ((minX1 `min` minX2, minY1 `min` minY2), (maxX1 `max` maxX2, maxY1 `max` maxY2)) 151 | 152 | -- Vector addition 153 | -- 154 | vplus :: (Int, Int) -> (Int, Int) -> (Int, Int) 155 | (i, j) `vplus` (k, l) = (i + k, j + l) 156 | 157 | -- Vector subtraction 158 | -- 159 | vminus :: (Int, Int) -> (Int, Int) -> (Int, Int) 160 | (i, j) `vminus` (k, l) = (i - k, j - l) 161 | 162 | 163 | -- UI presentation 164 | -- --------------- 165 | 166 | -- Determine an appropriate window size for the given application state. 167 | -- 168 | windowSize :: State -> Point 169 | windowSize state 170 | = (2 * (canvasW + paletteW) + 2 * windowPadding + 2 * elementPadding, 171 | (20 + 1.5 * canvasH + 2 * windowPadding) `max` (1.5 * paletteH + 2 * windowPadding)) 172 | where 173 | (canvasW, canvasH) = canvasSize state 174 | (paletteW, paletteH) = zoomedPaletteSize 175 | 176 | -- Size of the canvas in physical pixel. 177 | -- 178 | canvasSize :: State -> Point 179 | canvasSize state 180 | = (fromIntegral (width * fst pixelSize), 181 | fromIntegral (height * snd pixelSize)) 182 | where 183 | (width, height) = areaSize (area state) 184 | 185 | -- Size of the palette in physical pixel. 186 | -- 187 | paletteSize :: Point 188 | paletteSize = (fromIntegral (16 * fst pixelSize), fromIntegral (16 * snd pixelSize)) 189 | 190 | -- Size of the palette in physical pixel *scaled* by a factor of two. 191 | -- 192 | zoomedPaletteSize :: Point 193 | zoomedPaletteSize = (fst paletteSize * 2, snd paletteSize * 2) 194 | 195 | -- Convert window coordinates to a canvas index. 196 | -- 197 | windowPosToCanvas :: (Float, Float) -> Point -> Maybe (Int, Int) 198 | windowPosToCanvas (canvasWidth, canvasHeight) (x, y) 199 | | x_shifted < 0 || x_shifted >= canvasWidth 200 | || y_shifted < 0 || y_shifted >= canvasHeight 201 | = Nothing 202 | | otherwise 203 | = Just (truncate x_shifted `div` fst pixelSize, truncate y_shifted `div` snd pixelSize) 204 | where 205 | halfCanvasWidth = canvasWidth / 2 206 | halfCanvasHeight = canvasHeight / 2 207 | 208 | x_shifted = x + halfCanvasWidth 209 | y_shifted = y + halfCanvasHeight 210 | 211 | -- Convert a canvas index to widget coordinates. 212 | -- 213 | canvasToWidgetPos :: (Float, Float) -> (Int, Int) -> Point 214 | canvasToWidgetPos (canvasWidth, canvasHeight) (i, j) 215 | = (x, y) 216 | where 217 | x = (fromIntegral i + 0.5) * width - (canvasWidth / 2) 218 | y = (fromIntegral j + 0.5) * height - (canvasHeight / 2) 219 | 220 | width = fromIntegral (fst pixelSize) 221 | height = fromIntegral (snd pixelSize) 222 | 223 | -- Turn the canvas in the application state into a picture (one frame). 224 | -- 225 | drawCanvas :: State -> Picture 226 | drawCanvas state 227 | = let (start, end) = area state 228 | in 229 | Pictures $ 230 | map drawPixelBlock [(pos `vminus` start, canvas state!pos) | pos <- range (start, end)] 231 | where 232 | drawPixelBlock (pos, color) 233 | = Translate x y $ 234 | Pictures [ rectangleChecker width height 235 | , Color color (rectangleSolid width height) 236 | , Color gridColor (rectangleWire width height) 237 | ] 238 | where 239 | (x, y) = canvasToWidgetPos (canvasSize state) pos 240 | width = fromIntegral (fst pixelSize) 241 | height = fromIntegral (snd pixelSize) 242 | 243 | -- Turn the image in the application state into a picture (one frame). 244 | -- 245 | drawImage :: State -> Picture 246 | drawImage = bitmapOfBMP . image 247 | 248 | -- Produce the picture of the colour palette. 249 | -- 250 | drawPalette :: Picture 251 | drawPalette 252 | = Pictures (map drawPaletteBlock [(i, j) | i <- [0..15], j <- [0..15]]) 253 | where 254 | drawPaletteBlock :: (Int, Int) -> Picture 255 | drawPaletteBlock pos 256 | = Translate x y $ Pictures [ rectangleChecker width height 257 | , Color (paletteColour pos) (rectangleSolid width height) 258 | ] 259 | where 260 | (x, y) = canvasToWidgetPos paletteSize pos 261 | width = fromIntegral (fst pixelSize) 262 | height = fromIntegral (snd pixelSize) 263 | 264 | -- Draw a checker rectangle with a wire frame. 265 | -- 266 | -- Width and height must be divisible by 2. 267 | -- 268 | rectangleChecker :: Float -> Float -> Picture 269 | rectangleChecker width height 270 | = Pictures [ Translate (-w4) (-h4) $ Color (greyN 0.90) (rectangleSolid w2 h2) 271 | , Translate (-w4) ( h4) $ Color white (rectangleSolid w2 h2) 272 | , Translate ( w4) (-h4) $ Color white (rectangleSolid w2 h2) 273 | , Translate ( w4) ( h4) $ Color (greyN 0.90) (rectangleSolid w2 h2) 274 | , Translate 0 0 $ Color (greyN 0.95) (Line [(0, -h2), (0, h2)]) 275 | , Translate 0 0 $ Color (greyN 0.95) (Line [(-h2, 0), (h2, 0)]) 276 | , Translate 0 0 $ Color gridColor (rectangleWire width height) 277 | ] 278 | where 279 | w2 = width / 2 280 | h2 = height / 2 281 | w4 = width / 4 282 | h4 = height / 4 283 | 284 | -- Compute the colour of the palette at a particular index position. 285 | -- 286 | -- 8-bit palette: RRGIBBGT 287 | -- 288 | -- * RR = 2-bit red 289 | -- * GG = 2-bit green 290 | -- * BB = 2-bit blue 291 | -- * I = 1-bit brightness 292 | -- * T = 1-bit transparency 293 | -- 294 | -- Intensity scales 295 | -- 296 | -- * 00 = 0% (irrespective of brightness) 297 | -- * 01 = brightness ? 40% : (transparency ? 30% : 20%) 298 | -- * 10 = brightness ? 70% : (transparency ? 60% : 50%) 299 | -- * 11 = brightness ? 100% : (transparency ? 90% : 80%) 300 | -- 301 | -- Transparency is 50% if brightness == 1. 302 | -- 303 | -- Special values 304 | -- 305 | -- * 00010000 = 25% transparent (black) 306 | -- * 00000001 = 50% transparent (black) 307 | -- * 00010001 = fully transparent (black) 308 | -- 309 | -- Here, i = 4 MSBs and j = 4 LSBs. 310 | -- 311 | paletteColour :: (Int, Int) -> Color 312 | paletteColour (i, j) = paletteColour' (i, 15 - j) 313 | where 314 | paletteColour' (1, 0) = nearlytransparent 315 | paletteColour' (0, 1) = halftransparent 316 | paletteColour' (1, 1) = transparent 317 | paletteColour' (i, j) 318 | = makeColor (scale red / 100) (scale green / 100) (scale blue / 100) 319 | (if transparency == 1 && brightness == 1 then 0.5 else 1) 320 | where 321 | red = fromIntegral $ ((i `div` 8) `mod` 2) * 2 + (i `div` 4) `mod` 2 322 | green = fromIntegral $ ((i `div` 2) `mod` 2) * 2 + (j `div` 2) `mod` 2 323 | blue = fromIntegral $ ((j `div` 8) `mod` 2) * 2 + (j `div` 4) `mod` 2 324 | brightness = fromIntegral $ (i `mod` 2) 325 | transparency = fromIntegral $ (j `mod` 2) 326 | 327 | scale 0 = 0 328 | scale 1 | brightness == 1 = 40 329 | | transparency == 1 = 30 330 | | otherwise = 20 331 | scale 2 | brightness == 1 = 70 332 | | transparency == 1 = 60 333 | | otherwise = 50 334 | scale 3 | brightness == 1 = 100 335 | | transparency == 1 = 90 336 | | otherwise = 80 337 | 338 | {- 339 | -- Compute the colour of the palette at a particular index position, but use the transparency of the given colour. 340 | -- 341 | paletteColourWithTransparencyOf :: Color -> (Int, Int) -> Color 342 | paletteColourWithTransparencyOf col idx 343 | = makeColor r g b a 344 | where 345 | (r, g, b, _) = rgbaOfColor $ paletteColour idx 346 | (_, _, _, a) = rgbaOfColor col 347 | -} 348 | 349 | {- 350 | -- Adjust a colour transparency (alpha value) for the given index position in the transparency palette. 351 | -- 352 | transparencyColour :: Color -> Int -> Color 353 | transparencyColour col i 354 | = makeColor r g b (fromIntegral i / 16) 355 | where 356 | (r, g, b, _a) = rgbaOfColor col 357 | -} 358 | 359 | -- Draw a picture of the entire application window. 360 | -- 361 | drawWindow :: State -> IO Picture 362 | drawWindow state 363 | = return $ Pictures 364 | [ drawCanvas state 365 | , Translate (-40) sizeOffset canvasSizeText 366 | -- ^^FIXME: Gloss doesn't seem to center text :( 367 | -- , Translate (-imageOffset) 0 (drawImage state) 368 | , Translate paletteOffset 0 (Scale 2 2 drawPalette) 369 | , Translate paletteOffset (-colourOffset) colourIndicator 370 | ] 371 | where 372 | imageOffset = elementPadding + fst (canvasSize state) / 2 + 373 | fromIntegral (fst (bmpDimensions (image state))) / 2 374 | paletteOffset = elementPadding + fst (canvasSize state) / 2 + fst zoomedPaletteSize / 2 375 | colourOffset = 2 * colourIndicatorHeight + snd zoomedPaletteSize / 2 376 | sizeOffset = snd (canvasSize state) / 2 + 20 377 | 378 | colourIndicator = Pictures $ 379 | [ Translate (fromIntegral i * pixelWidth + pixelWidth / 2) 380 | (fromIntegral j * pixelHeight + pixelHeight / 2) $ 381 | rectangleChecker pixelWidth pixelHeight 382 | | i <- [-16..15], j <- [-1..0] ] ++ 383 | [ Color (colour state) (rectangleSolid (fst zoomedPaletteSize) colourIndicatorHeight) 384 | , Color gridColor (rectangleWire (fst zoomedPaletteSize) colourIndicatorHeight) 385 | ] 386 | pixelWidth = fromIntegral $ fst pixelSize 387 | pixelHeight = fromIntegral $ snd pixelSize 388 | 389 | canvasSizeText = let (width, height) = areaSize (area state) 390 | in 391 | Scale 0.2 0.2 (Text (show width ++ "x" ++ show height)) 392 | 393 | 394 | -- Reading and writing of image files 395 | -- ---------------------------------- 396 | 397 | -- Try to read the image file and to convert it to a canvas. If that fails yield an empty canvas. 398 | -- 399 | -- The first argument determines whether we clip the input colours to the BigPixel colour palette. 400 | -- 401 | readImageFile :: Bool -> FilePath -> IO (Canvas, BMP) 402 | readImageFile forcePalette fname 403 | = do 404 | { result <- readBMP fname 405 | ; case result of 406 | Left err -> do 407 | { putStrLn ("BigPixel: error reading '" ++ fname ++ "': " ++ show err) 408 | ; putStrLn "Delete the file if you want to replace it." 409 | ; exitFailure 410 | } 411 | Right bmp -> do 412 | { let (bmpWidth, bmpHeight) = bmpDimensions bmp 413 | canvasWidth = bmpWidth `div` fst pixelSize 414 | canvasHeight = bmpHeight `div` snd pixelSize 415 | ; unless (bmpWidth `mod` fst pixelSize == 0 && 416 | bmpHeight `mod` snd pixelSize == 0) $ 417 | do 418 | { putStrLn ("BigPixel: '" ++ fname ++ "' doesn't appear to be a BigPixel image") 419 | ; putStrLn ("Expected the image size to be a multiple of " ++ 420 | show (fst pixelSize) ++ "x" ++ show (snd pixelSize)) 421 | } 422 | ; let stream = unpack (unpackBMPToRGBA32 bmp) 423 | indices = [(i, j) | j <- [0..bmpHeight - 1], i <- [0..bmpWidth - 1]] 424 | image = array ((0, 0), (bmpWidth - 1, bmpHeight - 1)) 425 | (zip indices [word8ToColor quad | quad <- quads stream]) 426 | canvas0 = listArray ((0, 0), (canvasWidth - 1, canvasHeight - 1)) 427 | [averageAt image (i, j) | i <- [0..canvasWidth - 1] 428 | , j <- [0..canvasHeight - 1]] 429 | ; return (canvas0, bmp) 430 | } 431 | } 432 | `Exc.catch` \exc -> 433 | if isDoesNotExistErrorType (ioeGetErrorType exc) 434 | then return (emptyCanvas, canvasToImage emptyCanvas (bounds emptyCanvas)) 435 | else do 436 | { putStrLn ("BigPixel: error reading '" ++ fname ++ "': " ++ show exc) 437 | ; putStrLn "Delete the file if you want to replace it." 438 | ; exitFailure 439 | } 440 | where 441 | maxX = fst initialCanvasSize - 1 442 | maxY = snd initialCanvasSize - 1 443 | emptyCanvas = listArray ((0, 0), (maxX, maxY)) (repeat transparent) 444 | 445 | quads :: [a] -> [[a]] 446 | quads [] = [] 447 | quads (x:y:z:v:rest) = [x, y, z, v] : quads rest 448 | quads l = [l] 449 | 450 | averageAt image (i, j) 451 | -- = clipColour $ image ! (i * fst pixelSize + fst pixelSize `div` 2, 452 | -- j * snd pixelSize + snd pixelSize `div` 2) 453 | = (if forcePalette then clipColour else id) $ 454 | foldl1 (mixColors 0.5 0.5) [ image ! (i * fst pixelSize + ioff, j * snd pixelSize + joff) 455 | | ioff <- [0..fst pixelSize - 1] 456 | , joff <- [0..snd pixelSize - 1]] 457 | 458 | -- Write the contents of the canvas to the image file. 459 | -- 460 | writeImageFile :: State -> IO () 461 | writeImageFile state 462 | = writeBMP (fname state) (canvasToImage (canvas state) (area state)) 463 | 464 | -- Convert the specified area of a canvas array into a BMP image file. 465 | -- 466 | canvasToImage :: Array (Int, Int) Color -> Area -> BMP 467 | canvasToImage canvas area 468 | = packRGBA32ToBMP imageWidth imageHeight $ 469 | pack (concat [ colorToWord8 (canvas!(minX + x `div` fst pixelSize, 470 | minY + y `div` snd pixelSize)) 471 | | y <- [0..imageHeight - 1], x <- [0..imageWidth - 1]]) 472 | where 473 | (canvasWidth, canvasHeight) = areaSize area 474 | ((minX, minY), _) = area 475 | 476 | imageWidth = canvasWidth * fst pixelSize 477 | imageHeight = canvasHeight * snd pixelSize 478 | 479 | -- Convert a Gloss colour to an RGBA value (quad of 'Word8's) for a BMP. 480 | -- 481 | colorToWord8 :: Color -> [Word8] 482 | colorToWord8 col 483 | = let (red, green, blue, alpha) = rgbaOfColor col 484 | in 485 | [toWord8 red, toWord8 green, toWord8 blue, toWord8 alpha] 486 | where 487 | toWord8 = truncate . (* 255) 488 | 489 | -- Convert an RGBA value (quad of 'Word8's) for a BMP to a Gloss colour. 490 | -- 491 | word8ToColor :: [Word8] -> Color 492 | word8ToColor [red, green, blue, alpha] 493 | = makeColor (fromWord8 red) (fromWord8 green) (fromWord8 blue) (fromWord8 alpha) 494 | where 495 | fromWord8 = (/ 255) . fromIntegral 496 | word8ToColor arg = error ("word8ToColor: not a quad: " ++ show arg) 497 | 498 | -- Clip a colour to the BigPixel 8-bit colour space 499 | -- 500 | clipColour :: Color -> Color 501 | clipColour col 502 | | transparent = makeColor 0 0 0 0 503 | | black = makeColor 0 0 0 1 504 | | otherwise = makeColor red' green' blue' alpha' 505 | where 506 | (red, green, blue, alpha) = rgbaOfColor col 507 | 508 | black = averageBrightness [red, green, blue] < 0.15 509 | transparent = alpha < 0.25 510 | alpha' | alpha >= 0.25 && alpha < 0.75 = 0.5 511 | | otherwise = 1 512 | 513 | bright = averageBrightness [red, green, blue] >= 0.55 514 | red' = clip red 515 | green' = clip green 516 | blue' = clip blue 517 | 518 | averageBrightness cols = sum significantCols / fromIntegral (length significantCols) 519 | where 520 | significantCols = [col | col <- cols, col >= 0.15] 521 | 522 | clip c | c < 0.15 = 0 523 | | bright && c < 0.70 = 0.6 524 | | bright && c < 0.90 = 0.8 525 | | bright = 1 526 | | c > 0.45 = 0.5 527 | | c > 0.35 = 0.4 528 | | otherwise = 0.3 529 | 530 | 531 | -- Event handling 532 | -- -------------- 533 | 534 | -- Process a single event. 535 | -- 536 | handleEvent :: Event -> State -> IO State 537 | 538 | -- Drawing and colour selection 539 | handleEvent (EventKey (MouseButton LeftButton) Down mods mousePos) state 540 | = let newState | ctrl mods == Down = let pickedColour = pick mousePos state 541 | in 542 | state { penDown = Just pickedColour 543 | , colour = pickedColour } 544 | | shift mods == Down = state { penDown = Just transparent } 545 | | otherwise = state { penDown = Just (colour state) } 546 | in return $ draw mousePos newState 547 | handleEvent (EventKey (MouseButton RightButton) Down mods mousePos) state 548 | = let newState = state { penDown = Just transparent } 549 | in return $ draw mousePos newState 550 | handleEvent (EventKey (MouseButton LeftButton) Up _mods mousePos) state 551 | = return $ selectColour mousePos (state {penDown = Nothing}) 552 | handleEvent (EventKey (MouseButton RightButton) Up _mods mousePos) state 553 | = return $ state {penDown = Nothing} 554 | handleEvent (EventMotion mousePos) state 555 | = return $ draw mousePos state 556 | 557 | -- Alter canvas size 558 | handleEvent (EventKey (Char 'w') Down mods _mousePos) state 559 | = return $ resize ((0, 0), (0, 1)) state 560 | handleEvent (EventKey (Char 'W') Down mods _mousePos) state 561 | = return $ resize ((0, 0), (0, -1)) state 562 | handleEvent (EventKey (Char 's') Down mods _mousePos) state 563 | = return $ resize ((0, -1), (0, 0)) state 564 | handleEvent (EventKey (Char 'S') Down mods _mousePos) state 565 | = return $ resize ((0, 1), (0, 0)) state 566 | handleEvent (EventKey (Char 'a') Down mods _mousePos) state 567 | = return $ resize ((-1, 0), (0, 0)) state 568 | handleEvent (EventKey (Char 'A') Down mods _mousePos) state 569 | = return $ resize ((1, 0), (0, 0)) state 570 | handleEvent (EventKey (Char 'd') Down mods _mousePos) state 571 | = return $ resize ((0, 0), (1, 0)) state 572 | handleEvent (EventKey (Char 'D') Down mods _mousePos) state 573 | = return $ resize ((0, 0), (-1, 0)) state 574 | 575 | -- Unhandled event 576 | handleEvent event state = return state 577 | 578 | -- Draw onto the canvas if mouse position is within canvas boundaries. 579 | -- 580 | -- (NB: Does image conversion as well; i.e., only use once per frame in the current form.) 581 | -- 582 | draw :: Point -> State -> State 583 | draw mousePos (state@State { penDown = Just col }) 584 | = case windowPosToCanvas (canvasSize state) mousePos of 585 | Nothing -> state 586 | Just idx -> let base = fst (area state) 587 | newCanvas = canvas state // [(base `vplus` idx, col)] 588 | in 589 | state { canvas = newCanvas 590 | -- , image = canvasToImage newCanvas ?? 591 | , dirty = True 592 | } 593 | draw _mousePos state 594 | = state 595 | 596 | -- Determine the colour at the given point in the image, or return the current colour if the position is outside the 597 | -- image. 598 | -- 599 | pick :: Point -> State -> Color 600 | pick mousePos (state@State { colour = col }) 601 | = case windowPosToCanvas (canvasSize state) mousePos of 602 | Nothing -> col 603 | Just idx -> canvas state ! (base `vplus` idx) 604 | where 605 | base = fst (area state) 606 | 607 | -- Select a colour if mouse position is within palette boundaries. 608 | -- 609 | selectColour :: Point -> State -> State 610 | selectColour mousePos state 611 | = case windowPosToCanvas paletteSize paletteAdjustedMousePos of 612 | Nothing -> state 613 | Just idx -> state { colour = paletteColour idx } 614 | where 615 | paletteOffsetX = elementPadding + fst (canvasSize state) / 2 + fst zoomedPaletteSize / 2 616 | paletteAdjustedMousePos = ((fst mousePos - paletteOffsetX) / 2, snd mousePos / 2) 617 | 618 | -- Resize the used canvas area. 619 | -- 620 | -- We only change the actual canvas array if it needs to grow beyond its current size. If it, 621 | -- shrinks, we leave it as it is to enable undoing the shrinking by growing it again. 622 | -- 623 | resize :: Area -> State -> State 624 | resize ((dminX, dminY), (dmaxX, dmaxY)) state 625 | | newWidth >= 2 && newHeight >= 2 626 | = state { canvas = newCanvas, area = newArea, dirty = True } 627 | | otherwise 628 | = state 629 | where 630 | ((minX, minY), (maxX, maxY)) = area state 631 | (width, height) = areaSize (area state) 632 | (newWidth, newHeight) = areaSize newArea 633 | canvasArea = bounds (canvas state) 634 | 635 | newArea = ((minX + dminX, minY + dminY), (maxX + dmaxX, maxY + dmaxY)) 636 | newCanvasArea = canvasArea `unionArea` newArea 637 | 638 | newCanvas 639 | | newArea `containedWithin` canvasArea 640 | = canvas state 641 | | otherwise 642 | = array newCanvasArea [ (pos, if inRange canvasArea pos 643 | then canvas state ! pos 644 | else transparent) 645 | | pos <- range newCanvasArea] 646 | 647 | 648 | -- Advance the application state 649 | -- ----------------------------- 650 | 651 | -- Account for passing time. 652 | -- 653 | stepState :: Float -> State -> IO State 654 | stepState time state = maybeWriteFile $ state {timeSinceWrite = timeSinceWrite state + time} 655 | 656 | -- Determine whether we should write the image file. 657 | -- 658 | maybeWriteFile :: State -> IO State 659 | maybeWriteFile state@(State {dirty = True, timeSinceWrite = time}) 660 | | time > writeInterval 661 | = do 662 | { writeImageFile state 663 | ; return $ state {dirty = False, timeSinceWrite = 0} 664 | } 665 | maybeWriteFile state 666 | = return state 667 | 668 | 669 | -- The program body 670 | -- ---------------- 671 | 672 | -- Kick of the event loop 673 | -- 674 | main :: IO () 675 | main 676 | = do 677 | { -- Read the image file name from the command line arguments 678 | ; args <- getArgs 679 | ; let forcePalette = length args == 2 && head args == "--force-palette" 680 | ; when (not $ length args == 1 || forcePalette) $ do 681 | { putStrLn "BigPixel: needs image file name with suffix '.bmp' as argument,\n optionally preceeded by --force-palette" 682 | ; exitFailure 683 | } 684 | ; let [fname] = if forcePalette then tail args else args 685 | ; when (take 4 (reverse fname) /= reverse ".bmp") $ do 686 | { putStrLn "BigPixel: image file must have suffix '.bmp'" 687 | ; exitFailure 688 | } 689 | 690 | ; when forcePalette $ 691 | putStrLn "WARNING: --force-palette needs to be adapted to the latest palette" 692 | 693 | -- Read the image from the given file, or yield an empty canvas 694 | ; (canvas, image) <- readImageFile forcePalette fname 695 | 696 | -- Initialise the application state 697 | ; let state = initialState fname canvas image 698 | initialWindowSize = windowSize state 699 | 700 | -- Enter the event loop 701 | ; playIO (InWindow "BigPixel" (round (fst initialWindowSize), round (snd initialWindowSize)) 702 | (100, 50)) white fps state 703 | drawWindow handleEvent stepState 704 | } 705 | --------------------------------------------------------------------------------