import Data.Binary -- image size data Size = Size { width :: Integer, height :: Integer } deriving (Eq, Ord, Show, Read) -- RGB components for an image pixel data Pixel = Pixel { r :: Integer, g :: Integer, b :: Integer } deriving (Eq, Ord, Show, Read) -- helper functions for saving bytes writeByte byte = putWord8 (fromIntegral byte) writeBytes bytes = mapM_ putWord8 bytes -- binary instance for saving Pixels instance Binary Pixel where put (Pixel r g b) = do writeByte b writeByte g writeByte r get = error "Pixel get not supported" -- Image definition data Image = Image { size :: Size, pixels :: [[Pixel]] } deriving (Eq, Ord, Read) -- images are saved in TGA format instance Binary Image where put (Image (Size width height) pixels) = do writeBytes [0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0] writeByte $ mod width 256 writeByte $ div width 256 writeByte $ mod height 256 writeByte $ div height 256 writeBytes [24, 0] mapM_ (mapM_ put) pixels get = error "Image get not supported" -- for debugging. Don't show all pixels instance Show Image where show (Image size pixels) = "Image {" ++ show size ++ ", pixels = ...}" -- unit circle circle x y = sqrt(x*x + y*y) < 1 -- scale scale factor f x y = f (x/factor) (y/factor) -- translate translate deltaX deltaY f x y = f (x-deltaX) (y-deltaY) -- combine two functions with an operator to a new function makeCombinator op f1 f2 x y = op (f1 x y) (f2 x y) -- a ring and an example for "inline" usage of makeCombinator for xor ring innerRadius outerRadius = makeCombinator (/=) innerCircle outerCircle where innerCircle = scale innerRadius circle outerCircle = scale outerRadius circle -- makeCombinator can be used for defining a function as well maskOr f1 f2 = makeCombinator (||) f1 f2 -- fill the specified color on the background where the mask returns true fillMask mask color background x y = if mask x y then color else background x y -- blit the image on the background where the mask returns true maskedAnd mask image background x y = if mask x y then image x y else background x y -- ring dimensions ringRadius = 0.1 ringLineWidth = 0.015 ringOutlineLineWidth = 0.02 -- ring center mask for the colored part of a circle ringCenter = ring innerRadius outerRadius where innerRadius = ringRadius - ringLineWidth outerRadius = ringRadius + ringLineWidth -- ring outline mask for the white outline of a circle ringOutline = ring innerRadius outerRadius where innerRadius = ringRadius - ringOutlineLineWidth outerRadius = ringRadius + ringOutlineLineWidth -- circle positions circleDx = 0.125 circleY1 = 0.15 circleY2 = 0.25 circle1Translate = translate (0.5 - 2 * circleDx) circleY1 circle2Translate = translate (0.5 - circleDx) circleY2 circle3Translate = translate 0.5 circleY1 circle4Translate = translate (0.5 + circleDx) circleY2 circle5Translate = translate (0.5 + 2 * circleDx) circleY1 -- masks for the colored part of the rings circle1Center = circle1Translate ringCenter circle2Center = circle2Translate ringCenter circle3Center = circle3Translate ringCenter circle4Center = circle4Translate ringCenter circle5Center = circle5Translate ringCenter -- masks for the white outline of the rings circle1Outline = circle1Translate ringOutline circle2Outline = circle2Translate ringOutline circle3Outline = circle3Translate ringOutline circle4Outline = circle4Translate ringOutline circle5Outline = circle5Translate ringOutline -- RGB color definitions white = Pixel 0xff 0xff 0xff blue = Pixel 0x00 0x85 0xc7 yellow = Pixel 0xf4 0xc3 0x00 black = Pixel 0x00 0x00 0x00 green = Pixel 0x00 0x9f 0x3d red = Pixel 0xdf 0x00 0x24 -- background color backgroundImage x y = white -- the colored rings with the white outline circle1 background = fillMask circle1Center blue $ fillMask circle1Outline white background circle2 background = fillMask circle2Center yellow $ fillMask circle2Outline white background circle3 background = fillMask circle3Center black $ fillMask circle3Outline white background circle4 background = fillMask circle4Center green $ fillMask circle4Outline white background circle5 background = fillMask circle5Center red $ fillMask circle5Outline white background -- mask for masking the bottom half of the image -- for the ring interleave construction bottomHalfMask x y = circleY2-0.05 < y -- additional images for the ring interleave construction maskedCross1 background = maskedAnd bottomHalfMask (circle2 background) background maskedCross2 background = maskedAnd bottomHalfMask (circle3 background) background maskedCross3 background = maskedAnd bottomHalfMask (circle4 background) background maskedCross4 background = maskedAnd bottomHalfMask (circle5 background) background -- the olympic rings image olympicRings = maskedCross4 $ maskedCross3 $ maskedCross2 $ maskedCross1 $ circle1 $ circle2 $ circle3 $ circle4 $ circle5 $ backgroundImage -- calculate the average color of 4 pixels average (Pixel r1 g1 b1) (Pixel r2 g2 b2) (Pixel r3 g3 b3) (Pixel r4 g4 b4) = Pixel (floor ((fromInteger (r1+r2+r3+r4)) / 4)) (floor ((fromInteger (g1+g2+g3+g4)) / 4)) (floor ((fromInteger (b1+b2+b3+b4)) / 4)) -- calculate 800x300 size image, with 2x2 oversampling for anti-aliased output main = encodeFile "/tmp/test.tga" image where image = Image (Size width height) pixels pixels = [[pixel x y | x <- [0..(width-1)]] | y <- [0..(height-1)]] pixel x y = average (pixel1 x y) (pixel2 x y) (pixel3 x y) (pixel4 x y) pixel1 x y = olympicRings (scaledX (x + 1)) (scaledY y) pixel2 x y = olympicRings (scaledX x) (scaledY (y + 1)) pixel3 x y = olympicRings (scaledX x) (scaledY y) pixel4 x y = olympicRings (scaledX (x + 1)) (scaledY (y + 1)) scaledX x = (fromInteger x) / (fromInteger width) scaledY y = (fromInteger (height-y-1)) / (fromInteger width) width = 800 height = 300