Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
179 lines (139 sloc) 5.17 KB
-- 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
= case configFullScreen config of
True -> FullScreen (configSizeX config, configSizeY config)
False -> 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" : sizeX : sizeY : rest <- args
, all isDigit sizeX
, all isDigit sizeY
= parseArgs rest
$ config { configSizeX = read sizeX
, configSizeY = read sizeY
, 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 sizeX sizeY 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