gloss-examples 1.11.1.1 → 1.12.0.0
raw patch · 59 files changed
+1089/−845 lines, 59 filesdep ~basedep ~glossdep ~gloss-algorithmsnew-uploader
Dependency ranges changed: base, gloss, gloss-algorithms, gloss-raster
Files
- gloss-examples.cabal +394/−199
- picture/Bitmap/Main.hs +6/−3
- picture/Boids/KDTree2d.hs +19/−19
- picture/Boids/Main.hs +42/−40
- picture/Boids/Vec2.hs +2/−2
- picture/Clock/Main.hs +13/−9
- picture/Color/Main.hs +8/−4
- picture/Conway/Cell.hs +20/−20
- picture/Conway/Main.hs +15/−14
- picture/Conway/World.hs +23/−21
- picture/Draw/Main.hs +9/−6
- picture/Easy/Main.hs +5/−0
- picture/Eden/Cell.hs +8/−8
- picture/Eden/Community.hs +3/−3
- picture/Eden/Main.hs +2/−2
- picture/Eden/World.hs +8/−7
- picture/Flake/Main.hs +11/−9
- picture/GameEvent/Main.hs +4/−1
- picture/Graph/Main.hs +47/−46
- picture/Gravity/Main.hs +23/−20
- picture/Hello/Main.hs +6/−3
- picture/Lifespan/Cell.hs +3/−3
- picture/Lifespan/Community.hs +2/−2
- picture/Lifespan/Main.hs +7/−9
- picture/Lifespan/World.hs +7/−6
- picture/Machina/Main.hs +17/−9
- picture/Occlusion/Cell.hs +4/−5
- picture/Occlusion/Data.hs +2/−0
- picture/Occlusion/Main.hs +23/−23
- picture/Occlusion/State.hs +4/−3
- picture/Occlusion/World.hs +20/−22
- picture/Styrene/Actor.hs +3/−3
- picture/Styrene/Advance.hs +24/−28
- picture/Styrene/Collide.hs +29/−30
- picture/Styrene/Contact.hs +25/−26
- picture/Styrene/Main.hs +20/−21
- picture/Styrene/QuadTree.hs +15/−14
- picture/Styrene/World.hs +11/−11
- picture/Tree/Main.hs +8/−7
- picture/Visibility/Draw.hs +16/−16
- picture/Visibility/Geometry/Randomish.hs +12/−12
- picture/Visibility/Geometry/Segment.hs +9/−11
- picture/Visibility/Interface.hs +2/−2
- picture/Visibility/Main.hs +1/−1
- picture/Visibility/State.hs +3/−3
- picture/Visibility/World.hs +8/−8
- picture/Zen/Main.hs +8/−8
- raster/Crystal/Main.hs +13/−13
- raster/Mandel/Main.hs +28/−26
- raster/Mandel/Solver.hs +14/−11
- raster/Pulse/Main.hs +4/−3
- raster/Ray/Light.hs +4/−4
- raster/Ray/Main.hs +26/−24
- raster/Ray/Object.hs +18/−18
- raster/Ray/Trace.hs +9/−9
- raster/Ray/Vec3.hs +3/−3
- raster/Ray/World.hs +7/−7
- raster/Snow/Main.hs +5/−2
- raster/Wave/Main.hs +7/−6
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.11.1.1+Version: 1.12.0.0 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -10,284 +10,457 @@ Category: Graphics Homepage: http://gloss.ouroborus.net Bug-reports: gloss@ouroborus.net-Description: - Examples using the gloss graphics library.+Description:+ Examples using the gloss graphics library. A mixed bag of fractals, particle simulations and cellular automata. Synopsis: Examples using the gloss library Flag llvm- Description: Compile via LLVM. This produces much better object code,+ Description: Compile via LLVM. This produces much better object code but your GHC needs to have been built against the LLVM compiler. Default: False source-repository head- type: git- location: https://github.com/benl23x5/gloss+ type: git+ location: https://github.com/benl23x5/gloss +source-repository this+ type: git+ tag: v1.12.0.0+ location: https://github.com/benl23x5/gloss+ Executable gloss-bitmap- Build-depends:- base >= 4.8 && < 4.10,- bytestring == 0.10.*,- bmp == 1.2.*,- gloss == 1.11.*- Main-is: Main.hs+ Main-is: Main.hs hs-source-dirs: picture/Bitmap- ghc-options: -threaded -O2+ Build-depends:+ base >= 4.8 && < 4.12+ , bytestring == 0.10.*+ , bmp == 1.2.*+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts + Executable gloss-boids- Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs- other-modules: KDTree2d Vec2 hs-source-dirs: picture/Boids- ghc-options: -threaded -O2 + other-modules:+ Vec2+ KDTree2d + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-clock- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Clock- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-color- Build-depends: - base >= 4.8 && < 4.10,- vector == 0.11.*,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Color- ghc-options: -threaded -O2- extensions: ParallelListComp + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , vector >= 0.11 && < 0.13 + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-conway- Build-depends: - base >= 4.8 && < 4.10,- vector == 0.11.*,- gloss == 1.11.* Main-is: Main.hs- other-modules: Cell World hs-source-dirs: picture/Conway- ghc-options: -threaded -O2 + other-modules:+ Cell+ World -Executable gloss-draw Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.*+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , vector >= 0.11 && < 0.13++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts+++Executable gloss-draw Main-is: Main.hs hs-source-dirs: picture/Draw- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-easy- Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Easy- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-eden- Build-depends: - base >= 4.8 && < 4.10,- random == 1.1.*,- gloss == 1.11.* Main-is: Main.hs- other-modules: Cell Community World hs-source-dirs: picture/Eden- ghc-options: -threaded -O2 + other-modules:+ Cell+ Community+ World -Executable gloss-flake Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.*+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , random == 1.1.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts+++Executable gloss-flake Main-is: Main.hs hs-source-dirs: picture/Flake- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-gameevent- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/GameEvent- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-hello- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Hello- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-lifespan- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.*,- random == 1.1.* Main-is: Main.hs- other-modules: Cell Community World hs-source-dirs: picture/Lifespan- ghc-options: -threaded -O2 + other-modules:+ Cell+ Community+ World + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , random == 1.1.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-machina- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Machina- ghc-options: -threaded -O2- + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-occlusion- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.*,- gloss-algorithms == 1.11.* Main-is: Main.hs- other-modules: Cell World State Data hs-source-dirs: picture/Occlusion- ghc-options: -threaded -O2 + other-modules:+ Cell+ World+ State+ Data + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , gloss-algorithms == 1.12.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-styrene- Build-depends: - base >= 4.8 && < 4.10,- ghc-prim >= 0.4 && < 0.6,- containers == 0.5.*,- gloss == 1.11.* Main-is: Main.hs- other-modules: Actor Advance Collide Config Contact QuadTree World hs-source-dirs: picture/Styrene- ghc-options: -threaded -O2 + other-modules:+ Actor+ Advance+ Collide+ Config+ Contact+ QuadTree+ World + Build-depends:+ base >= 4.8 && < 4.12+ , containers == 0.5.*+ , ghc-prim+ , gloss == 1.12.*++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-tree- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Tree- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-visibility- Build-depends: - base >= 4.8 && < 4.10,- vector == 0.11.*,- gloss == 1.11.* Main-is: Main.hs- other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment- hs-source-dirs: picture/Visibility - ghc-options: -threaded -O2+ hs-source-dirs: picture/Visibility + other-modules:+ Draw+ Geometry.Randomish+ Geometry.Segment+ Interface+ State+ World + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , vector >= 0.11 && < 0.13++ ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-zen- Build-depends: - base >= 4.8 && < 4.10,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Zen- ghc-options: -threaded -O2 + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.* + ghc-options:+ -O2+ -Wall+ -threaded+ -rtsopts++ Executable gloss-crystal- Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.*,- gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Crystal - extensions:- PatternGuards- BangPatterns+ Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , gloss-raster == 1.12.* - ghc-options: - -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case+ ghc-options:+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 - Executable gloss-ray- Build-depends:- base >= 4.8 && < 4.10,- repa == 3.4.*,- repa-io == 3.4.*,- gloss == 1.11.*,- gloss-raster == 1.11.* Main-is: Main.hs- other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray- ghc-options: - -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case++ other-modules:+ Light+ Object+ Trace+ Vec3+ World++ Build-depends:+ base >= 4.8 && < 4.12+ , repa == 3.4.*+ , repa-io == 3.4.*+ , gloss == 1.12.*+ , gloss-raster == 1.12.*++ ghc-options:+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 Executable gloss-pulse- Build-depends:- base >= 4.8 && < 4.10,- gloss == 1.11.*,- gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Pulse++ Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , gloss-raster == 1.12.*+ ghc-options:- -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 Executable gloss-wave- Build-depends:- base >= 4.8 && < 4.10,- ghc-prim == 0.5.*,- vector == 0.11.*,- gloss == 1.11.*,- gloss-raster == 1.11.* Main-is: Main.hs hs-source-dirs: raster/Wave++ Build-depends:+ base >= 4.8 && < 4.12+ , ghc-prim+ , gloss == 1.12.*+ , gloss-raster == 1.12.*+ , vector >= 0.11 && < 0.13+ ghc-options:- -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 -- Disabled on 8/11/2016 as the linear solver is taking too long to build.@@ -296,111 +469,133 @@ -- -- Executable gloss-fluid -- Build-depends:--- base >= 4.8 && < 4.10,--- ghc-prim == 0.5.*,--- vector == 0.11.*,--- repa == 3.4.*,--- repa-io == 3.4.*,--- repa-algorithms == 3.4.*,--- gloss == 1.11.*+-- base >= 4.8 && < 4.12+-- ghc-prim+-- vector == 0.11.*+-- repa == 3.4.*+-- repa-io == 3.4.*+-- repa-algorithms == 3.4.*+-- gloss == 1.12.* -- Main-is: Main.hs--- other-modules: +-- other-modules: -- Args Config FieldElt Model UserEvent -- Solve.Density Solve.Velocity -- Stage.Advection Stage.Boundary Stage.Diffusion -- Stage.Linear Stage.Project Stage.Sources -- hs-source-dirs: raster/Fluid/src-repa--- --- extensions:--- PatternGuards--- +-- -- ghc-options: -- -Wall -threaded -rtsopts -eventlog -- -Odph -fno-liberate-case -- -funfolding-use-threshold1000 -- -funfolding-keeness-factor1000--- +-- -- if flag(llvm) -- ghc-options: -- -fllvm -optlo-O3 - + Executable gloss-snow- Build-depends:- base >= 4.8 && < 4.10,- repa == 3.4.*,- repa-algorithms == 3.4.*,- gloss == 1.11.*- Main-is: Main.hs+ Main-is: Main.hs hs-source-dirs: raster/Snow++ Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , repa == 3.4.*+ , repa-algorithms == 3.4.*+ ghc-options:- -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 Executable gloss-mandel- Build-depends:- base >= 4.8 && < 4.10,- repa == 3.4.*,- gloss == 1.11.* Main-is: Main.hs- other-modules: Solver hs-source-dirs: raster/Mandel - extensions:- PatternGuards+ other-modules:+ Solver + Build-depends:+ base >= 4.8 && < 4.12+ , gloss == 1.12.*+ , repa == 3.4.*+ ghc-options:- -Wall -threaded -rtsopts -eventlog- -Odph -fno-liberate-case+ -Wall+ -threaded+ -rtsopts+ -eventlog+ -Odph+ -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(llvm)- ghc-options:- -fllvm -optlo-O3-+ if flag(llvm)+ ghc-options:+ -fllvm+ -optlo-O3 Executable gloss-graph- Build-depends:- base >= 4.8 && < 4.10,- containers == 0.5.*,- gloss == 1.11.* Main-is: Main.hs hs-source-dirs: picture/Graph++ Build-depends:+ base >= 4.8 && < 4.12+ , containers == 0.5.*+ , gloss == 1.12.*+ ghc-options:- -Wall -O2+ -O2+ -Wall+ -threaded+ -rtsopts 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++ Build-depends:+ base >= 4.8 && < 4.12+ , containers == 0.5.*+ , gloss == 1.12.*+ ghc-options:- -Wall -O2+ -O2+ -Wall+ -threaded+ -rtsopts -- 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.11.*,--- gloss-rendering == 1.11.*,+-- base >= 4.8 && < 4.12+-- containers == 0.5.*+-- gloss == 1.12.*+-- gloss-rendering == 1.12.* -- GLFW-b -- Main-is: Main.hs -- hs-source-dirs: picture/Render -- ghc-options:--- -Wall -O2+-- -O2+-- -Wall+-- -threaded+-- -rtsopts +-- vim: nospell
picture/Bitmap/Main.hs view
@@ -1,17 +1,20 @@ +module Main where+ import Graphics.Gloss-import Codec.BMP import System.Environment -- | Displays uncompressed 24/32 bit BMP images.+main :: IO () main = do args <- getArgs case args of [fileName] -> run fileName- _ -> putStr + _ -> putStr $ unlines [ "usage: bitmap <file.bmp>" , " file.bmp should be a 24 or 32-bit uncompressed BMP file" ] +run :: FilePath -> IO () run fileName = do picture@(Bitmap width height _ _) <- loadBMP fileName@@ -22,6 +25,6 @@ frame :: Int -> Int -> Picture -> Float -> Picture frame width height picture t = Color (greyN (abs $ sin (t * 2)))- $ Pictures + $ Pictures [rectangleSolid (fromIntegral width) (fromIntegral height) , picture]
picture/Boids/KDTree2d.hs view
@@ -19,7 +19,7 @@ import System.IO -data KDTreeNode a +data KDTreeNode a = Empty | Node !(KDTreeNode a) !Vec2 !a !(KDTreeNode a) deriving Show@@ -42,10 +42,10 @@ kdtAddWithDepth :: KDTreeNode a -> Vec2 -> a -> Int -> KDTreeNode a-kdtAddWithDepth Empty pos dat _ +kdtAddWithDepth Empty pos dat _ = Node Empty pos dat Empty -kdtAddWithDepth (Node left npos ndata right) pos dat d +kdtAddWithDepth (Node left npos ndata right) pos dat d | vecDimSelect pos d < vecDimSelect npos d = Node (kdtAddWithDepth left pos dat d') npos ndata right @@ -55,10 +55,10 @@ kdtAddPoint :: KDTreeNode a -> Vec2 -> a -> KDTreeNode a-kdtAddPoint t p d +kdtAddPoint t p d = kdtAddWithDepth t p d 0 -kdtInBounds p bMin bMax +kdtInBounds p bMin bMax = vecLessThan p bMax && vecGreaterThan p bMin @@ -73,7 +73,7 @@ = nextfun left bMin bMax | kdtInBounds npos bMin bMax- = (npos, ndata) + = (npos, ndata) : (nextfun right bMin bMax ++ nextfun left bMin bMax) | otherwise@@ -91,10 +91,10 @@ kdtRangeSearchRecY (Node left npos ndata right) bMin bMax | nc < mnc = nextfun right bMin bMax- + | nc > mxc = nextfun left bMin bMax- + | (kdtInBounds npos bMin bMax) = (npos, ndata) : (nextfun right bMin bMax ++ nextfun left bMin bMax)@@ -109,13 +109,13 @@ kdtRangeSearch :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2,a)]-kdtRangeSearch t bMin bMax +kdtRangeSearch t bMin bMax = kdtRangeSearchRecX t bMin bMax kdtAddPoints :: [(Vec2,a)] -> (KDTreeNode a) -> (KDTreeNode a) kdtAddPoints [] t = t-kdtAddPoints ((pt, dat):ps) t +kdtAddPoints ((pt, dat):ps) t = kdtAddPoints ps $ kdtAddPoint t pt dat @@ -123,7 +123,7 @@ singleCollision pt start a eps dat | sqrd_dist < eps * eps = Just (vecAdd start p, dat)- + | otherwise = Nothing @@ -135,8 +135,8 @@ kdtCollisionDetect :: KDTreeNode a -> Vec2 -> Vec2 -> Double -> [(Vec2,a)]-kdtCollisionDetect root !start !end !eps - = colls +kdtCollisionDetect root !start !end !eps+ = colls where Vec2 sx sy = start Vec2 ex ey = end rmin = Vec2 (min sx ex - eps) (min sy ey - eps)@@ -144,12 +144,12 @@ pts = kdtRangeSearch root rmin rmax a = vecSub end start colls = mapMaybe (\(pt,dat) -> singleCollision pt start a eps dat) pts- - ++ -- Dumping -------------------------------------------------------------------- -- | Dump a KDTree to a file dumpKDTree :: KDTreeNode Int -> FilePath -> IO ()-dumpKDTree kdt name +dumpKDTree kdt name = do h <- openFile name WriteMode hPutStrLn h "n x y z" dumpKDTreeInner kdt h@@ -158,11 +158,11 @@ -- | Dump a KDTree to a handle. dumpKDTreeInner :: KDTreeNode Int -> Handle -> IO ()-dumpKDTreeInner kdt h +dumpKDTreeInner kdt h = case kdt of Empty -> return () - Node l v d r + Node l v d r -> do printVec v h d dumpKDTreeInner l h dumpKDTreeInner r h@@ -170,6 +170,6 @@ -- | Print a vector to a handle. printVec :: Vec2 -> Handle -> Int -> IO ()-printVec (Vec2 x y) h i +printVec (Vec2 x y) h i = hPutStrLn h $ show i ++ " " ++ show x ++ " " ++ show y
picture/Boids/Main.hs view
@@ -1,9 +1,11 @@--- Implementation of the Boids flocking algorithm. +-- Implementation of the Boids flocking algorithm. -- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org> -- Described in http://syntacticsalt.com/2011/03/10/functional-flocks/ -- -- Read more about Boids here: http://www.red3d.com/cwr/boids/--- +--+module Main where+ import KDTree2d import Vec2 import System.Random@@ -59,7 +61,7 @@ -- Main ----------------------------------------------------------------------- main :: IO ()-main +main = do let w = World { width = maxx - minx , height = maxy - miny , pixWidth = 700@@ -74,7 +76,7 @@ -- Coordinate Conversion ------------------------------------------------------ modelToScreen :: World -> (Double, Double) -> (Float, Float)-modelToScreen world (x,y) +modelToScreen world (x,y) = let xscale = fromIntegral (pixWidth world) / width world yscale = fromIntegral (pixHeight world) / height world in (realToFrac $ x * xscale, realToFrac $ y * yscale)@@ -97,7 +99,7 @@ = Pictures $ mapKDTree bs (renderboid world) renderboid :: World -> Boid -> Picture-renderboid world b +renderboid world b = let (Vec2 x y) = position b (Vec2 vx vy) = velocity b v = velocity b@@ -111,8 +113,8 @@ vxs = sf * (realToFrac vx) :: Float vys = sf * (realToFrac vy) :: Float - in Pictures - [ Color boidColor $ + in Pictures+ [ Color boidColor $ Translate xs ys $ Circle 2 @@ -120,7 +122,7 @@ Translate xs ys $ Circle ((realToFrac epsilon) * sf') - , Color boidColor $ + , Color boidColor $ Line [(xs, ys), (xs + vxs, ys + vys)] , Color cohesionColor $@@ -135,23 +137,23 @@ -- Initialisation ------------------------------------------------------------- rnlist :: Int -> IO [Double]-rnlist n +rnlist n = mapM (\_ -> randomRIO (0.0,1.0)) [1..n] initialize :: Int -> Double -> Double -> [Boid]-initialize n sp sv - = let nums = unsafePerformIO $ rnlist (n*6) +initialize n sp sv+ = let nums = unsafePerformIO $ rnlist (n*6) nums' = map (\i -> (0.5 - i) / 2.0) nums makeboids [] [] = []- makeboids (a:b:c:d:e:f:rest) (id:ids) + makeboids (a:b:c:d:e:f:rest) (id:ids) = Boid { identifier = id , velocity = Vec2 (a*sv) (b*sv) , position = Vec2 (d*sp) (e*sp) , dbgC = vecZero , dbgS = vecZero- , dbgA = vecZero} + , dbgA = vecZero} : makeboids rest ids in makeboids nums' [1..n]@@ -172,7 +174,7 @@ -- Boids Logic ---------------------------------------------------------------- --- three rules: +-- three rules: -- cohesion (seek centroid) -- separation (avoid neighbors), -- and alignment (fly same way as neighbors)@@ -182,7 +184,7 @@ -- boid positions scaled by 1/(number of boids) findCentroid :: [Boid] -> Vec2 findCentroid [] = error "Bad centroid"-findCentroid boids +findCentroid boids = let n = length boids in vecScale (foldl1 vecAdd (map position boids)) (1.0 / (fromIntegral n))@@ -194,8 +196,8 @@ where c = findCentroid boids p = position b diff = vecSub c p- + -- | separation: avoid neighbours separation :: Boid -> [Boid] -> Double -> Vec2 separation b [] a = vecZero@@ -209,7 +211,7 @@ -- | alignment: fly the same way as neighbours alignment :: Boid -> [Boid] -> Double -> Vec2 alignment b [] a = vecZero-alignment b boids a +alignment b boids a = let v = foldl1 vecAdd (map velocity boids) s = 1.0 / (fromIntegral $ length boids) v' = vecScale v s@@ -218,7 +220,7 @@ -- | Move one boid, with respect to its neighbours. oneboid :: Boid -> [Boid] -> Boid-oneboid b boids +oneboid b boids = let c = cohesion b boids cParam s = separation b boids sParam a = alignment b boids aParam@@ -254,17 +256,17 @@ -- be very large (approx. the width of the world). findNeighbors :: KDTreeNode Boid -> Boid -> [Boid]-findNeighbors w b +findNeighbors w b = let p = position b- + -- bounds vlo = vecSub p epsvec vhi = vecAdd p epsvec- + -- split the boxes splith = splitBoxHoriz (vlo, vhi, 0.0, 0.0) splitv = concatMap splitBoxVert splith- + -- adjuster for wraparound adj1 ax ay (pos, theboid) = (vecAdd pos av, theboid { position = vecAdd p av })@@ -272,53 +274,53 @@ where av = Vec2 ax ay p = position theboid - adjuster lo hi ax ay + adjuster lo hi ax ay = let neighbors = kdtRangeSearch w lo hi in map (adj1 ax ay) neighbors- + -- do the sequence of range searches ns = concatMap (\(lo,hi,ax,ay) -> adjuster lo hi ax ay) splitv- + -- compute the distances from boid b to members dists = map (\(np,n) -> (vecNorm (vecSub p np), n)) ns in b : map snd (filter (\(d,_) -> d <= epsilon) dists) -splitBoxHoriz - :: (Vec2, Vec2, Double, Double) +splitBoxHoriz+ :: (Vec2, Vec2, Double, Double) -> [(Vec2, Vec2, Double, Double)]- -splitBoxHoriz (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) ++splitBoxHoriz (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) | hx-lx > w = [(Vec2 minx ly, Vec2 maxx hy, ax, ay)]- + | lx < minx = [ (Vec2 minx ly, Vec2 hx hy, ax, ay) , (Vec2 (maxx-(minx-lx)) ly, Vec2 maxx hy, (ax-w), ay)]- + | hx > maxx = [ (Vec2 lx ly, Vec2 maxx hy, ax, ay) , (Vec2 minx ly, Vec2 (minx + (hx-maxx)) hy, ax+w, ay)]- + | otherwise = [(lo, hi, ax, ay)] where w = maxx-minx -splitBoxVert +splitBoxVert :: (Vec2, Vec2, Double, Double) -> [(Vec2, Vec2, Double, Double)] -splitBoxVert (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) +splitBoxVert (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) | hy-ly > h = [(Vec2 lx miny, Vec2 hx maxy, ax, ay)]- + | ly < miny = [ (Vec2 lx miny, Vec2 hx hy, ax, ay) , (Vec2 lx (maxy-(miny-ly)), Vec2 hx maxy, ax, ay-h) ]- + | hy > maxy = [ (Vec2 lx ly, Vec2 hx maxy, ax, ay) , (Vec2 lx miny, Vec2 hx (miny + (hy-maxy)), ax, ay+h) ]@@ -330,7 +332,7 @@ wraparound :: Vec2 -> Vec2-wraparound (Vec2 x y) +wraparound (Vec2 x y) = let w = maxx-minx h = maxy-miny x' = if x > maxx then x - w else (if x < minx then x+w else x)@@ -338,16 +340,16 @@ in Vec2 x' y' - + iteration :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid-iteration vp step w +iteration vp step w = let all = kdtreeToList w boids = mapKDTree w (\i -> oneboid i all) in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids iterationkd :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid-iterationkd vp step w +iterationkd vp step w = let boids = mapKDTree w (\i -> oneboid i (findNeighbors w i)) in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids
picture/Boids/Vec2.hs view
@@ -1,8 +1,8 @@- {-# LANGUAGE BangPatterns #-}+ module Vec2 where -data Vec2 +data Vec2 = Vec2 {-# UNPACK #-}!Double {-# UNPACK #-}!Double deriving Show
picture/Clock/Main.hs view
@@ -1,8 +1,12 @@ -- A fractal consisting of circles and lines which looks a bit like -- the workings of a clock.+module Main where+ import Graphics.Gloss+import Prelude hiding ( lines ) +main :: IO () main = animate (InWindow "Clock" (600, 600) (20, 20)) black frame@@ -16,8 +20,8 @@ $ Scale 120 120 $ Rotate (time * 2*pi) $ clockFractal 5 time- + -- The basic fractal consists of three circles offset from the origin -- as follows. --@@ -31,7 +35,7 @@ -- Components at higher iterations also spin faster. -- clockFractal :: Int -> Float -> Picture-clockFractal 0 s = Blank+clockFractal 0 _ = Blank clockFractal n s = Pictures [circ1, circ2, circ3, lines] where -- y offset from origin to center of circle 1.@@ -46,27 +50,27 @@ else (-50 * s * (log (1 + nf))) -- each element contains a copy of the (n-1) iteration contained- -- within a larger circle, and some text showing the time since + -- within a larger circle, and some text showing the time since -- the animation started. --- circNm1 + circNm1 = Pictures [ circle 1 , Scale (a/2.5) (a/2.5) $ clockFractal (n-1) s , if n > 2- then Color cyan + then Color cyan $ Translate (-0.15) 1- $ Scale 0.001 0.001 - $ Text (show s) + $ Scale 0.001 0.001+ $ Text (show s) else Blank ] circ1 = Translate 0 a $ Rotate rot circNm1 circ2 = Translate 1 (-b) $ Rotate (-rot) circNm1 circ3 = Translate (-1) (-b) $ Rotate rot circNm1- + -- join each iteration to the origin with some lines.- lines + lines = Pictures [ Line [(0, 0), ( 0, a)] , Line [(0, 0), ( 1, -b)]
picture/Color/Main.hs view
@@ -1,18 +1,22 @@+{-# LANGUAGE ParallelListComp #-} -- Draw a color wheel. import Graphics.Gloss -main - = display +main :: IO ()+main+ = display (InWindow "Colors" (800, 800) (5, 5)) (greyN 0.4)- (Pictures - [ Translate + (Pictures+ [ Translate (200 * cos (2 * pi * (fromIntegral n) / 12)) (200 * sin (2 * pi * (fromIntegral n) / 12)) $ Color (withAlpha 0.8 c) $ circleSolid 100 | n <- [0 .. length colors] | c <- colors ])++colors :: [ Color ] colors = [ red , orange
picture/Conway/Cell.hs view
@@ -1,11 +1,11 @@ module Cell where-import Graphics.Gloss +import Graphics.Gloss -- | A cell in the world. data Cell = -- | A living cell with its age- CellAlive Int + CellAlive Int -- | A dead / blank cell. | CellDead@@ -28,11 +28,11 @@ posY = fromIntegral posYi x1 = posX x2 = posX + cs- y1 = posY + y1 = posY y2 = posY + cs in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]- + -- | Convert a cell to a picture, based on a primitive shape. -- We pass the shape in to avoid recomputing it for each cell. pictureOfCell :: Int -> Int -> Int -> Int -> Cell -> Picture@@ -45,47 +45,47 @@ ageColor oldAge age = let (r, g, b) = rampColorHotToCold 0 (fromIntegral oldAge) (fromIntegral age) in makeColor r g b 1.0- - ++ -- Color Ramps ----------------------------------------------------------------------------------- -- | Standard Hot -> Cold hypsometric color ramp. -- Sequence is red, yellow, green, cyan, blue.-rampColorHotToCold - :: (Ord a, Floating a) - => a - -> a - -> a +rampColorHotToCold+ :: (Ord a, Floating a)+ => a+ -> a+ -> a -> (a, a, a)- + rampColorHotToCold vmin vmax vNotNorm- = let + = let v | vNotNorm < vmin = vmin | vNotNorm > vmax = vmax | otherwise = vNotNorm- - dv = vmax - vmin + dv = vmax - vmin+ result | v < vmin + 0.25 * dv = ( 0 , 4 * (v - vmin) / dv , 1.0)- + | v < vmin + 0.5 * dv = ( 0 , 1.0 , 1 + 4 * (vmin + 0.25 * dv - v) / dv)- + | v < vmin + 0.75 * dv = ( 4 * (v - vmin - 0.5 * dv) / dv , 1.0 , 0.0)- + | otherwise = ( 1.0 , 1 + 4 * (vmin + 0.75 * dv - v) / dv , 0)- + in result - +
picture/Conway/Main.hs view
@@ -1,42 +1,43 @@ module Main where+ import World import Cell import Graphics.Gloss import qualified Data.Vector as Vec main :: IO ()-main - = do +main+ = do let width = 150 let height = 100 world <- randomWorld (width, height)- - simulate (InWindow "John Conway's Game of Life" ++ simulate (InWindow "John Conway's Game of Life" (windowSizeOfWorld world) (5, 5)) white 10 world drawWorld simulateWorld- + -- | Convert a world to a picture. drawWorld- :: World + :: World -> Picture -drawWorld world - = let (windowWidth, windowHeight) +drawWorld world+ = let (windowWidth, windowHeight) = windowSizeOfWorld world- + offsetX = - fromIntegral windowWidth / 2- offsetY = - fromIntegral windowHeight / 2 + offsetY = - fromIntegral windowHeight / 2 in Translate offsetX offsetY- $ Pictures - $ Vec.toList + $ Pictures+ $ Vec.toList $ Vec.imap (drawCell world) (worldCells world) -- | Convert a cell at a particular coordinate to a picture. drawCell :: World -> Index -> Cell -> Picture-drawCell world index cell +drawCell world index cell = let cs = fromIntegral (worldCellSize world) cp = fromIntegral (worldCellSpace world) @@ -50,7 +51,7 @@ fx fy cell- + -- | Get the size of the window needed to display a world. windowSizeOfWorld :: World -> (Int, Int)
picture/Conway/World.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE PatternGuards, ParallelListComp, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-} module World where import Cell import System.Random import Control.Monad-import Graphics.Gloss import Graphics.Gloss.Interface.Pure.Simulate import qualified Data.Vector as Vec+ type Vec = Vec.Vector -- Index ----------------------------------------------------------------------@@ -17,21 +19,21 @@ type Coord = (Int, Int) indexOfCoord :: World -> Coord -> Index-indexOfCoord world (x, y) +indexOfCoord world (x, y) = x + y * (worldWidth world) coordOfIndex :: World -> Index -> Coord-coordOfIndex world i +coordOfIndex world i = ( i `mod` worldWidth world , i `div` worldWidth world) -- World -----------------------------------------------------------------------data World +data World = World- { worldCells :: Vec Cell - , worldWidth :: Int - , worldHeight :: Int + { worldCells :: Vec Cell+ , worldWidth :: Int+ , worldHeight :: Int -- | Width and height of each cell. , worldCellSize :: Int@@ -43,8 +45,8 @@ , worldCellOldAge :: Int -- | Seconds to wait between each simulation step.- , worldSimulationPeriod :: Float - + , worldSimulationPeriod :: Float+ -- | Time that has elapsed since we drew the last step , worldElapsedTime :: Float } @@ -52,15 +54,15 @@ -- | Make a new world of a particular size. randomWorld :: (Int, Int) -> IO World randomWorld (width, height)- = do bools <- replicateM (width * height) randomIO + = do bools <- replicateM (width * height) randomIO return $ World { worldCells = Vec.fromList $ map cellOfBool bools , worldWidth = width , worldHeight = height , worldCellSize = 5- , worldCellSpace = 1 + , worldCellSpace = 1 , worldCellOldAge = 20- , worldSimulationPeriod = 0.1 + , worldSimulationPeriod = 0.1 , worldElapsedTime = 0 } @@ -78,14 +80,14 @@ | x < 0 || x >= worldWidth world = CellDead | y < 0 || y >= worldHeight world = CellDead - | otherwise - = worldCells world Vec.! indexOfCoord world coord + | otherwise+ = worldCells world Vec.! indexOfCoord world coord --- | Get the neighbourhood of cells aroudn this coordinate.+-- | Get the neighbourhood of cells around this coordinate. getNeighbourhood :: World -> Coord -> [Cell] getNeighbourhood world (ix, iy)- = let indexes = [ (x, y) + = let indexes = [ (x, y) | x <- [ix - 1 .. ix + 1] , y <- [iy - 1 .. iy + 1] , not (x == ix && y == iy) ]@@ -108,22 +110,22 @@ neigh = getNeighbourhood world coord in stepCell cell neigh - + -- | Compute the next world state. stepWorld :: World -> World stepWorld world = world { worldCells = Vec.imap (stepIndex world) (worldCells world) } - + -- | Simulation function for worlds. simulateWorld :: ViewPort -> Float -> World -> World-simulateWorld _ time world +simulateWorld _ time world -- If enough time has passed then it's time to step the world. | worldElapsedTime world >= (worldSimulationPeriod world) = let world' = stepWorld world in world' { worldElapsedTime = 0 }- + -- Wait some more. | otherwise = world { worldElapsedTime = worldElapsedTime world + time }
picture/Draw/Main.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE PatternGuards #-}--- | Simple picture drawing application. +-- | Simple picture drawing application. -- Like MSPaint, but you can only draw lines.-import Graphics.Gloss.Interface.Pure.Game+--+module Main where+ import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Game import Data.Maybe (maybe)-import Debug.Trace -main +main :: IO ()+main = do let state = State Nothing [] play (InWindow "Draw" (600, 600) (0,0)) white 100 state@@ -15,7 +18,7 @@ -- | The game state.-data State +data State = State (Maybe Path) -- The current line being drawn. [Picture] -- All the lines drawn previously. @@ -36,7 +39,7 @@ -- If the mouse has moved, then extend the current line. | EventMotion (x, y) <- event , State (Just ps) ss <- state- = State (Just ((x, y):ps)) ss + = State (Just ((x, y):ps)) ss -- Start drawing a new line. | EventKey (MouseButton LeftButton) Down _ pt@(x,y) <- event
picture/Easy/Main.hs view
@@ -1,3 +1,8 @@ +module Main where+ import Graphics.Gloss++main :: IO () main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80)+
picture/Eden/Cell.hs view
@@ -2,10 +2,10 @@ import Graphics.Gloss -data Cell +data Cell = Cell Point -- centre Float -- radius- Int + Int deriving Show -- Produce a new cell of a certain relative radius at a certain angle.@@ -13,24 +13,24 @@ -- smaller than their parent. -- The check whether it fits in the community is elsewhere. offspring :: Cell -> Float -> Float -> Cell-offspring (Cell (x,y) r gen) alpha factor - = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha) - childR +offspring (Cell (x,y) r gen) alpha factor+ = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha)+ childR (gen + 1) where childR = factor * r --- Do two cells overlap? +-- Do two cells overlap? -- Used to decide if newly spawned cells can join the community. overlap :: Cell -> Cell -> Bool-overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) +overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) = centreDist < (r1 + r2) * 0.999 where centreDist = sqrt(xdiff*xdiff + ydiff*ydiff) xdiff = x1 - x2 ydiff = y1 - y2 render :: Cell -> Picture-render (Cell (x,y) r gen) +render (Cell (x,y) r gen) = let z = fromIntegral gen * 0.1 color = makeColor 0.0 z 0.5 1.0 in Color color
picture/Eden/Community.hs view
@@ -8,7 +8,7 @@ -- does a (newly spawned) cell fit in the community? -- that is, does it overlap with any others? fits :: Cell -> Community -> Bool-fits cell cells +fits cell cells = not $ any (overlap cell) cells -- For each member of a community, produce one offspring@@ -29,11 +29,11 @@ -- The next generation of a community generation :: Community -> [Float] -> [Float] -> Community-generation comm angles scales +generation comm angles scales = survive (spawn comm angles scales) comm render :: Community -> Picture-render comm +render comm = Pictures $ map Cell.render comm initial :: Community
picture/Eden/Main.hs view
@@ -3,11 +3,11 @@ module Main where import qualified World as W import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate import System.Random -- varying prng sequence-main +main :: IO ()+main = do gen <- getStdGen simulate (InWindow "Eden" (800, 600) (10, 10)) (greyN 0.1) -- background color
picture/Eden/World.hs view
@@ -6,31 +6,32 @@ import Community import Cell -maxSteps = 30+maxSteps :: Int+maxSteps = 30 -- The World consists of a Community and a random number generator. -- (The RNG is a model of chaos or hand-of-god.)-data World +data World = World Community StdGen Int deriving (Show) -- The initial world genesis :: World-genesis +genesis = World [Cell (0,0) 30 0] (mkStdGen 1023) 0 -- Seeding the prng means every run is identical. -- To get different runs, need to use gen <- getStdGen in main :: IO() -- and pass gen in as an argument. Edit Main.hs accordingly. genesis' :: StdGen -> World-genesis' gen +genesis' gen = World [Cell (0,0) 30 0] gen 0 -- Consume some random numbers to advance the simulation evolve :: ViewPort -> Float -> World -> World-evolve vp step world@(World comm gen steps) - | steps < maxSteps +evolve vp step world@(World comm gen steps)+ | steps < maxSteps = let (genThis, genNext) = split gen (genA, genS) = split genThis angles = randomRs (0.0, 2*pi) genA@@ -42,6 +43,6 @@ -- Converting the world to a picture is just converting the community component render :: World -> Picture-render (World comm gen steps) +render (World comm gen steps) = Color (makeColor 0.3 0.3 0.6 1.0) $ Community.render comm
picture/Flake/Main.hs view
@@ -4,41 +4,43 @@ -- import Graphics.Gloss +main :: IO () main = display (InWindow "Snowflake" (500, 500) (20, 20)) black (picture 3) -- Fix a starting edge length of 360-edge = 360 :: Float+edge :: Float+edge = 360 -- Move the fractal into the center of the window and colour it nicely picture :: Int -> Picture-picture degree +picture degree = Color aquamarine $ Translate (-edge/2) (-edge * sqrt 3/6) $ snowflake degree- + -- The fractal function side :: Int -> Picture side 0 = Line [(0, 0), (edge, 0)]-side n - = let newSide = Scale (1/3) (1/3) +side n+ = let newSide = Scale (1/3) (1/3) $ side (n-1) in Pictures [ newSide- , Translate (edge/3) 0 $ Rotate 60 newSide - , Translate (edge/2) (-(edge * sqrt 3)/6) $ Rotate (-60) newSide + , Translate (edge/3) 0 $ Rotate 60 newSide+ , Translate (edge/2) (-(edge * sqrt 3)/6) $ Rotate (-60) newSide , Translate (2 * edge/3) 0 $ newSide ] -- Put 3 together to form the snowflake snowflake :: Int -> Picture-snowflake n +snowflake n = let oneSide = side n in Pictures- [ oneSide + [ oneSide , Translate edge 0 $ Rotate (-120) $ oneSide , Translate (edge/2) (edge * sqrt 3/2) $ Rotate 120 $ oneSide]
picture/GameEvent/Main.hs view
@@ -1,7 +1,10 @@ +module Main where+ import Graphics.Gloss -- | Display the last event received as text.+main :: IO () main = play (InWindow "GameEvent" (700, 100) (10, 10)) white@@ -10,5 +13,5 @@ (\str -> Translate (-340) 0 $ Scale 0.1 0.1 $ Text str) (\event _ -> show event) (\_ world -> world)- +
picture/Graph/Main.hs view
@@ -12,6 +12,7 @@ import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Interface.Pure.Game+import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt type Vertex = Int type Edge = (Vertex, Vertex)@@ -20,7 +21,7 @@ -- Graph ---------------------------------------------------------------------- -- INVARIANT Every `Vertex` present in a set of neighbours is present as -- a key in the `Map`.-newtype Graph +newtype Graph = Graph {grNeighs :: Map Vertex (Set Vertex)} -- | An empty graph, with no edges or vertexes.@@ -30,19 +31,19 @@ -- | Add a new vertex to the graph. addVertex :: Vertex -> Graph -> Graph-addVertex v (Graph neighs) - = Graph +addVertex v (Graph neighs)+ = Graph $ case Map.lookup v neighs of Nothing -> Map.insert v Set.empty neighs Just _ -> neighs -- | Add a new edge to the graph. addEdge :: Edge -> Graph -> Graph-addEdge (v1, v2) gr +addEdge (v1, v2) gr = Graph neighs where gr' = addVertex v1 (addVertex v2 gr)- neighs = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr')) - $ Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) + neighs = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr'))+ $ Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) $ grNeighs gr' @@ -53,21 +54,21 @@ -- | Get the set of edges in a graoh. graphEdges :: Graph -> Set Edge-graphEdges +graphEdges = Map.foldrWithKey' foldNeighs Set.empty . grNeighs where -- For each vertex `v1`, insert an edge for each neighbour `v2`.- foldNeighs v1 ns es + foldNeighs v1 ns es = Set.foldr' (\v2 -> Set.insert (order (v1, v2))) es ns - order (v1, v2) + order (v1, v2) = if v1 > v2 then (v1, v2) else (v2, v1) -- Scene ---------------------------------------------------------------------- -- INVARIANT The keys in `scGraph` are the same as the keys in `scPoints`.-data Scene - = Scene +data Scene+ = Scene { scGraph :: Graph , scPoints :: Map Vertex Point , scSelected :: Maybe Vertex@@ -76,8 +77,8 @@ -- | An empty scene. emptyScene :: Scene-emptyScene - = Scene +emptyScene+ = Scene { scGraph = emptyGraph , scPoints = Map.empty , scSelected = Nothing@@ -92,7 +93,7 @@ -- | Add an edge to a scene. scAddEdge :: Edge -> Scene -> Scene-scAddEdge e@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} +scAddEdge e@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} = if Map.member v1 pts && Map.member v2 pts then sc{scGraph = addEdge e gr} else error "scAddEdge: non existant point!"@@ -100,14 +101,14 @@ -- | Randomize the endpoints of some edges, and pack them into a Scene. fromEdges :: StdGen -> [Edge] -> Scene-fromEdges gen es +fromEdges gen es = foldr scAddEdge (fst (Set.foldr' addv (emptyScene, gen) vs)) es where vs = Set.fromList (concat [[v1, v2] | (v1, v2) <- es]) halfWidth = fromIntegral (fst windowSize) / 2 halfHeight = fromIntegral (snd windowSize) / 2 - addv v (sc, gen1) + addv v (sc, gen1) = let (x, gen2) = randomR (-halfWidth, halfWidth ) gen1 (y, gen3) = randomR (-halfHeight, halfHeight) gen2 in (scAddVertex v (x, y) sc, gen3)@@ -115,7 +116,7 @@ -- Drawing -------------------------------------------------------------------- vertexPos :: Vertex -> Scene -> Point-vertexPos v Scene{scPoints = pts} +vertexPos v Scene{scPoints = pts} = pts Map.! v @@ -137,13 +138,13 @@ drawEdge :: Edge -> Scene -> Picture-drawEdge (v1, v2) sc +drawEdge (v1, v2) sc = Line [vertexPos v1 sc, vertexPos v2 sc] drawScene :: Scene -> Picture-drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} - = applyViewPortToPicture port +drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}}+ = applyViewPortToPicture port $ Pictures [Color edgeColor edges, Color vertexColor vertices] where vertices = Pictures [drawVertex n sc | n <- Map.keys (grNeighs gr) ]@@ -154,16 +155,16 @@ charge :: Float charge = 100000 -pushForce +pushForce :: Point -- Vertex we're calculating the force for -> Point -- Vertex pushing the other away -> Vector -pushForce v1 v2 +pushForce v1 v2 = -- If we are analysing the same vertex, l = 0- if l > 0 then (charge / l) `mulSV` normalizeV d - else 0- where d = v1 - v2+ if l > 0 then (charge / l) `mulSV` normalizeV d+ else (0, 0)+ where d = v1 Pt.- v2 l = magV d ** 2 @@ -171,19 +172,19 @@ stiffness = 1 / 2 pullForce :: Point -> Point -> Vector-pullForce v1 v2 - = stiffness `mulSV` (v2 - v1)+pullForce v1 v2+ = stiffness `mulSV` (v2 Pt.- v1) -- | Apply forces to update the position of a single point.-updatePosition +updatePosition :: Float -- Time since the last update -> Vertex -- Vertex we are analysing -> Scene -> Point -- New position -updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} - = v1pos + pull + push+updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr}+ = v1pos Pt.+ pull Pt.+ push where v1pos = vertexPos v1 sc @@ -193,19 +194,19 @@ -- Sum all the pushing and pulling. All the other vertices push, -- the connected vertices pull.- push = Map.foldr' (\v2pos -> (getVel pushForce v2pos +)) 0 pts- pull = foldr (\v2pos -> (getVel pullForce v2pos +)) 0+ push = Map.foldr' (\v2pos -> (getVel pushForce v2pos Pt.+)) (0, 0) pts+ pull = foldr (\v2pos -> (getVel pullForce v2pos Pt.+)) (0, 0) [vertexPos v2 sc | v2 <- Set.toList (vertexNeighs v1 gr)] -- | Apply forces to update the position of all the points. updatePositions :: Float -> Scene -> Scene-updatePositions dt sc@Scene{scSelected = sel, scGraph = Graph neighs} +updatePositions dt sc@Scene{scSelected = sel, scGraph = Graph neighs} = foldr f sc (Map.keys neighs) where- f n sc' - = let pt = if Just n == sel - then vertexPos n sc + f n sc'+ = let pt = if Just n == sel+ then vertexPos n sc else updatePosition dt n sc' in scAddVertex n pt sc' @@ -215,8 +216,8 @@ -> Float -- The scaling factor in the ViewPort -> Point -- The position of the vertex -> Bool-inCircle p sca v - = magV (v - p) <= vertexRadius * sca+inCircle p sca v+ = magV (v Pt.- p) <= vertexRadius * sca findVertex :: Point -> Float -> Scene -> Maybe Vertex@@ -228,24 +229,24 @@ -- Events --------------------------------------------------------------------- handleEvent :: Event -> Scene -> Scene-handleEvent (EventKey (MouseButton LeftButton) Down Modifiers{shift = Down} pos) sc +handleEvent (EventKey (MouseButton LeftButton) Down Modifiers{shift = Down} pos) sc = case findVertex (invertViewPort port pos) (viewPortScale port) sc of Nothing -> sc Just v -> sc{scSelected = Just v} where viewState = scViewState sc port = viewStateViewPort viewState -handleEvent (EventKey (MouseButton LeftButton) Up _ _) - sc@Scene{scSelected = Just _} +handleEvent (EventKey (MouseButton LeftButton) Up _ _)+ sc@Scene{scSelected = Just _} = sc {scSelected = Nothing} -handleEvent (EventMotion pos) - sc@Scene{scPoints = pts, scSelected = Just v} +handleEvent (EventMotion pos)+ sc@Scene{scPoints = pts, scSelected = Just v} = sc{ scPoints = Map.insert v (invertViewPort port pos) pts} where port = viewStateViewPort (scViewState sc) -handleEvent ev sc +handleEvent ev sc = sc{ scViewState = updateViewStateWithEvent ev (scViewState sc)} @@ -277,12 +278,12 @@ sceneWindow :: Scene -> IO ()-sceneWindow sc +sceneWindow sc = play (InWindow "Graph Drawing - shift + left mouse button to drag" windowSize (10, 10)) black 30 sc drawScene handleEvent updatePositions main :: IO ()-main +main = do gen <- getStdGen sceneWindow (fromEdges gen sampleGraph)
picture/Gravity/Main.hs view
@@ -1,14 +1,17 @@++module Main where+ import Graphics.Gloss import Graphics.Gloss.Interface.Environment import System.Random -- x, y, dx, dy-type Particle - = (Float, Float, Float, Float) +type Particle+ = (Float, Float, Float, Float) main :: IO ()-main +main = do g <- getStdGen (width,height) <- getScreenSize let initialstate = generateParticles g width height@@ -19,21 +22,21 @@ fps = 60 render xs = pictures $ map particleImage xs update _ = updateParticles- + -- | Generates particles from StdGen generateParticles :: StdGen -> Int -> Int -> [Particle]-generateParticles gen widthInt heightInt +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) + f = \(x,y) -> (x * width - width / 2, y * height - height / 2) -- add speed of 0- g = \(x,y) -> (x,y,0,0) + g = \(x,y) -> (x,y,0,0) -- 200 Random float tuples- tups = take 50 $ zip randoms1 randoms2 + tups = take 50 $ zip randoms1 randoms2 randoms1 = randoms gen1 :: [Float] randoms2 = randoms gen2 :: [Float] (gen1,gen2) = split gen@@ -43,35 +46,35 @@ -- | Particle to its picture particleImage :: Particle -> Picture-particleImage (x,y,_,_) +particleImage (x,y,_,_) = translate x y $ color white $ circleSolid 2 -- | To update particles for next frame updateParticles :: Float -> [Particle] -> [Particle]-updateParticles dt +updateParticles dt = (accelerateParticles dt) . (moveParticles dt) -- | Moves particles based on their speed moveParticles :: Float -> [Particle] -> [Particle]-moveParticles dt +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 +accelerateParticles dt ps = map (gravitate ps dt) ps -- | Given particles to be gravitating to and for how long,--- updates a single particle's speed +-- updates a single particle's speed gravitate :: [Particle] -> Float -> Particle -> Particle gravitate [] _ p = p-gravitate ((x',y',_,_):ps) dt p@(x,y,dx,dy) +gravitate ((x',y',_,_):ps) dt p@(x,y,dx,dy) = -- To dodge divByZero or near divByZero anomalies- if separated x x' && separated y y' + if separated x x' && separated y y' then gravitate ps dt p' else gravitate ps dt p where@@ -80,27 +83,27 @@ 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') +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 +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') +gravitation (x,y) (x',y') = g / sqrt (dx ^ (2 :: Int) + dy ^ (2 :: Int)) where dx = x' - x dy = y' - y
picture/Hello/Main.hs view
@@ -3,8 +3,9 @@ -- import Graphics.Gloss -main - = display +main :: IO ()+main+ = display (InWindow "Hello World" -- window title (400, 150) -- window size@@ -12,7 +13,9 @@ white -- background color picture -- picture to display -picture +picture :: Picture+picture = Translate (-170) (-20) -- shift the text to the middle of the window $ Scale 0.5 0.5 -- display it half the original size $ Text "Hello World" -- text to display+
picture/Lifespan/Cell.hs view
@@ -14,11 +14,11 @@ offspring :: Cell -> Float -> Float -> Int -> Cell offspring (Cell (x,y) r _) alpha factor lifespan = Cell (x + (childR+r) * cos alpha, y + (childR+r) * sin alpha)- childR + childR lifespan where childR = factor * r --- Do two cells overlap? +-- Do two cells overlap? -- Used to decide if newly spawned cells can join the community. overlap :: Cell -> Cell -> Bool overlap (Cell (x1,y1) r1 _) (Cell (x2,y2) r2 _) = centreDist < (r1 + r2) *0.999@@ -28,7 +28,7 @@ -- thickness of circle is determined by lifespan render :: Cell -> Picture-render (Cell (x,y) r life) +render (Cell (x,y) r life) = Color (makeColor 0.6 z 0.6 1.0) $ Translate x y $ ThickCircle (r - thickness / 2) thickness
picture/Lifespan/Community.hs view
@@ -48,8 +48,8 @@ survive (spawn comm angles scales (repeat 5)) (age comm) render :: Community -> Picture-render comm - = Pictures +render comm+ = Pictures $ map Cell.render comm initial :: Community
picture/Lifespan/Main.hs view
@@ -3,18 +3,16 @@ module Main where import qualified World as W import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Simulate import System.Random -- varying prng sequence-main +main :: IO ()+main = do gen <- getStdGen simulate (InWindow "Lifespan" (800, 600) (10, 10))- (greyN 0.1) -- background color- 2 -- number of steps per second- (W.genesis' gen) -- initial world- W.render -- function to convert world to a Picture- W.evolve -- function to step the world one iteration--+ (greyN 0.1) -- background color+ 2 -- number of steps per second+ (W.genesis' gen) -- initial world+ W.render -- function to convert world to a Picture+ W.evolve -- function to step the world one iteration
picture/Lifespan/World.hs view
@@ -6,29 +6,30 @@ import Community import Cell -stepsMax = 20+stepsMax :: Int+stepsMax = 20 -- The World consists of a Community and a random number generator. -- (The RNG is a model of chaos or hand-of-god.)-data World +data World = World Community StdGen Int deriving (Show) -- The initial world genesis :: World-genesis +genesis = World [Cell (0,0) 50 5] (mkStdGen 1023) 0 -- Seeding the prng means every run is identical. -- To get different runs, need to use gen <- getStdGen in main :: IO() -- and pass gen in as an argument. Edit Main.hs accordingly. genesis' :: StdGen -> World-genesis' gen +genesis' gen = World [Cell (0,0) 50 5] gen 0 -- Consume some random numbers to advance the simulation evolve :: ViewPort -> Float -> World -> World-evolve _ _ world@(World comm gen step) +evolve _ _ world@(World comm gen step) | step > stepsMax = world | otherwise = World (generation comm angles scales) genNext (step + 1)@@ -39,6 +40,6 @@ -- Converting the world to a picture is just converting the community component render :: World -> Picture-render (World comm gen _) +render (World comm gen _) = Color (makeColor 0.3 0.3 0.6 1.0) $ Community.render comm
picture/Machina/Main.hs view
@@ -1,30 +1,38 @@ +module Main where+ import Graphics.Gloss +main :: IO () main = animate (InWindow "machina" (800, 600) (10, 10)) black frame +frame :: Float -> Picture frame time = Scale 0.8 0.8 $ Rotate (time * 30) $ mach time 6- -mach t 0 = leaf++mach :: Float -> Int -> Picture+mach _ 0 = leaf mach t d = Pictures [ leaf- , Translate 0 (-100) - $ Scale 0.8 0.8 - $ Rotate (90 + t * 30) + , Translate 0 (-100)+ $ Scale 0.8 0.8+ $ Rotate (90 + t * 30) $ mach (t * 1.5) (d - 1) - , Translate 0 100 - $ Scale 0.8 0.8 - $ Rotate (90 - t * 30) + , Translate 0 100+ $ Scale 0.8 0.8+ $ Rotate (90 - t * 30) $ mach (t * 1.5) (d - 1) ]- ++leaf :: Picture leaf = Pictures [ Color (makeColor 1.0 1.0 1.0 0.5) $ Polygon loop , Color (makeColor 0.0 0.0 1.0 0.8) $ Line loop ] +loop :: [(Float,Float)] loop = [(-10, -100), (-10, 100), (10, 100), (10, -100), (-10, -100)]+
picture/Occlusion/Cell.hs view
@@ -1,7 +1,7 @@ module Cell ( Cell (..)- , readCell + , readCell , pictureOfCell , cellShape) where@@ -27,15 +27,14 @@ -- | The basic shape of a cell. cellShape :: Int -> Int -> Int -> Picture cellShape cellSize posXi posYi- = let cs = fromIntegral cellSize- posX = fromIntegral posXi+ = let posX = fromIntegral posXi posY = fromIntegral posYi x1 = posX x2 = posX + 1- y1 = posY + y1 = posY y2 = posY + 1 in Polygon [(x1, y1), (x1, y2), (x2, y2), (x2, y1)]- + -- | Convert a cell to a picture, based on a primitive shape. -- We pass the shape in to avoid recomputing it for each cell.
picture/Occlusion/Data.hs view
@@ -1,6 +1,7 @@ module Data where +worldData :: String worldData = unlines [ "WORLD"@@ -38,3 +39,4 @@ , "9..#.#.........#................." , "0..............#................." , "1#..............................#" ]+
picture/Occlusion/Main.hs view
@@ -9,32 +9,32 @@ import Graphics.Gloss.Data.Extent import System.Environment import Data.Maybe-import Data.List-import Data.Function -main +main :: IO ()+main = do args <- getArgs case args of- [fileName] + [fileName] -> do world <- loadWorld fileName mainWithWorld world- + _ -> do let world = readWorld worldData mainWithWorld world- - +++mainWithWorld :: World -> IO () mainWithWorld world = play (InWindow "Occlusion" (windowSizeOfWorld world) (10, 10))- black + black 10 (initState world) drawState (handleInput world) (\_ -> id)- - ++ -- | Convert the state to a picture. drawState :: State -> Picture drawState state@@ -55,7 +55,7 @@ picCellsAll = Pictures $ map (uncurry (drawCell False world)) cellsAll -- The cells visible from the designated point.- cellsVisible + cellsVisible = [ (coord, cell) | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world) , cellAtCoordIsVisibleFromPoint world p1 coord ]@@ -65,10 +65,10 @@ -- How big to draw the cells. scale = fromIntegral $ worldCellSize world - (windowSizeX, windowSizeY) + (windowSizeX, windowSizeY) = windowSizeOfWorld $ stateWorld state- + -- Shift the cells so they are centered in the window. offsetX = - (fromIntegral $ windowSizeX `div` 2) offsetY = - (fromIntegral $ windowSizeY `div` 2)@@ -85,34 +85,34 @@ x = w y = s - posX = fromIntegral x + posX = fromIntegral x posY = fromIntegral y- + in Pictures [ Color blue $ cellShape 1 posX posY ] -- | Draw the ray defined by the user.-drawRay :: World -> Point -> Point -> Picture +drawRay :: World -> Point -> Point -> Picture drawRay world p1@(x, y) p2 = Pictures [ Color red $ Line [p1, p2]- , Color cyan - $ Translate x y - $ Pictures + , Color cyan+ $ Translate x y+ $ Pictures [ Line [(-0.3, -0.3), (0.3, 0.3)] , Line [(-0.3, 0.3), (0.3, -0.3)] ] ] -- | Draw a cell in the world. drawCell :: Bool -> World -> Coord -> Cell -> Picture-drawCell visible world (x, y) cell +drawCell visible world (x, y) cell = let cs = fromIntegral (worldCellSize world)- cp = fromIntegral (worldCellSpace world)+ -- cp = fromIntegral (worldCellSpace world) - posX = fromIntegral x + posX = fromIntegral x posY = fromIntegral y in if visible then pictureOfCell (worldCellSize world) posX posY cell else Color (greyN 0.4) (cellShape cs posX posY)- +
picture/Occlusion/State.hs view
@@ -13,24 +13,25 @@ -- | Initial game state.+initState :: World -> State initState world = State { stateWorld = world , stateLineStart = (10, 10) , stateLineEnd = (10, 10) }- + -- | Handle an input event. handleInput :: World -> Event -> State -> State handleInput world (EventKey key keyState mods pos) state | MouseButton LeftButton <- key , Down <- keyState- , shift mods == Down + , shift mods == Down = state { stateLineEnd = worldPosOfWindowPos world pos } | MouseButton LeftButton <- key , Down <- keyState- = state { stateLineStart = worldPosOfWindowPos world pos + = state { stateLineStart = worldPosOfWindowPos world pos , stateLineEnd = worldPosOfWindowPos world pos } | MouseButton RightButton <- key
picture/Occlusion/World.hs view
@@ -6,12 +6,10 @@ import Graphics.Gloss.Data.Extent import Graphics.Gloss.Data.QuadTree import Graphics.Gloss.Algorithms.RayCast-import System.IO-import Control.Monad -- | The game world.-data World +data World = World { worldWidth :: Int , worldHeight :: Int@@ -27,24 +25,24 @@ = makeExtent (worldWidth world) 0 (worldHeight world) 0 --- | Load a world from a file. +-- | Load a world from a file. loadWorld :: FilePath -> IO World loadWorld fileName = do str <- readFile fileName return $ readWorld str- - ++ -- | Read a world from a string. readWorld :: String -> World readWorld str- = let ("WORLD" : strWidthHeight : skip : cellLines) + = let ("WORLD" : strWidthHeight : skip : cellLines) = lines str- + [width, height] = map read $ words strWidthHeight rows = take height $ cellLines - cells = concat - $ map (readLine width) + cells = concat+ $ map (readLine width) $ reverse rows extent = makeExtent height 0 width 0@@ -77,21 +75,21 @@ makeWorldTree :: Extent -> [Cell] -> QuadTree Cell makeWorldTree extent cells = foldr insert' emptyTree nonEmptyPosCells- where + where insert' (pos, cell) tree = case insertByCoord extent pos cell tree of Nothing -> tree Just tree' -> tree'- - (width, height) ++ (width, height) = sizeOfExtent extent- - posCells ++ posCells = zip [(x, y) | y <- [0 .. height - 1] , x <- [0 .. width - 1]] cells- - nonEmptyPosCells ++ nonEmptyPosCells = filter (\x -> snd x /= CellEmpty) posCells @@ -100,12 +98,12 @@ worldPosOfWindowPos world (x, y) = let (windowSizeX, windowSizeY) = windowSizeOfWorld world- + offsetX = fromIntegral $ windowSizeX `div` 2 offsetY = fromIntegral $ windowSizeY `div` 2- + scale = fromIntegral $ worldCellSize world- + x' = (x + offsetX) / scale y' = (y + offsetY) / scale @@ -131,8 +129,8 @@ pb = (x + 0.4999, y) pc = (x, y - 0.4999) pd = (x, y + 0.4999)- - ++ -- | Check if a point on some cell (P2) is visible from some other point (P1). cellAtPointIsVisibleFromPoint :: World -> Point -> Point -> Bool cellAtPointIsVisibleFromPoint world p1 p2
picture/Styrene/Actor.hs view
@@ -23,7 +23,7 @@ !Position -- ^ wall starting point !Position -- ^ wall ending point - | Bead !Index -- ^ unique index of this actor + | Bead !Index -- ^ unique index of this actor !Int -- ^ whether the bead is stuck !Radius -- ^ radius of bead !Position -- ^ position of bead@@ -35,7 +35,7 @@ -- We need Ord so we can put them in Maps and Sets. instance Eq Actor where a1 == a2 = actorIx a1 == actorIx a2- + instance Ord Actor where compare a1 a2 = compare (actorIx a1) (actorIx a2) @@ -63,7 +63,7 @@ actorSetIndex :: Actor -> Index -> Actor actorSetIndex actor ix = case actor of- Bead _ m r pos vel -> Bead ix m r pos vel + Bead _ m r pos vel -> Bead ix m r pos vel Wall _ p1 p2 -> Wall ix p1 p2
picture/Styrene/Advance.hs view
@@ -4,49 +4,45 @@ module Advance where import World import Contact-import QuadTree import Collide import Actor import Config -import Graphics.Gloss.Interface.Pure.Simulate-import Graphics.Gloss.Geometry.Line-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Geometry.Angle+import Graphics.Gloss.Interface.Pure.Simulate+import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -import Data.List import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Set (Set) import Data.Map (Map) -- Advance ---------------------------------------------------------------------------------------- -- | Advance all the actors in this world by a certain time.-advanceWorld +advanceWorld :: ViewPort -- ^ current viewport -> Time -- ^ time to advance them for. -> World -- ^ the world to advance. -> World -- ^ the new world. advanceWorld viewport time (World actors tree)- = let + = let rot = viewPortRotate viewport force = rotateV (degToRad rot) (0, negate gravityCoeff) - -- move all the actors + -- move all the actors actors_moved = Map.map (moveActor_free time force) actors- + -- find contacts in the world- (contacts, tree') + (contacts, tree') = findContacts (World actors_moved tree) -- apply contacts to each pair of actors- actors_bounced - = Set.fold - (applyContact time force) + actors_bounced+ = Set.fold+ (applyContact time force) actors_moved contacts @@ -54,7 +50,7 @@ -- Move two actors which are known to be in contact.-applyContact +applyContact :: Time -- ^ time step -> Force -- ^ ambient force on the actors -> (Index, Index) -- ^ indicies of the the two actors in contact@@ -65,18 +61,18 @@ = let -- use the indicies to lookup the data for each actor from the map Just a1 = Map.lookup ix1 actors Just a2 = Map.lookup ix2 actors- + resultActors -- handle a collision between bead and a wall | Bead _ _ r1 p1 v1 <- a1 , Wall{} <- a2 = let a1' = collideBeadWall a1 a2 in Map.insert ix1 a1' actors- + -- handle a collision between two beads | Bead ix1 m1 r1 p1 v1 <- a1 , Bead ix2 m2 r2 p2 v2 <- a2- = let + = let (a1', a2') -- if one of the beads is stuck then do a safer, static collision. -- with this method the beads don't transfer energy into each other@@ -95,12 +91,12 @@ -- write the new data for the actors back into the map in Map.insert ix1 a1' $ Map.insert ix2 a2' actors- - in resultActors - + in resultActors++ -- | Move a bead which isn't in contact with anything else.-moveActor_free +moveActor_free :: Time -- ^ time to move it for -> Force -- ^ ambient force on the actor during this time -> Actor -- ^ the bead to move@@ -111,17 +107,17 @@ | Bead ix stuck radius pos vel <- actor = let -- assume all beads have the same mass. beadMass = 1- + -- calculate the new position and velocity of the bead.- pos' = (pos + time `mulSV` vel)- vel' = (vel + (time / beadMass) `mulSV` force)+ pos' = (pos Pt.+ time `mulSV` vel)+ vel' = (vel Pt.+ (time / beadMass) `mulSV` force) -- if the bead is travelling slowly then set it as being stuck.- stuck' + stuck' | magV vel' < 20 = min beadStuckCount (stuck + 1) - | otherwise + | otherwise = max 0 (stuck - 2) in Bead ix stuck' radius pos' vel'
picture/Styrene/Collide.hs view
@@ -1,11 +1,10 @@ -- | Physics for bead bouncing. module Collide where-import World import Actor import Graphics.Gloss.Data.Point+import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt import Graphics.Gloss.Data.Vector import Graphics.Gloss.Geometry.Line-import Graphics.Gloss.Geometry.Angle -- Config ----------------------------------------------------------------------------------------- -- How bouncy the beads are@@ -19,7 +18,7 @@ -- | Move a bead which is in contact with a wall. collideBeadWall- :: Actor -- ^ the bead + :: Actor -- ^ the bead -> Actor -- ^ the wall that bead is in contact with -> Actor -- ^ the new bead @@ -27,13 +26,13 @@ bead@(Bead ix _ radius pBead vIn@(velX, velY)) wall@(Wall _ pWall1 pWall2) - = let -- Take the collision point as being the point on the wall which is + = let -- Take the collision point as being the point on the wall which is -- closest to the bead's center. pCollision = closestPointOnLine pWall1 pWall2 pBead- + -- then do a static, non energy transfering collision.- in collideBeadPoint_static - bead + in collideBeadPoint_static+ bead pCollision beadWallLoss @@ -44,16 +43,16 @@ -> (Actor, Actor) collideBeadBead_elastic- bead1@(Bead ix1 mode1 r1 p1 v1) + bead1@(Bead ix1 mode1 r1 p1 v1) bead2@(Bead ix2 mode2 r2 p2 v2) = let mass1 = 1 mass2 = 1 -- the axis of collision (towards p2)- vCollision@(cX, cY) = normalizeV (p2 - p1)+ vCollision@(cX, cY) = normalizeV (p2 Pt.- p1) vCollisionR = (cY, -cX)- + -- the velocity component of each bead along the axis of collision s1 = dotV v1 vCollision s2 = dotV v2 vCollision@@ -61,15 +60,15 @@ -- work out new velocities along the collision s1' = (s1 * (mass1 - mass2) + 2 * mass2 * s2) / (mass1 + mass2) s2' = (s2 * (mass2 - mass1) + 2 * mass1 * s1) / (mass1 + mass2)- + -- the velocity components at right angles to the collision -- there is no friction in the collision so these don't change k1 = dotV v1 vCollisionR k2 = dotV v2 vCollisionR- + -- new bead velocities- v1' = mulSV s1' vCollision + mulSV k1 vCollisionR- v2' = mulSV s2' vCollision + mulSV k2 vCollisionR+ v1' = mulSV s1' vCollision Pt.+ mulSV k1 vCollisionR+ v2' = mulSV s2' vCollision Pt.+ mulSV k2 vCollisionR v1_slow = mulSV beadBeadLoss v1' v2_slow = mulSV beadBeadLoss v2'@@ -78,12 +77,12 @@ u1 = r1 / (r1 + r2) u2 = r2 / (r1 + r2) - pCollision - = p1 + mulSV u1 (p2 - p1)+ pCollision+ = p1 Pt.+ mulSV u1 (p2 Pt.- p1) -- place the beads just next to each other so they are no longer overlapping.- p1' = pCollision - (r1 + 0.001) `mulSV` vCollision- p2' = pCollision + (r2 + 0.001) `mulSV` vCollision+ p1' = pCollision Pt.- (r1 + 0.001) `mulSV` vCollision+ p2' = pCollision Pt.+ (r2 + 0.001) `mulSV` vCollision bead1' = Bead ix1 mode1 r1 p1' v1_slow bead2' = Bead ix2 mode2 r2 p2' v2_slow@@ -92,19 +91,19 @@ collideBeadBead_static- :: Actor -> Actor + :: Actor -> Actor -> Actor- + collideBeadBead_static bead1@(Bead ix1 _ radius1 pBead1 _) bead2@(Bead ix2 _ radius2 pBead2 _) - = let -- Take the collision point as being between the center's of the two beads. + = let -- Take the collision point as being between the center's of the two beads. -- For beads which have the same radius the collision point is half way between -- their centers and u == 0.5 u = radius1 / (radius1 + radius2)- pCollision = pBead1 + mulSV u (pBead2 - pBead1)- + pCollision = pBead1 Pt.+ mulSV u (pBead2 Pt.- pBead1)+ bead1' = collideBeadPoint_static bead1 pCollision@@ -120,29 +119,29 @@ -> Actor collideBeadPoint_static- bead@(Bead ix mode radius pBead vIn) + bead@(Bead ix mode radius pBead vIn) pCollision velLoss = let -- take a normal vector from the wall to the bead. -- this vector is at a right angle to the wall.- vNormal = normalizeV (pBead - pCollision)- + vNormal = normalizeV (pBead Pt.- pCollision)+ -- the bead at pBead is overlapping with what it collided with, but we don't want that. -- place the bead so it's surface is just next to the point of collision.- pBead_new = pCollision + (radius + 0.01) `mulSV` vNormal+ pBead_new = pCollision Pt.+ (radius + 0.01) `mulSV` vNormal -- work out the angle of incidence for the bounce. -- this is the angle between the surface normal and -- the direction of travel for the bead.- aInc = angleVV vNormal (negate vIn)+ aInc = angleVV vNormal (Pt.negate vIn) -- aInc2 is the angle between the wall /surface/ and -- the direction of travel. aInc2 = (pi / 2) - aInc -- take the determinant between the surface normal and the direction of travel.- -- This will tell us what direction the bead hit the wall. + -- This will tell us what direction the bead hit the wall. -- The diagram shows the sign of the determinant for the four possiblities. -- -- \ +ve -ve /@@ -156,7 +155,7 @@ determinant = detV vIn vNormal -- Use the determinant to rotate the bead's velocity vector for the bounce.- vOut + vOut | determinant > 0 = rotateV (2 * aInc2) vIn | otherwise = rotateV (negate (2 * aInc2)) vIn
picture/Styrene/Contact.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MagicHash, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} -- | Find actors in the world that are in contact with each other. module Contact where@@ -7,34 +8,29 @@ import Actor import Graphics.Gloss.Data.Point import Graphics.Gloss.Geometry.Line-import Graphics.Gloss.Geometry.Angle-import Data.Maybe-import Data.List import GHC.Exts-import GHC.Prim-import Data.Map (Map) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -- Find all pairs of actors in the world that are in contact with each other.-findContacts - :: World +findContacts+ :: World -> ( -- a set of all pairs of actors that are in contact.- Set (Index, Index) + Set (Index, Index) -- also return the quadtree so we can draw it in the window.- , QuadTree Actor) - + , QuadTree Actor)+ findContacts (World actors _)- = let + = let -- the initial tree has no actors in it and has a -- size of 300 (with is half the width of the box). treeInit = treeZero 300 -- insert all the actors into the quadtree.- tree' = Map.fold insertActor treeInit actors+ tree' = Map.foldr' insertActor treeInit actors -- the potential contacts are lists of actors -- that _might_ be in contact.@@ -44,17 +40,18 @@ -- filter the lists of potential contacts to determine the actors -- which are _actually_ in contact. contactSet = makeContacts potentialContacts- + in (contactSet, tree')- + -- | Make add all these test pairs to a map -- normalise so the actor with the lowest ix is first in the pair. makeContacts :: [[Actor]] -> Set (Index, Index) makeContacts contactLists- = makeContacts' Set.empty contactLists + = makeContacts' Set.empty contactLists +makeContacts' :: Set (Index,Index) -> [[Actor]] -> Set (Index, Index) makeContacts' acc xx = case xx of -- no more potentials to add, return the current contact set@@ -63,11 +60,13 @@ -- add pairs of actors that are actually in contact to the contact set (list : lists) -> makeContacts' (makeTests acc list) lists- ++makeTests :: Set (Index, Index) -> [Actor] -> Set (Index, Index) makeTests acc [] = acc makeTests acc (x:xs) = makeTests (makeTests1 acc x xs) xs- ++makeTests1 :: Set (Index, Index) -> Actor -> [Actor] -> Set (Index, Index) makeTests1 acc a1 [] = acc makeTests1 acc a1 (a2 : as) | inContact a1 a2@@ -76,11 +75,11 @@ contact = (min k1 k2, max k1 k2) acc' = Set.insert contact acc in makeTests1 acc' a1 as- + | otherwise = makeTests1 acc a1 as- + -- See if these two actors are in contact inContact :: Actor -> Actor -> Bool inContact a1 a2@@ -92,15 +91,15 @@ -- | Check whether a bead is in contact with a wall. inContact_beadWall :: Actor -> Actor -> Bool-inContact_beadWall - bead@(Bead ix mode radius pBead _) +inContact_beadWall+ bead@(Bead ix mode radius pBead _) wall@(Wall _ pWall1 pWall2) = let -- work out the point on the infinite line between pWall1 and pWall2 -- which is closest to the bead. pClosest = closestPointOnLine pWall1 pWall2 pBead - -- the distance between the bead center and pClosest + -- the distance between the bead center and pClosest -- needs to be less than the bead radius for them to touch. !(F# radius#) = radius closeEnough = distancePP_contact pBead pClosest `ltFloat#` radius#@@ -116,8 +115,8 @@ -- | Check whether a bead is in concat with another bead. inContact_beadBead :: Actor -> Actor -> Bool-inContact_beadBead - bead1@(Bead ix1 _ radius1 pBead1 _) +inContact_beadBead+ bead1@(Bead ix1 _ radius1 pBead1 _) bead2@(Bead ix2 _ radius2 pBead2 _) =let !dist# = distancePP_contact pBead1 pBead2 !(F# rad) = radius1 + radius2@@ -133,4 +132,4 @@ !xd2 = xd `timesFloat#` xd !yd = y2 `minusFloat#` y1- !yd2 = yd `timesFloat#` yd + !yd2 = yd `timesFloat#` yd
picture/Styrene/Main.hs view
@@ -1,28 +1,25 @@ +module Main where+ import Actor import Advance import QuadTree-import Contact-import Collide import World import Config import Graphics.Gloss-import Graphics.Gloss.Geometry.Line-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Interface.Pure.Simulate import Graphics.Gloss.Data.Vector import qualified Data.Map as Map-import Data.Map (Map) -main - = simulate +main :: IO ()+main+ = simulate (InWindow "Polystyrene - alt-left-click-drag rotates" (600, 600) -- x and y size of window (in pixels). (10, 10)) -- position of window black -- background color- simResolution -- simulation resolution + simResolution -- simulation resolution -- (number of steps to take for each second of time) worldInit -- the initial world. drawWorld -- a function to convert the world to a Picture.@@ -34,12 +31,12 @@ -- | Draw this world as a picture. drawWorld :: World -> Picture drawWorld (World actors tree)- = let + = let -- split the list of actors into beads and walls.- -- this lets us draw all the beads at once without having to keep changing + -- this lets us draw all the beads at once without having to keep changing -- the current color (which is a bit of a performance improvement) (beads, walls) = splitActors $ Map.elems actors- + picBeads = Color beadColor $ Pictures $ map drawActor beads picWalls = Pictures $ map drawActor walls picTree = drawQuadTree tree@@ -53,18 +50,19 @@ splitActors as = splitActors' [] [] as -splitActors' accBeads accWalls [] +splitActors' :: [Actor] -> [Actor] -> [Actor] -> ([Actor], [Actor])+splitActors' accBeads accWalls [] = (accBeads, accWalls) -splitActors' accBeads accWalls (a : as) +splitActors' accBeads accWalls (a : as) = case a of Bead{} -> splitActors' (a : accBeads) accWalls as Wall{} -> splitActors' accBeads (a : accWalls) as -- | Draw an actor as a picture.-drawActor :: Actor -> Picture -drawActor actor +drawActor :: Actor -> Picture+drawActor actor = case actor of Bead ix mode radius p@(posX, posY) v@(velX, velY) -> Translate posX posY $ Pictures [bead, vel]@@ -78,11 +76,11 @@ -- | Draw a quadtree as a picture drawQuadTree :: QuadTree a -> Picture-drawQuadTree tree +drawQuadTree tree = case tree of QNode p size tTL tTR tBL tBR -> Pictures- [ drawQuadTree tTL + [ drawQuadTree tTL , drawQuadTree tTR , drawQuadTree tBL , drawQuadTree tBR@@ -90,10 +88,11 @@ QLeaf p size elems -> nodeBox p size leafColor- + QNil (x0, y0) size -> Blank +nodeBox :: (Float, Float) -> Float -> Color -> Picture nodeBox p@(x0, y0) size color = Color color $ Translate x0 y0@@ -105,8 +104,8 @@ circleFilled r n = Scale r r $ Polygon (circlePoints n)- - ++ -- A list of n points spaced equally around the unit circle. circlePoints :: Float -> [(Float, Float)] circlePoints n
picture/Styrene/QuadTree.hs view
@@ -1,5 +1,5 @@ -module QuadTree +module QuadTree ( QuadTree(..) , treeZero , treeInsert@@ -10,12 +10,12 @@ data QuadTree a -- Nil cells take up space in the world, but don't contain any elements. -- They can be at any depth in the tree.- = QNil !Point -- cell center point + = QNil !Point -- cell center point !Float -- cell size -- Leaf cells are the only ones that contain elements. -- They are always at the bottom of the tree.- | QLeaf !Point -- cell center point + | QLeaf !Point -- cell center point !Float -- cell size ![a] -- elements in this cell @@ -24,18 +24,19 @@ !Float -- cell size !(QuadTree a) !(QuadTree a) -- NW NE !(QuadTree a) !(QuadTree a) -- SW SE- + deriving (Eq, Show) -- Initial ----------------------------------------------------------------------------------------+treeZero :: Float -> QuadTree a treeZero size = QNil (0, 0) size -- Quadrant --------------------------------------------------------------------------------------- -- | Insert an element with a bounding box into the tree-treeInsert +treeInsert :: Int -- ^ maximum depth to place a leaf -> Int -- ^ current depth -> Point -- ^ bottom left of bounding box of new element@@ -47,8 +48,8 @@ treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree = case tree of QNode p@(x, y) size tNW tNE tSW tSE- -> let - + -> let+ tNW' | y1 > y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tNW | otherwise = tNW @@ -60,31 +61,31 @@ tSE' | y0 < y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tSE | otherwise = tSE- + in QNode p size tNW' tNE' tSW' tSE'- + QLeaf p@(x, y) size elems | depth >= depthMax -> QLeaf p size (a : elems)- + QNil p@(x, y) size | depth >= depthMax -> QLeaf p size [a]- + | otherwise -> treeInsert depthMax depth p0 p1 a (let s2 = size / 2- in QNode p size + in QNode p size (QNil (x - s2, y + s2) s2) (QNil (x + s2, y + s2) s2) (QNil (x - s2, y - s2) s2) (QNil (x + s2, y - s2) s2)) -- flatten a quadtree into a list of its elements. treeElems :: QuadTree a -> [[a]]-treeElems tree +treeElems tree = case tree of QNode _ _ tNW tNE tSW tSE -> treeElems tNW ++ treeElems tNE ++ treeElems tSW ++ treeElems tSE- + QLeaf _ _ elems -> [elems] QNil{} -> []
picture/Styrene/World.hs view
@@ -12,17 +12,17 @@ import Data.Map (Map) -- The world -------------------------------------------------------------------data World +data World = World (Map Index Actor) -- actors (QuadTree Actor) -- tree -- | The initial world worldInit :: World-worldInit +worldInit = World actorMapInit treeInit -actorMapInit - = Map.fromList +actorMapInit+ = Map.fromList $ map (\a -> (actorIx a, a)) $ (walls ++ beads) @@ -44,23 +44,23 @@ splitter :: [Actor] splitter- = [ Wall 0 (-15, -100) (-200, 0) + = [ Wall 0 (-15, -100) (-200, 0) , Wall 0 ( 15, -100) ( 200, 0) ] -- Beads ------------------ beads :: [Actor]-beads +beads = let -- beads start off with their index just set to 0 beads_raw = [Bead 0 0 beadRadius (beadPos ix iy) (0, 0) | ix <- [0 .. beadCountX - 1] , iy <- [0 .. beadCountY - 1 ] ]- + -- set the unique index on the beads before returning them in zipWith actorSetIndex beads_raw [0..]- -beadPos ix iy ++beadPos ix iy = ( (ix * beadBoxSize) - (beadBoxSize * beadCountX / 2) , (iy * beadBoxSize) ) @@ -85,6 +85,6 @@ -- the bottom left and top right of the wall's bounding box. p0 = (min x0 x1, min y0 y1) p1 = (max x0 x1, max y0 y1)- + in treeInsert treeMaxDepth 0 p0 p1 wall tree- +
picture/Tree/Main.hs view
@@ -1,15 +1,16 @@ -- | Tree Fractal. -- Based on ANUPlot code by Clem Baker-Finch.--- +-- import Graphics.Gloss +main :: IO () main = animate (InWindow "Tree" (500, 650) (20, 20)) black (picture 4) -- The picture is a tree fractal, graded from brown to green-picture :: Int -> Float -> Picture +picture :: Int -> Float -> Picture picture degree time = Translate 0 (-300) $ tree degree time (dim $ dim brown)@@ -17,7 +18,7 @@ -- Basic stump shape stump :: Color -> Picture-stump color +stump color = Color color $ Polygon [(30,0), (15,300), (-15,300), (-30,0)] @@ -29,10 +30,10 @@ -> Picture tree 0 time color = stump color-tree n time color - = let smallTree +tree n time color+ = let smallTree = Rotate (sin time)- $ Scale 0.5 0.5 + $ Scale 0.5 0.5 $ tree (n-1) (- time) (greener color) in Pictures [ stump color@@ -41,7 +42,7 @@ , Translate 0 180 $ Rotate (-20) smallTree , Translate 0 120 $ Rotate 40 smallTree , Translate 0 60 $ Rotate (-40) smallTree ]- + -- A starting colour for the stump brown :: Color
picture/Visibility/Draw.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE PatternGuards #-}+ module Draw ( drawState , drawWorld) where import State import World-import Geometry.Segment import Graphics.Gloss import Graphics.Gloss.Geometry.Line import qualified Data.Vector.Unboxed as V@@ -15,32 +15,32 @@ drawState :: State -> Picture drawState state | ModeDisplayWorld <- stateModeDisplay state- = drawWorldWithViewPos + = drawWorldWithViewPos (stateModeOverlay state)- (stateViewPos state) + (stateViewPos state) (stateTargetPos state) (stateWorld state) | ModeDisplayNormalised <- stateModeDisplay state- = drawWorldWithViewPos + = drawWorldWithViewPos (stateModeOverlay state)- (0, 0) + (0, 0) Nothing $ normaliseWorld (stateViewPos state) $ stateWorld state | otherwise = Blank- + drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture-drawWorldWithViewPos +drawWorldWithViewPos modeOverlay- pView@(vx, vy) + pView@(vx, vy) mTarget world- = let - -- the world + = let+ -- the world picWorld = Color white $ drawWorld world @@ -56,7 +56,7 @@ -- line between view and target pos picLine = Line [pView, pTarget]- + picSegsHit = Pictures $ [ Line [p1, p2] | (_, p1, p2) <- V.toList $ worldSegments world@@ -80,14 +80,14 @@ -- | Draw a grid of points showing what is visible from a view position drawVisGrid :: Float -> Point -> World -> Picture drawVisGrid cellSize pView world- = let + = let visible pTarget = not $ any isJust $ map (\(_, p1, p2) -> intersectSegSeg pView pTarget p1 p2)- $ V.toList + $ V.toList $ worldSegments world- + picGrid = Pictures- $ [ if visible (x, y) + $ [ if visible (x, y) then Color (dim green) $ Translate x y $ rectangleSolid cellSize cellSize else Color (greyN 0.2) $ Translate x y $ rectangleSolid cellSize cellSize | x <- [-400, -400 + cellSize .. 400]@@ -108,7 +108,7 @@ drawSegments segments = Pictures $ map drawSegment- $ V.toList + $ V.toList $ segments
picture/Visibility/Geometry/Randomish.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} module Geometry.Randomish- ( randomishPoints + ( randomishPoints , randomishInts , randomishDoubles) where@@ -29,20 +29,20 @@ -- numbers with reasonable statistical properties. By "reasonable" we mean good -- enough for games and test data, but not cryptography or anything where the -- quality of the randomness really matters.--- +-- -- From "Random Number Generators: Good ones are hard to find" -- Stephen K. Park and Keith W. Miller. -- Communications of the ACM, Oct 1988, Volume 31, Number 10. ---randomishInts +randomishInts :: Int -- Length of vector. -> Int -- Minumum value in output. -> Int -- Maximum value in output.- -> Int -- Random seed. + -> Int -- Random seed. -> V.Vector Int -- Vector of random numbers. randomishInts !len !valMin' !valMax' !seed'- + = let -- a magic number (don't change it) multiplier :: Word64 multiplier = 16807@@ -52,7 +52,7 @@ modulus = 2^(31 :: Integer) - 1 -- if the seed is 0 all the numbers in the sequence are also 0.- seed + seed | seed' == 0 = 1 | otherwise = seed' @@ -62,11 +62,11 @@ {-# INLINE f #-} f x = multiplier * x `mod` modulus- in G.create - $ do + in G.create+ $ do vec <- MV.new len - let go !ix !x + let go !ix !x | ix == len = return () | otherwise = do let x' = f x@@ -79,7 +79,7 @@ -- | Generate some randomish doubles with terrible statistical properties. -- This is good enough for test data, but not much else.-randomishDoubles +randomishDoubles :: Int -- Length of vector -> Double -- Minimum value in output -> Double -- Maximum value in output@@ -92,7 +92,7 @@ mx = 2^(30 :: Integer) - 1 mxf = fromIntegral mx ints = randomishInts len 0 mx seed- + in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints @@ -111,5 +111,5 @@ mx = 2^(30 :: Integer) - 1 mxf = fromIntegral mx ints = randomishInts len 0 mx seed- + in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints
picture/Visibility/Geometry/Segment.hs view
@@ -6,10 +6,8 @@ , splitSegmentsOnX , chooseSplitX) where-import Graphics.Gloss import Graphics.Gloss.Geometry.Line import Data.Maybe-import Data.Function import qualified Data.Vector.Unboxed as V -- | A line segement in the 2D plane.@@ -20,16 +18,16 @@ translateSegment :: Float -> Float -> Segment -> Segment translateSegment tx ty (n, (x1, y1), (x2, y2)) = (n, (x1 + tx, y1 + ty), (x2 + tx, y2 + ty))- + -- | Split segments that cross the line y = y0, for some y0. splitSegmentsOnY :: Float -> V.Vector Segment -> V.Vector Segment splitSegmentsOnY y0 segs- = let + = let -- TODO: we only need to know IF the seg crosse the line here, -- not the actual intersection point. Do a faster test. (segsCross, segsOther)- = V.unstablePartition + = V.unstablePartition (\(_, p1, p2) -> isJust $ intersectSegHorzLine p1 p2 y0) segs @@ -38,19 +36,19 @@ splitCrossingSeg (n, p1, p2) = let Just pCross = intersectSegHorzLine p1 p2 y0 in V.fromList [(n, p1, pCross), (n, pCross, p2)]- - -- TODO: vector append requires a copy. ++ -- TODO: vector append requires a copy. in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross) -- | Split segments that cross the line x = x0, for some x0. splitSegmentsOnX :: Float -> V.Vector Segment -> V.Vector Segment splitSegmentsOnX x0 segs- = let + = let -- TODO: we only need to know IF the seg crosse the line here, -- not the actual intersection point. Do a faster test. (segsCross, segsOther)- = V.unstablePartition + = V.unstablePartition (\(_, p1, p2) -> isJust $ intersectSegVertLine p1 p2 x0) segs @@ -59,8 +57,8 @@ splitCrossingSeg (n, p1, p2) = let Just pCross = intersectSegVertLine p1 p2 x0 in V.fromList [(n, p1, pCross), (n, pCross, p2)]- - -- TODO: vector append requires a copy. ++ -- TODO: vector append requires a copy. in segsOther V.++ (V.concat $ map splitCrossingSeg $ V.toList segsCross)
picture/Visibility/Interface.hs view
@@ -14,7 +14,7 @@ -- move the view position. | G.MouseButton G.LeftButton <- key , G.Down <- keyState- = state { stateModeInterface = ModeInterfaceMove + = state { stateModeInterface = ModeInterfaceMove , stateViewPos = ( fromRational $ toRational x , fromRational $ toRational y) }@@ -61,7 +61,7 @@ = state { stateModeOverlay = case stateModeOverlay state of ModeOverlayVisApprox -> ModeOverlayNone- _ -> ModeOverlayVisApprox } + _ -> ModeOverlayVisApprox } handleInput _ state = state
picture/Visibility/Main.hs view
@@ -21,7 +21,7 @@ main = do world <- initialWorld let state = initialState world- + play (InWindow "Visibility" (800, 800) (10, 10)) black 100 state drawState handleInput stepState
picture/Visibility/State.hs view
@@ -12,7 +12,7 @@ , stateModeInterface :: ModeInterface , stateModeDisplay :: ModeDisplay , stateModeOverlay :: ModeOverlay- , stateViewPos :: Point + , stateViewPos :: Point , stateTargetPos :: Maybe Point } @@ -40,7 +40,7 @@ data ModeOverlay -- | No overlay = ModeOverlayNone- + -- | Brute force, approximate visibility | ModeOverlayVisApprox deriving (Show, Eq)@@ -54,6 +54,6 @@ , stateModeInterface = ModeInterfaceIdle , stateModeDisplay = ModeDisplayWorld , stateModeOverlay = ModeOverlayVisApprox- , stateViewPos = (0, 0) + , stateViewPos = (0, 0) , stateTargetPos = Nothing }
picture/Visibility/World.hs view
@@ -13,7 +13,7 @@ -- We keep this unpacked so we can use unboxed vector. -- index, x1, y1, x2, y2-data World +data World = World { worldSegments :: V.Vector Segment } @@ -24,10 +24,10 @@ = do let n = 100 let minZ = -300 let maxZ = 300- + let minDelta = -100 let maxDelta = 100- + let centers = randomishPoints 1234 n minZ maxZ let deltas = randomishPoints 4321 n minDelta maxDelta @@ -35,19 +35,19 @@ = (n', (cX, cY), (cX + dX, cY + dY)) let segs = V.zipWith3 makePoint (V.enumFromTo 0 (n - 1)) centers deltas- + return $ World segs -- | Normalise the world so that the given point is at the origin, -- and split segements that cross the y=0 line.-normaliseWorld :: Point -> World -> World +normaliseWorld :: Point -> World -> World normaliseWorld (px, py) world- = let segments_trans = V.map (translateSegment (-px) (-py)) + = let segments_trans = V.map (translateSegment (-px) (-py)) $ worldSegments world- + segments_split = splitSegmentsOnY 0 segments_trans- + in world { worldSegments = segments_split }
picture/Zen/Main.hs view
@@ -1,19 +1,19 @@ --- A nifty animated fractal of a tree, superimposed on a background +-- A nifty animated fractal of a tree, superimposed on a background -- of three red rectangles. import Graphics.Gloss main :: IO ()-main +main = animate (InWindow "Zen" (800, 600) (5, 5)) (greyN 0.2)- frame + frame -- Produce one frame of the animation. frame :: Float -> Picture frame timeS- = Pictures + = Pictures -- the red rectangles [ Translate 0 150 backRec , Translate 0 0 backRec@@ -26,7 +26,7 @@ -- One of the red backing rectangles, with a white outline. backRec :: Picture-backRec +backRec = Pictures [ Color red (rectangleSolid 400 100) , Color white (rectangleWire 400 100) ]@@ -47,18 +47,18 @@ -- The position of the branches changes depending on the animation time -- as well as the iteration number of the fractal. treeFrac :: Int -> Float -> Picture-treeFrac 0 timeS = Blank+treeFrac 0 _ = Blank treeFrac n timeS = Pictures [ Color treeColor $ rectangleUpperSolid 20 300 , Color treeOutline $ rectangleUpperWire 20 300 , Translate 0 30 $ Rotate (200 * sin timeS / (fromIntegral n) )- $ Scale 0.9 0.9 + $ Scale 0.9 0.9 $ treeFrac (n-1) timeS , Translate 0 70 $ Rotate (-200 * sin timeS / (fromIntegral n))- $ Scale 0.8 0.8 + $ Scale 0.8 0.8 $ treeFrac (n-1) timeS ]
raster/Crystal/Main.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE BangPatterns #-}-+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-} --- Quasicrystals demo. --- +-- Quasicrystals demo.+-- -- Based on code from: -- http://mainisusuallyafunction.blogspot.com/2011/10/quasicrystals-as-sums-of-waves-in-plane.html --@@ -13,7 +13,7 @@ -- Main ----------------------------------------------------------------------- main :: IO ()-main +main = do args <- getArgs config <- parseArgs args defaultConfig @@ -44,7 +44,7 @@ defaultConfig :: Config defaultConfig = Config- { configSizeX = 800 + { configSizeX = 800 , configSizeY = 600 , configFullScreen = False , configZoom = 2@@ -96,7 +96,7 @@ , " -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)"- , " -degree <NAT> Number waves to sum for each point (default 5)" + , " -degree <NAT> Number waves to sum for each point (default 5)" , "" , " You'll want to run this with +RTS -N to enable threads" ] @@ -123,11 +123,11 @@ quasicrystal :: Scale -> Degree -> Time -> Point -> Color quasicrystal !scale !degree !time !p = let -- Scale the time to be the phi value of the animation.- -- The action seems to slow down at increasing phi values, + -- The action seems to slow down at increasing phi values, -- so we increase phi faster as time moves on. phi = 1 + (time ** 1.5) * 0.005 - in rampColor + in rampColor $ waves degree phi $ point scale p @@ -143,8 +143,8 @@ | n == 0 = acc | otherwise = waver (acc + wave (fromIntegral n * th) x) (n - 1)- - wrap n ++ wrap n = let !n_ = truncate n :: Int !n' = n - fromIntegral n_ in if odd n_ then 1 - n'@@ -163,13 +163,13 @@ -- | Convert an image point to a point on our wave plane. point :: Scale -> Point -> Point-point !scale (x, y) +point !scale (x, y) = (x * scale, y * scale) -- | Color ramp from blue to white. rampColor :: Float -> Color-rampColor v +rampColor v = rgb' v (0.4 + (v * 0.6)) 1
raster/Mandel/Main.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-} import Graphics.Gloss.Interface.IO.Game import Graphics.Gloss.Interface.Environment@@ -11,11 +13,11 @@ main :: IO ()-main +main = do args <- getArgs config <- parseArgs args defaultConfig - (width,height) + (width,height) <- if configDisplay config == FullScreen then getScreenSize else return (configSizeX config, configSizeY config)@@ -35,7 +37,7 @@ -- Render image and write to .bmp file. Just filePath- -> do arr <- mandelArray + -> do arr <- mandelArray (worldSizeX world) (worldSizeY world) (worldPosX world) (worldPosY world) (worldZoom world) (worldRadius world)@@ -45,9 +47,9 @@ -- Config ----------------------------------------------------------------------data Config +data Config = Config- { configDisplay :: Display + { configDisplay :: Display , configFileName :: Maybe FilePath , configPreset :: World -> World , configPixelsDynamic :: Int@@ -58,7 +60,7 @@ defaultConfig :: Config defaultConfig = Config- { configDisplay = InWindow "Mandelbrot" (800, 600) (10, 10) + { configDisplay = InWindow "Mandelbrot" (800, 600) (10, 10) , configFileName = Nothing , configPreset = id , configPixelsDynamic = 4@@ -72,7 +74,7 @@ = return config | "-fullscreen" : rest <- args- = parseArgs rest + = parseArgs rest $ config { configDisplay = FullScreen } | "-window" : sizeX : sizeY : rest <- args@@ -106,15 +108,15 @@ = do printUsage exitWith $ ExitFailure 1 - + printUsage :: IO () printUsage- = putStrLn + = putStrLn $ unlines [ "Usage: gloss-mandel [flags]" , " -fullscreen"- , " -window <width::INT> <height::INT>" - , " -bmp <width::INT> <height::INT> <FILE>" + , " -window <width::INT> <height::INT>"+ , " -bmp <width::INT> <height::INT> <FILE>" , " -dynamic <INT> Level of detail reduction when zooming and panning. (4) " , "" , " Controls:"@@ -140,18 +142,18 @@ , worldPixelsDynamic :: Int , worldPosX :: Double- , worldPosY :: Double + , worldPosY :: Double , worldZoom :: Double , worldIterations :: Double , worldRadius :: Double - , worldDragging :: Maybe (Float, Float) - , worldZooming :: Maybe Double } + , worldDragging :: Maybe (Float, Float)+ , worldZooming :: Maybe Double } initWorld :: Int -> Int -> World-initWorld sizeX sizeY +initWorld sizeX sizeY = World { worldPicture = Blank @@ -161,22 +163,22 @@ , worldPixelsDynamic = 4 , worldPosX = -0.5- , worldPosY = 0 + , worldPosY = 0 , worldZoom = 2 , worldIterations = 100 , worldRadius = 2- , worldDragging = Nothing + , worldDragging = Nothing , worldZooming = Nothing } draw :: World -> IO Picture-draw world +draw world = return $ worldPicture world handle :: Event -> World -> IO World-handle event world +handle event world -- Pan | EventKey (MouseButton LeftButton) Down _ (x, y) <- event@@ -208,7 +210,7 @@ | EventKey (Char 'd') Down _ _ <- event = return $ world { worldIterations = worldIterations world * 1.2 } - -- Radius + -- Radius | EventKey (Char 'z') Down _ _ <- event = return $ world { worldRadius = worldRadius world * 0.5 } @@ -246,7 +248,7 @@ advance :: Float -> World -> IO World-advance _ world +advance _ world | Just factor <- worldZooming world = return $ zoomWorld factor world @@ -276,12 +278,12 @@ | dynamic = worldPixels world + worldPixelsDynamic world | otherwise = worldPixels world - in world { worldPicture + in world { worldPicture = mandelPicture (worldSizeX world) (worldSizeY world) pixels pixels (worldPosX world) (worldPosY world)- (worldZoom world) + (worldZoom world) (worldRadius world) (truncate $ worldIterations world) }@@ -310,8 +312,8 @@ presets :: [World -> World]-presets - = map loadWorld +presets+ = map loadWorld $ [ (-0.5, 0, 2, 100, 2) , (0.20508818500545423, 0.9014915666351141 * 900/1440,6.375321937544527e-6, 629.3354966759534, 16.0) , (0.4510757067879078, 0.6144133202705898 * 900/1440,7.632248223018773e-5, 253.61352386150395, 2.0)
raster/Mandel/Solver.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-module Solver +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Solver ( mandelPicture , mandelArray , f2d@@ -75,12 +78,12 @@ sizeX = winSizeX `div` zoomX sizeY = winSizeY `div` zoomY - {-# INLINE conv #-} + {-# INLINE conv #-} conv (r, g, b) = let r' = fromIntegral r g' = fromIntegral g b' = fromIntegral b- a = 255 + a = 255 !w = unsafeShiftL r' 24 .|. unsafeShiftL g' 16@@ -93,12 +96,12 @@ -- Define the image, and extract out just the RGB color components. -- We don't need the alpha because we're only drawing one image. (arrRGB :: Array F DIM2 Word32)- <- R.computeP + <- R.computeP $ R.map conv $ makeFrame winSizeX winSizeY zoomX zoomY makePixel -- Wrap the ForeignPtr from the Array as a gloss picture.- let picture + let picture = Scale (fromIntegral zoomX) (fromIntegral zoomY) $ bitmapOfForeignPtr sizeX sizeY -- raw image size@@ -145,14 +148,14 @@ in makePixel x' y' in R.hintInterleave- $ R.map unpackColor + $ R.map unpackColor $ R.fromFunction (Z :. sizeY :. sizeX) $ pixelOfIndex {-# INLINE makeFrame #-} -- Mandel ----------------------------------------------------------------------mandelPixel +mandelPixel :: Double -- Scale X -> Double -- Scale Y -> Double -- Offset X@@ -163,7 +166,7 @@ -> Double -- X (Real) -> Double -- Y (Imaginary) -> Color-mandelPixel scaleX scaleY x0 y0 zoom cMax rMax x y +mandelPixel scaleX scaleY x0 y0 zoom cMax rMax x y = let !x' = x0 + x * zoom * scaleX !y' = y0 + y * zoom * scaleY@@ -188,7 +191,7 @@ | count >= countMax = count | sqrt (zr * zr + zi * zi) > rMax = count - | otherwise + | otherwise = let !z2r = zr*zr - zi*zi !z2i = 2 * zr * zi !yr = z2r + cr@@ -212,7 +215,7 @@ -- doesn't have enout specialisations and goes via Integer. word8OfFloat :: Float -> Word8 word8OfFloat f- = fromIntegral (truncate f :: Int) + = fromIntegral (truncate f :: Int) {-# INLINE word8OfFloat #-}
raster/Pulse/Main.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE BangPatterns #-}+ import Graphics.Gloss.Raster.Field main :: IO ()-main +main = let get :: Float -> Point -> Color get !t _ = makeColor t t t 1.0 {-# INLINE get #-}- - in animateField ++ in animateField (InWindow "Pulse" (800, 600) (100, 100)) (1, 1) get
raster/Ray/Light.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -module Light +module Light ( Light(..) , translateLight , applyLights)@@ -46,7 +46,7 @@ :: [Object] -- possible occluding objects, used for shadows. -> Vec3 -- point which is being lit -> Vec3 -- surface normal at this point- -> Light + -> Light -> Color applyLight !objs !point !normal !(Light lpoint color)@@ -65,5 +65,5 @@ -- the light that is reflected !refl = color `mulsV3` mag in refl-{-# INLINE applyLight #-} - +{-# INLINE applyLight #-}+
raster/Ray/Main.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, PatternGuards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+ import World import Trace import Light@@ -15,7 +17,7 @@ main :: IO ()-main +main = do args <- getArgs config <- parseArgs args defaultConfig @@ -26,13 +28,13 @@ (configZoom config) (configFieldOfView config) (configBounces config) - Just file + Just file -> runBmp file (configSizeX config) (configSizeY config) (configFieldOfView config) (configBounces config) - + -- Config --------------------------------------------------------------------- data Config = Config@@ -95,10 +97,10 @@ exitWith $ ExitFailure 1 printUsage :: IO ()-printUsage +printUsage = putStrLn $ unlines [ "gloss-ray [flags]"- , " -window <sizeX::INT> <sizeY::INT> <zoom::INT> (800, 400, 4)"+ , " -window <sizeX::INT> <sizeY::INT> <zoom::INT> (800, 600, 4)" , " -bmp <sizeX::INT> <sizeY::INT> <FILE>" , " -fov <INT> Field of view (100)" , " -bounces <INT> Ray bounce limit (4)"@@ -110,7 +112,7 @@ -- | World and interface state. data State = State- { stateTime :: !Float + { stateTime :: !Float , stateEyePos :: !Vec3 , stateEyeLoc :: !Vec3 @@ -139,7 +141,7 @@ , stateEyePos = Vec3 50 (-100) (-700) , stateEyeLoc = Vec3 (-50) 200 1296 - , stateLeftClick = Nothing + , stateLeftClick = Nothing , stateMoveSpeed = 400 , stateMovingForward = False@@ -156,9 +158,9 @@ -- Run ------------------------------------------------------------------------ -- | Run the simulation interactively.-runInteractive :: Int -> Int -> Int -> Int -> Int -> IO () +runInteractive :: Int -> Int -> Int -> Int -> Int -> IO () runInteractive sizeX sizeY zoom fov bounces- = G.playField + = G.playField (G.InWindow "Ray" (sizeX, sizeY) (10, 10)) (zoom, zoom) 100@@ -173,10 +175,10 @@ -- | Write the first frame to a .bmp file runBmp :: FilePath -> Int -> Int -> Int -> Int -> IO () runBmp file sizeX sizeY fov bounces- = do img <- R.computeUnboxedP + = do img <- R.computeUnboxedP $ G.makeFrame sizeX sizeY- $ tracePixel sizeX sizeY fov bounces - $ advanceState 1 + $ tracePixel sizeX sizeY fov bounces+ $ advanceState 1 $ initState 0 R.writeImageToBMP file img@@ -193,13 +195,13 @@ !fov' = fromIntegral fov !fovX = fov' * aspect !fovY = fov'- + !ambient = Vec3 0.3 0.3 0.3 !eyePos = stateEyePos state !eyeDir = normaliseV3 ((Vec3 (x * fovX) ((-y) * fovY) 0) - eyePos) Vec3 r g b- = traceRay (stateObjectsView state) + = traceRay (stateObjectsView state) (stateLightsView state) ambient eyePos eyeDir bounces@@ -210,14 +212,14 @@ -- | Handle an event from the user interface. handleEvent :: G.Event -> State -> State-handleEvent event state +handleEvent event state -- Start translation.- | G.EventKey (G.MouseButton G.LeftButton) + | G.EventKey (G.MouseButton G.LeftButton) G.Down _ (x, y) <- event = state { stateLeftClick = Just (x, y)} -- End transation.- | G.EventKey (G.MouseButton G.LeftButton) + | G.EventKey (G.MouseButton G.LeftButton) G.Up _ _ <- event = state { stateLeftClick = Nothing } @@ -259,7 +261,7 @@ in setEyeLoc (Vec3 eyeX' eyeY' eyeZ') $ state { stateLeftClick = Just (x, y) }- + | otherwise = state {-# NOINLINE handleEvent #-}@@ -271,7 +273,7 @@ = let time' = stateTime state + advTime speed = stateMoveSpeed state- move = (if stateMovingForward state + move = (if stateMovingForward state then moveEyeLoc (Vec3 0 0 (-speed * advTime)) else id) . (if stateMovingBackward state@@ -293,10 +295,10 @@ setEyeLoc eyeLoc state = let objects = makeObjects (stateTime state) lights = makeLights (stateTime state)- in state + in state { stateEyeLoc = eyeLoc , stateObjectsView = map (translateObject (stateEyeLoc state)) objects- , stateLightsView = map (translateLight (stateEyeLoc state)) lights + , stateLightsView = map (translateLight (stateEyeLoc state)) lights } {-# NOINLINE setEyeLoc #-} @@ -319,12 +321,12 @@ setTime time state = let objects = makeObjects time lights = makeLights time- in state + in state { stateTime = time , stateObjects = objects , stateObjectsView = map (translateObject (stateEyeLoc state)) objects , stateLights = lights- , stateLightsView = map (translateLight (stateEyeLoc state)) lights + , stateLightsView = map (translateLight (stateEyeLoc state)) lights } {-# NOINLINE setTime #-}
raster/Ray/Object.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -module Object +module Object ( Color , Object(..) , translateObject@@ -49,7 +49,7 @@ castRay :: [Object] -- check for intersections on all these objects -> Vec3 -- ray origin -> Vec3 -- ray direction- -> Maybe + -> Maybe ( Object -- object of first intersected , Vec3) -- position of intersection, on surface of object @@ -57,14 +57,14 @@ = go0 objs where -- We haven't hit any objects yet. go0 [] = Nothing- go0 (obj:rest) + go0 (obj:rest) = case distanceToObject obj orig dir of Nothing -> go0 rest Just dist -> go1 rest obj dist -- We hit an object before, and we're testing others -- to see if they're closer.- go1 [] !objClose !dist + go1 [] !objClose !dist = Just (objClose, orig + dir `mulsV3` dist) go1 (obj:rest) !objClose !dist@@ -76,14 +76,14 @@ {-# INLINE castRay #-} --- | Like castRay, but take continuations for the Nothing and Just branches to +-- | Like castRay, but take continuations for the Nothing and Just branches to -- eliminate intermediate unboxings. castRay_continuation :: [Object] -- check for intersections on all these objects -> Vec3 -- ray origin -> Vec3 -- ray direction - -> a -- continuation when no intersection + -> a -- continuation when no intersection -> (Object -> Vec3 -> a) -- continuation with intersection -> a @@ -91,14 +91,14 @@ = go0 objs where -- We haven't hit any objects yet. go0 [] = contNone- go0 (obj:rest) + go0 (obj:rest) = case distanceToObject obj orig dir of Nothing -> go0 rest Just dist -> go1 rest obj dist -- We hit an object before, and we're testing others -- to see if they're closer.- go1 [] !objClose !dist + go1 [] !objClose !dist = contJust objClose (orig + dir `mulsV3` dist) go1 (obj:rest) !objClose !dist@@ -117,7 +117,7 @@ -> Vec3 -- ^ Ray direction. -> Float -- ^ Minimum distance. -> Bool- + checkRay !objs !orig !dir !dist = go0 objs where go0 [] = False@@ -127,7 +127,7 @@ Just dist' | dist' < dist -> True | otherwise -> go0 rest-{-# INLINE checkRay #-} +{-# INLINE checkRay #-} -- | Compute the distance to the surface of this shape@@ -140,26 +140,26 @@ distanceToObject !obj !orig !dir = case obj of Sphere pos radius _ _- -> let !p = orig + dir `mulsV3` ((pos - orig) `dotV3` dir) + -> let !p = orig + dir `mulsV3` ((pos - orig) `dotV3` dir) !d_cp = magnitudeV3 (p - pos) in if d_cp >= radius then Nothing else if (p - orig) `dotV3` dir <= 0.0 then Nothing else Just $ magnitudeV3 (p - orig) - sqrt (radius * radius - d_cp * d_cp) Plane pos normal _ _- -> if dotV3 dir normal >= 0.0 + -> if dotV3 dir normal >= 0.0 then Nothing else Just (((pos - orig) `dotV3` normal) / (dir `dotV3` normal)) PlaneCheck pos normal _- -> if dotV3 dir normal >= 0.0 + -> if dotV3 dir normal >= 0.0 then Nothing else Just (((pos - orig) `dotV3` normal) / (dir `dotV3` normal)) {-# INLINE distanceToObject #-} - + -- | Compute the surface normal of the shape at this point-surfaceNormal +surfaceNormal :: Object -> Vec3 -- ^ A point on the surface of the shape. -> Vec3@@ -185,13 +185,13 @@ -- | Get the shine of an object at the given point. shineOfObject :: Object -> Vec3 -> Float shineOfObject obj _point- = case obj of + = case obj of Sphere _ _ _ s -> s Plane _ _ _ s -> s PlaneCheck _ _ s -> s {-# INLINE shineOfObject #-} - + -- | A checkerboard pattern along the x/z coords checkers :: Vec3 -> Vec3 checkers (Vec3 x _ z)@@ -200,7 +200,7 @@ `xor` (x < 0.0) `xor` (z < 0.0) = Vec3 1.0 1.0 1.0- + | otherwise = Vec3 0.4 0.4 0.4
raster/Ray/Trace.hs view
@@ -15,29 +15,29 @@ -> Vec3 -- direction of ray -> Int -- maximum reflection count -> Color -- visible color for this ray- + traceRay !objs !lights !ambient !(Vec3 gX gY gZ) !dir !limit = go gX gY gZ dir limit- where + where -- too many reflections, -- give up incase we've found two parallel mirrors.. go _ _ _ _ 0 = Vec3 0.0 0.0 0.0 go !oX !oY oZ !dir' !bounces- = castRay_continuation objs (Vec3 oX oY oZ) dir' + = castRay_continuation objs (Vec3 oX oY oZ) dir' -- ray didn't intersect any objects (Vec3 0.0 0.0 0.0) -- ray hit an object (\obj point@(Vec3 pX' pY' pZ')- -> let + -> let -- get the surface normal at that point. !normal = surfaceNormal obj point -- result angle of ray after reflection. !newdir = dir - normal `mulsV3` (2.0 * (normal `dotV3` dir))- + -- determine the direct lighting at this point !direct = applyLights objs point normal lights @@ -46,14 +46,14 @@ -- total lighting is the direct lights plus ambient !lighting = direct + ambient- + -- total incoming light is direct lighting plus reflections !color = colorOfObject obj point !shine = shineOfObject obj point- - !light_in = refl `mulsV3` shine ++ !light_in = refl `mulsV3` shine + lighting `mulsV3` (1.0 - shine)- + -- Outgoing light is incoming light modified by surface color. -- We also need to clip it incase the sum of all incoming lights -- will be too bright to display.
raster/Ray/Vec3.hs view
@@ -40,12 +40,12 @@ -- | Normalise a vector to have unit length. normaliseV3 :: Vec3 -> Vec3 normaliseV3 v- = v `mulsV3` (1.0 / magnitudeV3 v) + = v `mulsV3` (1.0 / magnitudeV3 v) {-# INLINE normaliseV3 #-} -- | Multiply a vector by a scalar.-mulsV3 :: Vec3 -> Float -> Vec3 +mulsV3 :: Vec3 -> Float -> Vec3 mulsV3 (Vec3 x1 y1 z1) s = Vec3 (s * x1) (s * y1) (s * z1) {-# INLINE mulsV3 #-}@@ -63,7 +63,7 @@ clampV3 (Vec3 r g b) minVal maxVal = Vec3 (clamp r) (clamp g) (clamp b) where {-# INLINE clamp #-}- clamp x + clamp x | x <= minVal = minVal | x >= maxVal = maxVal | otherwise = x
raster/Ray/World.hs view
@@ -3,7 +3,7 @@ module World ( makeLights , makeObjects)-where +where import Object import Light import Vec3@@ -17,19 +17,19 @@ (Vec3 300.0 (-300.0) (-100.0)) (Vec3 150000.0 150000.0 150000.0) ] - + -- | Objects in the world {-# NOINLINE makeObjects #-} makeObjects :: Float -> [Object] makeObjects time =- [ Sphere + [ Sphere (Vec3 (40 * sin time) 80 0.0) 20 (Vec3 1.0 0.3 1.0) 0.4- + , Sphere- (Vec3 (200 * sin time) + (Vec3 (200 * sin time) ((-40) * sin (time + pi/2)) (200 * cos time)) 100.0@@ -37,7 +37,7 @@ 0.8 , Sphere- (Vec3 (-200.0 * sin time) + (Vec3 (-200.0 * sin time) ((-40) * sin (time - pi/2)) (-200 * cos time)) 100.0@@ -48,7 +48,7 @@ (Vec3 0.0 (-150.0) (-100.0)) 50.0 (Vec3 1.0 1.0 1.0) 0.8- + , PlaneCheck (Vec3 0.0 100.0 0.0) (normaliseV3 (Vec3 0 (-1) (-0.2)))
raster/Snow/Main.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE BangPatterns #-}++module Main where+ import Graphics.Gloss.Raster.Array import System.Environment import Data.Array.Repa.Algorithms.Randomish@@ -20,8 +23,8 @@ [ "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@@ -42,7 +45,7 @@ in R.zipWith makePixel arr1 arr2 - animateArray + animateArray (InWindow "Digital Snow" (windowX, windowY) (10, 10)) (scaleX, scaleY) frame
raster/Wave/Main.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE BangPatterns, MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+ import Graphics.Gloss.Raster.Field import qualified Data.Vector.Unboxed as U import GHC.Prim import GHC.Exts main :: IO ()-main +main = let !n = 65536 !sins = U.fromList [sin ( (i / n) * (2 * pi)) | i <- [0..n]]@@ -20,7 +22,7 @@ get :: Float -> Point -> Color get !t (x, y)- = t `seq` + = t `seq` let !x' = abs $ x + 1 !y' = abs $ y + 1 !r1 = abs $ 0.5 * (usin (x' + 0.2 * (usin t)) + ucos y')@@ -28,7 +30,7 @@ in rgb' r1 0 r2 {-# INLINE get #-} - in animateField + in animateField (InWindow "Wave" (800, 600) (100, 100)) (1, 1) get@@ -44,6 +46,5 @@ w' = and# w (int2Word# 0x0ffff#) i = word2Int# w' in (I# i)-{-# INLINE to64k #-} +{-# INLINE to64k #-} -