brillo-examples (empty) → 1.13.3
raw patch · 51 files changed
+4649/−0 lines, 51 filesdep +GLFW-bdep +basedep +bmpsetup-changed
Dependencies added: GLFW-b, base, bmp, brillo, brillo-algorithms, brillo-rendering, bytestring, containers, ghc-prim, random, vector
Files
- LICENSE +22/−0
- Setup.hs +4/−0
- brillo-examples.cabal +297/−0
- picture/Bitmap/Main.hs +41/−0
- picture/Boids/KDTree2d.hs +174/−0
- picture/Boids/Main.hs +367/−0
- picture/Boids/Vec2.hs +59/−0
- picture/Clock/Main.hs +82/−0
- picture/Color/Main.hs +38/−0
- picture/Conway/Cell.hs +94/−0
- picture/Conway/Main.hs +70/−0
- picture/Conway/World.hs +137/−0
- picture/Draw/Main.hs +67/−0
- picture/Easy/Main.hs +7/−0
- picture/Eden/Cell.hs +43/−0
- picture/Eden/Community.hs +65/−0
- picture/Eden/Main.hs +20/−0
- picture/Eden/World.hs +52/−0
- picture/Flake/Main.hs +53/−0
- picture/GameEvent/Main.hs +16/−0
- picture/Graph/Main.hs +395/−0
- picture/Gravity/Main.hs +113/−0
- picture/Hello/Main.hs +23/−0
- picture/Lifespan/Cell.hs +46/−0
- picture/Lifespan/Community.hs +63/−0
- picture/Lifespan/Main.hs +20/−0
- picture/Lifespan/World.hs +52/−0
- picture/Machina/Main.hs +46/−0
- picture/Occlusion/Cell.hs +48/−0
- picture/Occlusion/Data.hs +42/−0
- picture/Occlusion/Main.hs +123/−0
- picture/Occlusion/State.hs +45/−0
- picture/Occlusion/World.hs +161/−0
- picture/Render/Main.hs +68/−0
- picture/Styrene/Actor.hs +92/−0
- picture/Styrene/Advance.hs +138/−0
- picture/Styrene/Collide.hs +186/−0
- picture/Styrene/Config.hs +59/−0
- picture/Styrene/Contact.hs +156/−0
- picture/Styrene/Main.hs +128/−0
- picture/Styrene/QuadTree.hs +114/−0
- picture/Styrene/World.hs +111/−0
- picture/Tree/Main.hs +71/−0
- picture/Visibility/Draw.hs +138/−0
- picture/Visibility/Geometry/Randomish.hs +120/−0
- picture/Visibility/Geometry/Segment.hs +81/−0
- picture/Visibility/Interface.hs +93/−0
- picture/Visibility/Main.hs +34/−0
- picture/Visibility/State.hs +57/−0
- picture/Visibility/World.hs +54/−0
- picture/Zen/Main.hs +64/−0
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2010-2024 The Gloss Development Team,+Copyright (c) 2024-2025 The Brillo Development Team++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ brillo-examples.cabal view
@@ -0,0 +1,297 @@+cabal-version: 3.0+name: brillo-examples+version: 1.13.3+license: MIT+license-file: LICENSE+author: Ben Lippmeier, Adrian Sieber+maintainer: brillo@ad-si.com+build-type: Simple+stability: experimental+category: Graphics+homepage: https://github.com/ad-si/Brillo+description:+ Examples using the Brillo graphics library.+ A mixed bag of fractals, particle simulations and cellular automata.++synopsis: Examples using the Brillo library++flag llvm+ 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/ad-si/Brillo++executable brillo-bitmap+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Bitmap+ build-depends:+ , base >=4.8 && <5+ , bmp >=1.2 && <1.3+ , brillo >=1.13.3 && <1.15+ , bytestring >=0.11 && <0.12++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-boids+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Boids+ other-modules:+ KDTree2d+ Vec2++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , random >=1.2 && <1.3++ ghc-options: -O2 -threaded -rtsopts++executable brillo-clock+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Clock+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-color+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Color+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , vector >=0.13 && <0.14++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-conway+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Conway+ other-modules:+ Cell+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , random >=1.2 && <1.3+ , vector >=0.13 && <0.14++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-draw+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Draw+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-easy+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Easy+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-eden+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Eden+ other-modules:+ Cell+ Community+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , random >=1.2 && <1.3++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-flake+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Flake+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-gameevent+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/GameEvent+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-hello+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Hello+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-lifespan+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Lifespan+ other-modules:+ Cell+ Community+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , random >=1.2 && <1.3++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-machina+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Machina+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-occlusion+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Occlusion+ other-modules:+ Cell+ Data+ State+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , brillo-algorithms >=1.13.3 && <1.15++ ghc-options: -O2 -threaded -rtsopts++executable brillo-styrene+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Styrene+ other-modules:+ Actor+ Advance+ Collide+ Config+ Contact+ QuadTree+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , containers >=0.5 && <0.7+ , ghc-prim++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-tree+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Tree+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-visibility+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Visibility+ other-modules:+ Draw+ Geometry.Randomish+ Geometry.Segment+ Interface+ State+ World++ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , vector >=0.13 && <0.14++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-zen+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Zen+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-graph+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Graph+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , containers >=0.5 && <0.7+ , random >=1.2 && <1.3++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-gravity+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Gravity+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , containers >=0.5 && <0.7+ , random >=1.2 && <1.3++ ghc-options: -O2 -Wall -threaded -rtsopts++executable brillo-render+ default-language: GHC2021+ build-depends:+ , base >=4.8 && <5+ , brillo >=1.13.3 && <1.15+ , brillo-rendering >=1.13.3 && <1.15+ , containers >=0.5 && <0.7+ , GLFW-b >=3.3 && <4++ main-is: Main.hs+ hs-source-dirs: picture/Render+ ghc-options: -O2 -Wall -threaded -rtsopts
+ picture/Bitmap/Main.hs view
@@ -0,0 +1,41 @@+module Main where++import Brillo+import System.Environment+++-- | Displays uncompressed 24/32 bit BMP images.+main :: IO ()+main =+ do+ args <- getArgs+ case args of+ [fileName] -> run fileName+ _ ->+ 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 bmpData) <-+ loadBMP fileName++ let (width, height) = bitmapSize bmpData+ animate+ (InWindow fileName (width, height) (10, 10))+ black+ (frame width height picture)+++frame :: Int -> Int -> Picture -> Float -> Picture+frame width height picture t =+ Color (greyN (abs $ sin (t * 2))) $+ Pictures+ [ rectangleSolid (fromIntegral width) (fromIntegral height)+ , picture+ ]
+ picture/Boids/KDTree2d.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE BangPatterns #-}++-- KDTree code+-- by Matthew Sottile <matt@galois.com> <mjsottile@computer.org>+--+module KDTree2d (+ KDTreeNode (..),+ newKDTree,+ kdtAddPoints,+ kdtAddPoint,+ kdtRangeSearch,+ kdtCollisionDetect,+ kdtInBounds,+ dumpKDTree,+ mapKDTree,+ kdtreeToList,+) where++import Data.Maybe+import System.IO+import Vec2+++data KDTreeNode a+ = Empty+ | Node !(KDTreeNode a) !Vec2 !a !(KDTreeNode a)+ deriving (Show)+++-- | An empty KDTree+newKDTree :: KDTreeNode a+newKDTree = Empty+++-- | Flatten out a KDTree to a list.+kdtreeToList :: KDTreeNode a -> [a]+kdtreeToList Empty = []+kdtreeToList (Node l _ x r) = [x] ++ kdtreeToList l ++ kdtreeToList r+++-- | Apply a worker function to all elements of a KDTree.+mapKDTree :: KDTreeNode a -> (a -> b) -> [b]+mapKDTree Empty _ = []+mapKDTree (Node l _p n r) f = f n : (mapKDTree l f ++ mapKDTree r f)+++kdtAddWithDepth :: KDTreeNode a -> Vec2 -> a -> Int -> KDTreeNode a+kdtAddWithDepth Empty pos dat _ =+ Node Empty pos dat Empty+kdtAddWithDepth (Node left npos ndata right) pos dat d+ | vecDimSelect pos d < vecDimSelect npos d =+ Node (kdtAddWithDepth left pos dat d') npos ndata right+ | otherwise =+ Node left npos ndata (kdtAddWithDepth right pos dat d')+ where+ d' = if (d == 1) then 0 else 1+++kdtAddPoint :: KDTreeNode a -> Vec2 -> a -> KDTreeNode a+kdtAddPoint t p d =+ kdtAddWithDepth t p d 0+++kdtInBounds :: Vec2 -> Vec2 -> Vec2 -> Bool+kdtInBounds p bMin bMax =+ vecLessThan p bMax && vecGreaterThan p bMin+++-- X dimension+kdtRangeSearchRecX :: KDTreeNode a -> Vec2 -> Vec2 -> [(Vec2, a)]+kdtRangeSearchRecX Empty _ _ = []+kdtRangeSearchRecX (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)+ | otherwise =+ nextfun right bMin bMax ++ nextfun left bMin bMax+ where+ Vec2 nc _ = npos+ Vec2 mnc _ = bMin+ Vec2 mxc _ = bMax+ nextfun = kdtRangeSearchRecY+++-- Y dimension+kdtRangeSearchRecY :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2, a)]+kdtRangeSearchRecY Empty _ _ = []+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)+ | otherwise =+ nextfun right bMin bMax ++ nextfun left bMin bMax+ where+ Vec2 _ nc = npos+ Vec2 _ mnc = bMin+ Vec2 _ mxc = bMax+ nextfun = kdtRangeSearchRecX+++kdtRangeSearch :: (KDTreeNode a) -> Vec2 -> Vec2 -> [(Vec2, a)]+kdtRangeSearch t bMin bMax =+ kdtRangeSearchRecX t bMin bMax+++kdtAddPoints :: [(Vec2, a)] -> (KDTreeNode a) -> (KDTreeNode a)+kdtAddPoints [] t = t+kdtAddPoints ((pt, dat) : ps) t =+ kdtAddPoints ps $ kdtAddPoint t pt dat+++singleCollision :: Vec2 -> Vec2 -> Vec2 -> Double -> a -> Maybe (Vec2, a)+singleCollision pt start a eps dat+ | sqrd_dist < eps * eps =+ Just (vecAdd start p, dat)+ | otherwise =+ Nothing+ where+ b = vecSub pt start+ xhat = (vecDot a b) / (vecDot a a)+ p = vecScale a xhat+ e = vecSub p b+ sqrd_dist = vecDot e e+++kdtCollisionDetect :: KDTreeNode a -> Vec2 -> Vec2 -> Double -> [(Vec2, a)]+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)+ rmax = Vec2 (max sx ex + eps) (max sy ey + eps)+ 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 =+ do+ h <- openFile name WriteMode+ hPutStrLn h "n x y z"+ dumpKDTreeInner kdt h+ hClose h+++-- | Dump a KDTree to a handle.+dumpKDTreeInner :: KDTreeNode Int -> Handle -> IO ()+dumpKDTreeInner kdt h =+ case kdt of+ Empty -> return ()+ Node l v d r ->+ do+ printVec v h d+ dumpKDTreeInner l h+ dumpKDTreeInner r h+++-- | Print a vector to a handle.+printVec :: Vec2 -> Handle -> Int -> IO ()+printVec (Vec2 x y) h i =+ hPutStrLn h $ show i ++ " " ++ show x ++ " " ++ show y
+ picture/Boids/Main.hs view
@@ -0,0 +1,367 @@+-- 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 Brillo+import Brillo.Interface.Pure.Simulate+import KDTree2d+import System.IO.Unsafe+import System.Random+import Vec2+++-- Parameters -----------------------------------------------------------------+cParam = 0.0075+++sParam = 0.1+sScale = 1.25+++aParam = 1.0 / 1.8+vLimit = 0.0025 * max (maxx - minx) (maxy - miny)+epsilon = 0.40+maxx = 8.0+maxy = 8.0+minx = -8.0+miny = -8.0+++-- Colors ---------------------------------------------------------------------+boidColor = makeColor 1.0 1.0 0.0 1.0+radiusColor = makeColor 0.5 1.0 1.0 0.2+cohesionColor = makeColor 1.0 0.0 0.0 1.0+separationColor = makeColor 0.0 1.0 0.0 1.0+alignmentColor = makeColor 0.0 0.0 1.0 1.0+++-- Types ----------------------------------------------------------------------+data World+ = World+ { width :: Double+ , height :: Double+ , pixWidth :: Int+ , pixHeight :: Int+ }+ deriving (Show)+++data Boid+ = Boid+ { identifier :: Int+ , position :: Vec2+ , velocity :: Vec2+ , dbgC :: Vec2+ , dbgS :: Vec2+ , dbgA :: Vec2+ }+ deriving (Show)+++-- Main -----------------------------------------------------------------------+main :: IO ()+main =+ do+ let w =+ World+ { width = maxx - minx+ , height = maxy - miny+ , pixWidth = 700+ , pixHeight = 700+ }++ let bs = initialize 500 10.0 0.5+ let t = foldl (\t b -> kdtAddPoint t (position b) b) newKDTree bs++ simulate+ (InWindow "Boids" (pixWidth w, pixHeight w) (10, 10))+ (greyN 0.1)+ 30+ t+ (renderboids w)+ iterationkd+++-- Coordinate Conversion ------------------------------------------------------+modelToScreen :: World -> (Double, Double) -> (Float, Float)+modelToScreen world (x, y) =+ let xscale = fromIntegral (pixWidth world) / width world+ yscale = fromIntegral (pixHeight world) / height world+ in (realToFrac $ x * xscale, realToFrac $ y * yscale)+++scaleFactor :: World -> Float+scaleFactor world =+ let xscale = fromIntegral (pixWidth world) / width world+ yscale = fromIntegral (pixHeight world) / height world+ in realToFrac $ max xscale yscale+++velocityScale :: Float+velocityScale = 10.0 * (realToFrac (max (maxx - minx) (maxy - miny)) :: Float)+++-- Rendering -----------------------------------------------------------------+renderboids :: World -> KDTreeNode Boid -> Picture+renderboids world bs =+ Pictures $ mapKDTree bs (renderboid world)+++renderboid :: World -> Boid -> Picture+renderboid world b =+ let (Vec2 x y) = position b+ (Vec2 vx vy) = velocity b+ v = velocity b+ (Vec2 dCX dCY) = dbgC b+ (Vec2 dSX dSY) = dbgS b+ (Vec2 dAX dAY) = dbgA b+ sf = 5.0 * (scaleFactor world)+ sf' = 1.0 * (scaleFactor world)+ sf2 = sf * 10+ (xs, ys) = modelToScreen world (x, y)+ vxs = sf * (realToFrac vx) :: Float+ vys = sf * (realToFrac vy) :: Float+ in Pictures+ [ Color boidColor $+ Translate xs ys $+ Circle 2+ , Color radiusColor $+ Translate xs ys $+ Circle ((realToFrac epsilon) * sf')+ , Color boidColor $+ Line [(xs, ys), (xs + vxs, ys + vys)]+ , Color cohesionColor $+ Line [(xs, ys), (xs + sf2 * realToFrac dCX, ys + sf2 * realToFrac dCY)]+ , Color alignmentColor $+ Line [(xs, ys), (xs + sf2 * realToFrac dAX, ys + sf2 * realToFrac dAY)]+ , Color separationColor $+ Line [(xs, ys), (xs + sf' * realToFrac dSX, ys + sf' * realToFrac dSY)]+ ]+++-- Initialisation -------------------------------------------------------------+rnlist :: Int -> IO [Double]+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)+ nums' = map (\i -> (0.5 - i) / 2.0) nums++ makeboids [] [] = []+ 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+ }+ : makeboids rest ids+ in makeboids nums' [1 .. n]+++-- Vector Helpers -------------------------------------------------------------++{-| Sometimes we want to control runaway of vector scales, so this can+ be used to enforce an upper bound+-}+limiter :: Vec2 -> Double -> Vec2+limiter x lim =+ let d = vecNorm x+ in if (d < lim)+ then x+ else vecScale (vecNormalize x) lim+++-- | Vector with all components length epsilon+epsvec :: Vec2+epsvec = Vec2 epsilon epsilon+++-- Boids Logic ----------------------------------------------------------------++-- three rules:+-- cohesion (seek centroid)+-- separation (avoid neighbors),+-- and alignment (fly same way as neighbors)++{-| Centroid is average position of boids, or the vector sum of all+ boid positions scaled by 1/(number of boids)+-}+findCentroid :: [Boid] -> Vec2+findCentroid [] = error "Bad centroid"+findCentroid boids =+ let n = length boids+ in vecScale+ (foldl1 vecAdd (map position boids))+ (1.0 / (fromIntegral n))+++{-| cohesion : go towards centroid. Parameter dictates fraction of+ distance from boid to centroid that contributes to velocity+-}+cohesion :: Boid -> [Boid] -> Double -> Vec2+cohesion b boids a = vecScale diff a+ where+ c = findCentroid boids+ p = position b+ diff = vecSub c p+++-- | separation: avoid neighbours+separation :: Boid -> [Boid] -> Double -> Vec2+separation b [] a = vecZero+separation b boids a =+ let diff_positions = map (\i -> vecSub (position i) (position b)) boids+ closeby = filter (\i -> (vecNorm i) < a) diff_positions+ sep = foldl vecSub vecZero closeby+ in vecScale sep sScale+++-- | alignment: fly the same way as neighbours+alignment :: Boid -> [Boid] -> Double -> Vec2+alignment b [] a = vecZero+alignment b boids a =+ let v = foldl1 vecAdd (map velocity boids)+ s = 1.0 / (fromIntegral $ length boids)+ v' = vecScale v s+ in vecScale (vecSub v' (velocity b)) a+++-- | Move one boid, with respect to its neighbours.+oneboid :: Boid -> [Boid] -> Boid+oneboid b boids =+ let c = cohesion b boids cParam+ s = separation b boids sParam+ a = alignment b boids aParam+ p = position b+ v = velocity b+ id = identifier b+ v' = vecAdd v (vecScale (vecAdd c (vecAdd s a)) 0.1)+ v'' = limiter (vecScale v' 1.0025) vLimit+ p' = vecAdd p v''+ in Boid+ { identifier = id+ , position = wraparound p'+ , velocity = v''+ , dbgC = c+ , dbgS = s+ , dbgA = a+ }+++{-| Neighbor finding code++ This is slightly tricky if we want to represent a world that wraps+ around in one or more dimensions (aka, a torus or cylinder).++ The issue is that we need to split the bounding box that we query the+ KDTree with when that box extends outside the bounds of the world.+ Furthermore, when a set of boids are found in the split bounding boxes+ representing a neighbor after wrapping around, we need to adjust the+ relative position of those boids with respect to the reference frame+ of the central boid. For example, if the central boid is hugging the left+ boundary, and another boid is right next to it hugging the right+ boundary, their proper distance is likely very small. If the one on the+ right boundary isn't adjusted, then the distance will actually appear to+ be very large (approx. the width of the world).+-}+findNeighbors :: KDTreeNode Boid -> Boid -> [Boid]+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})+ where+ av = Vec2 ax ay+ p = position theboid++ 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)+ -> [(Vec2, Vec2, Double, Double)]+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+ :: (Vec2, Vec2, Double, Double)+ -> [(Vec2, Vec2, Double, Double)]+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)+ ]+ | otherwise =+ [(lo, hi, ax, ay)]+ where+ h = maxy - miny+++wraparound :: Vec2 -> Vec2+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)+ y' = if y > maxy then y - h else (if y < miny then y + h else y)+ in Vec2 x' y'+++iteration :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid+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 =+ 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
@@ -0,0 +1,59 @@+{-# LANGUAGE BangPatterns #-}++module Vec2 where+++data Vec2+ = Vec2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double+ deriving (Show)+++vecZero :: Vec2+vecZero = Vec2 0.0 0.0+++vecAdd :: Vec2 -> Vec2 -> Vec2+vecAdd (Vec2 a b) (Vec2 x y) =+ Vec2 (a + x) (b + y)+++vecSub :: Vec2 -> Vec2 -> Vec2+vecSub (Vec2 a b) (Vec2 x y) =+ Vec2 (a - x) (b - y)+++vecScale :: Vec2 -> Double -> Vec2+vecScale (Vec2 a b) !s =+ Vec2 (a * s) (b * s)+++vecDot :: Vec2 -> Vec2 -> Double+vecDot (Vec2 a b) (Vec2 x y) =+ (a * x) + (b * y)+++vecNorm :: Vec2 -> Double+vecNorm v =+ sqrt (vecDot v v)+++vecNormalize :: Vec2 -> Vec2+vecNormalize v =+ vecScale v (1.0 / (vecNorm v))+++vecDimSelect :: Vec2 -> Int -> Double+vecDimSelect (Vec2 a b) n =+ case rem n 2 of+ 0 -> a+ _ -> b+++vecLessThan :: Vec2 -> Vec2 -> Bool+vecLessThan (Vec2 a b) (Vec2 x y) =+ a < x && b < y+++vecGreaterThan :: Vec2 -> Vec2 -> Bool+vecGreaterThan (Vec2 a b) (Vec2 x y) =+ a > x && b > y
+ picture/Clock/Main.hs view
@@ -0,0 +1,82 @@+-- A fractal consisting of circles and lines which looks a bit like+-- the workings of a clock.+module Main where++import Brillo+import Prelude hiding (lines)+++main :: IO ()+main =+ animate+ (InWindow "Clock" (600, 600) (20, 20))+ black+ frame+++-- Build the fractal, scale it so it fits in the window+-- and rotate the whole thing as time moves on.+frame :: Float -> Picture+frame time =+ Color white $+ Scale 120 120 $+ Rotate (time * 2 * pi) $+ clockFractal 5 time+++-- The basic fractal consists of three circles offset from the origin+-- as follows.+--+-- 1+-- |+-- .+-- / \+-- 2 3+--+-- The direction of rotation switches as n increases.+-- Components at higher iterations also spin faster.+--+clockFractal :: Int -> Float -> Picture+clockFractal 0 _ = Blank+clockFractal n s = Pictures [circ1, circ2, circ3, lines]+ where+ -- y offset from origin to center of circle 1.+ a = 1 / sin (2 * pi / 6)++ -- x offset from origin to center of circles 2 and 3.+ b = a * cos (2 * pi / 6)++ nf = fromIntegral n+ rot =+ if n `mod` 2 == 0+ then 50 * s * (log (1 + nf))+ 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+ -- the animation started.+ --+ circNm1 =+ Pictures+ [ circle 1+ , Scale (a / 2.5) (a / 2.5) $ clockFractal (n - 1) s+ , if n > 2+ then+ Color cyan $+ Translate (-0.15) 1 $+ 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 =+ Pictures+ [ Line [(0, 0), (0, a)]+ , Line [(0, 0), (1, -b)]+ , Line [(0, 0), (-1, -b)]+ ]
+ picture/Color/Main.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ParallelListComp #-}++-- Draw a color wheel.+import Brillo+++main :: IO ()+main =+ display+ (InWindow "Colors" (800, 800) (5, 5))+ (greyN 0.4)+ ( 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+ , yellow+ , chartreuse+ , green+ , aquamarine+ , cyan+ , azure+ , blue+ , violet+ , magenta+ , rose+ ]
+ picture/Conway/Cell.hs view
@@ -0,0 +1,94 @@+module Cell where++import Brillo+++-- | A cell in the world.+data Cell+ = -- | A living cell with its age+ CellAlive Int+ | -- | A dead / blank cell.+ CellDead+ deriving (Show, Eq)+++-- | Sort the living from the dead.+isAlive :: Cell -> Bool+isAlive cell =+ case cell of+ CellAlive _ -> True+ CellDead -> False+++-- | The basic shape of a cell.+cellShape :: Int -> Int -> Int -> Picture+cellShape cellSize posXi posYi =+ let cs = fromIntegral cellSize+ posX = fromIntegral posXi+ posY = fromIntegral posYi+ x1 = posX+ x2 = posX + cs+ 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+pictureOfCell oldAge cellSize posX posY cell =+ case cell of+ CellAlive age -> Color (ageColor oldAge age) (cellShape cellSize posX posY)+ CellDead -> Color (greyN 0.8) (cellShape cellSize posX posY)+++ageColor :: Int -> Int -> Color+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+ -> (a, a, a)+rampColorHotToCold vmin vmax vNotNorm =+ let+ v+ | vNotNorm < vmin = vmin+ | vNotNorm > vmax = vmax+ | otherwise = vNotNorm++ 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
@@ -0,0 +1,70 @@+module Main where++import Brillo+import Cell+import Data.Vector qualified as Vec+import World+++main :: IO ()+main =+ do+ let width = 150+ let height = 100+ world <- randomWorld (width, height)++ 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+ -> Picture+drawWorld world =+ let (windowWidth, windowHeight) =+ windowSizeOfWorld world++ offsetX = -fromIntegral windowWidth / 2+ offsetY = -fromIntegral windowHeight / 2+ in Translate offsetX offsetY $+ 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 =+ let cs = fromIntegral (worldCellSize world)+ cp = fromIntegral (worldCellSpace world)++ (x, y) = coordOfIndex world index+ fx = fromIntegral x * (cs + cp) + 1+ fy = fromIntegral y * (cs + cp) + 1+ in pictureOfCell+ (worldCellOldAge world)+ (worldCellSize world)+ fx+ fy+ cell+++-- | Get the size of the window needed to display a world.+windowSizeOfWorld :: World -> (Int, Int)+windowSizeOfWorld world =+ let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)
+ picture/Conway/World.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}++module World where++import Brillo.Interface.Pure.Simulate+import Cell+import Control.Monad+import Data.Vector qualified as Vec+import System.Random+++type Vec = Vec.Vector+++-- Index ----------------------------------------------------------------------++-- | An index into the vector holding all the cells.+type Index = Int+++-- | The x y coordinate of a cell.+type Coord = (Int, Int)+++indexOfCoord :: World -> Coord -> Index+indexOfCoord world (x, y) =+ x + y * (worldWidth world)+++coordOfIndex :: World -> Index -> Coord+coordOfIndex world i =+ ( i `mod` worldWidth world+ , i `div` worldWidth world+ )+++-- World ----------------------------------------------------------------------+data World+ = World+ { worldCells :: Vec Cell+ , worldWidth :: Int+ , worldHeight :: Int+ , worldCellSize :: Int+ -- ^ Width and height of each cell.+ , worldCellSpace :: Int+ -- ^ Number of pixels to leave between each cell.+ , worldCellOldAge :: Int+ -- ^ Cells less than this age are drawn with the color ramp+ , worldSimulationPeriod :: Float+ -- ^ Seconds to wait between each simulation step.+ , worldElapsedTime :: Float+ -- ^ Time that has elapsed since we drew the last step+ }+++-- | Make a new world of a particular size.+randomWorld :: (Int, Int) -> IO World+randomWorld (width, height) =+ do+ bools <- replicateM (width * height) randomIO+ return $+ World+ { worldCells = Vec.fromList $ map cellOfBool bools+ , worldWidth = width+ , worldHeight = height+ , worldCellSize = 5+ , worldCellSpace = 1+ , worldCellOldAge = 20+ , worldSimulationPeriod = 0.1+ , worldElapsedTime = 0+ }+++-- | Convert a bool to a live or dead cell.+cellOfBool :: Bool -> Cell+cellOfBool b =+ case b of+ True -> CellAlive 0+ False -> CellDead+++-- | Get the cell at a particular coordinate in the world.+getCell :: World -> Coord -> Cell+getCell world coord@(x, y)+ | x < 0 || x >= worldWidth world = CellDead+ | y < 0 || y >= worldHeight world = CellDead+ | otherwise =+ worldCells world Vec.! indexOfCoord world coord+++-- | Get the neighbourhood of cells around this coordinate.+getNeighbourhood :: World -> Coord -> [Cell]+getNeighbourhood world (ix, iy) =+ let indexes =+ [ (x, y)+ | x <- [ix - 1 .. ix + 1]+ , y <- [iy - 1 .. iy + 1]+ , not (x == ix && y == iy)+ ]+ in map (getCell world) indexes+++-- | Compute the next cell state depending on its neighbours.+stepCell :: Cell -> [Cell] -> Cell+stepCell cell neighbours =+ let live = length (filter isAlive neighbours)+ in case cell of+ CellAlive age -> if elem live [2, 3] then CellAlive (age + 1) else CellDead+ CellDead -> if live == 3 then CellAlive 0 else CellDead+++-- | Compute the next state of the cell at this index in the world.+stepIndex :: World -> Int -> Cell -> Cell+stepIndex world index cell =+ let coord = coordOfIndex world index+ 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+ -- 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
@@ -0,0 +1,67 @@+{-# LANGUAGE PatternGuards #-}++{-| Simple picture drawing application.+ Like MSPaint, but you can only draw lines.+-}+module Main where++import Brillo+import Brillo.Interface.Pure.Game+++main :: IO ()+main =+ do+ let state = State Nothing []+ play+ (InWindow "Draw" (600, 600) (0, 0))+ white+ 100+ state+ makePicture+ handleEvent+ stepWorld+++-- | The game state.+data State+ = State+ (Maybe Path) -- The current line being drawn.+ [Picture] -- All the lines drawn previously.+++-- | A Line Segment+type Segment = ((Float, Float), (Float, Float))+++-- | Convert our state to a picture.+makePicture :: State -> Picture+makePicture (State m xs) =+ Pictures (maybe xs (\x -> Line x : xs) m)+++-- | Handle mouse click and motion events.+handleEvent :: Event -> State -> State+handleEvent event state+ -- 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+ -- Start drawing a new line.+ | EventKey (MouseButton LeftButton) Down _ pt@(x, y) <- event+ , State Nothing ss <- state =+ State+ (Just [pt])+ ((Translate x y $ Scale 0.1 0.1 $ Text "Down") : ss)+ -- Finish drawing a line, and add it to the picture.+ | EventKey (MouseButton LeftButton) Up _ pt@(x, y) <- event+ , State (Just ps) ss <- state =+ State+ Nothing+ ((Translate x y $ Scale 0.1 0.1 $ Text "up") : Line (pt : ps) : ss)+ | otherwise =+ state+++stepWorld :: Float -> State -> State+stepWorld _ = id
+ picture/Easy/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Brillo+++main :: IO ()+main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80)
+ picture/Eden/Cell.hs view
@@ -0,0 +1,43 @@+module Cell where++import Brillo+++data Cell+ = Cell+ Point -- centre+ Float -- radius+ Int+ deriving (Show)+++-- Produce a new cell of a certain relative radius at a certain angle.+-- The factor argument is in the range [0..1] so spawned cells are+-- 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+ (gen + 1)+ where+ childR = factor * r+++-- 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+ where+ centreDist = sqrt (xdiff * xdiff + ydiff * ydiff)+ xdiff = x1 - x2+ ydiff = y1 - y2+++render :: Cell -> Picture+render (Cell (x, y) r gen) =+ let z = fromIntegral gen * 0.1+ color' = makeColor 0.0 z 0.5 1.0+ in Color color' $ Translate x y $ Circle r
+ picture/Eden/Community.hs view
@@ -0,0 +1,65 @@+module Community where++import Brillo+import Cell+++type Community = [Cell]+++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells =+ not $ any (overlap cell) cells+++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size+-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Cell]+spawn = zipWith3 offspring+++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell : cells) comm+ | fits cell comm = survive cells (cell : comm)+ | otherwise = survive cells comm+++-- The next generation of a community+generation :: Community -> [Float] -> [Float] -> Community+generation comm angles scales =+ survive (spawn comm angles scales) comm+++render :: Community -> Picture+render comm =+ Pictures $ map Cell.render comm+++initial :: Community+initial = [Cell (0, 0) 50 0]+++-- thread the random lists for testing outside IO()+--+life :: Community -> [Float] -> [Float] -> (Community, [Float], [Float])+life comm randomAngles randomScales =+ (generation comm angles scales, randomAngles', randomScales')+ where+ population = length comm+ (angles, randomAngles') = splitAt population randomAngles+ (scales, randomScales') = splitAt population randomScales+++evolution :: Community -> [Float] -> [Float] -> [Community]+evolution comm randomAngles randomScales = comm1 : comms+ where+ (comm1, ras, rss) = life comm randomAngles randomScales+ comms = evolution comm1 ras rss
+ picture/Eden/Main.hs view
@@ -0,0 +1,20 @@+-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where++import Brillo+import System.Random+import World qualified as W+++-- varying prng sequence+main :: IO ()+main =+ do+ gen <- getStdGen+ simulate+ (InWindow "Eden" (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
+ picture/Eden/World.hs view
@@ -0,0 +1,52 @@+module World where++import Brillo+import Brillo.Interface.Pure.Simulate+import Cell+import Community+import System.Random+++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+ = World Community StdGen Int+ deriving (Show)+++-- The initial world+genesis :: World+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 =+ 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 =+ let (genThis, genNext) = split gen+ (genA, genS) = split genThis+ angles = randomRs (0.0, 2 * pi) genA+ scales = randomRs (0.7, 0.9) genS+ in World (generation comm angles scales) genNext (steps + 1)+ | otherwise =+ world+++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen steps) =+ Color (makeColor 0.3 0.3 0.6 1.0) $+ Community.render comm
+ picture/Flake/Main.hs view
@@ -0,0 +1,53 @@+{-| Snowflake Fractal.+ Based on ANUPlot code by Clem Baker-Finch.+-}+module Main where++import Brillo+++main :: IO ()+main =+ display+ (InWindow "Snowflake" (500, 500) (20, 20))+ black+ (picture 3)+++-- Fix a starting edge length of 360+edge :: Float+edge = 360+++-- Move the fractal into the center of the window and colour it nicely+picture :: Int -> Picture+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 - 1)+ in Pictures+ [ 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 =+ let oneSide = side n+ in Pictures+ [ oneSide+ , Translate edge 0 $ Rotate (-120) $ oneSide+ , Translate (edge / 2) (edge * sqrt 3 / 2) $ Rotate 120 $ oneSide+ ]
+ picture/GameEvent/Main.hs view
@@ -0,0 +1,16 @@+module Main where++import Brillo+++-- | Display the last event received as text.+main :: IO ()+main =+ play+ (InWindow "GameEvent" (700, 100) (10, 10))+ white+ 100+ ""+ (\str -> Translate (-340) 0 $ Scale 0.1 0.1 $ Text str)+ (\event _ -> show event)+ (\_ world -> world)
+ picture/Graph/Main.hs view
@@ -0,0 +1,395 @@+-- See <http://mazzo.li/posts/graph-drawing.html> for a lengthy+-- explanation about this code.+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import System.Random++import Brillo+import Brillo.Data.Point.Arithmetic qualified as Pt+import Brillo.Data.Vector+import Brillo.Data.ViewPort+import Brillo.Data.ViewState+import Brillo.Interface.Pure.Game+++type Vertex = Int+type Edge = (Vertex, Vertex)+++-- Graph ----------------------------------------------------------------------+-- INVARIANT Every `Vertex` present in a set of neighbours is present as+-- a key in the `Map`.+newtype Graph+ = Graph {grNeighs :: Map Vertex (Set Vertex)}+++-- | An empty graph, with no edges or vertexes.+emptyGraph :: Graph+emptyGraph = Graph Map.empty+++-- | Add a new vertex to the graph.+addVertex :: Vertex -> Graph -> 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 =+ 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')) $+ grNeighs gr'+++-- | Yield the neighbours of a vertex.+vertexNeighs :: Vertex -> Graph -> Set Vertex+vertexNeighs v (Graph neighs) = neighs Map.! v+++-- | Get the set of edges in a graoh.+graphEdges :: Graph -> Set Edge+graphEdges =+ Map.foldrWithKey' foldNeighs Set.empty . grNeighs+ where+ -- For each vertex `v1`, insert an edge for each neighbour `v2`.+ foldNeighs v1 ns es =+ Set.foldr' (\v2 -> Set.insert (order (v1, v2))) es ns++ 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+ { scGraph :: Graph+ , scPoints :: Map Vertex Point+ , scSelected :: Maybe Vertex+ , scViewState :: ViewState+ }+++-- | An empty scene.+emptyScene :: Scene+emptyScene =+ Scene+ { scGraph = emptyGraph+ , scPoints = Map.empty+ , scSelected = Nothing+ , scViewState = viewStateInit+ }+++-- | Add a vertex to a scene.+scAddVertex :: Vertex -> Point -> Scene -> Scene+scAddVertex v pt sc@Scene{scGraph = gr, scPoints = pts} =+ sc{scGraph = addVertex v gr, scPoints = Map.insert v pt pts}+++-- | Add an edge to a scene.+scAddEdge :: Edge -> Scene -> Scene+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!"+++-- | Randomize the endpoints of some edges, and pack them into a Scene.+fromEdges :: StdGen -> [Edge] -> Scene+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) =+ let (x, gen2) = randomR (-halfWidth, halfWidth) gen1+ (y, gen3) = randomR (-halfHeight, halfHeight) gen2+ in (scAddVertex v (x, y) sc, gen3)+++-- Drawing --------------------------------------------------------------------+vertexPos :: Vertex -> Scene -> Point+vertexPos v Scene{scPoints = pts} =+ pts Map.! v+++vertexRadius :: Float+vertexRadius = 6+++vertexColor :: Color+vertexColor = makeColor 1 0 0 1 -- Red+++edgeColor :: Color+edgeColor = makeColor 1 1 1 0.8 -- Whiteish+++drawVertex :: Vertex -> Scene -> Picture+drawVertex v sc = Translate x y (ThickCircle (vertexRadius / 2) vertexRadius)+ where+ (x, y) = vertexPos v sc+++drawEdge :: Edge -> Scene -> Picture+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 $+ Pictures [Color edgeColor edges, Color vertexColor vertices]+ where+ vertices = Pictures [drawVertex n sc | n <- Map.keys (grNeighs gr)]+ edges = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)]+++-- Graph Layout ---------------------------------------------------------------+charge :: Float+charge = 100000+++pushForce+ :: Point -- Vertex we're calculating the force for+ -> Point -- Vertex pushing the other away+ -> Vector+pushForce v1 v2 =+ -- If we are analysing the same vertex, l = 0+ if l > 0+ then (charge / l) `mulSV` normalizeV d+ else (0, 0)+ where+ d = v1 Pt.- v2+ l = magV d ** 2+++stiffness :: Float+stiffness = 1 / 2+++pullForce :: Point -> Point -> Vector+pullForce v1 v2 =+ stiffness `mulSV` (v2 Pt.- v1)+++-- | Apply forces to update the position of a single point.+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 Pt.+ pull Pt.+ push+ where+ v1pos = vertexPos v1 sc++ -- Gets a velocity by multiplying the time by the force (we assume+ -- a mass of 1).+ getVel f v2pos = dt `mulSV` f v1pos v2pos++ -- Sum all the pushing and pulling. All the other vertices push,+ -- the connected vertices pull.+ 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} =+ foldr f sc (Map.keys neighs)+ where+ f n sc' =+ let pt =+ if Just n == sel+ then vertexPos n sc+ else updatePosition dt n sc'+ in scAddVertex n pt sc'+++-- | Check if a point is in the given circle.+inCircle+ :: Point -- Where the user has clicked+ -> Float -- The scaling factor in the ViewPort+ -> Point -- The position of the vertex+ -> Bool+inCircle p sca v =+ magV (v Pt.- p) <= vertexRadius * sca+++findVertex :: Point -> Float -> Scene -> Maybe Vertex+findVertex p1 sca Scene{scPoints = pts} = Map.foldrWithKey' f Nothing pts+ where+ f _ _ (Just v) = Just v+ f v p2 Nothing = if inCircle p1 sca p2 then Just v else Nothing+++-- Events ---------------------------------------------------------------------+handleEvent :: Event -> Scene -> Scene+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 _} =+ sc{scSelected = Nothing}+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 =+ sc{scViewState = updateViewStateWithEvent ev (scViewState sc)}+++-- Sample Graph ---------------------------------------------------------------+-- Taken from <http://www.graphviz.org/Gallery/undirected/transparency.gv.txt>.+sampleGraph :: [Edge]+sampleGraph =+ [ (1, 30)+ , (1, 40)+ , (8, 46)+ , (8, 16)+ , (10, 25)+ , (10, 19)+ , (10, 33)+ , (12, 8)+ , (12, 36)+ , (12, 17)+ , (13, 38)+ , (13, 24)+ , (24, 49)+ , (24, 13)+ , (24, 47)+ , (24, 12)+ , (25, 27)+ , (25, 12)+ , (27, 12)+ , (27, 14)+ , (29, 10)+ , (29, 8)+ , (30, 24)+ , (30, 44)+ , (38, 29)+ , (38, 35)+ , (2, 42)+ , (2, 35)+ , (2, 11)+ , (14, 18)+ , (14, 24)+ , (14, 38)+ , (18, 49)+ , (18, 47)+ , (26, 41)+ , (26, 42)+ , (31, 39)+ , (31, 47)+ , (31, 25)+ , (37, 26)+ , (37, 16)+ , (39, 50)+ , (39, 14)+ , (39, 18)+ , (39, 47)+ , (41, 31)+ , (41, 8)+ , (42, 44)+ , (42, 29)+ , (44, 37)+ , (44, 32)+ , (3, 20)+ , (3, 28)+ , (6, 45)+ , (6, 28)+ , (9, 6)+ , (9, 16)+ , (15, 16)+ , (15, 48)+ , (16, 50)+ , (16, 32)+ , (16, 39)+ , (20, 33)+ , (33, 9)+ , (33, 46)+ , (33, 48)+ , (45, 15)+ , (4, 17)+ , (4, 15)+ , (4, 12)+ , (17, 21)+ , (19, 35)+ , (19, 15)+ , (19, 43)+ , (21, 19)+ , (21, 50)+ , (23, 36)+ , (34, 23)+ , (34, 24)+ , (35, 34)+ , (35, 16)+ , (35, 18)+ , (36, 46)+ , (5, 7)+ , (5, 36)+ , (7, 32)+ , (7, 11)+ , (7, 14)+ , (11, 40)+ , (11, 50)+ , (22, 46)+ , (28, 43)+ , (28, 8)+ , (32, 28)+ , (32, 39)+ , (32, 42)+ , (40, 22)+ , (40, 47)+ , (43, 11)+ , (43, 17)+ ]+++-- Main -----------------------------------------------------------------------+windowSize :: (Int, Int)+windowSize = (800, 600)+++sceneWindow :: Scene -> IO ()+sceneWindow sc =+ play+ (InWindow "Graph Drawing - shift + left mouse button to drag" windowSize (10, 10))+ black+ 30+ sc+ drawScene+ handleEvent+ updatePositions+++main :: IO ()+main =+ do+ gen <- getStdGen+ sceneWindow (fromEdges gen sampleGraph)
+ picture/Gravity/Main.hs view
@@ -0,0 +1,113 @@+module Main where++import Brillo+import Brillo.Interface.Environment+import System.Random+++-- x, y, dx, dy+type Particle =+ (Float, Float, Float, Float)+++main :: IO ()+main =+ do+ g <- getStdGen+ (width, height) <- getScreenSize+ let initialstate = generateParticles g width height+ simulate window background fps initialstate render update+ where+ window = FullScreen+ background = black+ fps = 60+ render xs = pictures $ map particleImage xs+ update _ = updateParticles+++-- | Generates particles from StdGen+generateParticles :: StdGen -> Int -> Int -> [Particle]+generateParticles gen widthInt heightInt =+ map (g . f) tups+ where+ -- change range [0,1] -> [-s/2,s/2]+ f = \(x, y) -> (x * width - width / 2, y * height - height / 2)++ -- add speed of 0+ g = \(x, y) -> (x, y, 0, 0)++ -- 200 Random float tuples+ tups = take 50 $ zip randoms1 randoms2+ randoms1 = randoms gen1 :: [Float]+ randoms2 = randoms gen2 :: [Float]+ (gen1, gen2) = split gen+ width = toEnum widthInt+ height = toEnum heightInt+++-- | Particle to its picture+particleImage :: Particle -> Picture+particleImage (x, y, _, _) =+ translate x y $ color white $ circleSolid 2+++-- | To update particles for next frame+updateParticles :: Float -> [Particle] -> [Particle]+updateParticles dt =+ (accelerateParticles dt) . (moveParticles dt)+++-- | Moves particles based on their speed+moveParticles :: Float -> [Particle] -> [Particle]+moveParticles dt =+ map (\(x, y, dx, dy) -> (x + dx * dt, y + dy * dt, dx, dy))+++-- | Accelerates particles based on gravity+accelerateParticles :: Float -> [Particle] -> [Particle]+accelerateParticles dt ps =+ map (gravitate ps dt) ps+++{-| Given particles to be gravitating to and for how long,+ updates a single particle's speed+-}+gravitate :: [Particle] -> Float -> Particle -> Particle+gravitate [] _ p = p+gravitate ((x', y', _, _) : ps) dt p@(x, y, dx, dy) =+ -- To dodge divByZero or near divByZero anomalies+ if separated x x' && separated y y'+ then gravitate ps dt p'+ else gravitate ps dt p+ where+ p' = (x, y, dx + ddx, dy + ddy)+ ddx = dirx * g+ ddy = diry * g+ (dirx, diry) = direction (x, y) (x', y')+ g = gravitation (x, y) (x', y')+++-- | Normalized vector from one point to another.+direction :: (Float, Float) -> (Float, Float) -> (Float, Float)+direction (x, y) (x', y') =+ (dx * scale', dy * scale')+ where+ dx = x' - x+ dy = y' - y+ scale' = 1 / sqrt (dx ^ (2 :: Int) + dy ^ (2 :: Int))+++-- | Checks if floats not too close to each other+separated :: Float -> Float -> Bool+separated x y =+ 0.001 < abs (x - y)+++-- | Gravitational force of one particle to another+gravitation :: (Float, Float) -> (Float, Float) -> Float+gravitation (x, y) (x', y') =+ g / sqrt (dx ^ (2 :: Int) + dy ^ (2 :: Int))+ where+ dx = x' - x+ dy = y' - y+ g = 1
+ picture/Hello/Main.hs view
@@ -0,0 +1,23 @@+-- | Display "Hello World" in a window.+module Main where++import Brillo+++main :: IO ()+main =+ display+ ( InWindow+ "Hello World" -- window title+ (400, 150) -- window size+ (10, 10) -- window position+ )+ white -- background color+ picture -- picture to display+++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
@@ -0,0 +1,46 @@+module Cell where++import Brillo+++data Cell+ = Cell+ Point -- centre+ Float -- radius+ Int -- remaining lifetime+ deriving (Show)+++-- Produce a new cell of a certain relative radius at a certain angle.+-- The factor argument is in the range [0..1] so spawned cells are+-- smaller than their parent.+-- The check whether it fits in the community is elsewhere.+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+ lifespan+ where+ childR = factor * r+++-- 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+ where+ centreDist = sqrt (xdiff * xdiff + ydiff * ydiff)+ xdiff = x1 - x2+ ydiff = y1 - y2+++-- thickness of circle is determined by lifespan+render :: Cell -> Picture+render (Cell (x, y) r life) =+ Color (makeColor 0.6 z 0.6 1.0) $+ Translate x y $+ ThickCircle (r - thickness / 2) thickness+ where+ z = fromIntegral life * 0.12+ thickness = fromIntegral life
+ picture/Lifespan/Community.hs view
@@ -0,0 +1,63 @@+module Community where++import Brillo+import Cell+++type Community = [Cell]+++-- does a (newly spawned) cell fit in the community?+-- that is, does it overlap with any others?+fits :: Cell -> Community -> Bool+fits cell cells = not $ any (overlap cell) cells+++-- For each member of a community, produce one offspring+-- The lists of Floats are the (random) parameters that determine size++-- and location of each offspring.+spawn :: Community -> [Float] -> [Float] -> [Int] -> [Cell]+spawn = zipWith4 offspring+++zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]+zipWith4 f [] _ _ _ = []+zipWith4 f _ [] _ _ = []+zipWith4 f _ _ [] _ = []+zipWith4 f _ _ _ [] = []+zipWith4 f (b : bs) (c : cs) (d : ds) (e : es) =+ f b c d e : zipWith4 f bs cs ds es+++-- Given a collection of cells (one spawned by each member of the+-- community) check if it fits, and if so add it to the community.+-- That check must include new cells that have been added to the+-- community in this process.+survive :: [Cell] -> Community -> Community+survive [] comm = comm+survive (cell : cells) comm+ | fits cell comm = survive cells (cell : comm)+ | otherwise = survive cells comm+++age :: Community -> Community+age [] = []+age (Cell c r 0 : cells) = age cells+age (Cell c r life : cells) = Cell c r (life - 1) : age cells+++-- The next generation of a community+generation :: Community -> [Float] -> [Float] -> Community+generation comm angles scales =+ survive (spawn comm angles scales (repeat 5)) (age comm)+++render :: Community -> Picture+render comm =+ Pictures $+ map Cell.render comm+++initial :: Community+initial = [Cell (0, 0) 50 5]
+ picture/Lifespan/Main.hs view
@@ -0,0 +1,20 @@+-- Adapted from ANUPlot version by Clem Baker-Finch+module Main where++import Brillo+import System.Random+import World qualified as W+++-- varying prng sequence+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
+ picture/Lifespan/World.hs view
@@ -0,0 +1,52 @@+module World where++import Brillo+import Brillo.Interface.Pure.Simulate+import Cell+import Community+import System.Random+++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+ = World Community StdGen Int+ deriving (Show)+++-- The initial world+genesis :: World+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 =+ 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)+ | step > stepsMax = world+ | otherwise =+ World (generation comm angles scales) genNext (step + 1)+ where+ (genThis, genNext) = split gen+ (genA, genS) = split genThis+ angles = randomRs (0.0, 2 * pi) genA+ scales = randomRs (0.7, 0.9) genS+++-- Converting the world to a picture is just converting the community component+render :: World -> Picture+render (World comm gen _) =+ Color (makeColor 0.3 0.3 0.6 1.0) $+ Community.render comm
+ picture/Machina/Main.hs view
@@ -0,0 +1,46 @@+module Main where++import Brillo+++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 :: Float -> Int -> Picture+mach _ 0 = leaf+mach t d =+ Pictures+ [ leaf+ , 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) $+ 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
@@ -0,0 +1,48 @@+module Cell (+ Cell (..),+ readCell,+ pictureOfCell,+ cellShape,+)+where++import Brillo+import Data.Char+++-- | A terrain cell in the world.+data Cell+ = CellEmpty+ | CellWall+ deriving (Show, Eq)+++-- | Read a cell from a character.+readCell :: Char -> Cell+readCell c =+ case c of+ '.' -> CellEmpty+ '#' -> CellWall+ _ -> error $ "readCell: no match for char " ++ show (ord c) ++ " " ++ show c+++-- | The basic shape of a cell.+cellShape :: Int -> Int -> Int -> Picture+cellShape cellSize posXi posYi =+ let posX = fromIntegral posXi+ posY = fromIntegral posYi+ x1 = posX+ x2 = posX + 1+ 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.+-}+pictureOfCell :: Int -> Int -> Int -> Cell -> Picture+pictureOfCell cellSize posX posY cell =+ case cell of+ CellEmpty -> Color (greyN 0.2) (cellShape cellSize posX posY)+ CellWall -> Color white (cellShape cellSize posX posY)
+ picture/Occlusion/Data.hs view
@@ -0,0 +1,42 @@+module Data where+++worldData :: String+worldData =+ unlines+ [ "WORLD"+ , "32 32"+ , " 01234567890123456789012345678901"+ , "0#..............................#"+ , "1.....................#####......"+ , "2....#.#.#.#..#.#.#.............."+ , "3....#######...#.#....#.#.#......"+ , "4....#######..#.#.#.............."+ , "5....#######...#.#...###.###....."+ , "6................................"+ , "7......#.#.............#.#......."+ , "8......#.#.............#.#......."+ , "9......#.#.............#.#......."+ , "0......#.#####.........#.#......."+ , "1......#.....#.........#.#......."+ , "2......#.###.#.........#.#......."+ , "3......#.#.#.###########.#######."+ , "4......#.#.#...................#."+ , "5......#.#.#####################."+ , "6......#.#......................."+ , "7......#.#...########............"+ , "8......#.#...#......#............"+ , "9......#.#...########............"+ , "0......#.#................####..."+ , "1......#.#.........#####..#..#..."+ , "2......#.###########...####..#..."+ , "3......#.....................#..."+ , "4..#####.###########...####..#..."+ , "5..#.....#.........#####..#..#..."+ , "6..#.#####.....#..........####..."+ , "7..#.#.........#................."+ , "8..#.#......#######.............."+ , "9..#.#.........#................."+ , "0..............#................."+ , "1#..............................#"+ ]
+ picture/Occlusion/Main.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE PatternGuards #-}++import Brillo.Data.Extent+import Brillo.Data.QuadTree+import Brillo.Interface.Pure.Game+import Cell+import Data+import Data.Maybe+import State+import System.Environment+import World+++main :: IO ()+main =+ do+ args <- getArgs+ case args of+ [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+ 10+ (initState world)+ drawState+ (handleInput world)+ (\_ -> id)+++-- | Convert the state to a picture.+drawState :: State -> Picture+drawState state =+ let world = stateWorld state++ -- The ray cast by the user.+ p1 = stateLineStart state+ p2 = stateLineEnd state+ picRay = drawRay world p1 p2++ -- The cell hit by the ray (if any)+ mHitCell = castSegIntoWorld world p1 p2+ hitCells = maybeToList mHitCell+ picCellsHit = Pictures $ map (drawHitCell world) hitCells++ -- All the cells in the world.+ cellsAll = flattenQuadTree (worldExtent world) (worldTree world)+ picCellsAll = Pictures $ map (uncurry (drawCell False world)) cellsAll++ -- The cells visible from the designated point.+ cellsVisible =+ [ (coord, cell)+ | (coord, cell) <- flattenQuadTree (worldExtent world) (worldTree world)+ , cellAtCoordIsVisibleFromPoint world p1 coord+ ]++ picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible++ -- How big to draw the cells.+ scale = fromIntegral $ worldCellSize world++ (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)+ in Translate offsetX offsetY $+ Scale scale scale $+ Pictures [picCellsAll, picCellsVisible, picCellsHit, picRay]+++-- | Draw the cell hit by the ray defined by the user.+drawHitCell :: World -> (Point, Extent, Cell) -> Picture+drawHitCell world (pos@(px, py), extent, cell) =+ let (n, s, e, w) = takeExtent extent+ x = w+ y = s++ 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 p1@(x, y) p2 =+ Pictures+ [ Color red $ Line [p1, p2]+ , 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 =+ let cs = fromIntegral (worldCellSize world)+ -- cp = fromIntegral (worldCellSpace world)++ 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
@@ -0,0 +1,45 @@+{-# LANGUAGE PatternGuards #-}++module State where++import Brillo.Interface.Pure.Game+import World+++-- | The game state.+data State+ = State+ { stateWorld :: World+ , stateLineStart :: Point+ , stateLineEnd :: Point+ }+++-- | 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 =+ state{stateLineEnd = worldPosOfWindowPos world pos}+ | MouseButton LeftButton <- key+ , Down <- keyState =+ state+ { stateLineStart = worldPosOfWindowPos world pos+ , stateLineEnd = worldPosOfWindowPos world pos+ }+ | MouseButton RightButton <- key+ , Down <- keyState =+ state{stateLineEnd = worldPosOfWindowPos world pos}+handleInput _ _ state =+ state
+ picture/Occlusion/World.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ScopedTypeVariables #-}++module World where++import Brillo.Algorithms.RayCast+import Brillo.Data.Extent+import Brillo.Data.QuadTree+import Brillo.Interface.Pure.Game+import Cell+++-- | The game world.+data World+ = World+ { worldWidth :: Int+ , worldHeight :: Int+ , worldTree :: QuadTree Cell+ , worldCellSize :: Int+ , worldCellSpace :: Int+ }+ deriving (Show)+++-- | Get the extent covering the entire world.+worldExtent :: World -> Extent+worldExtent world =+ makeExtent (worldWidth world) 0 (worldHeight world) 0+++-- | 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) =+ lines str++ [width, height] = map read $ words strWidthHeight+ rows = take height $ cellLines++ cells =+ concat $+ map (readLine width) $+ reverse rows++ extent = makeExtent height 0 width 0+ in World+ { worldWidth = width+ , worldHeight = height+ , worldTree = makeWorldTree extent cells+ , worldCellSize = 20+ , worldCellSpace = 0+ }+++readLine :: Int -> String -> [Cell]+readLine width (s : str) =+ map readCell $+ take width str+++-- | Get the size of the window needed to display a world.+windowSizeOfWorld :: World -> (Int, Int)+windowSizeOfWorld world =+ let cellSize = worldCellSize world+ cellSpace = worldCellSpace world+ cellPad = cellSize + cellSpace+ height = cellPad * (worldHeight world) + cellSpace+ width = cellPad * (worldWidth world) + cellSpace+ in (width, height)+++-- | Create the tree representing the world from a list of all its cells.+makeWorldTree :: Extent -> [Cell] -> QuadTree Cell+makeWorldTree extent cells =+ foldr insert' emptyTree nonEmptyPosCells+ where+ insert' (pos, cell) tree =+ case insertByCoord extent pos cell tree of+ Nothing -> tree+ Just tree' -> tree'++ (width, height) =+ sizeOfExtent extent++ posCells =+ zip+ [ (x, y)+ | y <- [0 .. height - 1]+ , x <- [0 .. width - 1]+ ]+ cells++ nonEmptyPosCells =+ filter (\x -> snd x /= CellEmpty) posCells+++-- | Get the world position coresponding to a point in the window.+worldPosOfWindowPos :: World -> Point -> Point+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+ in (x', y')+++-- | Check if a the cell at a given coordinate is visible from a point.+cellAtCoordIsVisibleFromCoord :: World -> Coord -> Coord -> Bool+cellAtCoordIsVisibleFromCoord world cFrom cTo =+ let (cx, cy) = cFrom+ pFrom = (fromIntegral cx + 0.5, fromIntegral cy + 0.5)+ in cellAtCoordIsVisibleFromPoint world pFrom cTo+++{-| Check if a cell at a given coordinate is visible from a point.+ We say it's visible if the center of any of its faces is visible.+-}+cellAtCoordIsVisibleFromPoint :: World -> Point -> Coord -> Bool+cellAtCoordIsVisibleFromPoint world pFrom (x', y') =+ or $ map (cellAtPointIsVisibleFromPoint world pFrom) [pa, pb, pc, pd]+ where+ x :: Float = fromIntegral x' + 0.5+ y :: Float = fromIntegral y' + 0.5+ pa = (x - 0.4999, y)+ 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 =+ let mOccluder = castSegIntoWorld world p1 p2+ in case mOccluder of+ Nothing -> False+ Just (pos, extent, cell) -> pointInExtent extent p2+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+castSegIntoWorld :: World -> Point -> Point -> Maybe (Point, Extent, Cell)+castSegIntoWorld world p1 p2 =+ castSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)+++-- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment.+traceSegIntoWorld :: World -> Point -> Point -> [(Point, Extent, Cell)]+traceSegIntoWorld world p1 p2 =+ traceSegIntoCellularQuadTree p1 p2 (worldExtent world) (worldTree world)
+ picture/Render/Main.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE PackageImports #-}++import Brillo (Picture (Circle), white)+import Brillo.Rendering (displayPicture, initState)+import Control.Concurrent (threadDelay)+import Control.Monad (unless, when)+import "GLFW-b" Graphics.UI.GLFW as GLFW (+ Key (Key'Escape),+ KeyState (KeyState'Pressed, KeyState'Repeating),+ Window,+ createWindow,+ destroyWindow,+ getKey,+ init,+ makeContextCurrent,+ pollEvents,+ setErrorCallback,+ swapBuffers,+ terminate,+ )+++main :: IO ()+main = do+ let width = 200+ height = 200++ state <- initState++ withWindow width height "Render" $ \win -> do+ loop state win (width, height)+ where+ loop state window (w, h) = do+ threadDelay 20000+ pollEvents+ displayPicture (w, h) white state 1.0 (Circle 80)+ swapBuffers window+ k <- keyIsPressed window Key'Escape+ unless k $ loop state window (w, h)+++withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO ()+withWindow width height title f = do+ GLFW.setErrorCallback $ Just simpleErrorCallback+ r <- GLFW.init+ when r $ do+ m <- GLFW.createWindow width height title Nothing Nothing+ case m of+ (Just win) -> do+ GLFW.makeContextCurrent m+ f win+ GLFW.setErrorCallback $ Just simpleErrorCallback+ GLFW.destroyWindow win+ Nothing -> return ()+ GLFW.terminate+ where+ simpleErrorCallback e s =+ putStrLn $ unwords [show e, show s]+++keyIsPressed :: Window -> Key -> IO Bool+keyIsPressed win key = isPress `fmap` GLFW.getKey win key+++isPress :: KeyState -> Bool+isPress KeyState'Pressed = True+isPress KeyState'Repeating = True+isPress _ = False
+ picture/Styrene/Actor.hs view
@@ -0,0 +1,92 @@+module Actor where+++-- | 2D position on the screen.+type Position = (Float, Float)+++-- | Force and velocity vectors.+type Force = (Float, Float)+++type Velocity = (Float, Float)+++-- | Time in seconds+type Time = Float+++-- | Radius of a bead+type Radius = Float+++-- | Each actor has its own unique index.+type Index = Int+++-- | The actors in the world.+data Actor+ = Wall+ !Index+ -- ^ unique index of this actor+ !Position+ -- ^ wall starting point+ !Position+ -- ^ wall ending point+ | Bead+ !Index+ -- ^ unique index of this actor+ !Int+ -- ^ whether the bead is stuck+ !Radius+ -- ^ radius of bead+ !Position+ -- ^ position of bead+ !Velocity+ -- ^ velocity of bead+ deriving (Show)+++{-| Equality and ordering of actors will consider their index only.+ 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)+++-- | Check whether an actor is a bead.+isBead :: Actor -> Bool+isBead (Bead _ _ _ _ _) = True+isBead _ = False+++-- | Check whether an actor is a wall.+isWall :: Actor -> Bool+isWall (Wall _ _ _) = True+isWall _ = False+++-- | Take the index of an actor+actorIx :: Actor -> Index+actorIx actor =+ case actor of+ Wall ix _ _ -> ix+ Bead ix _ _ _ _ -> ix+++-- | Set the index of an actor+actorSetIndex :: Actor -> Index -> Actor+actorSetIndex actor ix =+ case actor of+ Bead _ m r pos vel -> Bead ix m r pos vel+ Wall _ p1 p2 -> Wall ix p1 p2+++-- | Set whether a bead is stuck+actorSetMode :: Int -> Actor -> Actor+actorSetMode m (Bead ix _ r p v) =+ Bead ix m r p v
+ picture/Styrene/Advance.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE PatternGuards #-}++-- | Advance the world to the next time step.+module Advance where++import Actor (Actor (..), Force, Index, Time)+import Collide (collideBeadBeadElastic, collideBeadBeadStatic, collideBeadWall)+import Config (beadStuckCount, gravityCoeff)+import Contact (findContacts)+import World (World (..))++import Brillo.Data.Point.Arithmetic qualified as Pt+import Brillo.Data.Vector (magV, mulSV, rotateV)+import Brillo.Geometry.Angle (degToRad)+import Brillo.Interface.Pure.Simulate (ViewPort (viewPortRotate))++import Data.Map (Map)+import Data.Map qualified as Map+import Data.Set qualified as Set+++-- Advance ---------------------------------------------------------------------++-- | Advance all the actors in this world by a certain time.+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+ rot = viewPortRotate viewport+ force = rotateV (degToRad rot) (0, negate gravityCoeff)++ -- move all the actors+ actors_moved = Map.map (moveActorFree time force) actors++ -- find contacts in the world+ (contacts, tree') =+ findContacts (World actors_moved tree)++ -- apply contacts to each pair of actors+ actors_bounced =+ Set.fold+ (applyContact time force)+ actors_moved+ contacts+ in+ World actors_bounced tree'+++-- Move two actors which are known to be in contact.+applyContact+ :: Time+ -- ^ time step+ -> Force+ -- ^ ambient force on the actors+ -> (Index, Index)+ -- ^ indicies of the the two actors in contact+ -> Map Index Actor+ -- ^ the old world+ -> Map Index Actor+ -- ^ the new world+applyContact time force (ix1, ix2) actors =+ 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+ (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+ -- so there is less of a chance of lots of beads being crushed+ -- together if there are many in the same place.+ | m1 >= beadStuckCount || m2 >= beadStuckCount =+ let a1' = collideBeadBeadStatic a1 a2+ a2' = collideBeadBeadStatic a2 a1+ in (a1', a2')+ -- otherwise do the real elastic collision+ -- this is much more realistic.+ | otherwise =+ collideBeadBeadElastic a1 a2+ in+ -- write the new data for the actors back into the map+ Map.insert ix1 a1' $+ Map.insert ix2 a2' actors+ | otherwise =+ actors+ in+ resultActors+++-- | Move a bead which isn't in contact with anything else.+moveActorFree+ :: Time+ -- ^ time to move it for+ -> Force+ -- ^ ambient force on the actor during this time+ -> Actor+ -- ^ the bead to move+ -> Actor+ -- ^ the new bead+moveActorFree time force actor+ -- move a bead+ | 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 Pt.+ time `mulSV` vel)+ vel' = (vel Pt.+ (time / beadMass) `mulSV` force)++ -- if the bead is travelling slowly then set it as being stuck.+ stuck'+ | magV vel' < 20 =+ min beadStuckCount (stuck + 1)+ | otherwise =+ max 0 (stuck - 2)+ in+ Bead ix stuck' radius pos' vel'+ -- walls don't move+ | Wall{} <- actor =+ actor
+ picture/Styrene/Collide.hs view
@@ -0,0 +1,186 @@+-- | Physics for bead bouncing.+module Collide where++import Actor (Actor (..))+import Brillo.Data.Point (Point)+import Brillo.Data.Point.Arithmetic qualified as Pt+import Brillo.Data.Vector (+ angleVV,+ detV,+ dotV,+ mulSV,+ normalizeV,+ rotateV,+ )+import Brillo.Geometry.Line (closestPointOnLine)+++-- Config -----------------------------------------------------------------------------------------+-- How bouncy the beads are+-- at 0.2 and they look like melting plastic.+-- at 0.8 and they look like bouncy rubber balls.+-- at > 1 and they gain energy with each bounce and escape the box.+--+beadBeadLoss :: Float+beadBeadLoss = 0.95+beadWallLoss :: Float+beadWallLoss = 0.8+++-- | Move a bead which is in contact with a wall.+collideBeadWall+ :: Actor+ -- ^ the bead+ -> Actor+ -- ^ the wall that bead is in contact with+ -> Actor+ -- ^ the new bead+collideBeadWall+ bead@(Bead _ix _ _radius pBead _vIn)+ (Wall _ pWall1 pWall2) =+ 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+ in+ -- then do a static, non energy transfering collision.+ collideBeadPointStatic+ bead+ pCollision+ beadWallLoss+collideBeadWall _ _ = error "collideBeadWall: not a bead and a wall"+++-- | Move two beads which have bounced into each other.+collideBeadBeadElastic+ :: Actor+ -> Actor+ -> (Actor, Actor)+collideBeadBeadElastic+ (Bead ix1 mode1 r1 p1 v1)+ (Bead ix2 mode2 r2 p2 v2) =+ let mass1 = 1+ mass2 = 1++ -- the axis of collision (towards p2)+ 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++ -- 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 Pt.+ mulSV k1 vCollisionR+ v2' = mulSV s2' vCollision Pt.+ mulSV k2 vCollisionR++ v1_slow = mulSV beadBeadLoss v1'+ v2_slow = mulSV beadBeadLoss v2'++ -- work out the point of collision+ u1 = r1 / (r1 + r2)++ pCollision =+ p1 Pt.+ mulSV u1 (p2 Pt.- p1)++ -- place the beads just next to each other so they are no longer overlapping.+ 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+ in (bead1', bead2')+collideBeadBeadElastic _ _ = error "collideBeadBeadElastic: not two beads"+++collideBeadBeadStatic+ :: Actor+ -> Actor+ -> Actor+collideBeadBeadStatic+ bead1@(Bead _ix1 _ radius1 pBead1 _)+ (Bead _ix2 _ radius2 pBead2 _) =+ 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 Pt.+ mulSV u (pBead2 Pt.- pBead1)++ bead1' =+ collideBeadPointStatic+ bead1+ pCollision+ beadBeadLoss+ in+ bead1'+collideBeadBeadStatic _ _ = error "collideBeadBeadStatic: not two beads"+++-- | Move a bead which has collided with something.+collideBeadPointStatic+ :: Actor+ -- ^ the bead which collided with something+ -> Point+ -- ^ the point of collision (should be near the bead's surface)+ -> Float+ -- ^ velocity scaling factor (how much to slow the bead down after the collision)+ -> Actor+collideBeadPointStatic+ (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 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 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 (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.+ -- The diagram shows the sign of the determinant for the four possiblities.+ --+ -- \ +ve -ve /+ -- \ /+ -- \/ \/+ -- pWall1 ---------- pWall2 pWall1 ---------- pWall2+ -- /\ /\+ -- / \+ -- / -ve +ve \+ --+ determinant = detV vIn vNormal++ -- Use the determinant to rotate the bead's velocity vector for the bounce.+ vOut+ | determinant > 0 = rotateV (2 * aInc2) vIn+ | otherwise = rotateV (negate (2 * aInc2)) vIn++ -- Slow down the bead when it hits the wall+ vSlow = velLoss `mulSV` vOut++ bead1_new = Bead ix mode radius pBead_new vSlow+ in+ bead1_new+collideBeadPointStatic _ _ _ =+ error "collideBeadPointStatic: not a bead and a point"
+ picture/Styrene/Config.hs view
@@ -0,0 +1,59 @@+module Config where++import Brillo (Color, makeColor)+++-- Number of simulation steps per second of time.+simResolution :: Int+simResolution = 300+++-- How strongly the beads are pulled down to the bottom of the screen.+-- If this is too high wrt the simResoution then the simulation+-- will be unstable and beads will escape the box.+gravityCoeff :: Float+gravityCoeff = 300+++-- Whether to draw velocity vectors on beads.+showBeadVelocity :: Bool+showBeadVelocity = False+++-- Colors of things.+beadColor :: Color+beadColor = makeColor 0.5 0.5 1.0 1.0+beadOutlineColor :: Color+beadOutlineColor = makeColor 1.0 1.0 1.0 1.0+nodeColor :: Color+nodeColor = makeColor 0.2 0.8 0.2 0.1+leafColor :: Color+leafColor = makeColor 0.8 0.2 0.2 0.1+++-- The maximum depth of the quad tree.+treeMaxDepth :: Int+treeMaxDepth = 4+++-- Size of quadtree. Should be > boxSize.+treeSize :: Float+treeSize = 300+++-- Size of bead box.+boxSize :: Float+boxSize = 280+++-- Bead setup.+beadRadius, beadSpace, beadCountX, beadCountY, beadBoxSize :: Float+beadRadius = 5+beadSpace = 1+beadBoxSize = 2 * beadRadius + beadSpace+beadCountX = 20+beadCountY = 10+++beadStuckCount :: Int+beadStuckCount = 20
+ picture/Styrene/Contact.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- | Find actors in the world that are in contact with each other.+module Contact where++import Actor (Actor (..), Index, actorIx, isBead, isWall)+import Brillo.Data.Point (Point)+import Brillo.Geometry.Line (+ closestPointOnLine,+ closestPointOnLineParam,+ )+import Data.Map qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import GHC.Exts (+ Float (F#),+ Float#,+ gtFloat#,+ ltFloat#,+ minusFloat#,+ plusFloat#,+ sqrtFloat#,+ tagToEnum#,+ timesFloat#,+ )+import QuadTree (QuadTree, treeElems, treeZero)+import World (World (..), insertActor)+++-- Find all pairs of actors in the world that are in contact with each other.+findContacts+ :: World+ -> ( -- a set of all pairs of actors that are in contact.+ Set (Index, Index)+ , -- also return the quadtree so we can draw it in the window.+ QuadTree Actor+ )+findContacts (World actors _) =+ 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.foldr' insertActor treeInit actors++ -- the potential contacts are lists of actors+ -- that _might_ be in contact.+ potentialContacts =+ treeElems tree'++ -- 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 (Index, Index) -> [[Actor]] -> Set (Index, Index)+makeContacts' acc xx =+ case xx of+ -- no more potentials to add, return the current contact set+ [] -> acc+ -- 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 =+ let k1 = actorIx a1+ k2 = actorIx a2+ 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+ | isBead a1 && isWall a2 = inContactBeadWall a1 a2+ | isWall a1 && isBead a2 = inContactBeadWall a2 a1+ | isBead a1 && isBead a2 = inContactBeadBead a1 a2+ | otherwise = False+++-- | Check whether a bead is in contact with a wall.+inContactBeadWall :: Actor -> Actor -> Bool+inContactBeadWall+ (Bead _ix _mode radius pBead _)+ (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+ -- needs to be less than the bead radius for them to touch.+ !(F# radius#) = radius+ closeEnough = distancePPContact pBead pClosest `ltFloat#` radius#++ -- uParam gives where pClosest is relative to the endponts of the wall+ uParam = closestPointOnLineParam pWall1 pWall2 pBead++ -- pClosest needs to lie on the line segment between pWal1 and pWall2+ inSegment = uParam >= 0 && uParam <= 1+ in+ tagToEnum# closeEnough && inSegment+inContactBeadWall _ _ = False+++-- | Check whether a bead is in concat with another bead.+inContactBeadBead :: Actor -> Actor -> Bool+inContactBeadBead+ (Bead _ix1 _ radius1 pBead1 _)+ (Bead _ix2 _ radius2 pBead2 _) =+ let !dist# = distancePPContact pBead1 pBead2+ !(F# rad) = radius1 + radius2+ in tagToEnum# (dist# `ltFloat#` rad) && tagToEnum# (dist# `gtFloat#` 0.1#)+inContactBeadBead _ _ = False+++-- | Return the distance between these two points.+{-# INLINE distancePPContact #-}+distancePPContact :: Point -> Point -> Float#+distancePPContact (F# x1, F# y1) (F# x2, F# y2) = do+ let+ !xd = x2 `minusFloat#` x1+ !xd2 = xd `timesFloat#` xd++ !yd = y2 `minusFloat#` y1+ !yd2 = yd `timesFloat#` yd++ sqrtFloat# (xd2 `plusFloat#` yd2)
+ picture/Styrene/Main.hs view
@@ -0,0 +1,128 @@+module Main where++import Actor (Actor (..))+import Advance (advanceWorld)+import Config (beadColor, leafColor, nodeColor, showBeadVelocity, simResolution)+import QuadTree (QuadTree (..))+import World (World (..), worldInit)++import Brillo (+ Color,+ Display (InWindow),+ Picture (Blank, Color, Line, Pictures, Polygon, Scale, Translate),+ black,+ greyN,+ rectangleWire,+ red,+ simulate,+ )+import Brillo.Data.Vector (mulSV)++import Data.Map qualified as Map+++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+ -- (number of steps to take for each second of time)+ worldInit -- the initial world.+ drawWorld -- a function to convert the world to a Picture.+ advanceWorld -- a function to advance the world to+ -- the next simulation step.+++-- Draw ------------------------------------------------------------------------++-- | Draw this world as a picture.+drawWorld :: World -> Picture+drawWorld (World actors tree) = do+ let+ -- Split the list of actors into beads and walls.+ -- 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.)+ (theBeads, theWalls) = splitActors $ Map.elems actors++ picBeads = Color beadColor $ Pictures $ map drawActor theBeads+ picWalls = Pictures $ map drawActor theWalls+ picTree = drawQuadTree tree++ Scale 0.8 0.8 $+ Pictures [picTree, picWalls, picBeads]+++-- | Split actors into beads and walls+splitActors :: [Actor] -> ([Actor], [Actor])+splitActors =+ splitActors' [] []+++splitActors' :: [Actor] -> [Actor] -> [Actor] -> ([Actor], [Actor])+splitActors' accBeads accWalls [] =+ (accBeads, accWalls)+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 =+ case actor of+ Bead _ix _mode radius (posX, posY) v -> do+ let+ bead = circleFilled radius 10+ vel =+ if showBeadVelocity+ then Color red $ Line [(0, 0), mulSV 0.1 v]+ else Blank+ Translate posX posY $ Pictures [bead, vel]+ Wall _ p1 p2 ->+ Color (greyN 0.8) $ Line [p1, p2]+++-- | Draw a quadtree as a picture+drawQuadTree :: QuadTree a -> Picture+drawQuadTree tree =+ case tree of+ QNode p size tTL tTR tBL tBR ->+ Pictures+ [ drawQuadTree tTL+ , drawQuadTree tTR+ , drawQuadTree tBL+ , drawQuadTree tBR+ , nodeBox p size nodeColor+ ]+ QLeaf p size _elems ->+ nodeBox p size leafColor+ QNil (_x0, _y0) _size ->+ Blank+++nodeBox :: (Float, Float) -> Float -> Color -> Picture+nodeBox (x0, y0) size colr =+ Color colr $+ Translate x0 y0 $+ rectangleWire (size * 2) (size * 2)+++-- Make a circle of radius r consisting of n lines.+circleFilled :: Float -> Float -> Picture+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 =+ map+ (\d -> (cos d, sin d))+ [0, 2 * pi / n .. 2 * pi]
+ picture/Styrene/QuadTree.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}+module QuadTree (+ QuadTree (..),+ treeZero,+ treeInsert,+ treeElems,+)+where++import Brillo.Data.Point (Point)+++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+ !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+ !Float -- cell size+ ![a] -- elements in this cell+ | -- Node cells contain more sub-trees+ QNode+ !Point -- cell center point+ !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+ :: Int+ -- ^ maximum depth to place a leaf+ -> Int+ -- ^ current depth+ -> Point+ -- ^ bottom left of bounding box of new element+ -> Point+ -- ^ top right of bounding box of new element+ -> a+ -- ^ element to insert into tree+ -> QuadTree a+ -- ^ current tree+ -> QuadTree a+treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree =+ case tree of+ QNode p@(x, y) size tNW tNE tSW tSE ->+ let+ tNW'+ | y1 > y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tNW+ | otherwise = tNW++ tNE'+ | y1 > y && x1 > x = treeInsert depthMax (depth + 1) p0 p1 a tNE+ | otherwise = tNE++ tSW'+ | y0 < y && x0 < x = treeInsert depthMax (depth + 1) p0 p1 a tSW+ | otherwise = tSW++ 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 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+ (QNil (x - s2, y + s2) s2)+ (QNil (x + s2, y + s2) s2)+ (QNil (x - s2, y - s2) s2)+ (QNil (x + s2, y - s2) s2)+ )+ QLeaf (_, _) _ _ -> error "treeInsert: QLeaf"+++-- flatten a quadtree into a list of its elements.+treeElems :: QuadTree a -> [[a]]+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
@@ -0,0 +1,111 @@+{-# LANGUAGE PatternGuards #-}++-- The world contains a map of all the actors, along with the current+-- quadtree so we can also draw it on the screen.+module World where++import Actor (Actor (..), Index, actorIx, actorSetIndex)+import Config (+ beadBoxSize,+ beadCountX,+ beadCountY,+ beadRadius,+ boxSize,+ treeMaxDepth,+ treeSize,+ )+import QuadTree (QuadTree, treeInsert, treeZero)++import Data.Map (Map)+import Data.Map qualified as Map+++-- The world ------------------------------------------------------------------+data World+ = World+ (Map Index Actor) -- actors+ (QuadTree Actor) -- tree+++-- | The initial world+worldInit :: World+worldInit =+ World actorMapInit treeInit+++actorMapInit :: Map Index Actor+actorMapInit =+ Map.fromList $+ map+ (\a -> (actorIx a, a))+ (walls ++ beads)+++treeInit :: QuadTree a+treeInit = treeZero treeSize+++-- Walls ------------------+walls :: [Actor]+walls = zipWith actorSetIndex (box ++ splitter) [10000 ..]+++box :: [Actor]+box =+ let bs = boxSize+ in [ Wall 0 (-bs, -bs) (bs, -bs) -- bot+ , Wall 0 (-bs, bs) (bs, bs) -- top+ , Wall 0 (-bs, -bs) (-bs, bs) -- left+ , Wall 0 (bs, -bs) (bs, bs) -- right+ ]+++splitter :: [Actor]+splitter =+ [ Wall 0 (-15, -100) (-200, 0)+ , Wall 0 (15, -100) (200, 0)+ ]+++-- Beads ------------------+beads :: [Actor]+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]+ ]+ in+ -- set the unique index on the beads before returning them+ zipWith actorSetIndex beads_raw [0 ..]+++beadPos :: Float -> Float -> (Float, Float)+beadPos ix iy =+ ( (ix * beadBoxSize) - (beadBoxSize * beadCountX / 2)+ , iy * beadBoxSize+ )+++-- QuadTree -------------------------------------------------------------------++-- | insert an actor into the tree+insertActor :: Actor -> QuadTree Actor -> QuadTree Actor+insertActor actor tree+ -- insert a bead into the tree+ | bead@(Bead _ix _ radius (x, y) _vel) <- actor =+ let+ -- the bottom left and top right of the bead's bounding box.+ p0 = (x - radius, y - radius)+ p1 = (x + radius, y + radius)+ in+ treeInsert treeMaxDepth 0 p0 p1 bead tree+ | wall@(Wall _ix (x0, y0) (x1, y1)) <- actor =+ let+ -- 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
@@ -0,0 +1,71 @@+{-| Tree Fractal.+ Based on ANUPlot code by Clem Baker-Finch.+-}+module Main where++import Brillo (+ Color,+ Display (InWindow),+ Picture (Color, Pictures, Polygon, Rotate, Scale, Translate),+ animate,+ black,+ dim,+ green,+ makeColorI,+ mixColors,+ )+++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 degree time =+ Translate 0 (-300) $+ tree degree time (dim $ dim brown)+++-- Basic stump shape+stump :: Color -> Picture+stump colr =+ Color colr $+ Polygon [(30, 0), (15, 300), (-15, 300), (-30, 0)]+++-- Make a tree fractal.+tree+ :: Int -- Fractal degree+ -> Float -- time+ -> Color -- Color for the stump+ -> Picture+tree 0 _time colr = stump colr+tree n time colr =+ let smallTree =+ Rotate (sin time) $+ Scale 0.5 0.5 $+ tree (n - 1) (-time) (greener colr)+ in Pictures+ [ stump colr+ , Translate 0 300 smallTree+ , Translate 0 240 $ Rotate 20 smallTree+ , Translate 0 180 $ Rotate (-20) smallTree+ , Translate 0 120 $ Rotate 40 smallTree+ , Translate 0 60 $ Rotate (-40) smallTree+ ]+++-- | Starting color for the stump+brown :: Color+brown = makeColorI 139 100 35 255+++-- | Make the color a little greener+greener :: Color -> Color+greener =+ mixColors 1 10 green
+ picture/Visibility/Draw.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE PatternGuards #-}++module Draw (+ drawState,+ drawWorld,+)+where++import Brillo (+ Picture (Color, Line, Pictures, ThickCircle, Translate),+ Point,+ blank,+ dim,+ green,+ greyN,+ rectangleSolid,+ red,+ white,+ )+import Brillo.Geometry.Line (intersectSegSeg)+import Data.Maybe (isJust)+import Data.Vector.Unboxed qualified as V+import State (+ ModeDisplay (ModeDisplayNormalised, ModeDisplayWorld),+ ModeOverlay (ModeOverlayVisApprox),+ State (+ stateModeDisplay,+ stateModeOverlay,+ stateTargetPos,+ stateViewPos,+ stateWorld+ ),+ )+import World (Segment, World (worldSegments), normaliseWorld)+++drawState :: State -> Picture+drawState state+ | ModeDisplayWorld <- stateModeDisplay state =+ drawWorldWithViewPos+ (stateModeOverlay state)+ (stateViewPos state)+ (stateTargetPos state)+ (stateWorld state)+ | ModeDisplayNormalised <- stateModeDisplay state =+ drawWorldWithViewPos+ (stateModeOverlay state)+ (0, 0)+ Nothing+ $ normaliseWorld (stateViewPos state)+ $ stateWorld state+++drawWorldWithViewPos :: ModeOverlay -> Point -> Maybe Point -> World -> Picture+drawWorldWithViewPos+ modeOverlay+ pView@(vx, vy)+ mTarget+ world =+ let+ -- the world+ picWorld =+ Color white $+ drawWorld world++ -- view position indicator+ picView =+ Color red $+ Translate vx vy $+ ThickCircle 2 4++ -- target position indicator+ picTargets+ | Just pTarget@(px, py) <- mTarget =+ let picTarget = Translate px py $ ThickCircle 2 4++ -- line between view and target pos+ picLine = Line [pView, pTarget]++ picSegsHit =+ Pictures $+ [ Line [p1, p2]+ | (_, p1, p2) <- V.toList $ worldSegments world+ , isJust $ intersectSegSeg p1 p2 pView pTarget+ ]+ in Color red $ Pictures [picTarget, picLine, picSegsHit]+ | otherwise =+ blank++ -- overlay+ picOverlay+ | ModeOverlayVisApprox <- modeOverlay =+ drawVisGrid 10 pView world+ | otherwise =+ blank+ in+ Pictures [picOverlay, picWorld, picView, picTargets]+++-- | Draw a grid of points showing what is visible from a view position+drawVisGrid :: Float -> Point -> World -> Picture+drawVisGrid cellSize pView world = do+ let+ visible pTarget =+ not $+ any+ (isJust . (\(_, p1, p2) -> intersectSegSeg pView pTarget p1 p2))+ (V.toList $ worldSegments world)++ Pictures $+ [ 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]+ , y <- [-400, -400 + cellSize .. 400]+ ]+++-- | Draw the segments in the world.+drawWorld :: World -> Picture+drawWorld world =+ drawSegments $+ worldSegments world+++-- | Draw an array of segments.+drawSegments :: V.Vector Segment -> Picture+drawSegments segments =+ Pictures $+ map drawSegment $+ V.toList segments+++-- | Draw a single segment.+drawSegment :: Segment -> Picture+drawSegment (_, (x1, y1), (x2, y2)) = do+ let f = fromRational . toRational+ Line [(f x1, f y1), (f x2, f y2)]
+ picture/Visibility/Geometry/Randomish.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}++module Geometry.Randomish (+ randomishPoints,+ randomishInts,+ randomishDoubles,+)+where++import Data.Vector.Generic qualified as G+import Data.Vector.Unboxed qualified as V+import Data.Vector.Unboxed.Mutable qualified as MV+import Data.Word (Word64)+++-- | Some uniformly distributed points+randomishPoints+ :: Int+ -- ^ seed+ -> Int+ -- ^ number of points+ -> Float+ -- ^ minimum coordinate+ -> Float+ -- ^ maximum coordinate+ -> V.Vector (Float, Float)+randomishPoints seed' n pointMin pointMax =+ let pts = randomishFloats (n * 2) pointMin pointMax seed'+ xs = G.slice 0 n pts+ ys = G.slice n n pts+ in V.zip xs ys+++{-| Use the "minimal standard" Lehmer generator to quickly generate some random+ 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+ :: Int -- Length of vector.+ -> Int -- Minumum value in output.+ -> Int -- Maximum value in output.+ -> 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++ -- a merzenne prime (don't change it)+ modulus :: Word64+ modulus = 2 ^ (31 :: Integer) - 1++ -- if the seed is 0 all the numbers in the sequence are also 0.+ seed+ | seed' == 0 = 1+ | otherwise = seed'++ !valMin = fromIntegral valMin'+ !valMax = fromIntegral valMax' + 1+ !range = valMax - valMin++ {-# INLINE f #-}+ f x = multiplier * x `mod` modulus+ in+ G.create $+ do+ vec <- MV.new len++ let go !ix !x+ | ix == len = return ()+ | otherwise =+ do+ let x' = f x+ MV.write vec ix $ fromIntegral $ (x `mod` range) + valMin+ go (ix + 1) x'++ go 0 (f $ f $ f $ fromIntegral seed)+ return vec+++{-| Generate some randomish doubles with terrible statistical properties.+ This is good enough for test data, but not much else.+-}+randomishDoubles+ :: Int -- Length of vector+ -> Double -- Minimum value in output+ -> Double -- Maximum value in output+ -> Int -- Random seed.+ -> V.Vector Double -- Vector of randomish doubles.+randomishDoubles !len !valMin !valMax !seed =+ let range = valMax - valMin++ mx = 2 ^ (30 :: Integer) - 1+ mxf = fromIntegral mx+ ints = randomishInts len 0 mx seed+ in V.map (\n -> valMin + (fromIntegral n / mxf) * range) ints+++{-| Generate some randomish doubles with terrible statistical properties.+ This is good enough for test data, but not much else.+-}+randomishFloats+ :: Int -- Length of vector+ -> Float -- Minimum value in output+ -> Float -- Maximum value in output+ -> Int -- Random seed.+ -> V.Vector Float -- Vector of randomish doubles.+randomishFloats !len !valMin !valMax !seed =+ let range = valMax - valMin++ 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
@@ -0,0 +1,81 @@+module Geometry.Segment (+ Segment,+ translateSegment,+ splitSegmentsOnY,+ splitSegmentsOnX,+ chooseSplitX,+)+where++import Brillo.Geometry.Line (intersectSegHorzLine, intersectSegVertLine)+import Data.Maybe (isJust)+import Data.Vector.Unboxed qualified as V+++-- | A line segement in the 2D plane.+type Segment = (Int, (Float, Float), (Float, Float))+++-- | Translate both endpoints of a segment.+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 = do+ 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+ (\(_, p1, p2) -> isJust $ intersectSegHorzLine p1 p2 y0)+ segs++ -- TODO: going via lists here is bad.+ splitCrossingSeg :: Segment -> V.Vector Segment+ splitCrossingSeg (n, p1, p2) =+ case intersectSegHorzLine p1 p2 y0 of+ Just pCross -> V.fromList [(n, p1, pCross), (n, pCross, p2)]+ Nothing -> V.empty++ -- TODO: vector append requires a copy.+ 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 = do+ 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+ (\(_, p1, p2) -> isJust $ intersectSegVertLine p1 p2 x0)+ segs++ -- TODO: going via lists here is bad.+ splitCrossingSeg :: Segment -> V.Vector Segment+ splitCrossingSeg (n, p1, p2) =+ case intersectSegVertLine p1 p2 x0 of+ Just pCross -> V.fromList [(n, p1, pCross), (n, pCross, p2)]+ Nothing -> V.empty++ -- TODO: vector append requires a copy.+ segsOther V.++ V.concat (map splitCrossingSeg $ V.toList segsCross)+++{-| Decide where to split the plane.+ TODO: We're just taking the first point of the segment in the middle of the vector.+ It might be better to base the split on:+ - the closest segment+ - the widest sgement+ - the one closes to the middle of the field.+ - some combination of above.+-}+chooseSplitX :: V.Vector Segment -> Float+chooseSplitX segments =+ case segments V.!? (V.length segments `div` 2) of+ Nothing -> 0+ Just (_, (x1, _), _) -> x1
+ picture/Visibility/Interface.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE PatternGuards #-}++module Interface (+ handleInput,+ stepState,+)+where++import Brillo.Interface.Pure.Game qualified as G+import State (+ ModeDisplay (ModeDisplayNormalised, ModeDisplayWorld),+ ModeInterface (ModeInterfaceIdle, ModeInterfaceMove),+ ModeOverlay (ModeOverlayNone, ModeOverlayVisApprox),+ State (+ stateModeDisplay,+ stateModeInterface,+ stateModeOverlay,+ stateTargetPos,+ stateViewPos+ ),+ )+++-- Input ------------------------------------------------------------------------------------------++-- | Handle an input event.+handleInput :: G.Event -> State -> State+handleInput (G.EventKey key keyState _ (x, y)) state+ -- move the view position.+ | G.MouseButton G.LeftButton <- key+ , G.Down <- keyState =+ state+ { stateModeInterface = ModeInterfaceMove+ , stateViewPos =+ ( fromRational $ toRational x+ , fromRational $ toRational y+ )+ }+ -- set the target position.+ | G.MouseButton G.RightButton <- key+ , G.Down <- keyState =+ state+ { stateTargetPos =+ Just+ ( fromRational $ toRational x+ , fromRational $ toRational y+ )+ }+ | G.MouseButton G.LeftButton <- key+ , G.Up <- keyState =+ state{stateModeInterface = ModeInterfaceIdle}+handleInput (G.EventMotion (x, y)) state+ | stateModeInterface state == ModeInterfaceMove =+ state+ { stateViewPos =+ ( fromRational $ toRational x+ , fromRational $ toRational y+ )+ }+-- t : Turn target indicator off.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 't' <- key+ , G.Down <- keyState =+ state{stateTargetPos = Nothing}+-- w : Display the whole world.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'w' <- key+ , G.Down <- keyState =+ state{stateModeDisplay = ModeDisplayWorld}+-- n : Display the normalised world.+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'n' <- key+ , G.Down <- keyState =+ state{stateModeDisplay = ModeDisplayNormalised}+-- a : Toggle approximate visibility+handleInput (G.EventKey key keyState _ _) state+ | G.Char 'a' <- key+ , G.Down <- keyState =+ state+ { stateModeOverlay =+ case stateModeOverlay state of+ ModeOverlayVisApprox -> ModeOverlayNone+ _ -> ModeOverlayVisApprox+ }+handleInput _ state =+ state+++-- Step -------------------------------------------------------------------------------------------++-- | Advance the state one iteration+stepState :: Float -> State -> State+stepState _ state = state
+ picture/Visibility/Main.hs view
@@ -0,0 +1,34 @@+{-| Visibility on the 2D plane.+ Uses an instance of Warnocks algorithm.+ TODO: animate the line segments, make them spin and move around so we can see+ that it's a dynamic visiblity algorithm -- not pre-computed.+ Draw lines in random shades of color depending on the index.+ Make a key to swap between rectangular and polar projections.+ Allow viewpoint to be set with the mouse.++ TODO: To start with just do brute force visibility by dividing field into cells+ and doing vis based on center point of cell.+-}+module Main where++import Brillo.Interface.Pure.Game (Display (InWindow), black, play)+import Draw (drawState)+import Interface (handleInput, stepState)+import State (initialState)+import World (initialWorld)+++main :: IO ()+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
@@ -0,0 +1,57 @@+-- | Game state+module State where++import Brillo (Point)+import World (World)+++-- | The game state.+data State+ = State+ { stateWorld :: World+ , stateModeInterface :: ModeInterface+ , stateModeDisplay :: ModeDisplay+ , stateModeOverlay :: ModeOverlay+ , stateViewPos :: Point+ , stateTargetPos :: Maybe Point+ }+++-- | What mode the interface interaction is in.+data ModeInterface+ = -- | We're not doing anything inparticular.+ ModeInterfaceIdle+ | -- | We're moving the view position.+ ModeInterfaceMove+ deriving (Show, Eq)+++-- | What mode the display is in.+data ModeDisplay+ = -- | Show the world in rectangular coordinates.+ ModeDisplayWorld+ | -- | Show the world normalised so the view position is at the origin.+ ModeDisplayNormalised+ deriving (Show, Eq)+++-- | What overlay to display.+data ModeOverlay+ = -- | No overlay+ ModeOverlayNone+ | -- | Brute force, approximate visibility+ ModeOverlayVisApprox+ deriving (Show, Eq)+++-- | Initial game state.+initialState :: World -> State+initialState world =+ State+ { stateWorld = world+ , stateModeInterface = ModeInterfaceIdle+ , stateModeDisplay = ModeDisplayWorld+ , stateModeOverlay = ModeOverlayVisApprox+ , stateViewPos = (0, 0)+ , stateTargetPos = Nothing+ }
+ picture/Visibility/World.hs view
@@ -0,0 +1,54 @@+module World (+ Segment,+ World (..),+ initialWorld,+ normaliseWorld,+)+where++import Brillo (Point)+import Data.Vector.Unboxed qualified as V+import Geometry.Randomish (randomishPoints)+import Geometry.Segment (Segment, splitSegmentsOnY, translateSegment)+++-- We keep this unpacked so we can use unboxed vector.+-- index, x1, y1, x2, y2+newtype World = World {worldSegments :: V.Vector Segment}+++-- | Generate the initial world.+initialWorld :: IO World+initialWorld = do+ let+ n = 100+ minZ = -300+ maxZ = 300++ minDelta = -100+ maxDelta = 100++ centers = randomishPoints 1234 n minZ maxZ+ deltas = randomishPoints 4321 n minDelta maxDelta++ makePoint n' (cX, cY) (dX, dY) =+ (n', (cX, cY), (cX + dX, cY + dY))++ 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 (px, py) world = do+ let+ segments_trans =+ V.map (translateSegment (-px) (-py)) $+ worldSegments world+ segments_split =+ splitSegmentsOnY 0 segments_trans++ world{worldSegments = segments_split}
+ picture/Zen/Main.hs view
@@ -0,0 +1,64 @@+-- A nifty animated fractal of a tree, superimposed on a background+-- of three red rectangles.+import Brillo+++main :: IO ()+main =+ animate+ (InWindow "Zen" (800, 600) (5, 5))+ (greyN 0.2)+ frame+++-- Produce one frame of the animation.+frame :: Float -> Picture+frame timeS =+ Pictures+ -- the red rectangles+ [ Translate 0 150 backRec+ , Translate 0 0 backRec+ , Translate 0 (-150) backRec+ , -- the tree+ Translate 0 (-150) $ treeFrac 7 timeS+ ]+++-- One of the red backing rectangles, with a white outline.+backRec :: Picture+backRec =+ Pictures+ [ Color red (rectangleSolid 400 100)+ , Color white (rectangleWire 400 100)+ ]+++-- The color for the outline of the tree's branches.+treeOutline :: Color+treeOutline = makeColor 0.3 0.3 1.0 1.0+++-- The color for the shading of the tree's branches.+-- The Alpha here is set to 0.5 so the branches are partly transparent.+treeColor :: Color+treeColor = makeColor 0.0 1.0 0.0 0.5+++-- The tree fractal.+-- 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 _ = 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 $+ treeFrac (n - 1) timeS+ , Translate 0 70 $+ Rotate (-200 * sin timeS / (fromIntegral n)) $+ Scale 0.8 0.8 $+ treeFrac (n - 1) timeS+ ]