Tuesday, September 9, 2014

color space conversion

Between RGB and HSL.
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 ?

Sunday, August 10, 2014

nibbles

Remember this game?
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 ?

Sunday, January 26, 2014

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