chriswarbo-net: d2f9a8065d5c15a08d3da554e6b97b419d085ad9

     1: module Pic where
     2: 
     3: -- Constants
     4: scale  = 7
     5: dim    = 2 ^ scale
     6: pixels = [(x, y) | x <- [0..dim - 1], y <- [0..dim - 1]]
     7: 
     8: -- Types
     9: type Bits  = [Bool]
    10: type Pixel = (Int, Int)
    11: type Mono  = Bool
    12: type Grey  = Int
    13: type RGB   = (Int, Int, Int)
    14: 
    15: -- Conversions
    16: showMono :: Mono -> String
    17: showMono True  = "1"
    18: showMono False = "0"
    19: 
    20: showGrey :: Grey -> String
    21: showGrey = show
    22: 
    23: showRGB :: RGB -> String
    24: showRGB (r,g,b) = show r ++ " " ++ show g ++ " " ++ show b
    25: 
    26: toBits' :: Int -> Bits
    27: toBits' 0 = [False]
    28: toBits' 1 = [True]
    29: toBits' n = let (d, m) = n `divMod` 2
    30:              in toBits' m ++ toBits' d
    31: 
    32: toBits :: Int -> Bits
    33: toBits n = take scale $ toBits' n ++ repeat False
    34: 
    35: fromBits :: Bits -> Int
    36: fromBits []         = 0
    37: fromBits (True :xs) = 1 + fromBits (False:xs)
    38: fromBits (False:xs) = 2 * fromBits xs
    39: 
    40: -- Image
    41: header :: Int -> Int -> String
    42: header p c = unlines ["P" ++ show p,        -- Format
    43:                       show dim,             -- Width
    44:                       show dim,             -- Height
    45:                       if c > 0 then show c  -- Colour range
    46:                                else ""]
    47: 
    48: monoHeader   = header 1 0
    49: greyHeader   = header 2 dim
    50: colourHeader = header 3 dim
    51: 
    52: renderMono   :: (Int -> Int -> Mono) -> Pixel -> String
    53: renderMono   f (x, y) = showMono (f x y)
    54: 
    55: renderGrey   :: (Int -> Int -> Grey) -> Pixel -> String
    56: renderGrey   f (x, y) = showGrey (f x y)
    57: 
    58: renderColour :: (Int -> Int -> RGB)  -> Pixel -> String
    59: renderColour f (x, y) = showRGB (f x y)
    60: 
    61: monoFrom   f = unlines $ monoHeader   : map (renderMono    f) pixels
    62: greyFrom   f = unlines $ greyHeader   : map (renderGrey    f) pixels
    63: colourFrom f = unlines $ colourHeader : map (renderColour  f) pixels
    64: 
    65: -- Helpers
    66: bitWise :: (Bits -> Bits -> Bits) -> Int -> Int -> Int
    67: bitWise f x y = fromBits (f (toBits x) (toBits y))
    68: 
    69: toRGB :: Bits -> RGB
    70: toRGB bs = (fromBits (take scale                   bs),
    71:             fromBits (take scale (drop      scale  bs)),
    72:             fromBits (take scale (drop (2 * scale) bs)))
    73: 
    74: chunk :: Int -> [a] -> [[a]]
    75: chunk 0 xs = []
    76: chunk 1 xs = [xs]
    77: chunk n xs = let m = length xs `div` n
    78:               in take m xs : chunk (n - 1) (drop m xs)
    79: 
    80: hue :: Float -> (Float, Float, Float)
    81: hue h = let (i, f) = properFraction (h * 6)
    82:             q = (1 - f)
    83:          in case i of
    84:                  0 -> (1, f, 0)
    85:                  1 -> (q, 1, 0)
    86:                  2 -> (0, 1, f)
    87:                  3 -> (0, q, 1)
    88:                  4 -> (f, 0, 1)
    89:                  5 -> (1, 0, q)
    90: 
    91: hues :: Int -> [RGB]
    92: hues n = map (toScaleRGB . hue . (/ fromIntegral n) . fromIntegral) [0..n-1]
    93: 
    94: toScale :: Float -> Grey
    95: toScale = floor . (fromIntegral dim *)
    96: 
    97: toScaleRGB :: (Float, Float, Float) -> RGB
    98: toScaleRGB (x, y, z) = (toScale x, toScale y, toScale z)
    99: 
   100: cols' :: Int -> [(Float, Float, Float)]
   101: cols' n = let n'  = n `div` 8
   102:               xs  = map ((/ fromIntegral n') . fromIntegral) [1..n']
   103:            in concatMap (`map` xs) [\b -> (0, 0, b),
   104:                                     \g -> (0, g, 1),
   105:                                     \b -> (0, 1, b),
   106:                                     \r -> (r, 1, 0),
   107:                                     \b -> (1, 1, b),
   108:                                     \g -> (1, g, 1),
   109:                                     \b -> (1, 0, b),
   110:                                     \r -> (r, 0, 0)]
   111: 
   112: cols :: Int -> [RGB]
   113: cols = map toScaleRGB . cols'