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.

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

dart outs

For those who like to play X01 Games.
Update: with an unexpected application to Project Euler #109!

import Control.Applicative (liftA2)
import Data.List (sort, nub, sortBy, maximum)
import Data.Ord (comparing)
import System.Environment (getArgs)
  
data Dart n = Single n | Double n | Triple n | Bull | None deriving Show
  
main = mapM_ print . out . read . head =<< getArgs
  
out n = check . sort' . map (map dart) $ sortBy (comparing maximum) sums
 where
  check ns = if null ns then [None] else head ns
  sort'    = sortBy (comparing $ sum . map ease)
  sums     = nub $ filter ((== n) . sum) combos
  
---------------------------------------------------------------------------
  
combos = concat $ zipWith combosOf [1..3] $ repeat segments
  
segments = concat $ replicate 3 $ sort $ 50 : liftA2 (*) [1..3] [1..20]
   
dart n
  | n == 50    = Bull
  | n `elem` s = Single n
  | n `elem` d = Double (n `div` 2)
  | n `elem` t = Triple (n `div` 3)
 where
  [s,d,t] = liftA2 (map . (*)) [1..3] [[1..20]]
                  
ease (Single _) = 1
ease (Bull)     = 2
ease (Double _) = 3
ease (Triple _) = 4
                   
combosOf 0 _      = [[]]
combosOf _ []     = []
combosOf k (x:xs) = map (x:) (combosOf (k-1) xs) ++ combosOf k xs

efficiency

These 61 characters compute a 20899-digit number in 1 second @ 1ghz.

main = print $ fibs !! 100000

fibs = 0 : scanl (+) 1 fibs

graph search

An implementation of general graph search. The search strategy is determined by the definition on line 59, cost. The expression shown below produces an A* search. If instead one substitutes cost = sum . map dist . segments, the procedure becomes a uniform-cost search. Using length finds the path with fewest nodes, and simiarly dist [last ps, goal] produces a greedy best-first algorithm.

{-# LANGUAGE PackageImports #-}

import Graphics.UI.SDL.Primitives (line, filledCircle)
import Graphics.UI.SDL as SDL
import Control.Monad (mapM_, liftM, liftM2)
import System.Random.Mersenne.Pure64 (pureMT, randomInt)
import Data.List (unfoldr, groupBy, sortBy, maximumBy)
import Data.Ord (comparing)
import Data.Function (on)
import "hashmap" Data.HashSet (fromList, toList, difference,
  intersection, empty, insert, delete, unions, member)
  
main = withInit [InitVideo] $ do
  win <- setVideoMode xres yres 32 [Fullscreen]
  enableEvent SDLMouseMotion False
  fillRect win (Just $ Rect 0 0 xres yres) (Pixel 0)
  drawGraph win
  SDL.flip win
  loop
  
loop = do
  delay 200
  e <- pollEvent
  case e of
    KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
    _                              -> loop
  
drawGraph w = do
  let route = search [[start]] empty
  drawLines w 0x0000FFFF (map toList graph)
  drawNodes w 0xFFFFFFFF nodes
  drawNodes w 0xFFFF00FF route
  drawLines w 0xFFFF00FF (segments route)
  drawNodes w 0x00FF00FF [start]
  drawNodes w 0xFF0000FF [goal]
  
drawNodes w rgb = mapM_ draw
 where
  draw [x,y] = filledCircle w x y 4 (Pixel rgb)
  
drawLines w rgb = mapM_ draw
 where
  draw [[a, b], [c, d]] = line w a b c d (Pixel rgb)
 
--------------------------------------------------------------------------
 
search frontier explored
  | null frontier = []
  | otherwise     = if state == goal then path
                      else search next (state `insert` explored)
 where
  state = last path
  path  = head frontier
  next  = tail frontier ++ actions path explored state
  
actions path explored state = sort' . map nextstep $ toList locality
 where
  sort'    = sortBy $ comparing cost
  cost ps  = dist [last ps, goal] + sum (map dist $ segments ps)
  nextstep = (path ++) . return
  locality = let s = state `delete` unions (filter (member state) graph)
              in s `difference` (s `intersection` explored)
 
graph = map fromList . concatMap nearby $ group pairs
 where
  group  = groupBy ((==) `on` head)
  nearby = takeWhile ((< 280) . dist) . sortBy (comparing dist)
  
nodes = take 64 . map cast $ zipWith pair (rand xres 0) (rand yres 1)
 where
  rand m = map (`mod` m) . unfoldr (liftM randomInt . Just) . pureMT
 
--------------------------------------------------------------------------
 
[goal, start] = maximumBy (comparing dist) pairs
 
pairs         = filter (\[a,b] -> a /= b) $ liftM2 pair nodes nodes
  
segments ps   = zipWith pair ps (tail ps)
  
dist [a,b]    = sqrt $ (x'-x)^2 + (y'-y)^2
                  where ([x,y], [x',y']) = (cast a, cast b)
  
pair a b      = [a, b]
cast [a,b]    = [fromIntegral a, fromIntegral b]
 
(xres, yres)  = (1600, 900)

simple alarm clock

Finally a useful program! ;)

import System.Time
import System.Environment (getArgs)
import Control.Monad (forever)
import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.Mixer
 
main = do
  SDL.init [InitAudio]
  openAudio 22050 AudioS16Sys 2 4096
  h:m:_ <- fmap (map read) getArgs
  wait h m
 
wait h m = do
  now <- toCalendarTime =<< getClockTime
  if h == ctHour now && m == ctMin now
    then alarm
    else delay 5000 >> wait h m
 
alarm = do
  mus <- loadMUS "sawtooth.ogg"
  forever $ playMusic mus 1 >> delay 7000

the game of life

I find using a point set (rather than an array) to represent this CA surprisingly convenient. It suffers no edge effects, and I suspect its average-case complexity is less, since it's a function of the live cells' population, which grows little as a typical (random) pattern evolves.

An array representation on the other hand, grows proportionally with the area spanned by all live cells. Since random patterns quite often fire gliders in opposite directions, this area can grow very quickly.

Anyway, this program takes a .cells pattern file for an optional argument; you can also press 'r' while paused for a random pattern, or click to create your own.

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TupleSections #-}
 
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)
import Control.Arrow ((***))
import Control.Monad (liftM2, join)
import Data.List (delete, unfoldr)
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
import qualified "hashmap" Data.HashSet as S
import qualified "unordered-containers" Data.HashMap.Strict as M
 
(xres, yres, cellSz) = (1600, 900, 3)
 
main = withInit [InitVideo] $ do
  win  <- setVideoMode xres yres 32 [Fullscreen]
  args <- getArgs
  pat  <- case args of
           [s] -> loadPattern s
           _   -> return []
  enableEvent SDLMouseMotion False
  setCaption "Life" "Life"
  pause win pat
 
pause w cs = do
  delay 128
  drawCells w cs
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   KeyUp (Keysym SDLK_SPACE _ _)  -> run w cs
   KeyUp (Keysym SDLK_r  _ _)     -> pause w =<< randPattern
   MouseButtonUp x y _            -> click (scale x, scale y)
   _                              -> pause w cs
 where
  scale                 = (`div` cellSz) . fromIntegral
  click c | c `elem` cs = pause w $ delete c cs
          | otherwise   = pause w $ c:cs
 
run w cs = do
  drawCells w cs
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   KeyUp (Keysym SDLK_SPACE  _ _) -> pause w cs
   _                              -> run w $ next cs
 
drawCells w cs = do
  fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
  c <- createRGBSurface [SWSurface] cellSz cellSz 32 0 0 0 0
  mapM_ (draw c . scale) cs
  SDL.flip w
 where
  rect (x,y) = Just $ Rect x y cellSz cellSz
  scale      = join (***) (* cellSz)
  draw c p   = do fillRect c Nothing $ Pixel 0xFFFFFF
                  blitSurface c Nothing w $ rect p

----------------------------------------------------------------

loadPattern = fmap parse . readFile   -- reads .cells format
 where
  parse = center . clean . coord . strip . lines
  strip = dropWhile $ (== '!') . head
  coord = zipWith zip $ map (zip [0..] . repeat) [0..]
  clean = concatMap $ map fst . filter ((== 'O') . snd)
 
randPattern = fmap f newPureMT
 where
  f = center . uncurry zip . splitAt 48 . g
  g = map (`rem` 9) . unfoldr (Just . randomInt)

center = map $ (x+) *** (+y)
 where
  [x,y] = map (`div` (2 * cellSz)) [xres, yres]
 
next cs = [i | (i,n) <- M.toList neighbors,
           n == 3 || (n == 2 && S.member i cs')]
 where
  cs'         = S.fromList cs
  moore (x,y) = tail $ liftM2 (,) [x, x+1, x-1] [y, y+1, y-1]
  neighbors   = M.fromListWith (+) $ map (,1) $ moore =<< cs

magic squares

If your magic square needs are more industrial there are always better ways...

import Data.List (transpose, intersect)
 
answers  =  filter valid squares
              where valid m = diag1 m == 15 && diag2 m == 15
 
squares  =  horz combos `intersect` vert combos
              where vert = map transpose . horz
 
combos   =  [ [a,b,c] | a <- ns, b <- ns, c <- ns, a + b + c == 15 ]
              where ns = [1..9]
 
horz m   =  [ [a,b,c] | a <- m, b <- m, c <- m, uniq (a ++ b ++ c) ]
 
diag1 m  =  head (head m) + ((m !! 1) !! 1) + last (last m)
  
diag2 m  =  last (head m) + ((m !! 1) !! 1) + head (last m)
 
uniq ns  =  let f (n:ns) xs = n `notElem` xs && f ns (n:xs)
                f _ _       = True
            in f ns []

plenary ant

Here's a more polished edition of the basic Langton's ant previously posted. As in this version of Conway's Life, you can pause with the space key, and press r while paused to restart with a random pattern. Just for fun I also threw in colors. On exiting, the code prints the iteration count - given populous initial states, it's interesting how much this value can vary before the ant builds its inevitable highway.

import Data.Bits (shift)
import Data.List (unfoldr)
import Control.Arrow ((***)) 
import Control.Monad (when, join)
import Data.Set (insert, delete, member, empty, fromList, toList)
import Graphics.UI.SDL as SDL
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
 
(xres, yres, sq, cast) = (1600, 900, 3, fromIntegral)
 
origin = (xres `div` 2 `div` sq, yres `div` 2 `div` sq)
 
main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Langton's Ant" "Langton's Ant"
  pause w origin (0,1) empty
 
pause w p v ps = do
  delay 128
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   KeyUp (Keysym SDLK_SPACE _ _)  -> run w [1..] p v ps
   KeyUp (Keysym SDLK_r  _ _)     -> randomize
   _                              -> pause w p v ps
 where
  randomize = do
    ps <- randPattern
    render w ps
    pause w origin (0,1) ps
  
run w (n:ns) p v ps = do
  when (n `mod` 7 == 0) $ render w ps
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> print n
   KeyUp (Keysym SDLK_SPACE  _ _) -> pause w p v ps
   _                              -> continue
 where
  continue   = run w ns (move p $ g v) (g v) $ f p ps
  b          = member p ps
  f          = if b then delete else insert
  g          = if b then fl else fr
  move (x,y) = (x+) *** (+y)
  fr (x,y)   = if x == 0 then (-y,x) else (y,x)
  fl (x,y)   = if x == 0 then (y,x)  else (y,-x)
 
render w ps = do
  fillRect w (Just $ Rect 0 0 xres yres) $ Pixel 0
  mapM_ (draw w . join (***) (* sq)) $ toList ps
  SDL.flip w
  
draw w p = f p =<< g [SWSurface] sq sq 32 0 0 0 0
 where
  rect x y  = Just $ Rect x y sq sq
  g         = createRGBSurface
  f (x,y) s = do fillRect s (rect 0 0) $ Pixel $ rgb x y
                 blitSurface s (rect 0 0) w $ rect x y
 
randPattern = fmap (fromList . f) newPureMT
 where
  f = center . uncurry zip . splitAt 11000 . g
  g = map (`rem` 512) . unfoldr (Just . randomInt)
 
center = map $ (x+) *** (+y)
 where
  [x,y] = map (`div` (2 * sq)) [xres, yres]
 
rgb x y = shift r 16 + shift g 8 + 128
 where
  r = round $ (cast x / cast xres) * 255
  g = round $ (cast y / cast yres) * 255