gloss-examples 1.7.3.2 → 1.7.4.1
raw patch · 3 files changed
+73/−6 lines, 3 filesdep ~gloss-rasternew-component:exe:gloss-snow
Dependency ranges changed: gloss-raster
Files
- gloss-examples.cabal +21/−5
- raster/Fluid/Solve/Velocity.hs +4/−1
- raster/Snow/Main.hs +48/−0
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.7.3.2+Version: 1.7.4.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -189,7 +189,7 @@ Build-depends: base == 4.*, gloss == 1.7.*,- gloss-raster == 1.7.2.*+ gloss-raster == 1.7.4.* Main-is: Main.hs hs-source-dirs: raster/Crystal ghc-options: @@ -204,7 +204,7 @@ Build-depends: base == 4.*, gloss == 1.7.*,- gloss-raster == 1.7.2.*+ gloss-raster == 1.7.4.* Main-is: Main.hs other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray@@ -220,7 +220,7 @@ Build-depends: base == 4.*, gloss == 1.7.*,- gloss-raster == 1.7.2.*+ gloss-raster == 1.7.4.* Main-is: Main.hs hs-source-dirs: raster/Pulse ghc-options:@@ -235,7 +235,7 @@ Build-depends: base == 4.*, gloss == 1.7.*,- gloss-raster == 1.7.2.*,+ gloss-raster == 1.7.4.*, vector == 0.9.*, ghc-prim Main-is: Main.hs@@ -273,3 +273,19 @@ extensions: PatternGuards ++Executable gloss-snow+ Build-depends+ base == 4.*,+ gloss == 1.7.*,+ repa == 3.1.*,+ Main-is: Main.hs+ hs-source-dirs: raster/Snow+ ghc-options:+ -Wall -threaded -eventlog -rtsopts+ -Odph -fno-liberate-case+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ -fllvm -optlo-O3++
raster/Fluid/Solve/Velocity.hs view
@@ -6,9 +6,12 @@ import Stage.Advection import Stage.Sources import Stage.Project--- import Stage.Boundary import Model import Config++-- The pass that sets boundary conditions is buggy and +-- currently disabled.+-- import Stage.Boundary velocitySteps :: Config
+ raster/Snow/Main.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE BangPatterns #-}+import Graphics.Gloss.Raster.Array+import System.Environment+import Data.Array.Repa.Algorithms.Randomish+import Data.Array.Repa as R+import Data.List+import Data.Bits+import Prelude as P++main :: IO ()+main+ = do args <- getArgs+ case args of+ [] -> run 800 600 4 4++ [sizeX, sizeY, scaleX, scaleY]+ -> run (read sizeX) (read sizeY) (read scaleX) (read scaleY)++ _ -> putStr $ unlines+ [ "gloss-snow <sizeX::Int> <sizeY::Int> <scaleX::Int> <scaleY::Int>"+ , " sizeX, sizeY - visualisation size (default 800, 600)"+ , " scaleX, scaleY - pixel scaling factor (default 4, 4)" ]+ ++run :: Int -> Int -> Int -> Int -> IO ()+run windowX windowY scaleX scaleY+ = do+ let !sizeX = windowX `div` scaleX+ let !sizeY = windowY `div` scaleY++ let frame time+ = let seed1 = truncate (time * 10000)+ arr1 = randomishIntArray (Z :. sizeY :. sizeX) 0 255 seed1++ seed2 = truncate ((time * time) * 100)+ arr2 = randomishIntArray (Z :. sizeY :. sizeX) 0 255 seed2++ makePixel i j+ = let x = i + j+ x' = x .&. 0x0ff+ in rgb8 x' x' x'++ in R.zipWith makePixel arr1 arr2++ animateArray + (InWindow "Digital Snow" (windowX, windowY) (10, 10))+ (scaleX, scaleY)+ frame