connett circles

Like Barry Martin's 'Hopalong' fractal, this dynamical system from John Connett was first published in Scientific American in 1986. This demo is interactive: successively clicking two points specifies a rectangle to zoom into. Doing so, you'll see that the system isn't actually a fractal. Instead of self-similarity, deep zooms reveal peacock-like images.

	{-# 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)

view raw connett_circles.hs hosted with ❤ by GitHub

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.

Also, 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))

view raw barry-martin-hopalong.hs hosted with ❤ by GitHub

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 left - click it for more detail.

	{-# 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)

view raw lyapunov-fractals.hs hosted with ❤ by GitHub

the mandelbrot set

What programmer hasn't at some point written an implementation of Benoit Mandelbrot's great discovery, the most famous fractal in the world? Here's my own minimal version, with the simplest possible coloring scheme. To interact with it, just click any two points: the window will zoom in on the rectangle they define.

	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)

view raw mandelbrot_set_viewer.hs hosted with ❤ by GitHub