BigPixel 1.0.1 → 1.2.0
raw patch · 3 files changed
+145/−69 lines, 3 files
Files
- BigPixel.cabal +1/−1
- README.md +5/−0
- src/BigPixel.hs +139/−68
BigPixel.cabal view
@@ -1,5 +1,5 @@ Name: BigPixel-Version: 1.0.1+Version: 1.2.0 License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2013 Manuel M T Chakravarty & Leon A Chakravarty
README.md view
@@ -29,3 +29,8 @@ % git clone https://github.com/mchakravarty/BigPixel.git % cd BigPixel % cabal install++Hacking+-------++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.
src/BigPixel.hs view
@@ -75,16 +75,24 @@ -- The colour of the grid lines. -- gridColor :: Color-gridColor = makeColor 0.9 0.9 0.9 1+gridColor = makeColor 0.8 0.8 0.8 1 -- Fully transparent colour. ----- We use transparent white, so that software ignoring the alpha channel displays it as white.--- transparent :: Color-transparent = makeColor 1 1 1 0+transparent = makeColor 0 0 0 0 +-- Nearly (25% opaque) transparent black.+--+nearlytransparent :: Color+nearlytransparent = makeColor 0 0 0 0.25 +-- Half (50% opaque) transparent black.+--+halftransparent :: Color+halftransparent = makeColor 0 0 0 0.5++ -- Application state -- ----------------- @@ -163,7 +171,7 @@ (20 + 1.5 * canvasH + 2 * windowPadding) `max` (1.5 * paletteH + 2 * windowPadding)) where (canvasW, canvasH) = canvasSize state- (paletteW, paletteH) = paletteSize+ (paletteW, paletteH) = zoomedPaletteSize -- Size of the canvas in physical pixel. --@@ -179,10 +187,10 @@ paletteSize :: Point paletteSize = (fromIntegral (16 * fst pixelSize), fromIntegral (16 * snd pixelSize)) --- Size of the transparency picker in physical pixel.+-- Size of the palette in physical pixel *scaled* by a factor of two. ---pickerSize :: Point-pickerSize = (fromIntegral (16 * fst pixelSize), fromIntegral (snd pixelSize))+zoomedPaletteSize :: Point+zoomedPaletteSize = (fst paletteSize * 2, snd paletteSize * 2) -- Convert window coordinates to a canvas index. --@@ -245,41 +253,26 @@ where drawPaletteBlock :: (Int, Int) -> Picture drawPaletteBlock pos- = Translate x y $ Color (paletteColour pos) (rectangleSolid width height)+ = Translate x y $ Pictures [ rectangleChecker width height+ , Color (paletteColour pos) (rectangleSolid width height)+ ] where (x, y) = canvasToWidgetPos paletteSize pos width = fromIntegral (fst pixelSize) height = fromIntegral (snd pixelSize) --- Produce the picture if the transparency picker.----drawTransparency :: Color -> Picture-drawTransparency col- = Pictures (map drawTransparencyBlock [0..15])- where- drawTransparencyBlock :: Int -> Picture- drawTransparencyBlock i- = Translate x 0 $ - Pictures [rectangleChecker width height- , Color (transparencyColour col i) (rectangleSolid width height)- ]- where- (x, _) = canvasToWidgetPos paletteSize (i, 0)- width = fromIntegral (fst pixelSize)- height = fromIntegral (snd pixelSize)- -- Draw a checker rectangle with a wire frame. -- -- Width and height must be divisible by 2. -- rectangleChecker :: Float -> Float -> Picture rectangleChecker width height- = Pictures [ Translate (-w4) (-h4) $ Color (greyN 0.7) (rectangleSolid w2 h2)- , Translate (-w4) ( h4) $ Color white (rectangleSolid w2 h2)- , Translate ( w4) (-h4) $ Color white (rectangleSolid w2 h2)- , Translate ( w4) ( h4) $ Color (greyN 0.7) (rectangleSolid w2 h2)- , Translate 0 0 $ Color gridColor (Line [(0, -h2), (0, h2)])- , Translate 0 0 $ Color gridColor (Line [(-h2, 0), (h2, 0)])+ = Pictures [ Translate (-w4) (-h4) $ Color (greyN 0.90) (rectangleSolid w2 h2)+ , Translate (-w4) ( h4) $ Color white (rectangleSolid w2 h2)+ , Translate ( w4) (-h4) $ Color white (rectangleSolid w2 h2)+ , Translate ( w4) ( h4) $ Color (greyN 0.90) (rectangleSolid w2 h2)+ , Translate 0 0 $ Color (greyN 0.95) (Line [(0, -h2), (0, h2)])+ , Translate 0 0 $ Color (greyN 0.95) (Line [(-h2, 0), (h2, 0)]) , Translate 0 0 $ Color gridColor (rectangleWire width height) ] where@@ -290,17 +283,59 @@ -- Compute the colour of the palette at a particular index position. --+-- 8-bit palette: RRGIBBGT+--+-- * RR = 2-bit red+-- * GG = 2-bit green+-- * BB = 2-bit blue+-- * I = 1-bit brightness+-- * T = 1-bit transparency+--+-- Intensity scales+--+-- * 00 = 0% (irrespective of brightness)+-- * 01 = brightness ? 40% : (transparency ? 30% : 20%)+-- * 10 = brightness ? 70% : (transparency ? 60% : 50%)+-- * 11 = brightness ? 100% : (transparency ? 90% : 80%)+--+-- Transparency is 50% if brightness == 1.+--+-- Special values+--+-- * 00010000 = 25% transparent (black)+-- * 00000001 = 50% transparent (black)+-- * 00010001 = fully transparent (black)+--+-- Here, i = 4 MSBs and j = 4 LSBs.+-- paletteColour :: (Int, Int) -> Color-paletteColour (i, j)- = makeColor (scale red / 100) (scale green / 100) (scale blue / 100) 1+paletteColour (i, j) = paletteColour' (i, 15 - j) where- red = fromIntegral $ ((i `div` 8) `mod` 2) * 2 + (j `div` 8) `mod` 2- green = fromIntegral $ ((i `div` 4) `mod` 2) * 2 + (j `div` 4) `mod` 2- blue = fromIntegral $ ((i `div` 2) `mod` 2) * 2 + (j `div` 2) `mod` 2- brightness = fromIntegral $ (i `mod` 2) * 2 + j `mod` 2-- scale x = x * 25 + (25 / 3) * brightness+ paletteColour' (1, 0) = nearlytransparent+ paletteColour' (0, 1) = halftransparent+ paletteColour' (1, 1) = transparent+ paletteColour' (i, j)+ = makeColor (scale red / 100) (scale green / 100) (scale blue / 100) + (if transparency == 1 && brightness == 1 then 0.5 else 1)+ where+ red = fromIntegral $ ((i `div` 8) `mod` 2) * 2 + (i `div` 4) `mod` 2+ green = fromIntegral $ ((i `div` 2) `mod` 2) * 2 + (j `div` 2) `mod` 2+ blue = fromIntegral $ ((j `div` 8) `mod` 2) * 2 + (j `div` 4) `mod` 2+ brightness = fromIntegral $ (i `mod` 2)+ transparency = fromIntegral $ (j `mod` 2)+ + scale 0 = 0+ scale 1 | brightness == 1 = 40+ | transparency == 1 = 30+ | otherwise = 20+ scale 2 | brightness == 1 = 70+ | transparency == 1 = 60+ | otherwise = 50+ scale 3 | brightness == 1 = 100+ | transparency == 1 = 90+ | otherwise = 80 +{- -- Compute the colour of the palette at a particular index position, but use the transparency of the given colour. -- paletteColourWithTransparencyOf :: Color -> (Int, Int) -> Color@@ -309,7 +344,9 @@ where (r, g, b, _) = rgbaOfColor $ paletteColour idx (_, _, _, a) = rgbaOfColor col+ -} +{- -- Adjust a colour transparency (alpha value) for the given index position in the transparency palette. -- transparencyColour :: Color -> Int -> Color@@ -317,6 +354,7 @@ = makeColor r g b (fromIntegral i / 16) where (r, g, b, _a) = rgbaOfColor col+-} -- Draw a picture of the entire application window. --@@ -327,24 +365,23 @@ , Translate (-40) sizeOffset canvasSizeText -- ^^FIXME: Gloss doesn't seem to center text :( -- , Translate (-imageOffset) 0 (drawImage state)- , Translate paletteOffset 0 drawPalette+ , Translate paletteOffset 0 (Scale 2 2 drawPalette) , Translate paletteOffset (-colourOffset) colourIndicator- , Translate paletteOffset colourOffset (drawTransparency (colour state)) ] where imageOffset = elementPadding + fst (canvasSize state) / 2 + fromIntegral (fst (bmpDimensions (image state))) / 2- paletteOffset = elementPadding + fst (canvasSize state) / 2 + fst paletteSize / 2- colourOffset = 2 * colourIndicatorHeight + snd paletteSize / 2+ paletteOffset = elementPadding + fst (canvasSize state) / 2 + fst zoomedPaletteSize / 2+ colourOffset = 2 * colourIndicatorHeight + snd zoomedPaletteSize / 2 sizeOffset = snd (canvasSize state) / 2 + 20 colourIndicator = Pictures $ [ Translate (fromIntegral i * pixelWidth + pixelWidth / 2) (fromIntegral j * pixelHeight + pixelHeight / 2) $ rectangleChecker pixelWidth pixelHeight- | i <- [-8..7], j <- [-1..0] ] ++- [ Color (colour state) (rectangleSolid (fst paletteSize) colourIndicatorHeight)- , Color gridColor (rectangleWire (fst paletteSize) colourIndicatorHeight)+ | i <- [-16..15], j <- [-1..0] ] +++ [ Color (colour state) (rectangleSolid (fst zoomedPaletteSize) colourIndicatorHeight)+ , Color gridColor (rectangleWire (fst zoomedPaletteSize) colourIndicatorHeight) ] pixelWidth = fromIntegral $ fst pixelSize pixelHeight = fromIntegral $ snd pixelSize@@ -359,8 +396,10 @@ -- Try to read the image file and to convert it to a canvas. If that fails yield an empty canvas. ---readImageFile :: FilePath -> IO (Canvas, BMP)-readImageFile fname+-- The first argument determines whether we clip the input colours to the BigPixel colour palette.+--+readImageFile :: Bool -> FilePath -> IO (Canvas, BMP)+readImageFile forcePalette fname = do { result <- readBMP fname ; case result of@@ -409,11 +448,12 @@ quads l = [l] averageAt image (i, j)- = image ! (i * fst pixelSize + fst pixelSize `div` 2, - j * snd pixelSize + snd pixelSize `div` 2)- -- = foldl1 addColors [ image ! (i * fst pixelSize + ioff, j * snd pixelSize + joff) - -- | ioff <- [0..fst pixelSize - 1]- -- , joff <- [0..snd pixelSize - 1]]+ -- = clipColour $ image ! (i * fst pixelSize + fst pixelSize `div` 2, + -- j * snd pixelSize + snd pixelSize `div` 2)+ = (if forcePalette then clipColour else id) $+ foldl1 (mixColors 0.5 0.5) [ image ! (i * fst pixelSize + ioff, j * snd pixelSize + joff) + | ioff <- [0..fst pixelSize - 1]+ , joff <- [0..snd pixelSize - 1]] -- Write the contents of the canvas to the image file. --@@ -455,7 +495,39 @@ fromWord8 = (/ 255) . fromIntegral word8ToColor arg = error ("word8ToColor: not a quad: " ++ show arg) +-- Clip a colour to the BigPixel 8-bit colour space+--+clipColour :: Color -> Color+clipColour col+ | transparent = makeColor 0 0 0 0+ | black = makeColor 0 0 0 1+ | otherwise = makeColor red' green' blue' alpha'+ where+ (red, green, blue, alpha) = rgbaOfColor col+ + black = averageBrightness [red, green, blue] < 0.15+ transparent = alpha < 0.25+ alpha' | alpha >= 0.25 && alpha < 0.75 = 0.5+ | otherwise = 1+ + bright = averageBrightness [red, green, blue] >= 0.55+ red' = clip red+ green' = clip green+ blue' = clip blue+ + averageBrightness cols = sum significantCols / fromIntegral (length significantCols)+ where+ significantCols = [col | col <- cols, col >= 0.15]+ + clip c | c < 0.15 = 0+ | bright && c < 0.70 = 0.6+ | bright && c < 0.90 = 0.8+ | bright = 1+ | c > 0.45 = 0.5+ | c > 0.35 = 0.4+ | otherwise = 0.3 + -- Event handling -- -------------- @@ -516,21 +588,16 @@ draw _mousePos state = state --- Select a colour if mouse position is within palette boundaries or a transparency if mouse position is within--- transparency picker boundaries.+-- Select a colour if mouse position is within palette boundaries. -- selectColour :: Point -> State -> State selectColour mousePos state = case windowPosToCanvas paletteSize paletteAdjustedMousePos of- Nothing -> case windowPosToCanvas pickerSize pickerAdjustedMousePos of- Nothing -> state- Just (i, _) -> state { colour = transparencyColour (colour state) i }- Just idx -> state { colour = paletteColourWithTransparencyOf (colour state) idx }+ Nothing -> state+ Just idx -> state { colour = paletteColour idx } where- paletteOffsetX = elementPadding + fst (canvasSize state) / 2 + fst paletteSize / 2- pickerOffsetY = 2 * colourIndicatorHeight + snd paletteSize / 2- paletteAdjustedMousePos = (fst mousePos - paletteOffsetX, snd mousePos)- pickerAdjustedMousePos = (fst mousePos - paletteOffsetX, snd mousePos - pickerOffsetY)+ paletteOffsetX = elementPadding + fst (canvasSize state) / 2 + fst zoomedPaletteSize / 2+ paletteAdjustedMousePos = ((fst mousePos - paletteOffsetX) / 2, snd mousePos / 2) -- Resize the used canvas area. --@@ -593,18 +660,22 @@ = do { -- Read the image file name from the command line arguments ; args <- getArgs- ; when (length args /= 1) $ do- { putStrLn "BigPixel: need exactly one argument, the image file name with suffix '.bmp'"+ ; let forcePalette = length args == 2 && head args == "--force-palette"+ ; when (not $ length args == 1 || forcePalette) $ do+ { putStrLn "BigPixel: needs image file name with suffix '.bmp' as argument,\n optionally preceeded by --force-palette" ; exitFailure }- ; let [fname] = args+ ; let [fname] = if forcePalette then tail args else args ; when (take 4 (reverse fname) /= reverse ".bmp") $ do { putStrLn "BigPixel: image file must have suffix '.bmp'" ; exitFailure } + ; when forcePalette $+ putStrLn "WARNING: --force-palette needs to be adapted to the latest palette"+ -- Read the image from the given file, or yield an empty canvas- ; (canvas, image) <- readImageFile fname+ ; (canvas, image) <- readImageFile forcePalette fname -- Initialise the application state ; let state = initialState fname canvas image