{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Bits ((.|.), shiftL)
import Control.Arrow ((***), (&&&))
import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.Primitives (pixel)

(xres, yres, zz) = (1050, 1050, round *** round)

main = withInit [InitVideo] $ do
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Butterfly Curve" "Butterfly Curve"
  fillRect w (Just $ Rect 0 0 xres yres) $ Pixel 0
  plot w $ center $ scale curve
  loop w []
 where
  scale  = map ((150 *) *** (* 150))
  center = map (((xres / 2) +) *** (+ ((yres + 190) / 2)))

curve = map (f &&& (negate . g)) ts
 where
  ts  = [-999, -998.99.. 999]
  f t = sin t * (e ** cos t - 2 * cos (4*t) - h (t / 12))
  g t = cos t * (e ** cos t - 2 * cos (4*t) - h (t / 12))
  h   = foldr1 (.) $ replicate 5 sin
  e   = exp 1

plot w = mapM_ (f . zz)
 where
  f (x,y) = pixel w (fromIntegral x) (fromIntegral y) $ Pixel rgb
   where
    rgb   = rgb'  .|. shiftL (255 `div` (max x y `div` min x y)) 8
    rgb'  = rgb'' .|. shiftL (255 `div` (xres `div` x)) 16
    rgb'' = 0xFF  .|. shiftL (255 `div` (yres `div` y)) 24

loop w ps = do
  delay 128
  event <- pollEvent
  case event of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   _                              -> loop w ps