gruff-examples-0.3: src/gruff-whn.hs

{-

Music video for:

B1t Crunch3r vs Killeralien vs Phonetic System
White Hole Nocturne (Feat. Jay Cotton)
Planet Terror Records planet015 #03

speed up audio by 2.0408% from 140bpm to 142.857bpm
video at 25fps

-}
import Data.Maybe (mapMaybe)
import Data.MemoCombinators (list, char)
import System.Environment (getArgs)

import Fractal.GRUFF

import Fractal.RUFF.Mandelbrot.Address (parseAngledInternalAddress)
import Fractal.RUFF.Mandelbrot.Atom (MuAtom(..), findAtom_)
import Fractal.RUFF.Types.Complex (Complex((:+)))

import Number (R)

data Quality = Preview | P288 | P576 | P720 | P1080 deriving Read

main :: IO ()
main = do
  args <- getArgs
  let q = case args of
            [q'] -> case reads q' of
              [(q'', "")] -> q''
              _ -> Preview
            _ -> Preview
  print (animation q)

window :: Quality -> Window
window Preview = Window{ width =  512, height =  288, supersamples =  1    }
window P288    = Window{ width =  512, height =  288, supersamples = 14    }
window P576    = Window{ width = 1080, height =  576, supersamples =  3.5  }
window P720    = Window{ width = 1280, height =  720, supersamples =  2.25 }
window P1080   = Window{ width = 1920, height = 1080, supersamples =  1    }

animation :: Quality -> [(Image, String)]
animation q = mapMaybe (scene q) (score `zip` [0..])

scene :: Quality -> (String, Int) -> Maybe (Image, FilePath)
scene q (s, n) = do
  m <- findMu s
  let cx :+ cy = muNucleus m
      f = filename n
      i = Image
            { imageLocation = Location
                { center = toRational cx :+ toRational cy
                , radius = muSize m * 8
                }
            , imageViewport = Viewport
                { aspect = aspectQ q
                , orient = muOrient m - pi / 2
                }
            , imageWindow   = window q
            , imageColours  = Colours
                { colourInterior = Colour 1 0 0
                , colourBoundary = Colour 0 0 0
                , colourExterior = Colour 1 1 1
                }
            , imageLabels   = []
            , imageLines    = []
            }
  return (i, f)

findMu :: String -> Maybe (MuAtom R)
findMu = list char findMu'

findMu' :: String -> Maybe (MuAtom R)
findMu' s = do
  a <- parseAngledInternalAddress s
  findAtom_ a

aspectQ :: Quality -> Double
aspectQ q = let w = window q in fromIntegral (width w) / fromIntegral (height w)

filename :: Int -> String
filename n = (reverse . take 4 . (++ "0000") . reverse . show) n ++ ".ppm"

kick1, snare1, kick2, snare2, kick3, snare3 :: Int -> [String]
bass3 :: Int -> Int -> [String]
kick1  n = [ "1 2 "     ++ (unwords . map show . take m . scanl (+) (3 :: Int) . repeat) 1 | m <- [n, n - 1 .. 1] ]
snare1 n = [ "1 2 "     ++ (unwords . map show . take (2 * m) . filter (\x -> x `mod` 3 /= 0)) [(3 :: Int) ..] | m <- [n, n - 1 .. 1] ]
kick2  n = [ "1 2 "     ++ (unwords . map show . take m . scanl (+) (5 :: Int) . repeat) 2 | m <- [n, n - 1 .. 1] ]
snare2 n = [ "1 2 3 "   ++ (unwords . map show . take (3 * m) . filter (\x -> x `mod` 4 /= 0)) [(4 :: Int) ..] | m <- [n, n - 1 .. 1] ]
kick3  n = [ "1 2 4 8 " ++ (unwords . map show . take m . scanl (+) (10:: Int) . repeat) 4 | m <- [n, n - 1 .. 1] ]
snare3 n = [ "1 2 3 4 " ++ (unwords . map show . take (4 * m) . filter (\x -> x `mod` 5 /= 0)) [(5 :: Int) ..] | m <- [n, n - 1 .. 1] ]
bass3 n k= [ "1 2 4 "   ++ show k ++ "/7 " ++ (unwords . map show . take m) [(23 :: Int) ..] | m <- [n, n - 1 .. 1] ]

score :: [String]
score = concat $
  [ kick1  21
  , snare1 32
  , kick1  20
  , snare1 11
  , kick1   8
  , kick1   8
  , kick1   5
  , snare1 32
  , kick1  20
  , snare1 11
  ] ++
  [ kick2  21
  , snare2 32
  , kick2  20
  , snare2 11
  , kick2  21
  , snare2 32
  , kick2  10
  , snare2  8
  , snare2  8
  , snare2  5
  ] ++
  [ kick3  21
  , snare3 32
  , kick3  15
  , snare3  5
  , snare3 11
  , kick3   4
  , bass3   4 1
  , kick3   8
  , kick3   5
  , snare3 32
  , kick3  16
  , bass3   5 2
  , snare3  4
  , bass3   3 3
  , snare3  3
  ] ++
  [ kick3  21
  , snare1 32
  , kick2  20
  , snare3 11
  , kick1   8
  , kick2   5
  , bass3   3 4
  , kick3   5
  , snare2  6
  , bass3  26 5
  , kick2  16
  , bass3   5 6
  , snare3  5
  , snare2  3
  , snare1  2
  ]