diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/brillo-examples.cabal b/brillo-examples.cabal new file mode 100644 --- /dev/null +++ b/brillo-examples.cabal @@ -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 diff --git a/picture/Bitmap/Main.hs b/picture/Bitmap/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Bitmap/Main.hs @@ -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 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 + ] diff --git a/picture/Boids/KDTree2d.hs b/picture/Boids/KDTree2d.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/KDTree2d.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BangPatterns #-} + +-- KDTree code +-- by Matthew Sottile +-- +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 diff --git a/picture/Boids/Main.hs b/picture/Boids/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/Main.hs @@ -0,0 +1,367 @@ +-- Implementation of the Boids flocking algorithm. +-- by Matthew Sottile +-- 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 diff --git a/picture/Boids/Vec2.hs b/picture/Boids/Vec2.hs new file mode 100644 --- /dev/null +++ b/picture/Boids/Vec2.hs @@ -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 diff --git a/picture/Clock/Main.hs b/picture/Clock/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Clock/Main.hs @@ -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)] + ] diff --git a/picture/Color/Main.hs b/picture/Color/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Color/Main.hs @@ -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 + ] diff --git a/picture/Conway/Cell.hs b/picture/Conway/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/Cell.hs @@ -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 diff --git a/picture/Conway/Main.hs b/picture/Conway/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/Main.hs @@ -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) diff --git a/picture/Conway/World.hs b/picture/Conway/World.hs new file mode 100644 --- /dev/null +++ b/picture/Conway/World.hs @@ -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} diff --git a/picture/Draw/Main.hs b/picture/Draw/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Draw/Main.hs @@ -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 diff --git a/picture/Easy/Main.hs b/picture/Easy/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Easy/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Brillo + + +main :: IO () +main = display (InWindow "My Window" (200, 200) (10, 10)) white (Circle 80) diff --git a/picture/Eden/Cell.hs b/picture/Eden/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Cell.hs @@ -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 diff --git a/picture/Eden/Community.hs b/picture/Eden/Community.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Community.hs @@ -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 diff --git a/picture/Eden/Main.hs b/picture/Eden/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/Main.hs @@ -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 diff --git a/picture/Eden/World.hs b/picture/Eden/World.hs new file mode 100644 --- /dev/null +++ b/picture/Eden/World.hs @@ -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 diff --git a/picture/Flake/Main.hs b/picture/Flake/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Flake/Main.hs @@ -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 + ] diff --git a/picture/GameEvent/Main.hs b/picture/GameEvent/Main.hs new file mode 100644 --- /dev/null +++ b/picture/GameEvent/Main.hs @@ -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) diff --git a/picture/Graph/Main.hs b/picture/Graph/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Graph/Main.hs @@ -0,0 +1,395 @@ +-- See 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 . +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) diff --git a/picture/Gravity/Main.hs b/picture/Gravity/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Gravity/Main.hs @@ -0,0 +1,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 diff --git a/picture/Hello/Main.hs b/picture/Hello/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Hello/Main.hs @@ -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 diff --git a/picture/Lifespan/Cell.hs b/picture/Lifespan/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Cell.hs @@ -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 diff --git a/picture/Lifespan/Community.hs b/picture/Lifespan/Community.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Community.hs @@ -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] diff --git a/picture/Lifespan/Main.hs b/picture/Lifespan/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/Main.hs @@ -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 diff --git a/picture/Lifespan/World.hs b/picture/Lifespan/World.hs new file mode 100644 --- /dev/null +++ b/picture/Lifespan/World.hs @@ -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 diff --git a/picture/Machina/Main.hs b/picture/Machina/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Machina/Main.hs @@ -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)] diff --git a/picture/Occlusion/Cell.hs b/picture/Occlusion/Cell.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Cell.hs @@ -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) diff --git a/picture/Occlusion/Data.hs b/picture/Occlusion/Data.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Data.hs @@ -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#..............................#" + ] diff --git a/picture/Occlusion/Main.hs b/picture/Occlusion/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/Main.hs @@ -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) diff --git a/picture/Occlusion/State.hs b/picture/Occlusion/State.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/State.hs @@ -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 diff --git a/picture/Occlusion/World.hs b/picture/Occlusion/World.hs new file mode 100644 --- /dev/null +++ b/picture/Occlusion/World.hs @@ -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) diff --git a/picture/Render/Main.hs b/picture/Render/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Render/Main.hs @@ -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 diff --git a/picture/Styrene/Actor.hs b/picture/Styrene/Actor.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Actor.hs @@ -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 diff --git a/picture/Styrene/Advance.hs b/picture/Styrene/Advance.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Advance.hs @@ -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 diff --git a/picture/Styrene/Collide.hs b/picture/Styrene/Collide.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Collide.hs @@ -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" diff --git a/picture/Styrene/Config.hs b/picture/Styrene/Config.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Config.hs @@ -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 diff --git a/picture/Styrene/Contact.hs b/picture/Styrene/Contact.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Contact.hs @@ -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) diff --git a/picture/Styrene/Main.hs b/picture/Styrene/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/Main.hs @@ -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] diff --git a/picture/Styrene/QuadTree.hs b/picture/Styrene/QuadTree.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/QuadTree.hs @@ -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{} -> [] diff --git a/picture/Styrene/World.hs b/picture/Styrene/World.hs new file mode 100644 --- /dev/null +++ b/picture/Styrene/World.hs @@ -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 diff --git a/picture/Tree/Main.hs b/picture/Tree/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Tree/Main.hs @@ -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 diff --git a/picture/Visibility/Draw.hs b/picture/Visibility/Draw.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Draw.hs @@ -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)] diff --git a/picture/Visibility/Geometry/Randomish.hs b/picture/Visibility/Geometry/Randomish.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Geometry/Randomish.hs @@ -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 diff --git a/picture/Visibility/Geometry/Segment.hs b/picture/Visibility/Geometry/Segment.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Geometry/Segment.hs @@ -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 diff --git a/picture/Visibility/Interface.hs b/picture/Visibility/Interface.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Interface.hs @@ -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 diff --git a/picture/Visibility/Main.hs b/picture/Visibility/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/Main.hs @@ -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 diff --git a/picture/Visibility/State.hs b/picture/Visibility/State.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/State.hs @@ -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 + } diff --git a/picture/Visibility/World.hs b/picture/Visibility/World.hs new file mode 100644 --- /dev/null +++ b/picture/Visibility/World.hs @@ -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} diff --git a/picture/Zen/Main.hs b/picture/Zen/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Zen/Main.hs @@ -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 + ]