diff --git a/dph-examples.cabal b/dph-examples.cabal --- a/dph-examples.cabal +++ b/dph-examples.cabal @@ -2,7 +2,7 @@ Name: dph-examples -Version: 0.5.1.1 +Version: 0.5.1.2 License: BSD3 License-file: LICENSE Author: The DPH Team @@ -11,13 +11,13 @@ Cabal-Version: >=1.8 Stability: experimental Category: Data Structures -Homepage: http://www.cse.unsw.edu.au/~chak/project/dph/ -Description: Examples using the DPH library. -Synopsis: Examples using the DPH library. +Homepage: http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell +Description: Examples using Data Parallel Haskell +Synopsis: Examples using Data Parallel Haskell -Flag gloss - Description: Enable graphical front ends that use the gloss library. - Default: False +-- Flag gloss +-- Description: Enable graphical front ends that use the gloss library. +-- Default: False -- With these examples, -- the plain dph-NAME versions are parallel versions built against dph-par @@ -206,26 +206,32 @@ -- NBody ---------------------------------------------------------------------- -Executable dph-nbody - Main-is: Main.hs - other-modules: Common.Dump Common.World Common.Body Common.Util - Solver Solver.ListBH.Solver - Solver.NestedBH.Solver - Solver.VectorBH.Solver - Solver.VectorNaive.Solver - Timing Points2D.Types Points2D.Generate - - if flag(gloss) - other-modules: Gloss.MainArgs Gloss.Draw Gloss.Config +Executable dph-nbody-gloss + Main-is: MainGloss.hs + other-modules: Common.Dump Common.World Common.Body Common.Util + Solver Solver.ListBH.Solver + Solver.NestedBH.Solver + Solver.VectorBH.Solver + Solver.VectorNaive.Solver + Timing Points2D.Types Points2D.Generate + Gloss.MainArgs Gloss.Draw Gloss.Config Build-depends: base == 4.4.*, vector == 0.7.*, dph-base == 0.5.*, dph-prim-par == 0.5.*, dph-par == 0.5.*, random == 1.0.*, old-time == 1.0.*, parseargs == 0.1.*, gloss == 1.3.* hs-source-dirs: lib real/NBody real/NBody/Gloss ghc-options: -rtsopts -threaded -fllvm -Odph -fdph-par -fcpr-off -fsimplifier-phases=4 -fstrictness-before=3 -fno-liberate-case - else - other-modules: Batch.MainArgs Batch.Config + + +Executable dph-nbody-batch + Main-is: MainBatch.hs + other-modules: Common.Dump Common.World Common.Body Common.Util + Solver Solver.ListBH.Solver + Solver.NestedBH.Solver + Solver.VectorBH.Solver + Solver.VectorNaive.Solver + Timing Points2D.Types Points2D.Generate + Batch.MainArgs Batch.Config Build-depends: base == 4.4.*, vector == 0.7.*, dph-base == 0.5.*, dph-prim-par == 0.5.*, dph-par == 0.5.*, random == 1.0.*, old-time == 1.0.*, parseargs == 0.1.* hs-source-dirs: lib real/NBody real/NBody/Batch ghc-options: -rtsopts -threaded -fllvm -Odph -fdph-par -fcpr-off -fsimplifier-phases=4 -fstrictness-before=3 -fno-liberate-case - endif -- Executable dph-nbody-seq -- Main-is: Main.hs diff --git a/real/NBody/Gloss/Main.hs b/real/NBody/Gloss/Main.hs deleted file mode 100644 --- a/real/NBody/Gloss/Main.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE ParallelListComp, BangPatterns #-} - -import Gloss.MainArgs -import Gloss.Draw -import Gloss.Config - -import Common.Dump -import Common.World -import Common.Body -import Common.Util - -import Solver -import Timing -import Points2D.Generate - -import Graphics.Gloss -import Graphics.Gloss.Interface.Simulate - -import System.Environment -import System.Console.ParseArgs -import System.IO.Unsafe -import Control.Monad -import Data.Maybe -import qualified Data.Vector.Unboxed as V - - -main :: IO () -main - = do args <- parseArgsIO ArgsComplete mainArgs - - when (gotArg args ArgHelp) - $ usageError args "" - - mainWithArgs args - - -mainWithArgs :: Args MainArg -> IO () -mainWithArgs args - = let config = loadConfig args - - -- The solver we're using to calculate the acclerations. - solverName = configSolverName config - calcAccels = fromMaybe (error $ unlines - [ "unknown solver " ++ show solverName - , "choose one of " ++ (show $ map fst solvers) ]) - $ lookup solverName solvers - - -- Setup initial world - vPoints = genPointsDisc - (configBodyCount config) - (0, 0) - (configStartDiscSize config) - - vBodies = V.map (setStartVelOfBody $ configStartSpeed config) - $ V.map (setMassOfBody $ configBodyMass config) - $ V.map (uncurry unitBody) - $ vPoints - - worldStart = World - { worldBodies = vBodies - , worldSteps = 0 } - - in case configWindowSize config of - Just windowSize -> mainGloss config calcAccels worldStart windowSize - Nothing -> mainBatch config calcAccels worldStart - - --- | Run the simulation in a gloss window. -mainGloss - :: Config - -> Solver -- ^ Fn to calculate accels of each point. - -> World -- ^ Initial world. - -> Int -- ^ Size of window. - -> IO () - -mainGloss config calcAccels worldStart windowSize - = let draw = drawWorld (configShouldDrawTree config) - - advance _viewport time world - = let world' = advanceWorld - (calcAccels $ configEpsilon config) - (configTimeStep config) - world - - -- if we've done enough steps then bail out now. - in case configMaxSteps config of - Nothing -> world' - Just maxSteps - | worldSteps world' < maxSteps -> world' - - -- Gloss doesn't provide a clean way to end the animation... - | otherwise - -> unsafePerformIO (mainEnd (configDumpFinal config) world' >> (error $ "done")) - `seq` error "advanceWorld: we're finished, stop calling me." - - in simulateInWindow - "Barnes-Hut" -- window name - (windowSize, windowSize)-- window size - (10, 10) -- window position - black -- background color - (configRate config) -- number of iterations per second - worldStart -- initial world - draw -- fn to convert a world to a picture - advance -- fn to advance the world - - --- | Run the simulation in batch mode, not displaying anything to the screen. -mainBatch - :: Config - -> Solver -- ^ Fn to calculate accels of each point. - -> World -- ^ Initial world. - -> IO () - -mainBatch config calcAccels worldStart - = do - worldStart `seq` return () - - (world', tElapsed) - <- time - $ let world = mainBatchRun config calcAccels worldStart - in world `seq` return world - - putStr $ prettyTime tElapsed - mainEnd (configDumpFinal config) world' - - -mainBatchRun config calcAccels worldStart - = go worldStart - where go !world - = let world' = advanceWorld - (calcAccels $ configEpsilon config) - (configTimeStep config) - world - in case configMaxSteps config of - Nothing -> go world' - Just maxSteps - | worldSteps world' < maxSteps -> go world' - | otherwise -> world' - - --- | Called at end of run to dump final world state. -mainEnd - :: Maybe FilePath -- ^ Write final bodies to this file. - -> World -- ^ Final world state. - -> IO () - -mainEnd mDumpFinal world - = do -- Dump the final world state to file if requested. - maybe (return ()) (dumpWorld world) mDumpFinal - - diff --git a/real/NBody/MainBatch.hs b/real/NBody/MainBatch.hs new file mode 100644 --- /dev/null +++ b/real/NBody/MainBatch.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ParallelListComp, BangPatterns #-} + +import Batch.MainArgs +import Batch.Config +import Common.Dump +import Common.World +import Common.Body +import Common.Util +import Solver +import Timing +import Points2D.Generate +import System.Environment +import System.Console.ParseArgs +import System.IO.Unsafe +import Control.Monad +import Data.Maybe +import qualified Data.Vector.Unboxed as V + + +main :: IO () +main + = do args <- parseArgsIO ArgsComplete mainArgs + + when (gotArg args ArgHelp) + $ usageError args "" + + mainWithArgs args + + +mainWithArgs :: Args MainArg -> IO () +mainWithArgs args + = let config = loadConfig args + + -- The solver we're using to calculate the acclerations. + solverName = configSolverName config + calcAccels = fromMaybe (error $ unlines + [ "unknown solver " ++ show solverName + , "choose one of " ++ (show $ map fst solvers) ]) + $ lookup solverName solvers + + -- Setup initial world + vPoints = genPointsDisc + (configBodyCount config) + (0, 0) + (configStartDiscSize config) + + vBodies = V.map (setStartVelOfBody $ configStartSpeed config) + $ V.map (setMassOfBody $ configBodyMass config) + $ V.map (uncurry unitBody) + $ vPoints + + worldStart = World + { worldBodies = vBodies + , worldSteps = 0 } + + in mainBatch config calcAccels worldStart + + +-- | Run the simulation in batch mode. +mainBatch :: Config -> Solver -> World -> IO () +mainBatch config calcAccels worldStart + = do + worldStart `seq` return () + + (world', tElapsed) + <- time + $ let world = mainBatchRun config calcAccels worldStart + in world `seq` return world + + putStr $ prettyTime tElapsed + mainEnd (configDumpFinal config) world' + + +mainBatchRun config calcAccels worldStart + = go worldStart + where go !world + = let world' = advanceWorld + (calcAccels $ configEpsilon config) + (configTimeStep config) + world + + in if worldSteps world' < configMaxSteps config + then go world' + else world' + + +-- | Called at end of run to dump final world state. +mainEnd :: Maybe FilePath -- ^ Write final bodies to this file. + -> World -- ^ Final world state. + -> IO () + +mainEnd mDumpFinal world + = do -- Dump the final world state to file if requested. + maybe (return ()) (dumpWorld world) mDumpFinal + diff --git a/real/NBody/MainGloss.hs b/real/NBody/MainGloss.hs new file mode 100644 --- /dev/null +++ b/real/NBody/MainGloss.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE ParallelListComp, BangPatterns #-} + +import Gloss.MainArgs +import Gloss.Draw +import Gloss.Config + +import Common.Dump +import Common.World +import Common.Body +import Common.Util + +import Solver +import Timing +import Points2D.Generate + +import Graphics.Gloss +import Graphics.Gloss.Interface.Simulate + +import System.Environment +import System.Console.ParseArgs +import System.IO.Unsafe +import Control.Monad +import Data.Maybe +import qualified Data.Vector.Unboxed as V + + +main :: IO () +main + = do args <- parseArgsIO ArgsComplete mainArgs + + when (gotArg args ArgHelp) + $ usageError args "" + + mainWithArgs args + + +mainWithArgs :: Args MainArg -> IO () +mainWithArgs args + = let config = loadConfig args + + -- The solver we're using to calculate the acclerations. + solverName = configSolverName config + calcAccels = fromMaybe (error $ unlines + [ "unknown solver " ++ show solverName + , "choose one of " ++ (show $ map fst solvers) ]) + $ lookup solverName solvers + + -- Setup initial world + vPoints = genPointsDisc + (configBodyCount config) + (0, 0) + (configStartDiscSize config) + + vBodies = V.map (setStartVelOfBody $ configStartSpeed config) + $ V.map (setMassOfBody $ configBodyMass config) + $ V.map (uncurry unitBody) + $ vPoints + + worldStart = World + { worldBodies = vBodies + , worldSteps = 0 } + + in case configWindowSize config of + Just windowSize -> mainGloss config calcAccels worldStart windowSize + Nothing -> mainBatch config calcAccels worldStart + + +-- | Run the simulation in a gloss window. +mainGloss + :: Config + -> Solver -- ^ Fn to calculate accels of each point. + -> World -- ^ Initial world. + -> Int -- ^ Size of window. + -> IO () + +mainGloss config calcAccels worldStart windowSize + = let draw = drawWorld (configShouldDrawTree config) + + advance _viewport time world + = let world' = advanceWorld + (calcAccels $ configEpsilon config) + (configTimeStep config) + world + + -- if we've done enough steps then bail out now. + in case configMaxSteps config of + Nothing -> world' + Just maxSteps + | worldSteps world' < maxSteps -> world' + + -- Gloss doesn't provide a clean way to end the animation... + | otherwise + -> unsafePerformIO (mainEnd (configDumpFinal config) world' >> (error $ "done")) + `seq` error "advanceWorld: we're finished, stop calling me." + + in simulateInWindow + "Barnes-Hut" -- window name + (windowSize, windowSize)-- window size + (10, 10) -- window position + black -- background color + (configRate config) -- number of iterations per second + worldStart -- initial world + draw -- fn to convert a world to a picture + advance -- fn to advance the world + + +-- | Run the simulation in batch mode, not displaying anything to the screen. +mainBatch + :: Config + -> Solver -- ^ Fn to calculate accels of each point. + -> World -- ^ Initial world. + -> IO () + +mainBatch config calcAccels worldStart + = do + worldStart `seq` return () + + (world', tElapsed) + <- time + $ let world = mainBatchRun config calcAccels worldStart + in world `seq` return world + + putStr $ prettyTime tElapsed + mainEnd (configDumpFinal config) world' + + +mainBatchRun config calcAccels worldStart + = go worldStart + where go !world + = let world' = advanceWorld + (calcAccels $ configEpsilon config) + (configTimeStep config) + world + in case configMaxSteps config of + Nothing -> go world' + Just maxSteps + | worldSteps world' < maxSteps -> go world' + | otherwise -> world' + + +-- | Called at end of run to dump final world state. +mainEnd + :: Maybe FilePath -- ^ Write final bodies to this file. + -> World -- ^ Final world state. + -> IO () + +mainEnd mDumpFinal world + = do -- Dump the final world state to file if requested. + maybe (return ()) (dumpWorld world) mDumpFinal + +