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.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 diff --git a/picture/Gravity/Main.hs b/picture/Gravity/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Gravity/Main.hs @@ -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 + diff --git a/raster/Crystal/Main.hs b/raster/Crystal/Main.hs --- a/raster/Crystal/Main.hs +++ b/raster/Crystal/Main.hs @@ -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 Pixel replication factor (default 5)" , " -scale Feature size of visualisation (default 30)" diff --git a/raster/Mandel/Main.hs b/raster/Mandel/Main.hs --- a/raster/Mandel/Main.hs +++ b/raster/Mandel/Main.hs @@ -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 " + , " -fullscreen" , " -window " , " -bmp " , " -dynamic Level of detail reduction when zooming and panning. (4) "