Main.hs

{-# LANGUAGE BangPatterns  #-}
{-# LANGUAGE PatternGuards #-}

-- Quasicrystals demo.
--
-- Based on code from:
--   http://mainisusuallyafunction.blogspot.com/2011/10/quasicrystals-as-sums-of-waves-in-plane.html
--
import Graphics.Gloss.Raster.Field
import System.Environment
import System.Exit
import Data.Char

-- Main -----------------------------------------------------------------------
main :: IO ()
main
 = do   args    <- getArgs
        config  <- parseArgs args defaultConfig

        let display
             = if configFullScreen config
               then FullScreen
               else InWindow "Crystal"
                             (configSizeX config, configSizeY config)
                             (10, 10)

        let scale =  fromIntegral $ configScale config
        animateField display
                (configZoom config, configZoom config)
                (quasicrystal scale (configDegree config))


-- Config ---------------------------------------------------------------------
data Config
        = Config
        { configSizeX           :: Int
        , configSizeY           :: Int
        , configFullScreen      :: Bool
        , configZoom            :: Int
        , configScale           :: Int
        , configDegree          :: Int }
        deriving Show

defaultConfig :: Config
defaultConfig
        = Config
        { configSizeX           = 800
        , configSizeY           = 600
        , configFullScreen      = False
        , configZoom            = 2
        , configScale           = 30
        , configDegree          = 5 }


parseArgs :: [String] -> Config -> IO Config
parseArgs args config
        | []    <- args
        = return config

        | "-fullscreen" : rest <- args
        = parseArgs rest
        $ config { configFullScreen     = True }

        | "-window" : sizeX : sizeY : rest <- args
        , all isDigit sizeX
        , all isDigit sizeY
        = parseArgs rest
        $ config { configSizeX          = read sizeX
                 , configSizeY          = read sizeY
                 , configFullScreen     = False }

        | "-zoom" : zoom : rest <- args
        , all isDigit zoom
        = parseArgs rest
        $ config { configZoom           = read zoom }

        | "-scale" : scale : rest <- args
        , all isDigit scale
        = parseArgs rest
        $ config { configScale          = read scale }

        | "-degree" : degree : rest <- args
        , all isDigit degree
        = parseArgs rest
        $ config { configDegree         = read degree }

        | otherwise
        = do    printUsage
                exitWith $ ExitFailure 1

printUsage :: IO ()
printUsage
 = putStr $ unlines
        [ "quazicrystal [flags]"
        , "    -fullscreen              Run full screen"
        , "    -window     sizeX sizeY  Run in a window                     (default 800, 600)"
        , "    -zoom       <NAT>        Pixel replication factor            (default 5)"
        , "    -scale      <NAT>        Feature size of visualisation       (default 30)"
        , "    -degree     <NAT>        Number waves to sum for each point  (default 5)"
        , ""
        , " You'll want to run this with +RTS -N to enable threads" ]


-- Types ----------------------------------------------------------------------
-- | Angle in radians.
type Angle  = Float

-- | Angle offset used for animation.
type Phi    = Float

-- | Number of waves to sum for each pixel.
type Degree = Int

-- | Feature size of visualisation.
type Scale  = Float

-- | Time in seconds since the program started.
type Time   = Float


-- Point ----------------------------------------------------------------------
-- | Compute a single point of the visualisation.
quasicrystal :: Scale -> Degree -> Time -> Point -> Color
quasicrystal !scale !degree !time !p
 = let  -- Scale the time to be the phi value of the animation.
        -- The action seems to slow down at increasing phi values,
        -- so we increase phi faster as time moves on.
        phi     = 1 + (time ** 1.5) * 0.005

   in   rampColor
          $ waves degree phi
          $ point scale p


-- | Sum up all the waves at a particular point.
waves :: Degree -> Phi -> Point -> Float
waves !degree !phi !x = wrap $ waver 0 degree
 where
    !th = pi / phi

    waver :: Float -> Int -> Float
    waver !acc !n
     | n == 0    = acc
     | otherwise = waver (acc + wave (fromIntegral n * th) x)
                         (n - 1)

    wrap n
     = let !n_  = truncate n :: Int
           !n'  = n - fromIntegral n_
       in  if odd n_ then 1 - n'
                     else n'


-- | Generate the value for a single wave.
wave :: Angle -> Point -> Float
wave !th = f where
    !cth  = cos th
    !sth  = sin th

    {-# INLINE f #-}
    f (x, y)  = (cos (cth*x + sth*y) + 1) / 2


-- | Convert an image point to a point on our wave plane.
point :: Scale -> Point -> Point
point !scale (x, y)
        = (x * scale, y * scale)


-- | Color ramp from blue to white.
rampColor :: Float -> Color
rampColor v
        = rgb' v (0.4 + (v * 0.6)) 1