Wednesday, December 23, 2015

connett circles

Like Barry Martin's 'Hopalong' fractal, this dynamical system from John Connett was first published in Scientific American in 1986. However, it's not actually a fractal: when zooming in (by clicking two points to specify a rectangle), viewers will see the pattern is not infinitely detailed. Instead, peacock-like images appear.
{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Complex (magnitude, Complex((:+)))
import Graphics.UI.SDL as SDL
 
(xres, yres, cast) = (768, 768, fromIntegral)
 
main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Connett Circles" "Connett Circles"
  zoom w (-2000, -2000) (2000, 2000)
 
zoom w (x,y) (s,t) = do
  let r = area x s y t
  render w r
  run w r (0,0)

run w (xs,ys) p@(x,y) = do
  delay 32
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   MouseButtonUp i j _            -> click $ f i j
   _                              -> run w (xs,ys) p
 where
  f i j = (xs !! cast i, ys !! cast j)
  click q
    | p == (0,0) = run w (xs,ys) q
    | otherwise  = zoom w p q

render w r = draw w . concat . f $ set r
 where
  f = zipWith zip $ map (zip [0..] . repeat) [0..]

draw w r = do
  s <- createRGBSurface [] 1 1 32 0 0 0 0
  mapM_ (draw s) r
  SDL.flip w
 where
  rect (x,y)   = Just $ Rect x y 1 1
  draw s (p,n) = do fillRect s Nothing $ Pixel $ rgb n
                    blitSurface s Nothing w $ rect p

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

rgb n 
  | m `mod` 7 == 0 = 0xFFFFFF
  | m `mod` 6 == 0 = 0x00FFFF
  | m `mod` 5 == 0 = 0xFFFF00
  | m `mod` 4 == 0 = 0xFF0000
  | m `mod` 3 == 0 = 0xFF00
  | m `mod` 2 == 0 = 0xFF
  | otherwise      = 0
 where
  f x y = round $ magnitude $ (cast x^2) :+ (cast y^2)
  m     = abs n

set (xs, ys) = [[f x y | x <- xs] | y <- ys]
 where
  f x y = round $ magnitude $ (x^2) :+ (y^2)

area x x' y y' = ([t, t+a.. s], [u, u-b.. v])
 where
  (a,b)    = ((s - t) / dx, (u - v) / dy)
  (s,t)    = (max x x', min x x')
  (u,v)    = (max y y', min y y')
  (dx, dy) = (cast xres, cast yres)

martin attractor

This pattern generator, discovered by Barry Martin, was nicknamed 'Hopalong' when Scientific American introduced it in their September '86 issue.

Clicking the window adjusts the viewport position; there is also an alternate version with color and animation

Update: For a certain Rubyist friend, I wrote another lazily-evaluated, colored and animated implementation in Ruby.

import Control.Arrow ((***))
import Graphics.UI.SDL as SDL

(xres, yres) = (850, 850)
(a,b,c)      = (5, 1, 20)

main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Hopalong Pattern" "Barry Martin"
  render w p ps
  loop w p ps
 where
  p  = (xres `div` 2, yres `div` 2)
  ps = take 7000000 points

loop w p ps = do
  delay 32
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   MouseButtonUp x y _            -> click $ f x y
   _                              -> loop w p ps
 where
  click p = render w p ps >> loop w p ps
  f x y   = (fromIntegral x, fromIntegral y)

render w (x,y) ps = do
  s <- createRGBSurface [SWSurface] 1 1 32 0 0 0 0
  fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
  mapM_ (draw s 0xFFFFFF . rect . center) ps
  SDL.flip w
 where
  center     = ((xres - x) +) *** (+ (yres - y))
  rect (x,y) = Just $ Rect x y 1 1
  draw s c p = do fillRect s Nothing $ Pixel c
                  blitSurface s Nothing w p

points = map (round *** round) $ iterate f (0,0)
 where
  f (x,y) = (g x y, a - x)
  g x y   = y - (signum x * (sqrt . abs $ b*x - c))

Tuesday, December 22, 2015

lyapunov fractals

It took me some experimentation to figure out how to color this derivation of the logistic map; I'm still not quite sure how the hues should scale as you zoom. But the bi-tonal method shown below works well enough to produce the image at right.
{-# LANGUAGE NoMonomorphismRestriction #-}

import Control.Monad (liftM2)
import Data.Bits (shiftL)
import Graphics.UI.SDL as SDL
 
(xres, yres, cast) = (400, 400, fromIntegral)

main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Lyapunov" "Lyapunov"
  render w 1024 (3.2, 3.2) (3.8, 3.8)

render w i (x,y) (s,t) = do
  draw w (zip ps $ area x s y t) i
  run w
 where
  ps = liftM2 (,) [0.. xres] [0.. yres]

draw w cs i = do
  s <- createRGBSurface [] 1 1 32 0 0 0 0
  mapM_ (draw s) cs
  SDL.flip w
 where
  draw s (p,q) = do 
    let rect (x,y) = Just $ Rect x y 1 1
    fillRect s Nothing $ rgb $ lyapunov i q
    blitSurface s Nothing w $ rect p

run w = do
  delay 32
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   _                              -> run w

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

rgb n | n < 0 = Pixel $ f n
      | True  = Pixel $ f n `shiftL` 16
 where
  f x = round (min 255 $ abs n * 255)

lyapunov i p = (1 / cast i) * sum rs
 where
  rs = filter (not . isInfinite) $ f xs
  f  = map (log . abs) . zipWith ($) (str p)
  xs = map ((1 -) . (* 2)) $ verhulst i p

verhulst i p = take i $ go 0.5 $ str p
 where
  go x (f:fs) = x : go (f (x * (1-x))) fs

str (x,y) = map (*) $ concat $ repeat [x,x,y,x,y]

area x x' y y' = liftM2 (,) [s, s+a.. t] [u, u+b.. v]
 where
  (a,b) = ((t - s) / m, (v - u) / n)
  (s,t) = (min x x', max x x')
  (u,v) = (min y y', max y y')
  (m,n) = (cast xres, cast yres)

Tuesday, December 15, 2015

the mandelbrot set

Benoit's famous fractal. Click any two points to specify a zoom rectangle.
import Data.Complex (magnitude, Complex((:+)))
import Graphics.UI.SDL as SDL
 
(xres, yres) = (900, 750)

main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Mandelbrot" "Mandelbrot"
  zoom w 1 (-2, 1) (0.5, -1)

zoom w i (x,y) (s,t) = do
  let r = area x s y t
  render w r i
  run w (i + 1) r (0,0)

render w r i = draw w . concat . f $ set i r
 where
  f = zipWith zip $ map (zip [0..] . repeat) [0..]

draw w cs = do
  s <- createRGBSurface [] 1 1 32 0 0 0 0
  mapM_ (draw s) cs
  SDL.flip w
 where
  rgb n        = div (floor $ min n 2 * 512) 2
  rect (x,y)   = Just $ Rect x y 1 1
  draw s (p,n) = do fillRect s Nothing $ Pixel $ rgb n
                    blitSurface s Nothing w $ rect p

run w i (xs,ys) p@(x,y) = do
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   MouseButtonUp i j _            -> click $ f i j
   _                              -> run w i (xs,ys) p
 where
  f i j = (xs !! fromIntegral i, ys !! fromIntegral j)
  click q
    | p == (0,0) = run w i (xs,ys) q
    | otherwise  = zoom w i p q

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

area x x' y y' = ([t, t+a.. s], [u, u-b.. v])
 where
  (a,b)    = ((s - t) / dx, (u - v) / dy)
  (s,t)    = (max x x', min x x')
  (u,v)    = (max y y', min y y')
  (dx, dy) = (fromIntegral xres, fromIntegral yres)

set i (xs, ys) = [[f x y | x <- xs] | y <- ys]
 where
  f x = magnitude . g . (x :+)
  g a = iterate ((+ a) . (^2)) 0 !! (i * 20)