gloss-examples 1.10.2.3 → 1.10.2.4
raw patch · 16 files changed
+49/−1590 lines, 16 filesdep −GLFW-bdep −gloss-rendering
Dependencies removed: GLFW-b, gloss-rendering
Files
- gloss-examples.cabal +49/−41
- picture/Render/Main.hs +0/−54
- raster/Fluid/src-repa/Args.hs +0/−276
- raster/Fluid/src-repa/Config.hs +0/−66
- raster/Fluid/src-repa/FieldElt.hs +0/−95
- raster/Fluid/src-repa/Main.hs +0/−90
- raster/Fluid/src-repa/Model.hs +0/−209
- raster/Fluid/src-repa/Solve/Density.hs +0/−40
- raster/Fluid/src-repa/Solve/Velocity.hs +0/−42
- raster/Fluid/src-repa/Stage/Advection.hs +0/−118
- raster/Fluid/src-repa/Stage/Boundary.hs +0/−115
- raster/Fluid/src-repa/Stage/Diffusion.hs +0/−50
- raster/Fluid/src-repa/Stage/Linear.hs +0/−148
- raster/Fluid/src-repa/Stage/Project.hs +0/−68
- raster/Fluid/src-repa/Stage/Sources.hs +0/−77
- raster/Fluid/src-repa/UserEvent.hs +0/−101
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.10.2.3+Version: 1.10.2.4 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -234,6 +234,8 @@ Executable gloss-ray Build-depends: base >= 4.8 && < 4.10,+ repa == 3.4.*,+ repa-io == 3.4.*, gloss == 1.10.*, gloss-raster == 1.10.* Main-is: Main.hs@@ -288,35 +290,39 @@ -fllvm -optlo-O3 -Executable gloss-fluid- Build-depends:- base >= 4.8 && < 4.10,- ghc-prim == 0.5.*,- vector == 0.11.*,- repa == 3.4.*,- repa-io == 3.4.*,- repa-algorithms == 3.4.*,- gloss == 1.10.*- Main-is: Main.hs- other-modules: - Args Config FieldElt Model UserEvent- Solve.Density Solve.Velocity- Stage.Advection Stage.Boundary Stage.Diffusion- Stage.Linear Stage.Project Stage.Sources- hs-source-dirs: raster/Fluid/src-repa-- extensions:- PatternGuards-- ghc-options:- -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case- -funfolding-use-threshold1000- -funfolding-keeness-factor1000-- if flag(llvm)- ghc-options:- -fllvm -optlo-O3+-- Disabled on 8/11/2016 as the linear solver is taking too long to build.+-- GHC compile time performance has regressed recently, so we could enable+-- it again once that it fixed.+--+-- Executable gloss-fluid+-- Build-depends:+-- base >= 4.8 && < 4.10,+-- ghc-prim == 0.5.*,+-- vector == 0.11.*,+-- repa == 3.4.*,+-- repa-io == 3.4.*,+-- repa-algorithms == 3.4.*,+-- gloss == 1.10.*+-- Main-is: Main.hs+-- other-modules: +-- Args Config FieldElt Model UserEvent+-- Solve.Density Solve.Velocity+-- Stage.Advection Stage.Boundary Stage.Diffusion+-- Stage.Linear Stage.Project Stage.Sources+-- hs-source-dirs: raster/Fluid/src-repa+-- +-- extensions:+-- PatternGuards+-- +-- ghc-options:+-- -Wall -threaded -rtsopts -eventlog+-- -Odph -fno-liberate-case+-- -funfolding-use-threshold1000+-- -funfolding-keeness-factor1000+-- +-- if flag(llvm)+-- ghc-options:+-- -fllvm -optlo-O3 @@ -324,6 +330,7 @@ Build-depends: base >= 4.8 && < 4.10, repa == 3.4.*,+ repa-algorithms == 3.4.*, gloss == 1.10.* Main-is: Main.hs hs-source-dirs: raster/Snow@@ -373,15 +380,16 @@ -Wall -O2 -Executable gloss-render- Build-depends:- base >= 4.8 && < 4.10,- containers == 0.5.*,- gloss == 1.10.*,- gloss-rendering == 1.10.*,- GLFW-b- Main-is: Main.hs- hs-source-dirs: picture/Render- ghc-options:- -Wall -O2+-- Disabled on 8/11/2016 as GLFW-b does not build on OSX.+-- Executable gloss-render+-- Build-depends:+-- base >= 4.8 && < 4.10,+-- containers == 0.5.*,+-- gloss == 1.10.*,+-- gloss-rendering == 1.10.*,+-- GLFW-b+-- Main-is: Main.hs+-- hs-source-dirs: picture/Render+-- ghc-options:+-- -Wall -O2
− picture/Render/Main.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE PackageImports #-}-import "GLFW-b" Graphics.UI.GLFW as GLFW-import Control.Concurrent (threadDelay)-import Control.Monad (when, unless)-import Graphics.Gloss.Rendering-import Graphics.Gloss---main :: IO ()-main = do- let width = 200- height = 200-- state <- initState-- withWindow width height "Render" $ \win -> do- loop state win (width, height)-- where loop state window (w, h) = do- threadDelay 20000- pollEvents- displayPicture (w, h) white state 1.0 (Circle 80)- swapBuffers window- k <- keyIsPressed window Key'Escape- unless k $ loop state window (w, h)---withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO ()-withWindow width height title f = do- GLFW.setErrorCallback $ Just simpleErrorCallback- r <- GLFW.init- when r $ do- m <- GLFW.createWindow width height title Nothing Nothing- case m of- (Just win) -> do- GLFW.makeContextCurrent m- f win- GLFW.setErrorCallback $ Just simpleErrorCallback- GLFW.destroyWindow win- Nothing -> return ()- GLFW.terminate- where- simpleErrorCallback e s =- putStrLn $ unwords [show e, show s]---keyIsPressed :: Window -> Key -> IO Bool-keyIsPressed win key = isPress `fmap` GLFW.getKey win key---isPress :: KeyState -> Bool-isPress KeyState'Pressed = True-isPress KeyState'Repeating = True-isPress _ = False
− raster/Fluid/src-repa/Args.hs
@@ -1,276 +0,0 @@--module Args - ( parseArgs- , configDefault)-where-import Config-import Model-import Data.Array.Repa as R-import Data.Array.Repa.Algorithms.Pixel as R-import Data.Array.Repa.IO.BMP as R-import qualified Data.Vector.Unboxed as U-import Prelude as P-import System.Exit-import Data.Char---parseArgs :: [String] -> Config -> IO Config-parseArgs args config- | [] <- args- = return config-- | "-batch" : rest <- args- = parseArgs rest - $ config { configBatchMode = True }-- | "-frames" : path : rest <- args- = parseArgs rest- $ config { configFramesMode = Just path- , configBatchMode = True }-- | "-max" : num : rest <- args- , all isDigit num- = parseArgs rest- $ config { configMaxSteps = read num }-- | "-size" : width : height : rest <- args- , all isDigit width- , all isDigit height- , width' <- read width- , height' <- read height- = parseArgs rest- $ config { configModelSize = (width', height')- , configInitialDensity = makeDensField_empty width' height'- , configInitialVelocity = makeVeloField_empty width' height' }-- | "-unstable" : rest <- args- = parseArgs rest- $ config { configUnstable = True }-- | "-iters" : num : rest <- args- , all isDigit num- = parseArgs rest- $ config { configIters = read num }-- | "-scale" : int : rest <- args- = parseArgs rest- $ config { configScale = (read int, read int) }-- | "-rate" : int : rest <- args- = parseArgs rest- $ config { configRate = read int }-- | "-delta" : float : rest <- args- = parseArgs rest- $ config { configDelta = read float }-- | "-diff" : float : rest <- args- = parseArgs rest- $ config { configDiff = read float }-- | "-diff-after" : int : rest <- args- , all isDigit int- = parseArgs rest- $ config { configDiffAfter = read int }-- | "-visc" : float : rest <- args- = parseArgs rest- $ config { configVisc = read float }-- | "-user-dens" : float : rest <- args- = parseArgs rest- $ config { configDensity = read float }-- | "-user-velo" : float : rest <- args- = parseArgs rest- $ config { configVisc = read float }--- -- Initial Confditions ----------------------------------------------------- | "-dens-bmp" : filePath : rest <- args- = do dens <- loadDensBMP filePath- let Z :. height :. width = extent dens- parseArgs rest- $ config { configInitialDensity = dens- , configModelSize = (width, height) }-- | "-velo-bmp" : filePath : rest <- args- = do velo <- loadVeloBMP filePath- let Z :. height :. width = extent velo- parseArgs rest- $ config { configInitialVelocity = velo- , configModelSize = (width, height) }-- | "-init-checks" : rest <- args- = do let (width, height) = configModelSize config- parseArgs rest- $ config { configInitialDensity = makeDensField_checks width height - , configInitialVelocity = makeVeloField_empty width height }-- | "-init-man" : rest <- args- = do let (width, height) = configModelSize config- parseArgs rest- $ config { configInitialDensity = makeDensField_checks width height- , configInitialVelocity = makeVeloField_man width height }-- | "-init-elk" : rest <- args- = do let (width, height) = configModelSize config- parseArgs rest- $ config { configInitialDensity = makeDensField_checks width height- , configInitialVelocity = makeVeloField_elk width height }-- | otherwise- = do printUsage- exitWith ExitSuccess---printUsage :: IO ()-printUsage- = putStr- $ unlines- [ "gloss-fluid [flags]"- , " -batch Run a fixed number of steps instead of displaying in a window."- , " -frames <PATH.bmp> Dump all frames to .bmp files (implies -batch)"- , " -max <INT> Quit after this number of steps."- , " -size <INT> <INT> Size of simulation. (100)"- , " -unstable Use the unstable linear solver (False)"- , " -iters <INT> Iterations for the linear solver. (40)"- , " -scale <INT> Width of a cell in the window. (5)"- , " -rate <INT> Frame rate. (30)"- , " -delta <FLOAT> Length of time step. (0.1)"- , " -diff <FLOAT> Diffusion rate for the density. (0)"- , " -diff-after <INT> Trigger diffusion after this step. (0)"- , " -visc <FLOAT> Diffusion rate for the velocity. (0)"- , " -user-dens <FLOAT> Magnitude of user inserted density. (100)"- , " -user-velo <FLOAT> Magnitude of user inserted velocity. (20)"- , " -bmp-dens <FILE.bmp> File for initial fluid density."- , " -bmp-velo <FILE.bmp> File for initial fluid velocity." - , ""- , " Run this with +RTS -N -qa -qg to enable threads."- , "" ]---configDefault :: Config-configDefault- = let modelW = 100- modelH = 100- in Config- { configRate = 30- , configMaxSteps = 0- , configBatchMode = False- , configFramesMode = Nothing- , configModelSize = (modelW, modelH)- , configScale = (5, 5)- , configUnstable = False- , configIters = 40- , configDelta = 0.1- , configDiff = 0- , configDiffAfter = 0- , configVisc = 0- , configDensity = 100- , configVelocity = (20, 20)- , configInitialDensity = makeDensField_empty modelW modelH- , configInitialVelocity = makeVeloField_empty modelW modelH }----- | Load a density field from a BMP file.-loadDensBMP :: FilePath -> IO DensityField-loadDensBMP filePath- = do result <- readImageFromBMP filePath- let arr = case result of- Right arr' -> arr'- Left err -> error $ show err-- density <- computeUnboxedP - $ R.map floatLuminanceOfRGB8 arr-- return density----- | Load velocity field from a BMP file.-loadVeloBMP :: FilePath -> IO VelocityField-loadVeloBMP filePath- = do result <- readImageFromBMP filePath- let arr = case result of- Right arr' -> arr'- Left err -> error $ show err-- let {-# INLINE conv #-}- conv (r, g, _b) - = let r' = fromIntegral (-128 + fromIntegral r :: Int)- g' = fromIntegral (-128 + fromIntegral g :: Int)- in (r' * 0.0001, g' * 0.0001)-- velocity <- computeUnboxedP $ R.map conv arr-- return velocity-----------------------------------------------------------------------------------makeDensField_empty :: Int -> Int -> Array U DIM2 Float-makeDensField_empty width height- = R.fromUnboxed (Z :. height :. width)- $ U.replicate (width * height) 0---makeDensField_checks :: Int -> Int -> DensityField-makeDensField_checks width height- = let height' = fromIntegral height- xc = fromIntegral (width `div` 2)- yc = fromIntegral (height `div` 2)- - in R.fromListUnboxed (Z :. height :. width)- $ [ let x' = fromIntegral (x - 1)- y' = fromIntegral (y - 1)- tx = 10 * (x' - xc) / height'- ty = 10 * (y' - yc) / height'- xk1 = if abs tx > 3*pi/2 then 0 else cos tx- yk1 = if abs ty > 3*pi/2 then 0 else cos ty- d1 = xk1 * yk1- in if (d1 < 0) then 0 else d1- | y <- [1 .. height]- , x <- [1 .. width] ]-----------------------------------------------------------------------------------makeVeloField_empty :: Int -> Int -> Array U DIM2 (Float, Float)-makeVeloField_empty width height- = R.fromUnboxed (Z :. height :. width)- $ U.replicate (width * height) (0, 0)---makeVeloField_man :: Int -> Int -> VelocityField-makeVeloField_man width height- = let height' = fromIntegral height- xc = fromIntegral (width `div` 2)- yc = fromIntegral (height `div` 2)- - in R.fromListUnboxed (Z :. height :. width)- $ [ let x' = fromIntegral x- y' = fromIntegral y- xk2 = cos (19 * (x' - xc) / height')- yk2 = cos (17 * (y' - yc) / height')- d2 = xk2 * yk2 / 5- in (0, d2)- | y <- [0..height - 1]- , x <- [0..width - 1] ]---makeVeloField_elk :: Int -> Int -> VelocityField-makeVeloField_elk width height- = let height' = fromIntegral height- xc = fromIntegral (width `div` 2)- yc = fromIntegral (height `div` 2)- - in R.fromListUnboxed (Z :. height :. width)- $ [ let x' = fromIntegral x- y' = fromIntegral y- tx = 12 * (x' - xc) / height'- ty = 12 * (y' - yc) / height'- xk2 = cos tx- yk2 = -cos ty- d2 = xk2 * yk2 / 5- in (0, d2)- | y <- [0 .. height - 1]- , x <- [0 .. width - 1] ]-
− raster/Fluid/src-repa/Config.hs
@@ -1,66 +0,0 @@--module Config - ( Config (..)- , configWindowSize)-where-import Model-import Data.Array.Repa as R---data Config- = Config- { -- | Simulation rate (frames per second)- configRate :: Int-- -- | Maximum number of steps in simulation- , configMaxSteps :: Int-- -- | Whether to run in batch-mode, non-interactively.- , configBatchMode :: Bool-- -- | Whether to dump all frames to .bmp files.- , configFramesMode :: Maybe FilePath-- -- | Number of cells in model.- , configModelSize :: (Int, Int)-- -- | Window scale.- , configScale :: (Int, Int)-- -- | Use the unstable linear solver.- , configUnstable :: !Bool-- -- | Number of iterations to use in the linear solver- , configIters :: !Int-- -- | Time delta per step.- , configDelta :: !Delta-- -- | Diffusion rate.- , configDiff :: !Float-- -- | Apply diffusion after this step number.- , configDiffAfter :: !Int-- -- | Fluid viscosity.- , configVisc :: !Float-- -- | Magnitude of density to add with user interface.- , configDensity :: !Float-- -- | Magnitude of velocity to add with user interface.- , configVelocity :: !(Float, Float) -- -- | Initial density array- , configInitialDensity :: !(Array U DIM2 Float)-- -- | BMP file to use as the initial velocity- , configInitialVelocity :: !(Array U DIM2 (Float, Float))- } --configWindowSize :: Config -> (Int, Int)-configWindowSize config- = let (modelX, modelY) = configModelSize config- (scaleX, scaleY) = configScale config- in (modelX * scaleX, modelY * scaleY)-
− raster/Fluid/src-repa/FieldElt.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE FlexibleInstances, BangPatterns #-}---- | Field operations -module FieldElt where--class Show a => FieldElt a where- zero :: a-- -- | Add all elements.- (~+~) :: a -> a -> a-- -- | Subtract elements from second from first.- (~-~) :: a -> a -> a-- -- | Multiply all elements.- (~*~) :: a -> Float -> a-- -- | Divide first elemends by the second.- (~/~) :: a -> Float -> a-- -- | Negate all mambers.- negate :: a -> a-- -- | Masked addition.- addIf :: Bool -> a -> a -> a-- -- | Masked filter, members with their corresponding flags set- -- to False get zero.- useIf :: Bool -> a -> a---instance FieldElt Float where- zero = 0- {-# INLINE zero #-}-- (~+~) a b = a + b- {-# INLINE (~+~) #-}-- (~-~) a b = a - b- {-# INLINE (~-~) #-}-- (~*~) a b = a * b- {-# INLINE (~*~) #-}-- (~/~) a b = a / b- {-# INLINE (~/~) #-}-- negate a = 0 ~-~ a- {-# INLINE negate #-}-- addIf True a b = a + b- addIf False _ b = b- {-# INLINE addIf #-}-- useIf True a = a- useIf False _ = 0- {-# INLINE useIf #-}---instance FieldElt (Float, Float) where- zero = (0, 0)- {-# INLINE zero #-}-- (~+~) (a1, a2) (b1, b2) = (c1, c2)- where !c1 = a1 + b1- !c2 = a2 + b2- {-# INLINE (~+~) #-}-- (~-~) (a1, a2) (b1, b2) = (c1, c2)- where !c1 = a1 - b1- !c2 = a2 - b2- {-# INLINE (~-~) #-}-- (~*~) (a1, a2) b = (c1, c2)- where !c1 = a1 * b- !c2 = a2 * b- {-# INLINE (~*~) #-}-- (~/~) (a1, a2) b = (c1, c2)- where !c1 = a1 / b- !c2 = a2 / b- {-# INLINE (~/~) #-}-- addIf True a b = a ~+~ b- addIf False _ b = b - {-# INLINE addIf #-}-- useIf True a = a- useIf False _ = (0, 0)- {-# INLINE useIf #-}-- negate (a1, a2) - = (~-~) (0, 0) (a1, a2)- {-# INLINE negate #-}-
− raster/Fluid/src-repa/Main.hs
@@ -1,90 +0,0 @@---- | Stable fluid flow-solver.--- Based on "Real-time Fluid Dynamics for Games", Jos Stam, Game developer conference, 2003.--- Implementation by Ben Lambert-Smith.--- Converted to Repa 3 by Ben Lippmeier.----{-# LANGUAGE ScopedTypeVariables #-}-module Main (main)-where-import Solve.Density-import Solve.Velocity-import Model-import UserEvent-import Args-import Config--import Graphics.Gloss-import Graphics.Gloss.Interface.IO.Game-import System.Mem-import System.Environment (getArgs)-import Data.Array.Repa.IO.Timing as R-import Prelude as P---main :: IO ()-main - = do -- Parse the command-line arguments.- args <- getArgs- config <- parseArgs args configDefault-- -- Setup the initial fluid model.- let model = initModel- (configInitialDensity config)- (configInitialVelocity config)-- performGC- case configBatchMode config of- False -> runInteractive config model- True - -> do (_, elapsed) <- time $ do result <- runBatchMode config model- result `seq` return ()- putStrLn $ show $ wallTime milliseconds elapsed----- | Run the simulation interactively.-runInteractive :: Config -> Model -> IO ()-runInteractive config model0- = let (scaleX, scaleY) = configScale config- in playIO (InWindow "Stam's stable fluid. Use left-click right-drag to add density / velocity." - (configWindowSize config) - (20, 20))- black- (configRate config)- model0- (pictureOfModel (fromIntegral scaleX, fromIntegral scaleY))- (\event model -> return $ userEvent config event model)- (\_ -> stepFluid config)----- | Run in batch mode and dump a .bmp of the final state.-runBatchMode :: Config -> Model -> IO ()-runBatchMode config model- | stepsPassed model >= configMaxSteps config- = return ()-- | otherwise - = do model' <- stepFluid config model-- case configFramesMode config of- Nothing -> return ()- Just path- -> do putStrLn $ "frame " ++ show (stepsPassed model) - outputBMP path (stepsPassed model) (densityField model)-- runBatchMode config model'----- Function to step simulator one step forward in time-stepFluid :: Config -> Model -> IO Model-stepFluid config m@(Model df ds vf vs cl step dv cb)- | step >= configMaxSteps config- , configMaxSteps config > 0 - = return m-- | otherwise - = do performGC- vf' <- velocitySteps config step vf vs- df' <- densitySteps config step df ds vf'- return $ Model df' Nothing vf' Nothing cl (step + 1) dv cb-
− raster/Fluid/src-repa/Model.hs
@@ -1,209 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}-module Model- ( Delta- , Rate- , Field- , DensityField- , VelocityField- , SourceDensity (..)- , CurrentButton (..)-- , Model (..)- , initModel-- , pictureOfModel- , pixel32OfDensity- , pixel8OfDensity-- , outputBMP- , outputPPM)-where-import Data.Array.Repa as R-import Data.Array.Repa.IO.BMP as R-import Data.Array.Repa.Repr.ForeignPtr as R-import Data.Bits-import Data.Word-import Unsafe.Coerce-import Prelude as P-import qualified Graphics.Gloss as G----- | Time delta (seconds)-type Delta = Float---- | Time rate (or period) (1/seconds)-type Rate = Float----- | A 2d field.-type Field a - = Array U DIM2 a---- | Scalar density field.-type DensityField - = Field Float---- | Vector velocity field.-type VelocityField - = Field (Float, Float)----- | Button being pressed by the user.-data CurrentButton - = LeftButton- | RightButton- | None---- | A density source added by the user.-data SourceDensity a- = SourceDensity DIM2 a----- Model ------------------------------------------------------------------------- | The world model.-data Model- = Model- { densityField :: DensityField- , densitySource :: Maybe (SourceDensity Float)- , velocityField :: VelocityField- , velocitySource :: Maybe (SourceDensity (Float, Float))- , clickLoc :: Maybe (Int, Int)- , stepsPassed :: Int- , currButton :: CurrentButton- , drawVelocity :: Bool- }----- | Creates an initial blank model-initModel - :: Array U DIM2 Float- -> Array U DIM2 (Float, Float)- -> Model--initModel density velocity- | extent density /= extent velocity- = error "Fluid: initModel density and velocity extents do not match"-- | otherwise- = Model- { densityField = density- , densitySource = Nothing- , velocityField = velocity- , velocitySource = Nothing- , clickLoc = Nothing- , stepsPassed = 0- , currButton = None- , drawVelocity = False }-{-# INLINE initModel #-}----- Picture ----------------------------------------------------------------------- | Function to convert the Model into a Bitmap for displaying in Gloss-pictureOfModel :: Monad m => (Float, Float) -> Model -> m G.Picture-pictureOfModel (scaleX, scaleY) m - = let (Z :. height' :. width') = R.extent $ densityField m- width = fromIntegral width'- height = fromIntegral height'-- in do- (arrDensity :: Array F DIM2 Word32)- <- computeP $ R.map pixel32OfDensity $ densityField m-- let picVel :: G.Picture- picVel - | drawVelocity m- = G.Translate (- width / 2) (- height / 2)- $ G.Color (G.light $ G.light G.red)- $ G.Pictures- [ G.Line [(xf, yf), (xf + vx', yf + vy')]- | x <- [0, 5 .. width' - 1]- , y <- [0, 5 .. height' - 1]- , let xf = fromIntegral x- , let yf = fromIntegral y - , let (vx0, vy0) = velocityField m R.! (Z :. y :. x) - , let vx' = vx0 * 100- , let vy' = vy0 * 100 ]-- | otherwise- = G.blank-- let picDens :: G.Picture- picDens = G.bitmapOfForeignPtr width' height'- (G.BitmapFormat G.BottomToTop G.PxABGR)- (R.toForeignPtr $ unsafeCoerce arrDensity)- False-- return $ G.Scale scaleX scaleY- $ G.pictures [picDens, picVel ]--{-# NOINLINE pictureOfModel #-}----- | Converts Float value to Word32 for pixel data-pixel32OfDensity :: Float -> Word32-pixel32OfDensity f- = let !fsat- | f < 0 = 0- | f >= 1 = 1- | otherwise = f-- !x = truncate $ fsat * 255- !a = 255-- in unsafeShiftL x 24 .|. unsafeShiftL x 16 - .|. unsafeShiftL x 8 .|. a-{-# INLINE pixel32OfDensity #-}----- | Converts Float value to a tuple of pixel components.-pixel8OfDensity :: Float -> (Word8, Word8, Word8)-pixel8OfDensity f- = let !fsat- | f < 0 = 0- | f >= 1 = 1- | otherwise = f-- !x = truncate $ fsat * 255- in (x, x, x)-{-# INLINE pixel8OfDensity #-}----- Dump -------------------------------------------------------------------------- Writes bitmap data to test batch-mode ran correctly-outputBMP :: FilePath -> Int -> DensityField -> IO ()-outputBMP path step df - = do arr <- computeUnboxedP $ R.map pixel8OfDensity df- let step' = replicate (6 - length (show step)) '0' P.++ show step- R.writeImageToBMP (path P.++ step' P.++ ".bmp") arr---outputPPM :: Int -> String -> Float -> Array U DIM2 Float -> IO ()-outputPPM step name scale df- = do let (Z :. h :. w) = extent df- let step' - = replicate (4 - length (show step)) '0' P.++ show step-- let getVal x y- = let v = df R.! (Z :. y :. x)- in truncate (v * 255 * scale) :: Int-- let showVal x y- = let v = getVal x y- in replicate (4 - length (show v)) ' ' P.++ show v-- let mx- = maximum [getVal x y | x <- [0..w-1], y <- [0..h-1]]-- let out = unlines $ - [ "P2"- , show h P.++ " " P.++ show w- , show mx]- P.++ [ concat [ showVal x y P.++ " "- | x <- [0..w - 1]]- | y <- [h - 1, h - 2 .. 0]]-- writeFile ("out/" P.++ step' P.++ "-" P.++ name P.++ ".ppm") out----
− raster/Fluid/src-repa/Solve/Density.hs
@@ -1,40 +0,0 @@--module Solve.Density- (densitySteps)-where-import Stage.Diffusion-import Stage.Advection-import Stage.Sources-import Config-import Model---- | Run the stages for processing the density field in one time step-densitySteps - :: Config- -> Int- -> DensityField - -> Maybe (SourceDensity Float) - -> VelocityField - -> IO DensityField--densitySteps config step df ds vf - = {-# SCC "Solve.densitySteps" #-}- do df1 <- addSources (configDelta config) (configDensity config) - ds df-- let diff = if configDiffAfter config /= 0- && step >= configDiffAfter config - then 0.0005- else configDiff config-- let diffSolver- = if configUnstable config- then DiffUnstable- else DiffStable (configIters config)-- df2 <- diffusion diffSolver (configDelta config) diff- df1-- df' <- advection (configDelta config) vf df2-- return df'
− raster/Fluid/src-repa/Solve/Velocity.hs
@@ -1,42 +0,0 @@--module Solve.Velocity- (velocitySteps)-where-import Stage.Diffusion-import Stage.Advection-import Stage.Sources-import Stage.Project-import Model-import Config---- The pass that sets boundary conditions is buggy and --- currently disabled.--- import Stage.Boundary-velocitySteps - :: Config- -> Int- -> VelocityField - -> Maybe (SourceDensity (Float, Float)) - -> IO VelocityField--velocitySteps config _step vf vs - = {-# SCC "Solve.velocitySteps" #-}- do - vf1 <- addSources (configDelta config) (configVelocity config) - vs vf-- let diffSolver = DiffStable (configIters config)- vf2 <- diffusion diffSolver (configDelta config) (configVisc config) - vf1 --- vf3 <- setBoundary vf2-- vf4 <- project (configIters config) vf2--- vf5 <- setBoundary vf4-- vf6 <- advection (configDelta config) vf4 vf4--- vf7 <- setBoundary vf6-- vf8 <- project (configIters config) vf6--- vf' <- setBoundary vf8-- return vf8
− raster/Fluid/src-repa/Stage/Advection.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-module Stage.Advection- (advection)-where-import Model-import FieldElt-import Data.Array.Repa as R-import Data.Array.Repa.Unsafe as R-import Data.Vector.Unboxed (Unbox)----- | Apply a velocity field to another field.--- Both fields must have the same extent.-advection - :: (FieldElt a, Unbox a)- => Delta- -> VelocityField - -> Field a - -> IO (Field a)--advection !delta velField field- = {-# SCC "advection" #-} - velField `deepSeqArray` field `deepSeqArray`- do computeP $ unsafeTraverse field id (advectElem delta velField)--{-# SPECIALIZE advection - :: Delta- -> VelocityField -> Field Float- -> IO (Field Float) #-}--{-# SPECIALIZE advection - :: Delta- -> VelocityField -> Field (Float, Float)- -> IO (Field (Float, Float)) #-}----- | Compute the new field value at the given location.-advectElem - :: (FieldElt a)- => Delta -- ^ Time delta (in seconds)- -> VelocityField -- ^ Velocity field that moves the source field.- -> (DIM2 -> a) -- ^ Get an element from the source field.- -> DIM2 -- ^ Compute the new value at this index.- -> a--advectElem !delta !velField !get !pos@(Z:. j :. i)- = velField `deepSeqArray`- (((d00 ~*~ t0) ~+~ (d01 ~*~ t1)) ~*~ s0) - ~+~ (((d10 ~*~ t0) ~+~ (d11 ~*~ t1)) ~*~ s1)- where- _ :. height' :. width' = R.extent velField- !width = fromIntegral width'- !height = fromIntegral height'-- -- helper values- !dt0 = delta * width- !(u, v) = velField `unsafeIndex` pos-- -- backtrack densities to point based on velocity field- -- and make sure they are in field- !x = fromIntegral i - dt0 * u- !y = fromIntegral j - dt0 * v-- !x' | x < -0.5 = -0.5- | x > width + 0.5 = width + 0.5- | otherwise = x-- !y' | y < -0.5 = -0.5- | y > height + 0.5 = height + 0.5- | otherwise = y-- -- calculate discrete locations surrounding point- !i0 = truncate (x' + 1) - 1- !i1 = i0 + 1-- !j0 = truncate (y' + 1) - 1- !j1 = j0 + 1-- -- calculate ratio point is between the discrete locations- !s1 = x' - fromIntegral i0- !s0 = 1 - s1-- !t1 = y' - fromIntegral j0- !t0 = 1 - t1-- get' ix@(Z :. jj :. ii)- | ii < 0 = zero- | ii >= width' = zero- | jj < 0 = zero- | jj >= height' = zero- | otherwise = get ix-- -- grab values from grid surrounding advected point- !d00 = get' (Z:. j0 :. i0)- !d01 = get' (Z:. j1 :. i0)- !d10 = get' (Z:. j0 :. i1)- !d11 = get' (Z:. j1 :. i1)---{-# SPECIALIZE advectElem- :: Delta - -> VelocityField -> (DIM2 -> Float) - -> DIM2 -> Float #-}--{-# SPECIALIZE advectElem - :: Delta- -> VelocityField -> (DIM2 -> (Float,Float))- -> DIM2 -> (Float,Float) #-}--{---- | Wrap an index back into the simulation area if it is outside.-checkLocation :: Float -> Float -> Float-checkLocation !width !x- | x < 0.5 = 0.5- | x > width - 1.5 = width - 1.5- | otherwise = x-{-# INLINE checkLocation #-}--}
− raster/Fluid/src-repa/Stage/Boundary.hs
@@ -1,115 +0,0 @@--{-# LANGUAGE BangPatterns #-}-module Stage.Boundary- (setBoundary)-where-import Model-import Data.Array.Repa as R-import Control.Monad-import Debug.Trace-import Config-import FieldElt---- | Apply boundary conditions to a velocity field.-setBoundary :: Config -> VelocityField -> IO VelocityField-setBoundary config f- = let (width, _) = configModelSize config- in (rebuild width f <=< setBoundary' width <=< grabBorders width) f ----- | Takes the original VelocityField and the array of edges and replaces--- edge values with new values-rebuild :: Int -> VelocityField -> VelocityField -> IO VelocityField-rebuild width field edges- = field `deepSeqArray` edges `deepSeqArray` - do computeUnboxedP $ backpermuteDft field (rebuildPosMap width) edges-{-# INLINE rebuild #-}---rebuildPosMap :: Int -> DIM2 -> Maybe DIM2-rebuildPosMap !width (Z:.j:.i)- | j == 0 - = Just (Z:.0:.i)-- | j == width - 1 - = Just (Z:.1:.i)-- | i == 0 - = if j == 0 then Just (Z:. 0 :. 0)- else if j == end then Just (Z:. 1 :. 0)- else Just (Z:. 2 :. j)-- | i == width - 1 - = if j == 0 then Just (Z:. 0 :. (width-1))- else if j == end then Just (Z:. 1 :. (width-1))- else Just (Z:. 3 :. j)-- | otherwise = Nothing- where end = width - 1-{-# INLINE rebuildPosMap #-}------ | Grabs the border elements of the VelocityField and outputs them as--- one array, for ease of adding back into the original VelocityField later-grabBorders :: Int -> VelocityField -> IO VelocityField-grabBorders width f- = f `deepSeqArray` - do traceEventIO "Fluid: grabBorders"- computeUnboxedP $ backpermute (Z:. 4 :. width) (edgeCases width) f-{-# INLINE grabBorders #-}----- | Map a position in the edges array to what they were in the original--- array.-edgeCases :: Int -> DIM2 -> DIM2-edgeCases width (Z:.j:.i)- | j == 0 = (Z:.0 :.i)- | j == 1 = (Z:.(width-1) :.i)- | j == 2 = (Z:.i :.0)- | j == 3 = (Z:.i :.(width-1))- | otherwise = error "Incorrect coordinate given in setBoundary"-{-# INLINE edgeCases #-}----setBoundary' :: Int -> VelocityField -> IO VelocityField-setBoundary' width e- = e `deepSeqArray` - do traceEventIO "Fluid: setBoundary'"- computeUnboxedP $ traverse e id (revBoundary width)-{-# INLINE setBoundary' #-}----- | Based on position in edges array set the velocity accordingly-revBoundary :: Int -> (DIM2 -> (Float,Float)) -> DIM2 -> (Float,Float)-revBoundary width loc pos@(Z:.j:.i)- | j == 0 - = if i == 0 then grabCornerCase loc (Z:.2:.1) (Z:.0:.1)- else if i == end then grabCornerCase loc (Z:.0:.(width-2)) (Z:.3:.1)- else (-p1,p2)- | j == 1 - = if i == 0 then grabCornerCase loc (Z:.2:.(width-2)) (Z:.1:.1)- else if i == end then grabCornerCase loc (Z:.1:.(width-2)) (Z:.3:.(width-2))- else (-p1,p2)-- | j == 2 = (p1,-p2)- | j == 3 = (p1,-p2)-- | otherwise = error "Fluid: revBoundary"- where (p1,p2) = loc pos- end = width - 1---{-# INLINE revBoundary #-}---- | Corner cases are special and are calculated with this function-grabCornerCase :: (DIM2 -> (Float, Float)) -> DIM2 -> DIM2 -> (Float, Float)-grabCornerCase loc pos1 pos2- = (p1 * q1, p2 * q2) ~*~ 0.5- where (p1,p2) = loc pos1- (q1,q2) = loc pos2-{-# INLINE grabCornerCase #-}---
− raster/Fluid/src-repa/Stage/Diffusion.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Stage.Diffusion- ( DiffSolver (..)- , diffusion)-where-import Model-import FieldElt-import Stage.Linear-import Data.Array.Repa as R-import Data.Array.Repa.Eval as R-import Data.Vector.Unboxed---data DiffSolver- = DiffStable Int- | DiffUnstable----- | Diffuse a field at a certain rate.-diffusion - :: (FieldElt a, Num a, Elt a, Unbox a) - => DiffSolver- -> Delta - -> Rate- -> Field a - -> IO (Field a)-diffusion !solver !delta !rate field - = {-# SCC diffusion #-}- field `deepSeqArray` - let _ :. _ :. width' = R.extent field- !width = fromIntegral width'- in case solver of- DiffUnstable- -> let !a = delta * rate * width * width- in unstableSolver field field a-- DiffStable iters- -> let !a = delta * rate * width * width- !c = 1 + 4 * a- in linearSolver field field a c iters--{-# SPECIALIZE diffusion - :: DiffSolver -> Delta -> Rate- -> Field Float - -> IO (Field Float) #-}--{-# SPECIALIZE diffusion - :: DiffSolver -> Delta -> Rate- -> Field (Float, Float) - -> IO (Field (Float, Float)) #-}
− raster/Fluid/src-repa/Stage/Linear.hs
@@ -1,148 +0,0 @@-{-# LANGUAGE FlexibleContexts, BangPatterns #-}-module Stage.Linear- ( linearSolver- , unstableSolver)-where-import Model-import FieldElt as E-import Data.Array.Repa as R-import Data.Array.Repa.Stencil as R-import Data.Array.Repa.Stencil.Dim2 as R-import Data.Array.Repa.Eval as R-import Data.Vector.Unboxed-import Prelude as P-----------------------------------------------------------------------------------linearSolver - :: (FieldElt a, Source U a, Unbox a, Elt a, Num a)- => Field a -- ^ Original field.- -> Field a -- ^ Current field.- -> Float- -> Float- -> Int -- ^ Number of iterations to apply.- -> IO (Field a)--linearSolver origField curField !a !c !iters- -- If nothing would change by running the solver, then skip it.- | 0 <- a = return origField-- -- The solver has finished its loop- | 0 <- iters = return curField-- -- Do one iteration- | otherwise- = origField `deepSeqArray` curField `deepSeqArray`- do let !c' = 1/c- let {-# INLINE zipFunc #-}- zipFunc !orig !new- = (orig ~+~ (new ~*~ a)) ~*~ c'-- newField <- {-# SCC "linearSolver.mapStencil" #-}- computeUnboxedP - $ R.szipWith zipFunc origField- $ mapStencil2 (BoundConst 0) linearSolverStencil curField-- -- TODO: this boundConst thing is costing a fair bit.- -- Do something about the branches introduced into the core code.-- linearSolver origField newField a c (iters - 1)--{-# SPECIALIZE linearSolver - :: Field Float- -> Field Float - -> Float -> Float -> Int - -> IO (Field Float) #-}--{-# SPECIALIZE linearSolver - :: Field (Float, Float) - -> Field (Float, Float) - -> Float -> Float -> Int - -> IO (Field (Float, Float)) #-}------ | Stencil function for the linear solver.-linearSolverStencil - :: FieldElt a- => Stencil DIM2 a--linearSolverStencil- = StencilStatic (Z:.3:.3) E.zero- (\ix val acc ->- case linearSolverCoeffs ix of- Nothing -> acc- Just coeff -> acc ~+~ (val ~*~ coeff))-{-# INLINE linearSolverStencil #-}- ---- | Linear solver stencil kernel.-linearSolverCoeffs :: DIM2 -> Maybe Float-linearSolverCoeffs (Z:.j:.i)- | i == 1, j == 0 = Just 1- | i == -1, j == 0 = Just 1- | i == 0, j == 1 = Just 1- | i == 0, j == -1 = Just 1- | otherwise = Nothing-{-# INLINE linearSolverCoeffs #-}----- Unstable --------------------------------------------------------------------unstableSolver - :: (FieldElt a, Source U a, Unbox a, Elt a, Num a)- => Field a -- ^ Original field.- -> Field a -- ^ Current field.- -> Float- -> IO (Field a)--unstableSolver !origField !curField !a- = origField `deepSeqArray` curField `deepSeqArray` - do - let {-# INLINE zipFunc #-}- zipFunc !orig !new- = orig ~+~ (new ~*~ a)-- newField - <- computeUnboxedP- $ R.szipWith zipFunc origField- $ mapStencil2 (BoundConst 0) unstableSolverStencil curField-- return newField---{-# SPECIALIZE unstableSolver - :: Field Float- -> Field Float - -> Float- -> IO (Field Float) #-}--{-# SPECIALIZE unstableSolver - :: Field (Float, Float) - -> Field (Float, Float) - -> Float- -> IO (Field (Float, Float)) #-}---unstableSolverStencil- :: FieldElt a- => Stencil DIM2 a--unstableSolverStencil- = StencilStatic (Z:.3:.3) E.zero- (\ix val acc ->- case unstableSolverCoeffs ix of- Nothing -> acc- Just coeff -> acc ~+~ (val ~*~ coeff))-{-# INLINE unstableSolverStencil #-}---unstableSolverCoeffs :: DIM2 -> Maybe Float-unstableSolverCoeffs (Z:.j:.i)- | i == 1, j == 0 = Just 1- | i == -1, j == 0 = Just 1- | i == 0, j == 1 = Just 1- | i == 0, j == -1 = Just 1- | i == 0, j == 0 = Just (-4)- | otherwise = Nothing-{-# INLINE unstableSolverCoeffs #-}-
− raster/Fluid/src-repa/Stage/Project.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Stage.Project- (project)-where-import Model-import FieldElt-import Stage.Linear-import Data.Array.Repa as R-import Data.Array.Repa.Unsafe as R-import Prelude as P---project :: Int -> Field (Float, Float) -> IO (Field (Float, Float))-project iters field- = {-# SCC project #-}- field `deepSeqArray` - do let _ :. height :. width = extent field-- divergence <- {-# SCC "project.genDiv" #-}- computeUnboxedP - $ fromFunction (Z:. height :. width) (genDivergence width height field)-- p <- {-# SCC "project.linearSolver" #-}- linearSolver divergence divergence 1 4 iters-- f' <- {-# SCC "project.apply" #-}- computeUnboxedP - $ unsafeTraverse field id (projectElem width height p)-- return f'-{-# NOINLINE project #-}----- | Subtract a gradient field from the regular field to --- create a mass-conserving field.-projectElem- :: Int -- ^ Width of model.- -> Int -- ^ Height of model.- -> Field Float- -> (DIM2 -> (Float, Float)) -- ^ Get data from the regular field.- -> DIM2 -- ^ Compute the value at this point.- -> (Float, Float)--projectElem !width !height !p !get !pos@(Z:.j:.i)- = get pos ~-~ (0.5 * width' * (p0 - p1),- 0.5 * height' * (p2 - p3))- where- !width' = fromIntegral width- !height' = fromIntegral height- !p0 = useIf (i < width - 1) (p `unsafeIndex` (Z :. j :. i+1))- !p1 = useIf (i > 0) (p `unsafeIndex` (Z :. j :. i-1))- !p2 = useIf (j < height - 1) (p `unsafeIndex` (Z :. j+1 :. i ))- !p3 = useIf (j > 0) (p `unsafeIndex` (Z :. j-1 :. i ))-{-# INLINE projectElem #-}----- | Get an approximation of the gradient at this point.-genDivergence :: Int -> Int -> VelocityField -> DIM2 -> Float-genDivergence !width !height !f (Z :. j :. i)- = (-0.5 * ((u0 - u1) + (v0 - v1))) / fromIntegral width- where- (u0, _) = useIf (i < width - 1) (f `unsafeIndex` (Z:. j :. i+1))- (u1, _) = useIf (i > 0) (f `unsafeIndex` (Z:. j :. i-1))- ( _, v0) = useIf (j < height - 1) (f `unsafeIndex` (Z:. j+1 :. i ))- ( _, v1) = useIf (j > 0) (f `unsafeIndex` (Z:. j-1 :. i ))-{-# INLINE genDivergence #-}--
− raster/Fluid/src-repa/Stage/Sources.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleInstances #-}-module Stage.Sources- (addSources)-where-import Model-import FieldElt-import Data.Array.Repa as R-import Data.Array.Repa.Unsafe as R-import Data.Vector.Unboxed (Unbox)----- | Addition of forces stage for simulation-addSources - :: (FieldSource a, Unbox a)- => Delta -- ^ Time delta.- -> a -- ^ Value to insert.- -> Maybe (SourceDensity a) - -> Field a - -> IO (Field a)--addSources !delta !value (Just (SourceDensity aim mul)) field- = {-# SCC addSources #-}- field `deepSeqArray` - do computeP $ unsafeTraverse field id (insertSource delta value aim mul)--addSources _ _ Nothing field- = return field---insertSource - :: (FieldSource a) - => Delta- -> a -- ^ Value to insert- -> DIM2 -> a - -> (DIM2 -> a) - -> DIM2 - -> a--insertSource !delta !value !aim !mul locate !pos- | aim == pos = addSource delta value (locate pos) mul- | otherwise = locate pos-{-# INLINE insertSource #-}---{-# SPECIALIZE addSources - :: Delta - -> Float- -> Maybe (SourceDensity Float)- -> Field Float - -> IO (Field Float) #-}--{-# SPECIALIZE addSources - :: Delta- -> (Float, Float)- -> Maybe (SourceDensity (Float, Float))- -> Field (Float, Float) - -> IO (Field (Float, Float)) #-}----- FieldSource -----------------------------------------------------------------class FieldSource a where- addSource :: Delta -> a -> a -> a -> a--instance FieldSource Float where- addSource !delta !value !a !mul - = a ~+~ (value * delta * mul)- {-# INLINE addSource #-}--instance FieldSource (Float, Float) where- addSource !delta (newA, newB) (a,b) (mulA, mulB)- = ( a + (newA * delta * (-mulA))- , b + (newB * delta * (-mulB)))- {-# INLINE addSource #-}----
− raster/Fluid/src-repa/UserEvent.hs
@@ -1,101 +0,0 @@-module UserEvent- (userEvent)-where-import Config-import Model as M-import Data.Array.Repa as R-import Graphics.Gloss.Interface.Pure.Game as G----- | Handle user events for the Gloss `playIO` wrapper.-userEvent :: Config -> Event -> Model -> Model-userEvent config- (EventKey key keyState mods (x, y)) - model-- -- Add velocity ---------------------------------------------- | MouseButton G.RightButton <- key- , Down <- keyState- , (x',y') <- windowToModel config (x,y)- = model { clickLoc = Just (x',y')- , currButton = M.RightButton }-- -- Accept shift-leftbutton for people with trackpads- | MouseButton G.LeftButton <- key- , Down <- keyState- , Down <- shift mods- , (x',y') <- windowToModel config (x,y)- = model { clickLoc = Just (x',y')- , currButton = M.RightButton }-- | MouseButton G.RightButton <- key- , Up <- keyState- , Just (locX, locY) <- clickLoc model- , (x',y') <- windowToModel config (x,y)- = model { velocitySource = Just (SourceDensity (Z:.locY:.locX)- (fromIntegral (locX-x'),fromIntegral (locY-y')))- , clickLoc = Nothing- , currButton = M.None }-- -- Add density ----------------------------------------------- | MouseButton G.LeftButton <- key- , Down <- keyState- , (x',y') <- windowToModel config (x, y) - = model { densitySource = Just (SourceDensity (Z:.y':.x') 1)- , currButton = M.LeftButton }-- | MouseButton G.LeftButton <- key- , Up <- keyState- = model { currButton = M.None }-- -- Reset model - | Char 'r' <- key- , Down <- keyState- = initModel (configInitialDensity config)- (configInitialVelocity config)-- -- Toggle velocity display- | Char 'v' <- key- , Down <- keyState- = model { drawVelocity = not $ drawVelocity model }-- -- Quit program - | Char 'q' <- key- , Down <- keyState- = error "Quitting"---userEvent config (EventMotion (x, y)) model- | M.LeftButton <- currButton model- , (x',y') <- windowToModel config (x, y) - = model { densitySource = Just (SourceDensity (Z:.y':.x') 1)- , currButton = M.LeftButton- }--userEvent config (EventMotion (x, y)) model- | (x', y') <- windowToModel config (x,y)- , Just (clx, cly) <- clickLoc model- , M.RightButton <- currButton model- = model { velocitySource = Just (SourceDensity (Z:.y':.x')- (fromIntegral (clx-x'), fromIntegral (cly-y')))- , clickLoc = Just (x',y')- , currButton = M.RightButton- }--userEvent _ _ m = m---- Converts a window location to the corresponding location in the--- simulation.-windowToModel :: Config -> (Float, Float) -> (Int, Int)-windowToModel config (x, y) = (x', y')- where (scaleX, scaleY) = configScale config- (windowWidth, windowHeight) = configWindowSize config-- x' = round ((x + (fromIntegral windowWidth / 2)) / fromIntegral scaleX)- y' = round ((y + (fromIntegral windowHeight / 2)) / fromIntegral scaleY)------