color space conversion

Recently I was working on some C code for an image-manipulation app, and I had to write logic to convert between RGB and HSL (hue-saturation-lightness) representations of color. For extra confidence in its correctness, I decided to cross-check the C version against this Haskell implementation.

	hsl :: (Int, Int, Int) -> (Double, Double, Double)
	hsl (r',g',b') = r' == g' && g' == b' ? ((0,0,l), (h,s,l))
	where
	[r,g,b] = map ((/ 255) . fromIntegral) [r',g',b']
	cmin = minimum [r,g,b]
	cmax = maximum [r,g,b]
	d = cmax - cmin
	l = (cmin + cmax) / 2
	s = l > 0.5 ? (d / (2 - cmax - cmin), d / (cmax + cmin))
	h = h' < 0 ? (h' + 1, h')
	h' | r' == maximum [r',g',b'] = dB - dG
	| g' == maximum [r',g',b'] = (1 / 3) + dR - dB
	| otherwise = (2 / 3) + dG - dR
	where
	dR = (((cmax - r) / 6) + (d / 2)) / d
	dG = (((cmax - g) / 6) + (d / 2)) / d
	dB = (((cmax - b) / 6) + (d / 2)) / d
	--------------------------------------------------------------
	rgb :: (Double, Double, Double) -> (Int, Int, Int)
	rgb (h,s,l)
	| abs (0 - s) < 0.001 = f l l l
	| otherwise = f r g b
	where
	q = l < 0.5 ? (l * (1 + s), l + s - l*s)
	p = 2*l - q
	r = hueToRgb p q $ h + 1/3
	g = hueToRgb p q h
	b = hueToRgb p q $ h - 1/3
	f x y z = (round $ x*255, round $ y*255, round $ z*255)
	hueToRgb p q h''
	| h < 1/6 = p + (q - p) * 6 * h
	| h < 1/2 = q
	| h < 2/3 = p + (q - p) * 6 * (2/3 - h)
	| otherwise = p
	where
	h' = h'' < 0 ? (h'' + 1, h'')
	h = h' > 1 ? (h' - 1, h' )
	p ? (a,b) = if p then a else b; infix 2 ?

view raw rgb_hsl_conversion.hs hosted with ❤ by GitHub

nibbles

Remember this game? It came bundled with QBasic, back in the good old MS-DOS days...

The game's many subsequent clones often called it Snake instead.

	import Graphics.UI.SDL as SDL hiding (init)
	import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
	import Control.Monad (join, replicateM)
	import Control.Arrow ((***))
	import Data.List (unfoldr)
	[xres, yres, unit] = map (12 *) [90, 50, 1]
	main = withInit [InitVideo] $ do
	window <- setVideoMode xres yres 32 []
	seeds <- replicateM 2 newPureMT
	enableEvent SDLMouseMotion False
	setCaption "Nibbles" "Nibbles"
	run window 8 (rands seeds) snake right
	where
	snake = [unscale (xres `div` 2, yres `div` 2)]
	run w n (r:rs) s@(p:ps) d@(x,y) = if dead s then end else do
	delay 48
	render w r s
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> end
	KeyUp (Keysym SDLK_UP _ _) -> go $ d == down ? (d, up)
	KeyUp (Keysym SDLK_RIGHT _ _) -> go $ d == left ? (d, right)
	KeyUp (Keysym SDLK_DOWN _ _) -> go $ d == up ? (d, down)
	KeyUp (Keysym SDLK_LEFT _ _) -> go $ d == right ? (d, left)
	_ -> go d
	where
	end = putStrLn $ "Score: " ++ show (length s - 9)
	go = run w n' rs' $ f p : (n > 0 ? (s, init s))
	rs' = r == scale p ? (rs, r:rs)
	n' = r == scale p ? (7, n - 1)
	f = (x+) *** (+y)
	render w r ps = do
	s <- createRGBSurface [SWSurface] unit unit 32 0 0 0 0
	fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
	mapM_ (draw s 0xFFFFFF . scale) ps
	draw s 0x00FF00 r
	SDL.flip w
	where
	rect (x,y) = Just $ Rect x y unit unit
	draw s c p = do fillRect s Nothing $ Pixel c
	blitSurface s Nothing w $ rect p
	dead (p:ps) = p `elem` ps || exterior (scale p)
	where
	exterior (x,y) = or [x < 0, y < 0, x >= xres, y >= yres]
	rands [g, g'] = map (scale . unscale) $ zip xs ys
	where
	xs = map (`mod` xres) $ unfoldr (Just . randomInt) g
	ys = map (`mod` yres) $ unfoldr (Just . randomInt) g'
	scale = join (***) (* unit)
	unscale = join (***) (`div` unit)
	[up, right, down, left] = zip [0, 1, 0, -1] [-1, 0, 1, 0]
	p ? (a,b) = if p then a else b; infix 2 ?

view raw nibbles_aka_snake.hs hosted with ❤ by GitHub

prime curve

This curve is created, Logo-style, by the trail of a turtle that makes a clockwise quarter-turn at every prime iteration; the screenshot shows the curve after about 730000 steps.

import Control.Arrow ((***))
import Control.Monad (void, liftM3, when)
import Data.Bits (shift)
import Data.Numbers.Primes (primes)
import Graphics.UI.SDL as SDL
   
(xres, yres) = (800, 800)
  
main = withInit [InitVideo] $ do
  win <- setVideoMode xres yres 32 []
  fillRect win (Just $ Rect 0 0 xres yres) (Pixel 0)
  enableEvent SDLMouseMotion False
  setCaption "Prime Curve" "Prime Curve"
  run win (xres `div` 2, yres `div` 2) [1..] nesw rgbs
 where
  nesw    = cycle $ map f [(0,-1), (1,0), (0,1), (-1,0)]
  f (x,y) = (x+) *** (+y)
   
run w p (n:ns) (d:ds) (c:cs) = do
  drawCell w p c
  let ds' = if prime n then ds else d:ds
  when (n `mod` 13 == 0) $ SDL.flip w
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> void save
   _                              -> run w (d p) ns ds' cs
 where
  prime n = n `elem` takeWhile (< n + 1) primes
  save    = saveBMP w "out.bmp" >> print n
   
drawCell w p c =
  draw p =<< createRGBSurface [SWSurface] 1 1 32 0 0 0 0
 where
  rect x y     = Just $ Rect x y 1 1
  draw (x,y) s = do fillRect s (rect 0 0) (Pixel c)
                    blitSurface s (rect 0 0) w (rect x y)
 
rgbs = cycle . map f $ liftM3 (,,) ns ns ns
 where
  ns        = [151, 153.. 255]
  f (r,g,b) = shift r 16 + shift g 8 + b