creates an olympic rings image and saves it as test.tga

OlympicRings.hs

-- creates an olympic rings image and saves it as test.tga
-- output: http://www.frank-buss.de/haskell/OlympicRings.png

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 "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