diff --git a/dph-examples.cabal b/dph-examples.cabal --- a/dph-examples.cabal +++ b/dph-examples.cabal @@ -1,7 +1,7 @@ Name: dph-examples -Version: 0.6.1.3 +Version: 0.7.0.1 License: BSD3 License-file: LICENSE Author: The DPH Team @@ -17,146 +17,146 @@ -- Smoke ---------------------------------------------------------------------- -- examples/smoke/data Executable dph-smoke-bool - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised hs-source-dirs: examples/smoke/data/Bool - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 -- examples/smoke/prims Executable dph-smoke-concat - build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* main-is: Main.hs other-modules: Vectorised hs-source-dirs: examples/smoke/prims/Concat - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-smoke-sumsq - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vector Vectorised Timing Randomish hs-source-dirs: examples/smoke/prims/SumSquares/dph lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-smoke-evens - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vector Vectorised Timing Randomish hs-source-dirs: examples/smoke/prims/Evens/dph lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 -- examples/smoke/sharing Executable dph-smoke-indices - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised hs-source-dirs: examples/smoke/sharing/Indices lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-smoke-rank - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised Util Timing Randomish hs-source-dirs: examples/smoke/sharing/Rank lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-smoke-reverse - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs - other-modules: Vectorised Randomish Vector + other-modules: Vectorised Randomish hs-source-dirs: examples/smoke/sharing/Reverse lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 -- Imaginary ------------------------------------------------------------------ -- Executable dph-imaginary-primes --- Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* +-- Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* -- Main-is: Main.hs -- other-modules: Vectorised -- hs-source-dirs: examples/imaginary/Primes lib --- ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 +-- ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-imaginary-words - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised hs-source-dirs: examples/imaginary/Words lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 -- Spectral ------------------------------------------------------------------- Executable dph-spectral-dotp - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vector Vectorised Timing Randomish hs-source-dirs: examples/spectral/DotProduct/dph lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-spectral-smvm - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised Timing hs-source-dirs: examples/spectral/SMVM/dph lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-spectral-quickhull - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised Timing Points2D.Types SVG hs-source-dirs: examples/spectral/QuickHull/dph examples/spectral/QuickHull/lib lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-spectral-quickhull-vector - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: QuickHullIO QuickHullSplit QuickHullVector Timing Points2D.Types SVG hs-source-dirs: examples/spectral/QuickHull/vector examples/spectral/QuickHull/lib lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-spectral-quicksort - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* Main-is: Main.hs other-modules: Vectorised Timing hs-source-dirs: examples/spectral/QuickSort/dph lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 -- Real ----------------------------------------------------------------------- -Executable dph-real-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 - System.Console.ParseArgs - Gloss.MainArgs Gloss.Draw Gloss.Config - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.*, gloss == 1.6.1.* - hs-source-dirs: examples/real/NBody examples/real/NBody/Gloss lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 +-- Executable dph-real-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 +-- System.Console.ParseArgs +-- Gloss.MainArgs Gloss.Draw Gloss.Config +-- Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.*, gloss == 1.6.* +-- hs-source-dirs: examples/real/NBody examples/real/NBody/Gloss lib +-- ghc-options: -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 Executable dph-real-nbody Main-is: MainBatch.hs @@ -166,9 +166,8 @@ Solver.VectorBH.Solver Solver.VectorNaive.Solver Timing Points2D.Types Points2D.Generate - System.Console.ParseArgs Batch.MainArgs Batch.Config - Build-depends: base == 4.5.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.4.*, HUnit == 1.2.*, dph-base == 0.6.1.*, dph-prim-par == 0.6.1.*, dph-lifted-vseg == 0.6.1.* + Build-depends: base == 4.6.*, vector == 0.10.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.7.*, dph-prim-par == 0.7.*, dph-lifted-vseg == 0.7.*, HUnit == 1.2.* hs-source-dirs: examples/real/NBody examples/real/NBody/Batch lib - ghc-options: -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000 + ghc-options: -eventlog -rtsopts -threaded -fllvm -O0 -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000 diff --git a/examples/real/NBody/Gloss/Config.hs b/examples/real/NBody/Gloss/Config.hs deleted file mode 100644 --- a/examples/real/NBody/Gloss/Config.hs +++ /dev/null @@ -1,74 +0,0 @@ - -module Gloss.Config - ( Config (..) - , loadConfig) -where -import Gloss.MainArgs -import System.Console.ParseArgs -import Data.Maybe - --- | Program config. -data Config - = Config { - - -- How to present the output. - configWindowSize :: Maybe Int - , configShouldDrawTree :: Bool - , configRate :: Int - - -- What solver to use - , configSolverName :: String - - -- System setup - , configBodyCount :: Int - , configBodyMass :: Double - , configTimeStep :: Double - , configEpsilon :: Double - - -- Initial conditions. - , configStartDiscSize :: Double - , configStartSpeed :: Double - - -- Terminating conditions. - , configMaxSteps :: Maybe Int - - -- dump points to file - , configDumpFinal :: Maybe FilePath } - - --- | Load program config from its command line arguments. -loadConfig :: Args MainArg -> Config -loadConfig args - = let mWindowSize = getArgInt args ArgGloss - Just solverName = getArgString args ArgSolver - shouldDrawTree = gotArg args ArgDrawTree - Just timeStep = getArgDouble args ArgTimeStep - Just rate = getArgInt args ArgRate - Just bodyCount = getArgInt args ArgBodyCount - Just bodyMass = getArgDouble args ArgBodyMass - Just epsilon = getArgDouble args ArgEpsilon - Just discSize = getArgDouble args ArgDiscSize - Just startSpeed = getArgDouble args ArgStartSpeed - - mMaxSteps = getArgInt args ArgMaxSteps - mFilePath = getArgString args ArgDumpFinal - - checkMode x - = if not (isJust mWindowSize || isJust mMaxSteps) - then error "you must specify either --max-steps or --gloss " - else x - - in checkMode $ - Config - { configWindowSize = mWindowSize - , configShouldDrawTree = shouldDrawTree - , configRate = rate - , configSolverName = solverName - , configBodyCount = bodyCount - , configBodyMass = bodyMass - , configTimeStep = timeStep - , configEpsilon = epsilon - , configStartDiscSize = discSize - , configStartSpeed = startSpeed - , configMaxSteps = mMaxSteps - , configDumpFinal = mFilePath } diff --git a/examples/real/NBody/Gloss/Draw.hs b/examples/real/NBody/Gloss/Draw.hs deleted file mode 100644 --- a/examples/real/NBody/Gloss/Draw.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE PatternGuards #-} --- | Drawing the world as a gloss picture. -module Gloss.Draw - (drawWorld) -where -import Common.World -import Common.Body -import Graphics.Gloss -import qualified Solver.ListBH.Solver as L -import qualified Data.Vector.Unboxed as V - - --- | Radius of the circle representing each body. -pointSize :: Float -pointSize = 4 - - --- | Draw the world, and optionally show the Barnes-Hut tree. --- NOTE: We always show the list version tree, which might not be the one --- that's actually being used to calculate the accelerations. --- To display the other trees we'd have to write draw functions for them, --- or functions to convert them to the list version. --- -drawWorld :: Bool -> World -> Picture -drawWorld shouldDrawTree world - = let picPoints = Color (makeColor 1 1 1 0.4) - $ Pictures - $ map drawBody - $ V.toList - $ worldBodies world - - picTree = drawBHTree - $ L.buildTree - $ map massPointOfBody - $ V.toList - $ worldBodies world - - in Pictures - [ if shouldDrawTree - then Color (makeColor 0.5 1.0 0.5 0.2) $ picTree - else Blank - - , picPoints ] - - --- | Draw a list version Barnes-Hut tree. -drawBHTree :: L.BHTree -> Picture -drawBHTree bht - = drawBHTree' 0 bht - -drawBHTree' depth bht - = let - -- The bounding box - L.Box left down right up = L.bhTreeBox bht - [left', down', right', up'] = map realToFrac [left, down, right, up] - - picCell = lineLoop [(left', down'), (left', up'), (right', up'), (right', down')] - - - -- Draw a circle with an area equal to the mass of the centroid. - centroidX = realToFrac $ L.bhTreeCenterX bht - centroidY = realToFrac $ L.bhTreeCenterY bht - - centroidMass = L.bhTreeMass bht - circleRadius = realToFrac $ sqrt (centroidMass / pi) - - midX = (left' + right') / 2 - midY = (up' + down') / 2 - - picCentroid - | _:_ <- L.bhTreeBranch bht - , depth >= 1 - = Color (makeColor 0.5 0.5 1.0 0.4) - $ Pictures - [ Line [(midX, midY), (centroidX, centroidY)] - , Translate centroidX centroidY - $ ThickCircle - (circleRadius * 4 / 2) - (circleRadius * 4) ] - - | otherwise - = Blank - - -- The complete picture for this cell. - picHere = Pictures [picCentroid, picCell] - - -- Pictures of children. - picSubs = map (drawBHTree' (depth + 1)) - $ L.bhTreeBranch bht - - in Pictures (picHere : picSubs) - - --- | Draw a single body. -drawBody :: Body -> Picture -drawBody ((x, y, _), _, _) - = drawPoint (x, y) - - --- | Draw a point using a filled circle. -drawPoint :: (Double, Double) -> Picture -drawPoint (x, y) - = Translate (realToFrac x) (realToFrac y) - $ ThickCircle (pointSize / 2) pointSize diff --git a/examples/real/NBody/Gloss/MainArgs.hs b/examples/real/NBody/Gloss/MainArgs.hs deleted file mode 100644 --- a/examples/real/NBody/Gloss/MainArgs.hs +++ /dev/null @@ -1,113 +0,0 @@ - -module Gloss.MainArgs - ( MainArg(..) - , mainArgs) -where -import System.Console.ParseArgs - -data MainArg - = ArgHelp - | ArgSolver - | ArgMaxSteps - | ArgTimeStep - | ArgBodyCount - | ArgBodyMass - | ArgEpsilon - | ArgDiscSize - | ArgStartSpeed - - -- Gloss output - | ArgGloss - | ArgRate - | ArgDrawTree - - -- Dump output - | ArgDumpFinal - deriving (Eq, Ord, Show) - -mainArgs :: [Arg MainArg] -mainArgs - = [ Arg { argIndex = ArgHelp - , argAbbr = Just 'h' - , argName = Just "help" - , argData = Nothing - , argDesc = "Print this usage help." } - - -- Solver selection. - , Arg { argIndex = ArgSolver - , argAbbr = Just 's' - , argName = Just "solver" - , argData = argDataDefaulted "name" ArgtypeString "vector-bh" - , argDesc = "One of: list-bh, vector-naive, vector-bh, nested-bh. (default vector-bh)" } - - -- Simulation setup. - , Arg { argIndex = ArgTimeStep - , argAbbr = Just 't' - , argName = Just "timestep" - , argData = argDataDefaulted "Double" ArgtypeDouble 1 - , argDesc = "Time step between states (default 1)" } - - , Arg { argIndex = ArgBodyCount - , argAbbr = Just 'b' - , argName = Just "bodies" - , argData = argDataDefaulted "Int" ArgtypeInt 200 - , argDesc = "Number of bodies in simulation (default 200)" } - - , Arg { argIndex = ArgBodyMass - , argAbbr = Just 'm' - , argName = Just "mass" - , argData = argDataDefaulted "Double" ArgtypeDouble 10 - , argDesc = "Mass of each body (default 10)" } - - , Arg { argIndex = ArgEpsilon - , argAbbr = Just 'e' - , argName = Just "epsilon" - , argData = argDataDefaulted "Double" ArgtypeDouble 100 - , argDesc = "Smoothing parameter (default 100)" } - - , Arg { argIndex = ArgDiscSize - , argAbbr = Just 'd' - , argName = Just "disc" - , argData = argDataDefaulted "Double" ArgtypeDouble 50 - , argDesc = "Starting size of disc containing bodies (default 50)" } - - , Arg { argIndex = ArgStartSpeed - , argAbbr = Just 'p' - , argName = Just "speed" - , argData = argDataDefaulted "Double" ArgtypeDouble 0.5 - , argDesc = "Starting rotation speed of bodies (default 0.5)" } - - -- Termination conditions. - , Arg { argIndex = ArgMaxSteps - , argAbbr = Nothing - , argName = Just "max-steps" - , argData = argDataOptional "steps" ArgtypeInt - , argDesc = "Exit simulation after this many steps." } - - -- Gloss animation output. - , Arg { argIndex = ArgGloss - , argAbbr = Nothing - , argName = Just "gloss" - , argData = argDataOptional "Int" ArgtypeInt - , argDesc = "Animate simulation in window of this size" } - - , Arg { argIndex = ArgRate - , argAbbr = Nothing - , argName = Just "gloss-rate" - , argData = argDataDefaulted "Double" ArgtypeInt 50 - , argDesc = "(opt. for gloss) Number of steps per second of real time (default 50)" } - - , Arg { argIndex = ArgDrawTree - , argAbbr = Nothing - , argName = Just "gloss-tree" - , argData = Nothing - , argDesc = "(opt. for gloss) Draw the Barnes-Hut quad tree"} - - -- Dump points to file - , Arg { argIndex = ArgDumpFinal - , argAbbr = Nothing - , argName = Just "dump-final" - , argData = argDataOptional "FilePath" ArgtypeString - , argDesc = "Dump final body positions and masses to file" } - - ] diff --git a/examples/real/NBody/MainGloss.hs b/examples/real/NBody/MainGloss.hs deleted file mode 100644 --- a/examples/real/NBody/MainGloss.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 simulate - (InWindow "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/examples/smoke/sharing/Indices/Main.hs b/examples/smoke/sharing/Indices/Main.hs --- a/examples/smoke/sharing/Indices/Main.hs +++ b/examples/smoke/sharing/Indices/Main.hs @@ -8,19 +8,23 @@ import Randomish import System.Environment import Control.Exception +import qualified Vector as IU import qualified Vectorised as ID import qualified Data.Array.Parallel.PArray as P -import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed as U main = do args <- getArgs case args of - [alg, count] -> run alg (read count) + [alg, countMin, countMax] -> run alg (read countMin) (read countMax) _ -> usage -run "vectorised" count +-- Vectorised Nested Data Parallel Version. +run "vectorised" count countMax + | count > countMax = return () + | otherwise = do let arr = P.fromList [0 .. count - 1] arr `seq` return () @@ -29,14 +33,39 @@ $ let arr' = ID.indicesPA arr arr in P.nf arr' `seq` return arr' - print $ P.length arrResult - putStr $ prettyTime tElapsed +-- print $ P.length arrResult +-- putStr $ prettyTime tElapsed -run _ _ + putStrLn $ (show $ P.length arrResult) + ++ "\t " + ++ (show $ wallTime milliseconds tElapsed) + run "vectorised" (count * 2) countMax + +-- Sequential version using Data.Vector +run "vector" count countMax + | count > countMax = return () + | otherwise + = do let arr = U.fromList [0 .. count - 1] + arr `seq` return () + + (arrResult, tElapsed) + <- time + $ let arr' = U.force $ IU.treeLookup arr arr + in arr' `seq` return arr' + +-- print $ U.length arrResult +-- putStr $ prettyTime tElapsed + putStrLn $ (show $ U.length arrResult) + ++ "\t " + ++ (show $ wallTime milliseconds tElapsed) + + run "vector" (count * 2) countMax + +run _ _ _ = usage usage = putStr $ unlines - [ "usage: indices \n" - , " algorithm one of " ++ show ["vectorised"] + [ "usage: indices \n" + , " algorithm one of " ++ show ["vectorised", "vector"] , ""] diff --git a/examples/smoke/sharing/Reverse/Vector.hs b/examples/smoke/sharing/Reverse/Vector.hs deleted file mode 100644 --- a/examples/smoke/sharing/Reverse/Vector.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module Vector (treeReverse) where -import qualified Data.Vector.Unboxed as V -import Data.Vector.Unboxed (Vector) - --- | Reverse the elements in an array using a tree. -treeReverse :: Vector Int -> Vector Int -{-# NOINLINE treeReverse #-} -treeReverse xx - | V.length xx == 1 - = xx - - | otherwise - = let len = V.length xx - half = len `div` 2 - s1 = V.slice 0 half xx - s2 = V.slice half half xx - in treeReverse s2 V.++ treeReverse s1 - diff --git a/examples/spectral/SMVM/dph/Main.hs b/examples/spectral/SMVM/dph/Main.hs --- a/examples/spectral/SMVM/dph/Main.hs +++ b/examples/spectral/SMVM/dph/Main.hs @@ -5,47 +5,112 @@ import System.IO import Foreign.Storable import Foreign.Marshal.Alloc -import Data.Array.Parallel.PArray as P import Data.Array.Parallel -import qualified Data.Array.Parallel.Unlifted as U import System.Environment -import Control.Exception (evaluate) +import qualified Data.Vector as V +import qualified Vector as V +import Control.Exception (evaluate) +import qualified Data.Vector.Unboxed as U +import qualified Data.Array.Parallel.Unlifted as P +import Data.Array.Parallel.PArray as PA main :: IO () main = do args <- getArgs case args of - [fileName] -> run fileName - _ -> usage + [alg, reps, fileName] -> run alg (read reps) fileName + _ -> usage usage = putStr $ unlines - [ "usage: smvm " ] + [ "usage: smvm " ] -run fileName - = do (matrix, vector) <- loadPA fileName +-- Vectorised Nested Data Parallel Version +run "vectorised" reps fileName + = do (matrix, vector) <- loadPA fileName + matrix `seq` return () vector `seq` return () - -- Multiply sparse matrix by the dense vector. - (vResult, tElapsed) - <- time $ let result = smvmPA matrix vector - in P.nf result `seq` return result +-- -- Multiply sparse matrix by the dense vector. +-- (vResult, tElapsed) +-- <- time $ let result = smvmPA 0 matrix vector +-- in PA.nf result `seq` return result + -- Multiply sparse matrix by the dense vector + (vResult, tElapsed) + <- time $ let loop n + | n == 0 + = let result = smvmPA n matrix vector + in PA.nf result `seq` result + + | otherwise + = let result = smvmPA n matrix vector + in PA.nf result `seq` loop (n - 1) + + final = loop reps + in final `seq` return final + -- Print how long it took. putStr $ prettyTime tElapsed -- Print some info about the test setup. - putStrLn $ "vector length = " ++ show (U.length (P.toUArray vector)) --- putStrLn $ "matrix height = " ++ show (U.length (toUArrPA matrix)) - + putStrLn $ "vector length = " ++ show (U.length (PA.toUArray vector)) +-- putStrLn $ "matrix = " ++ show matrix + -- Print checksum of resulting vector. - putStrLn $ "result sum = " ++ show (U.sum (P.toUArray vResult)) + putStrLn $ "result sum = " ++ show (U.sum (PA.toUArray vResult)) +-- Sequential version using Data.Vector +run "vector" reps fileName + = do (segd, uaMatrix, uaVector) <- loadUArr fileName + let vMatrix = U.fromList $ P.toList uaMatrix + let vVector = U.fromList $ P.toList uaVector + let matrix + = V.force + $ V.map U.force + $ V.zipWith + (\start len -> U.slice start len vMatrix) + (U.convert $ P.indicesSegd segd) + (U.convert $ P.lengthsSegd segd) + + + let vector = U.fromList $ U.toList uaVector + matrix `seq` return () + vector `seq` return () + + -- Multiply sparse matrix by the dense vector + (vResult, tElapsed) + <- time $ let loop n + | n == 0 + = let result = U.force $ V.smvm n matrix vector + in result `seq` result + + | otherwise + = let result = U.force $ V.smvm n matrix vector + in result `seq` loop (n - 1) + + final = loop reps + + in final `seq` return final + + -- Print how long it took. + putStr $ prettyTime tElapsed + + -- Print some info about the test setup. + putStrLn $ "vector length = " ++ show (U.length vector) + +-- putStrLn $ "matrix = " ++ show matrix + + -- Print checksum of resulting vector. + putStrLn $ "result sum = " ++ show (U.sum vResult) + + +-- Load Matrices -------------------------------------------------------------- -- | Load a test file containing a sparse matrix and dense vector. loadPA :: String -- ^ filename. -> IO ( PArray (PArray (Int, Double)) -- sparse matrix @@ -54,17 +119,17 @@ loadPA fileName = do (segd, arrMatrixElems, arrVector) <- loadUArr fileName - let paMatrix = P.nestUSegd segd (P.fromUArray2 arrMatrixElems) - let paVector = P.fromUArray arrVector + let paMatrix = PA.nestUSegd segd (PA.fromUArray2 arrMatrixElems) + let paVector = PA.fromUArray arrVector return (paMatrix, paVector) -- | Load a test file containing a sparse matrix and dense vector. -loadUArr :: String -- ^ filename - -> IO ( U.Segd -- segment descriptor saying what array elements - -- belong to each row of the matrix. - , U.Array (Int, Double) -- column indices and matrix elements - , U.Array Double) -- the dense vector +loadUArr :: String -- ^ filename + -> IO ( P.Segd -- segment descriptor saying what array elements + -- belong to each row of the matrix. + , P.Array (Int, Double) -- column indices and matrix elements + , P.Array Double) -- the dense vector loadUArr fname = do h <- openBinaryFile fname ReadMode @@ -80,23 +145,23 @@ else error $ "bad magic in " ++ fname -- number of elements in each row of the matrix. - lengths <- U.hGet h + lengths <- P.hGet h -- indices of all the elements. - indices <- U.hGet h + indices <- P.hGet h -- values of the matrix elements. - values <- U.hGet h + values <- P.hGet h -- the dense vector. - vector <- U.hGet h + vector <- P.hGet h evaluate lengths evaluate indices evaluate values evaluate vector - let segd = U.lengthsToSegd lengths - matrix = U.zip indices values + let segd = P.lengthsToSegd lengths + matrix = P.zip indices values return (segd, matrix, vector) diff --git a/examples/spectral/SMVM/dph/Vectorised.hs b/examples/spectral/SMVM/dph/Vectorised.hs --- a/examples/spectral/SMVM/dph/Vectorised.hs +++ b/examples/spectral/SMVM/dph/Vectorised.hs @@ -7,11 +7,13 @@ import Data.Array.Parallel.Prelude.Int as I import qualified Prelude as P -smvmPA :: PArray (PArray (Int, Double)) -> PArray Double -> PArray Double -smvmPA m v = toPArrayP (smvm (fromNestedPArrayP m) (fromPArrayP v)) {-# NOINLINE smvmPA #-} +smvmPA :: Int -> PArray (PArray (Int, Double)) -> PArray Double -> PArray Double +smvmPA _ m v = toPArrayP (smvm (fromNestedPArrayP m) (fromPArrayP v)) smvm :: [:[: (Int, Double) :]:] -> [:Double:] -> [:Double:] -smvm m v = [: D.sumP [: x D.* (v !: i) | (i,x) <- row :] | row <- m :] +smvm m v = [: D.sumP [: x D.* (v !: i) + | (i,x) <- row :] + | row <- m :] diff --git a/lib/System/Console/ParseArgs.hs b/lib/System/Console/ParseArgs.hs deleted file mode 100644 --- a/lib/System/Console/ParseArgs.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-} --- Full-featured argument parsing library for Haskell programs --- Bart Massey - --- Copyright © 2007-2010 Bart Massey --- ALL RIGHTS RESERVED - --- You can redistribute and/or modify this library under the --- terms of the "3-clause BSD LICENSE", as stated in the file --- COPYING in the top-level directory of this distribution. --- --- This library is distributed in the hope that it will be --- useful, but WITHOUT ANY WARRANTY; without even the --- implied warranty of MERCHANTABILITY or FITNESS FOR A --- PARTICULAR PURPOSE. - --- |This module supplies an argument parser. --- Given a description of type [`Arg`] of the legal --- arguments to the program, a list of argument strings, --- and a bit of extra information, the `parseArgs` function --- in this module returns an --- `Args` data structure suitable for querying using the --- provided functions `gotArg`, `getArg`, etc. -module System.Console.ParseArgs ( - -- * Describing allowed arguments - -- |The argument parser requires a description of - -- the arguments that will be parsed. This is - -- supplied as a list of `Arg` records, built up - -- using the functions described here. - Arg(..), - Argtype(..), - ArgsComplete(..), - -- ** DataArg and its pseudo-constructors - DataArg, - argDataRequired, argDataOptional, argDataDefaulted, - -- * Argument processing - -- |The argument descriptions are used to parse - -- the command line arguments, and the results - -- of the parse can later be (efficiently) queried - -- to determine program behavior. - - -- ** Getting parse results - -- |The argument parser returns an opaque map - -- from argument index to parsed argument data - -- (plus some convenience information). - ArgRecord, Args(..), - parseArgs, parseArgsIO, - -- ** Using parse results - -- |Query functions permit checking for the existence - -- and values of command-line arguments. - gotArg, ArgType(..), - getArgString, getArgFile, getArgStdio, - getArgInteger, getArgInt, - getArgDouble, getArgFloat, - ArgFileOpener(..), - -- * Misc - ParseArgsException(..), - baseName, parseError, usageError, - System.IO.IOMode(ReadMode, WriteMode, AppendMode)) -where - -import Control.Exception -import Control.Monad -import Control.Monad.ST -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Data.Typeable -import System.Environment -import System.IO - --- The main job of this module is to provide parseArgs. --- See below for its contract. - --- --- Provided datatypes. --- - --- |The description of an argument, suitable for --- messages and for parsing. The `argData` field --- is used both for flags with a data argument, and --- for positional data arguments. --- --- There are two cases: --- --- (1) The argument is a flag, in which case at least --- one of `argAbbr` and `argName` is provided; --- --- (2) The argument is positional, in which case neither --- `argAbbr` nor `argName` are provided, but `argData` is. --- --- If none of `argAbbr`, `argName`, or `argData` are --- provided, this is an error. See also the --- `argDataRequired`, `argDataOptional`, and --- `argDataDefaulted` functions below, which are used to --- generate `argData`. -data Arg a = - Arg { argIndex :: a -- ^Connects the input description - -- to the output argument. - , argAbbr :: Maybe Char -- ^One-character flag name. - , argName :: Maybe String -- ^\"Long name\" of flag. - , argData :: Maybe DataArg -- ^Datum description. - , argDesc :: String -- ^Documentation for the argument. - } - - --- |The types of an argument carrying data. The constructor --- argument is used to carry a default value. --- --- The constructor argument should really be hidden. --- Values of this type are normally constructed within --- the pseudo-constructors pseudo-constructors --- `argDataRequired`, `argDataOptional`, and --- `argDataDefaulted`, to which only the constructor --- function itself is passed. -data Argtype = ArgtypeString (Maybe String) - | ArgtypeInteger (Maybe Integer) - | ArgtypeInt (Maybe Int) - | ArgtypeDouble (Maybe Double) - | ArgtypeFloat (Maybe Float) - - --- |Information specific to an argument carrying a datum. This --- is an opaque type, whose instances are constructed using the --- pseudo-constructors `argDataRequired`, `argDataOptional`, --- and `argDataDefaulted`. -data DataArg = DataArg { dataArgName :: String -- ^Print name of datum. - , dataArgArgtype :: Argtype -- ^Type of datum. - , dataArgOptional :: Bool -- ^Datum is not required. - } - --- |Generate the `argData` for the given non-optional argument. -argDataRequired :: String -- ^Datum print name. - -> (Maybe a -> Argtype) -- ^Type constructor for datum. - -> Maybe DataArg -- ^Result is `argData`-ready. -argDataRequired s c = Just (DataArg { dataArgName = s, - dataArgArgtype = c Nothing, - dataArgOptional = False }) - --- |Generate the `argData` for the given optional argument with no default. -argDataOptional :: String -- ^Datum print name. - -> (Maybe a -> Argtype) -- ^Type constructor for datum. - -> Maybe DataArg -- ^Result is `argData`-ready. -argDataOptional s c = Just (DataArg { dataArgName = s, - dataArgArgtype = c Nothing, - dataArgOptional = True }) - --- |Generate the `argData` for the given optional argument with the --- given default. -argDataDefaulted :: String -- ^Datum print name. - -> (Maybe a -> Argtype) -- ^Type constructor for datum. - -> a -- ^Datum default value. - -> Maybe DataArg -- ^Result is `argData`-ready. -argDataDefaulted s c d = Just (DataArg { dataArgName = s, - dataArgArgtype = c (Just d), - dataArgOptional = True }) --- --- Returned datatypes. --- - --- |The \"kinds of values\" an argument can have. -data Argval = ArgvalFlag -- ^For simple present vs not-present flags. - | ArgvalString String - | ArgvalInteger Integer - | ArgvalInt Int - | ArgvalDouble Double - | ArgvalFloat Float - --- |The type of the mapping from argument index to value. -newtype ArgRecord a = ArgRecord (Map.Map a Argval) - --- |The data structure `parseArgs` produces. The key --- element is the `ArgRecord` `args`. -data Args a = - Args { args :: ArgRecord a -- ^The argument map. - , argsProgName :: String -- ^Basename of 0th argument. - , argsUsage :: String -- ^Full usage string. - , argsRest :: [ String ] -- ^Remaining unprocessed arguments. - } - --- --- Exception type. --- - --- |This exception is raised with an appropriate error message --- when argument parsing fails. The first argument is the usage --- message, the second the actual error message from the parser. -data ParseArgsException = ParseArgsException String String - deriving (Eq, Typeable) - -instance Exception ParseArgsException - -instance Show ParseArgsException where - show (ParseArgsException usage msg) = msg ++ "\n" ++ usage - --- --- Implementation. --- - --- |True if the described argument is positional. -arg_posn :: (Ord a) => - Arg a -- ^Argument. - -> Bool -- ^True if argument is positional. -arg_posn (Arg { argAbbr = Nothing, - argName = Nothing }) = True -arg_posn _ = False - --- |True if the described argument is a flag. -arg_flag :: (Ord a) => - Arg a -- ^Argument. - -> Bool -- ^True if argument is a flag. -arg_flag a = not (arg_posn a) - --- |True if the described argument is optional. -arg_optional :: (Ord a) => - Arg a -- ^Argument. - -> Bool -- ^False if argument is required to be present. -arg_optional (Arg { argData = Just (DataArg { dataArgOptional = b }) }) = b -arg_optional _ = True - --- |Return the value of a defaulted argument. -arg_default_value :: (Ord a) - => Arg a -- ^Argument. - -> Maybe Argval -- ^Optional default value. -arg_default_value arg@(Arg { argData = Just - (DataArg { dataArgArgtype = da }) }) | - arg_optional arg = - defval da - where - defval (ArgtypeString (Just v)) = Just (ArgvalString v) - defval (ArgtypeInteger (Just v)) = Just (ArgvalInteger v) - defval (ArgtypeInt (Just v)) = Just (ArgvalInt v) - defval (ArgtypeDouble (Just v)) = Just (ArgvalDouble v) - defval (ArgtypeFloat (Just v)) = Just (ArgvalFloat v) - defval _ = Nothing -arg_default_value _ = Nothing - --- |There's probably a better way to do this. -perhaps b s = if b then s else "" - --- |Format the described argument as a string. -arg_string :: (Ord a) => - Arg a -- ^Argument to be described. - -> String -- ^String describing argument. -arg_string a@(Arg { argAbbr = abbr, - argName = name, - argData = arg }) = - (optionally "[") ++ - (sometimes flag_abbr abbr) ++ - (perhaps ((isJust abbr) && (isJust name)) ",") ++ - (sometimes flag_name name) ++ - (perhaps ((arg_flag a) && (isJust arg)) " ") ++ - (sometimes data_arg arg) ++ - (optionally "]") - where - sometimes = maybe "" - optionally s = perhaps (arg_optional a) s - flag_name s = "--" ++ s - flag_abbr c = [ '-', c ] - data_arg (DataArg {dataArgName = s}) = "<" ++ s ++ ">" - --- |Filter out the empty keys for a hash. -filter_keys :: [ (Maybe a, b) ] -- ^List of (optional key, value) pairs. - -> [ (a, b) ] -- ^Pairs with actual keys. -filter_keys l = - foldr check_key [] l - where - check_key (Nothing, _) rest = rest - check_key (Just k, v) rest = (k, v) : rest - --- |Fail with an error if the argument description is bad --- for some reason. -argdesc_error :: String -- ^Error message. - -> a -- ^Bogus polymorphic result. -argdesc_error msg = - error ("internal error: argument description: " ++ msg) - --- |Make a keymap. -keymap_from_list :: (Ord k, Show k) => - [ (k, a) ] -- ^List of key-value pairs. - -- Will be checked for duplicate keys. - -> Map.Map k a -- ^Key-value map. -keymap_from_list l = - foldl add_entry Map.empty l - where - add_entry m (k, a) = - case Map.member k m of - False -> Map.insert k a m - True -> argdesc_error ("duplicate argument description name " ++ - (show k)) - --- |Make a keymap for looking up a flag argument. -make_keymap :: (Ord a, Ord k, Show k) => - ((Arg a) -> Maybe k) -- ^Mapping from argdesc to flag key. - -> [ Arg a ] -- ^List of argdesc. - -> (Map.Map k (Arg a)) -- ^Map from key to argdesc. -make_keymap f_field args = - (keymap_from_list . - filter_keys . - map (\arg -> (f_field arg, arg))) args - --- |How \"sloppy\" the parse is. -data ArgsComplete = ArgsComplete -- ^Any extraneous arguments - -- (unparseable from description) - -- will cause the parser to fail. - | ArgsTrailing String -- ^Trailing extraneous arguments are - -- permitted, and will be skipped, - -- saved, and returned. The - -- constructor argument is the - -- name of the args. - | ArgsInterspersed -- ^All extraneous arguments are - -- permitted, and will be skipped, - -- saved, and returned. - --- |The iteration function is given a state and a list, and --- expected to produce a new state and list. The function --- is again invoked with the resulting state and list. --- When the function returns the empty list, `exhaust` returns --- the final state produced. -exhaust :: (s -> [e] -> ([e], s)) -- ^Function to iterate. - -> s -- ^Initial state. - -> [e] -- ^Initial list. - -> s -- ^Final state. -exhaust f s [] = s -exhaust f s l = - let (l', s') = f s l - in exhaust f s' l' - --- |Generate a usage error with the given supplementary message string. -parseError :: String -- ^Usage message. - -> String -- ^Specific error message. - -> a -- ^Bogus polymorphic result. -parseError usage msg = - throw (ParseArgsException usage msg) - --- |Given a description of the arguments, `parseArgs` produces --- a map from the arguments to their \"values\" and some other --- useful byproducts. `parseArgs` requires that the argument --- descriptions occur in the order 1) flag arguments, 2) required --- positional arguments, 3) optional positional arguments; otherwise --- a runtime error will be thrown. -parseArgs :: (Show a, Ord a) => - ArgsComplete -- ^Degree of completeness of parse. - -> [ Arg a ] -- ^Argument descriptions. - -> String -- ^Full program pathname. - -> [ String ] -- ^Incoming program argument list. - -> Args a -- ^Outgoing argument parse results. -parseArgs acomplete argd pathname argv = - runST (do - check_argd - let flag_args = takeWhile arg_flag argd - let posn_args = dropWhile arg_flag argd - let name_hash = make_keymap argName flag_args - let abbr_hash = make_keymap argAbbr flag_args - let prog_name = baseName pathname - let usage = make_usage_string prog_name - let (am, posn, rest) = exhaust (parse usage name_hash abbr_hash) - (Map.empty, posn_args, []) - argv - let required_args = filter (not . arg_optional) argd - unless (and (map (check_present usage am) required_args)) - (error "internal error") - let am' = foldl supply_defaults am argd - return (Args { args = ArgRecord am', - argsProgName = prog_name, - argsUsage = usage, - argsRest = rest })) - where - supply_defaults am ad@(Arg { argIndex = k }) = - case Map.lookup k am of - Just _ -> am - Nothing -> case arg_default_value ad of - Just v -> Map.insert k v am - Nothing -> am - check_present usage am ad@(Arg { argIndex = k }) = - case Map.lookup k am of - Just _ -> True - Nothing -> parseError usage ("missing required argument " ++ - (arg_string ad)) - --- Check for various possible misuses. - check_argd :: ST s () - check_argd = do - --- Order must be flags, posn args, optional posn args - let residue = dropWhile arg_flag argd - let residue' = dropWhile arg_fixed_posn residue - let residue'' = dropWhile arg_opt_posn residue' - unless (null residue'') - (argdesc_error "argument description in wrong order") - --- No argument may be "nullary". - when (or (map arg_nullary argd)) - (argdesc_error "bogus 'nothing' argument") - return () - where - arg_fixed_posn a = (arg_posn a) && (not (arg_optional a)) - arg_opt_posn a = (arg_posn a) && (arg_optional a) - arg_nullary (Arg { argName = Nothing, - argAbbr = Nothing, - argData = Nothing }) = True - arg_nullary _ = False - --- Generate a usage message string - make_usage_string prog_name = - summary_line ++ arg_lines - where - flag_args = filter arg_flag argd - posn_args = filter arg_posn argd - n = maximum (map (length . arg_string) argd) - --- top (summary) line - summary_line = - "usage: " ++ prog_name ++ - perhaps - (not (null flag_args)) - " [options]" ++ - perhaps - (not (null posn_args)) - (" " ++ unwords (map arg_string posn_args)) ++ - (case acomplete of - ArgsComplete -> "" - ArgsTrailing s -> " [--] [" ++ s ++ " ...]" - ArgsInterspersed -> " ... [--] ...") ++ "\n" - --- argument lines - arg_lines = concatMap (arg_line n) argd where - arg_line n a = - let s = arg_string a in - " " ++ s ++ - replicate (n - (length s)) ' ' ++ - " " ++ argDesc a ++ "\n" - --- simple recursive-descent parser - parse _ _ _ av@(_, _, []) [] = ([], av) - parse usage _ _ av [] = - case acomplete of - ArgsComplete -> parseError usage "unexpected extra arguments" - _ -> ([], av) - parse usage name_hash abbr_hash (am, posn, rest) av@(aa : aas) = - case aa of - "--" -> case acomplete of - ArgsComplete -> parseError usage - ("unexpected -- " ++ - "(extra arguments not allowed)") - _ -> ([], (am, posn, (rest ++ aas))) - s@('-' : '-' : name) -> - case Map.lookup name name_hash of - Just ad -> peel s ad aas - Nothing -> - case acomplete of - ArgsInterspersed -> - (aas, (am, posn, rest ++ ["--" ++ name])) - _ -> parseError usage - ("unknown argument --" ++ name) - ('-' : abbr : abbrs) -> - case Map.lookup abbr abbr_hash of - Just ad -> - let p@(args', state') = peel ['-', abbr] ad aas - in case abbrs of - [] -> p - ('-' : _) -> parseError usage - ("bad internal '-' in argument " ++ aa) - _ -> (['-' : abbrs] ++ args', state') - Nothing -> - case acomplete of - ArgsInterspersed -> - (['-' : abbrs] ++ aas, - (am, posn, rest ++ [['-', abbr]])) - _ -> parseError usage - ("unknown argument -" ++ [abbr]) - aa -> case posn of - (ad@(Arg { argData = Just adata }) : ps) -> - let (argl', (am', _, rest')) = - peel_process (dataArgName adata) ad av - in (argl', (am', ps, rest')) - [] -> case acomplete of - ArgsComplete -> parseError usage - ("unexpected argument " ++ aa) - _ -> (aas, (am, [], rest ++ [aa])) - where - add_entry s m (k, a) = - case Map.member k m of - False -> Map.insert k a m - True -> parseError usage ("duplicate argument " ++ s) - peel name ad@(Arg { argData = Nothing, argIndex = index }) argl = - let am' = add_entry name am (index, ArgvalFlag) - in (argl, (am', posn, rest)) - peel name (Arg { argData = Just (DataArg {}) }) [] = - parseError usage (name ++ " is missing its argument") - peel name ad argl = peel_process name ad argl - peel_process name - ad@(Arg { argData = Just (DataArg { - dataArgArgtype = atype }), - argIndex = index }) - (a : argl) = - let read_arg constructor kind = - case reads a of - [(v, "")] -> constructor v - _ -> parseError usage ("argument " ++ - a ++ " to " ++ name ++ - " is not " ++ kind) - v = case atype of - ArgtypeString _ -> ArgvalString a - ArgtypeInteger _ -> read_arg ArgvalInteger - "an integer" - ArgtypeInt _ -> read_arg ArgvalInt "an int" - ArgtypeDouble _ -> read_arg ArgvalDouble "a double" - ArgtypeFloat _ -> read_arg ArgvalFloat "a float" - am' = add_entry name am (index, v) - in (argl, (am', posn, rest)) - - --- |Most of the time, you just want the environment's --- arguments and are willing to live in the IO monad. --- This version of `parseArgs` digs the pathname and arguments --- out of the system directly. -parseArgsIO :: (Show a, Ord a) => - ArgsComplete -- ^Degree of completeness of parse. - -> [ Arg a ] -- ^Argument descriptions. - -> IO (Args a) -- ^Argument parse results. -parseArgsIO acomplete argd = do - argv <- getArgs - pathname <- getProgName - return (parseArgs acomplete argd pathname argv) - - --- |Check whether a given optional argument was supplied. Works on all types. -gotArg :: (Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be checked for. - -> Bool -- ^True if the arg was present. -gotArg (Args { args = ArgRecord am }) k = - case Map.lookup k am of - Just _ -> True - Nothing -> False - --- |Type of values that can be parsed by the argument parser. -class ArgType b where - -- |Fetch an argument's value if it is present. - getArg :: (Show a, Ord a) - => Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe b -- ^Argument value if present. - -- |Fetch the value of a required argument. - getRequiredArg :: (Show a, Ord a) - => Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> b -- ^Argument value. - getRequiredArg args index = - case getArg args index of - Just v -> v - Nothing -> error ("internal error: required argument " - ++ show index ++ "not supplied") - -getArgPrimitive decons (Args { args = ArgRecord am }) k = - case Map.lookup k am of - Just v -> Just (decons v) - Nothing -> Nothing - -instance ArgType ([] Char) where - getArg = getArgPrimitive (\(ArgvalString s) -> s) - --- |[Deprecated] Return the `String` value, if any, of the given argument. -getArgString :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe String -- ^Argument value if present. -getArgString = getArg - -instance ArgType Integer where - getArg = getArgPrimitive (\(ArgvalInteger i) -> i) - --- |[Deprecated] Return the `Integer` value, if any, of the given argument. -getArgInteger :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe Integer -- ^Argument value if present. -getArgInteger = getArg - -instance ArgType Int where - getArg = getArgPrimitive (\(ArgvalInt i) -> i) - --- |[Deprecated] Return the `Int` value, if any, of the given argument. -getArgInt :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe Int -- ^Argument value if present. -getArgInt = getArg - -instance ArgType Double where - getArg = getArgPrimitive (\(ArgvalDouble i) -> i) - --- |[Deprecated] Return the `Double` value, if any, of the given argument. -getArgDouble :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe Double -- ^Argument value if present. -getArgDouble = getArg - -instance ArgType Float where - getArg = getArgPrimitive (\(ArgvalFloat i) -> i) - --- |[Deprecated] Return the `Float` value, if any, of the given argument. -getArgFloat :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> Maybe Float -- ^Argument value if present. -getArgFloat = getArg - --- |`ArgType` instance for opening a file from its string name. -newtype ArgFileOpener = ArgFileOpener { - argFileOpener :: IOMode -> IO Handle -- ^Function to open the file - } - -instance ArgType ArgFileOpener where - getArg args index = - case getArg args index of - Nothing -> Nothing - Just s -> Just (ArgFileOpener { argFileOpener = openFile s }) - --- |[Deprecated] Treat the `String` value, if any, of the given argument as --- a file handle and try to open it as requested. -getArgFile :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> IOMode -- ^IO mode the file should be opened in. - -> IO (Maybe Handle) -- ^Handle of opened file, if the argument - -- was present. -getArgFile args k m = - case getArg args k of - Just fo -> (do h <- argFileOpener fo m; return (Just h)) - Nothing -> return Nothing - - --- |Treat the `String` value, if any, of the given argument as a --- file handle and try to open it as requested. If not --- present, substitute the appropriate one of stdin or --- stdout as indicated by `IOMode`. -getArgStdio :: (Show a, Ord a) => - Args a -- ^Parsed arguments. - -> a -- ^Index of argument to be retrieved. - -> IOMode -- ^IO mode the file should be opened in. - -- Must not be `ReadWriteMode`. - -> IO Handle -- ^Appropriate file handle. -getArgStdio args k m = - case getArg args k of - Just s -> openFile s m - Nothing -> - case m of - ReadMode -> return stdin - WriteMode -> return stdout - AppendMode -> return stdout - ReadWriteMode -> - error ("internal error: tried to open stdio " - ++ "in ReadWriteMode") - ---- ---- Misc ---- - --- |Return the filename part of a pathname. --- Unnecessarily efficient implementation does a single --- tail-call traversal with no construction. -baseName :: String -- ^Pathname. - -> String -- ^Rightmost component of pathname. -baseName s = - let s' = dropWhile (/= '/') s in - if null s' then s else baseName (tail s') - - --- |Generate a usage error with the given supplementary message string. -usageError :: (Ord a) => Args a -> String -> b -usageError args msg = error (argsUsage args ++ "\n" ++ msg) diff --git a/lib/Timing.hs b/lib/Timing.hs --- a/lib/Timing.hs +++ b/lib/Timing.hs @@ -1,5 +1,6 @@ module Timing - (time, showTime, prettyTime) + ( time, showTime, prettyTime + , wallTime, cpuTime, milliseconds) where import System.CPUTime import System.Time