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 []