diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -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 diff --git a/picture/Render/Main.hs b/picture/Render/Main.hs deleted file mode 100644 --- a/picture/Render/Main.hs +++ /dev/null @@ -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 diff --git a/raster/Fluid/src-repa/Args.hs b/raster/Fluid/src-repa/Args.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Args.hs +++ /dev/null @@ -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 Dump all frames to .bmp files (implies -batch)" - , " -max Quit after this number of steps." - , " -size Size of simulation. (100)" - , " -unstable Use the unstable linear solver (False)" - , " -iters Iterations for the linear solver. (40)" - , " -scale Width of a cell in the window. (5)" - , " -rate Frame rate. (30)" - , " -delta Length of time step. (0.1)" - , " -diff Diffusion rate for the density. (0)" - , " -diff-after Trigger diffusion after this step. (0)" - , " -visc Diffusion rate for the velocity. (0)" - , " -user-dens Magnitude of user inserted density. (100)" - , " -user-velo Magnitude of user inserted velocity. (20)" - , " -bmp-dens File for initial fluid density." - , " -bmp-velo 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] ] - diff --git a/raster/Fluid/src-repa/Config.hs b/raster/Fluid/src-repa/Config.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Config.hs +++ /dev/null @@ -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) - diff --git a/raster/Fluid/src-repa/FieldElt.hs b/raster/Fluid/src-repa/FieldElt.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/FieldElt.hs +++ /dev/null @@ -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 #-} - diff --git a/raster/Fluid/src-repa/Main.hs b/raster/Fluid/src-repa/Main.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Main.hs +++ /dev/null @@ -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 - diff --git a/raster/Fluid/src-repa/Model.hs b/raster/Fluid/src-repa/Model.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Model.hs +++ /dev/null @@ -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 - - - - diff --git a/raster/Fluid/src-repa/Solve/Density.hs b/raster/Fluid/src-repa/Solve/Density.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Solve/Density.hs +++ /dev/null @@ -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' diff --git a/raster/Fluid/src-repa/Solve/Velocity.hs b/raster/Fluid/src-repa/Solve/Velocity.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Solve/Velocity.hs +++ /dev/null @@ -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 diff --git a/raster/Fluid/src-repa/Stage/Advection.hs b/raster/Fluid/src-repa/Stage/Advection.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Advection.hs +++ /dev/null @@ -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 #-} --} diff --git a/raster/Fluid/src-repa/Stage/Boundary.hs b/raster/Fluid/src-repa/Stage/Boundary.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Boundary.hs +++ /dev/null @@ -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 #-} - - - diff --git a/raster/Fluid/src-repa/Stage/Diffusion.hs b/raster/Fluid/src-repa/Stage/Diffusion.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Diffusion.hs +++ /dev/null @@ -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)) #-} diff --git a/raster/Fluid/src-repa/Stage/Linear.hs b/raster/Fluid/src-repa/Stage/Linear.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Linear.hs +++ /dev/null @@ -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 #-} - diff --git a/raster/Fluid/src-repa/Stage/Project.hs b/raster/Fluid/src-repa/Stage/Project.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Project.hs +++ /dev/null @@ -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 #-} - - diff --git a/raster/Fluid/src-repa/Stage/Sources.hs b/raster/Fluid/src-repa/Stage/Sources.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/Stage/Sources.hs +++ /dev/null @@ -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 #-} - - - - diff --git a/raster/Fluid/src-repa/UserEvent.hs b/raster/Fluid/src-repa/UserEvent.hs deleted file mode 100644 --- a/raster/Fluid/src-repa/UserEvent.hs +++ /dev/null @@ -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) - - - - - -