gloss-examples 1.10.2.4 → 1.11.1.1
raw patch · 4 files changed
+176/−57 lines, 4 filesdep ~basedep ~ghc-primdep ~glossnew-component:exe:gloss-gravity
Dependency ranges changed: base, ghc-prim, gloss, gloss-algorithms, gloss-raster, vector
Files
- gloss-examples.cabal +45/−34
- picture/Gravity/Main.hs +108/−0
- raster/Crystal/Main.hs +10/−13
- raster/Mandel/Main.hs +13/−10
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.10.2.4+Version: 1.11.1.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -32,7 +32,7 @@ base >= 4.8 && < 4.10, bytestring == 0.10.*, bmp == 1.2.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Bitmap ghc-options: -threaded -O2@@ -41,7 +41,7 @@ Executable gloss-boids Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: KDTree2d Vec2 hs-source-dirs: picture/Boids@@ -51,7 +51,7 @@ Executable gloss-clock Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Clock ghc-options: -threaded -O2@@ -61,7 +61,7 @@ Build-depends: base >= 4.8 && < 4.10, vector == 0.11.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Color ghc-options: -threaded -O2@@ -72,7 +72,7 @@ Build-depends: base >= 4.8 && < 4.10, vector == 0.11.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: Cell World hs-source-dirs: picture/Conway@@ -82,7 +82,7 @@ Executable gloss-draw Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Draw ghc-options: -threaded -O2@@ -91,7 +91,7 @@ Executable gloss-easy Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Easy ghc-options: -threaded -O2@@ -101,7 +101,7 @@ Build-depends: base >= 4.8 && < 4.10, random == 1.1.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: Cell Community World hs-source-dirs: picture/Eden@@ -111,7 +111,7 @@ Executable gloss-flake Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Flake ghc-options: -threaded -O2@@ -120,7 +120,7 @@ Executable gloss-gameevent Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/GameEvent ghc-options: -threaded -O2@@ -129,7 +129,7 @@ Executable gloss-hello Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Hello ghc-options: -threaded -O2@@ -138,7 +138,7 @@ Executable gloss-lifespan Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*,+ gloss == 1.11.*, random == 1.1.* Main-is: Main.hs other-modules: Cell Community World@@ -149,7 +149,7 @@ Executable gloss-machina Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Machina ghc-options: -threaded -O2@@ -158,8 +158,8 @@ Executable gloss-occlusion Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*,- gloss-algorithms == 1.10.*+ gloss == 1.11.*,+ gloss-algorithms == 1.11.* Main-is: Main.hs other-modules: Cell World State Data hs-source-dirs: picture/Occlusion@@ -171,7 +171,7 @@ base >= 4.8 && < 4.10, ghc-prim >= 0.4 && < 0.6, containers == 0.5.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: Actor Advance Collide Config Contact QuadTree World hs-source-dirs: picture/Styrene@@ -181,7 +181,7 @@ Executable gloss-tree Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Tree ghc-options: -threaded -O2@@ -191,7 +191,7 @@ Build-depends: base >= 4.8 && < 4.10, vector == 0.11.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment hs-source-dirs: picture/Visibility @@ -201,7 +201,7 @@ Executable gloss-zen Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Zen ghc-options: -threaded -O2@@ -210,8 +210,8 @@ Executable gloss-crystal Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*,- gloss-raster == 1.10.*+ gloss == 1.11.*,+ gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Crystal @@ -236,8 +236,8 @@ base >= 4.8 && < 4.10, repa == 3.4.*, repa-io == 3.4.*,- gloss == 1.10.*,- gloss-raster == 1.10.*+ gloss == 1.11.*,+ gloss-raster == 1.11.* Main-is: Main.hs other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray@@ -255,8 +255,8 @@ Executable gloss-pulse Build-depends: base >= 4.8 && < 4.10,- gloss == 1.10.*,- gloss-raster == 1.10.*+ gloss == 1.11.*,+ gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Pulse ghc-options:@@ -275,8 +275,8 @@ base >= 4.8 && < 4.10, ghc-prim == 0.5.*, vector == 0.11.*,- gloss == 1.10.*,- gloss-raster == 1.10.*+ gloss == 1.11.*,+ gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Wave ghc-options:@@ -302,7 +302,7 @@ -- repa == 3.4.*, -- repa-io == 3.4.*, -- repa-algorithms == 3.4.*,--- gloss == 1.10.*+-- gloss == 1.11.* -- Main-is: Main.hs -- other-modules: -- Args Config FieldElt Model UserEvent@@ -331,7 +331,7 @@ base >= 4.8 && < 4.10, repa == 3.4.*, repa-algorithms == 3.4.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Snow ghc-options:@@ -349,7 +349,7 @@ Build-depends: base >= 4.8 && < 4.10, repa == 3.4.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs other-modules: Solver hs-source-dirs: raster/Mandel@@ -373,20 +373,31 @@ Build-depends: base >= 4.8 && < 4.10, containers == 0.5.*,- gloss == 1.10.*+ gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Graph ghc-options: -Wall -O2 +Executable gloss-gravity+ Build-depends:+ base >= 4.8 && < 4.10,+ containers == 0.5.*,+ gloss == 1.11.*+ Main-is: Main.hs+ hs-source-dirs: picture/Gravity+ 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.*,+-- gloss == 1.11.*,+-- gloss-rendering == 1.11.*, -- GLFW-b -- Main-is: Main.hs -- hs-source-dirs: picture/Render
+ picture/Gravity/Main.hs view
@@ -0,0 +1,108 @@+import Graphics.Gloss+import Graphics.Gloss.Interface.Environment+import System.Random++-- x, y, dx, dy+type Particle + = (Float, Float, Float, Float) +++main :: IO ()+main + = do g <- getStdGen+ (width,height) <- getScreenSize+ let initialstate = generateParticles g width height+ simulate window background fps initialstate render update+ where+ window = FullScreen+ background = black+ fps = 60+ render xs = pictures $ map particleImage xs+ update _ = updateParticles+ ++-- | Generates particles from StdGen+generateParticles :: StdGen -> Int -> Int -> [Particle]+generateParticles gen widthInt heightInt + = map (g . f) tups+ where+ -- change range [0,1] -> [-s/2,s/2]+ f = \(x,y) -> (x * width - width / 2, y * height - height / 2) ++ -- add speed of 0+ g = \(x,y) -> (x,y,0,0) ++ -- 200 Random float tuples+ tups = take 50 $ zip randoms1 randoms2 + randoms1 = randoms gen1 :: [Float]+ randoms2 = randoms gen2 :: [Float]+ (gen1,gen2) = split gen+ width = toEnum widthInt+ height = toEnum heightInt+++-- | Particle to its picture+particleImage :: Particle -> Picture+particleImage (x,y,_,_) + = translate x y $ color white $ circleSolid 2+++-- | To update particles for next frame+updateParticles :: Float -> [Particle] -> [Particle]+updateParticles dt + = (accelerateParticles dt) . (moveParticles dt)+++-- | Moves particles based on their speed+moveParticles :: Float -> [Particle] -> [Particle]+moveParticles dt + = map (\(x,y,dx,dy) -> (x+dx*dt,y+dy*dt,dx,dy))+++-- | Accelerates particles based on gravity+accelerateParticles :: Float -> [Particle] -> [Particle]+accelerateParticles dt ps + = map (gravitate ps dt) ps+++-- | Given particles to be gravitating to and for how long,+-- updates a single particle's speed +gravitate :: [Particle] -> Float -> Particle -> Particle+gravitate [] _ p = p+gravitate ((x',y',_,_):ps) dt p@(x,y,dx,dy) + = -- To dodge divByZero or near divByZero anomalies+ if separated x x' && separated y y' + then gravitate ps dt p'+ else gravitate ps dt p+ where+ p' = (x,y,dx+ddx,dy+ddy)+ ddx = dirx * g+ ddy = diry * g+ (dirx,diry) = direction (x,y) (x',y')+ g = gravitation (x,y) (x',y')+ ++-- | Normalized vector from one point to another.+direction :: (Float, Float) -> (Float, Float) -> (Float, Float)+direction (x,y) (x',y') + = (dx * scale', dy * scale')+ where+ dx = x' - x+ dy = y' - y+ scale' = 1 / sqrt (dx ^ (2 :: Int) + dy ^ (2 :: Int))+ ++-- | Checks if floats not too close to each other+separated :: Float -> Float -> Bool+separated x y + = 0.001 < abs (x - y)+++-- | Gravitational force of one particle to another+gravitation :: (Float,Float) -> (Float,Float) -> Float+gravitation (x,y) (x',y') + = g / sqrt (dx ^ (2 :: Int) + dy ^ (2 :: Int))+ where dx = x' - x+ dy = y' - y+ g = 1+
raster/Crystal/Main.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE BangPatterns #-} + -- Quasicrystals demo. -- -- Based on code from:@@ -16,11 +18,11 @@ config <- parseArgs args defaultConfig let display- = case configFullScreen config of- True -> FullScreen (configSizeX config, configSizeY config)- False -> InWindow "Crystal" - (configSizeX config, configSizeY config)- (10, 10)+ = if configFullScreen config+ then FullScreen+ else InWindow "Crystal"+ (configSizeX config, configSizeY config)+ (10, 10) let scale = fromIntegral $ configScale config animateField display@@ -55,13 +57,9 @@ | [] <- args = return config - | "-fullscreen" : sizeX : sizeY : rest <- args- , all isDigit sizeX- , all isDigit sizeY+ | "-fullscreen" : rest <- args = parseArgs rest- $ config { configSizeX = read sizeX- , configSizeY = read sizeY- , configFullScreen = True }+ $ config { configFullScreen = True } | "-window" : sizeX : sizeY : rest <- args , all isDigit sizeX@@ -90,12 +88,11 @@ = do printUsage exitWith $ ExitFailure 1 - printUsage :: IO () printUsage = putStr $ unlines [ "quazicrystal [flags]"- , " -fullscreen sizeX sizeY Run full screen"+ , " -fullscreen Run full screen" , " -window sizeX sizeY Run in a window (default 800, 600)" , " -zoom <NAT> Pixel replication factor (default 5)" , " -scale <NAT> Feature size of visualisation (default 30)"
raster/Mandel/Main.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} import Graphics.Gloss.Interface.IO.Game+import Graphics.Gloss.Interface.Environment import Solver import Data.Array.Repa.IO.BMP import System.Exit@@ -13,10 +14,15 @@ main = do args <- getArgs config <- parseArgs args defaultConfig++ (width,height) + <- if configDisplay config == FullScreen+ then getScreenSize+ else return (configSizeX config, configSizeY config)+ let world = configPreset config- $ (initWorld (configSizeX config)- (configSizeY config))- { worldPixelsDynamic = configPixelsDynamic config}+ $ (initWorld width height)+ { worldPixelsDynamic = configPixelsDynamic config} case configFileName config of -- Run interactively.@@ -65,13 +71,9 @@ | [] <- args = return config - | "-fullscreen" : sizeX : sizeY : rest <- args- , all isDigit sizeX- , all isDigit sizeY+ | "-fullscreen" : rest <- args = parseArgs rest - $ config { configDisplay = FullScreen (read sizeX, read sizeY) - , configSizeX = read sizeX- , configSizeY = read sizeY }+ $ config { configDisplay = FullScreen } | "-window" : sizeX : sizeY : rest <- args , all isDigit sizeX@@ -104,12 +106,13 @@ = do printUsage exitWith $ ExitFailure 1 + printUsage :: IO () printUsage = putStrLn $ unlines [ "Usage: gloss-mandel [flags]"- , " -fullscreen <width::INT> <height::INT>"+ , " -fullscreen" , " -window <width::INT> <height::INT>" , " -bmp <width::INT> <height::INT> <FILE>" , " -dynamic <INT> Level of detail reduction when zooming and panning. (4) "