├── .gitignore ├── example-image.png ├── src ├── ChaosBox │ ├── Prelude.hs │ ├── Draw.hs │ ├── Sequence.hs │ ├── Geometry │ │ ├── Transform.hs │ │ ├── Class.hs │ │ ├── P2.hs │ │ ├── Angle.hs │ │ ├── Path.hs │ │ ├── Polygon.hs │ │ ├── Curve.hs │ │ ├── Quad.hs │ │ ├── Rect.hs │ │ ├── Line.hs │ │ ├── Triangle.hs │ │ ├── Arc.hs │ │ ├── Circle.hs │ │ ├── Ellipse.hs │ │ └── ClosedCurve.hs │ ├── Orphanage.hs │ ├── Math │ │ ├── Vector.hs │ │ └── Matrix.hs │ ├── AABB.hs │ ├── Math.hs │ ├── Geometry.hs │ ├── PNG.hs │ ├── Color.hs │ ├── Random.hs │ ├── Generate.hs │ ├── CLI.hs │ ├── Interactive.hs │ └── Noise.hs └── ChaosBox.hs ├── stack.yaml ├── LICENSE ├── stack.yaml.lock ├── example └── Main.hs ├── package.yaml └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | chaosbox.cabal 2 | .stack-work 3 | images/ 4 | -------------------------------------------------------------------------------- /example-image.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/5outh/chaosbox/HEAD/example-image.png -------------------------------------------------------------------------------- /src/ChaosBox/Prelude.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Prelude 2 | ( module X 3 | ) 4 | where 5 | 6 | import Linear as X 7 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | 3 | packages: 4 | - . 5 | extra-deps: 6 | - random-extras-0.19 7 | - gtk2hs-buildtools-0.13.5.4 8 | - gi-cairo-render-0.0.1@sha256:ff2ccc309c021c2c023fa0d380375ef36cff2df93e0c78ed733f052dd1aa9782,3502 9 | -------------------------------------------------------------------------------- /src/ChaosBox/Draw.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Draw 2 | ( Draw(..) 3 | ) 4 | where 5 | 6 | import GI.Cairo.Render 7 | 8 | -- | Class of drawable items. 9 | -- 10 | -- 'draw' traces the path of a shape, which can then be 'fill'ed or 'stroke'd 11 | -- using the regular cairo utilities. 12 | class Draw a where 13 | draw :: a -> Render () 14 | -------------------------------------------------------------------------------- /src/ChaosBox/Sequence.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Sequence 2 | ( lerpSeq 3 | , lerpSeq2 4 | , lerpSeqWith 5 | ) 6 | where 7 | 8 | import ChaosBox.Math (clamp) 9 | import Data.Sequence (Seq, index) 10 | import Linear.V2 11 | 12 | -- | Get the element of a sequence some percentage through it 13 | -- 14 | -- For a non-empty sequence: 15 | -- 16 | -- @lerpSeq 0 seq = head seq@ 17 | -- @lerpSeq 1 seq = last seq@ 18 | -- 19 | lerpSeq :: Double -> Seq a -> a 20 | lerpSeq perc xs = xs `index` lerpSeqIndex perc xs 21 | 22 | lerpSeqIndex :: Double -> Seq a -> Int 23 | lerpSeqIndex perc xs = floor $ perc * fromIntegral (length xs - 1) 24 | 25 | lerpSeqWith :: (Double -> Double) -> Double -> Seq a -> a 26 | lerpSeqWith f perc xs = lerpSeq (f perc) xs 27 | 28 | lerpSeq2 :: V2 Double -> Seq (Seq a) -> a 29 | lerpSeq2 (V2 x0 y0) xs = 30 | row `index` (floor $ y * fromIntegral (length row - 1)) 31 | where 32 | row = xs `index` (floor $ x * fromIntegral (length xs - 1)) 33 | x = clamp (0, 1) x0 34 | y = clamp (0, 1) y0 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018 Benjamin Kovach 2 | 3 | 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: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | 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. 8 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Transform.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Geometry.Transform 2 | ( translatePoints 3 | , scalePoints 4 | , scaleAroundPoints 5 | , rotatePoints 6 | , rotateAroundPoints 7 | ) 8 | where 9 | 10 | import ChaosBox.Geometry.Angle 11 | import ChaosBox.Geometry.Class 12 | import ChaosBox.Geometry.P2 13 | import Control.Lens ((%~)) 14 | 15 | translatePoints :: (Functor f, HasP2 a) => P2 -> f a -> f a 16 | translatePoints p2 = fmap (_V2 %~ translateP2 p2) 17 | 18 | scalePoints :: (Functor f, HasP2 a) => P2 -> f a -> f a 19 | scalePoints amount = fmap (_V2 %~ scaleP2 amount) 20 | 21 | scaleAroundPoints :: (Functor f, HasP2 a) => P2 -> P2 -> f a -> f a 22 | scaleAroundPoints center amount = fmap (_V2 %~ scaleP2Around center amount) 23 | 24 | rotatePoints :: (Functor f, HasP2 a) => Angle -> f a -> f a 25 | rotatePoints theta = fmap (_V2 %~ rotateP2 theta) 26 | 27 | rotateAroundPoints :: (Functor f, HasP2 a) => P2 -> Angle -> f a -> f a 28 | rotateAroundPoints center theta = fmap (_V2 %~ rotateP2Around center theta) 29 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module ChaosBox.Geometry.Class 3 | ( Boundary(..) 4 | , HasP2(..) 5 | , Intersects(..) 6 | , getP2 7 | , setP2 8 | , modifyP2 9 | ) 10 | where 11 | 12 | import ChaosBox.Geometry.P2 13 | import Control.Lens (Lens', lens, (%~), (&), (.~), (^.)) 14 | import Data.Complex 15 | import Linear.V2 16 | 17 | -- | Class of objects that can be queried for points 18 | class Boundary a where 19 | containsPoint :: a -> P2 -> Bool 20 | 21 | class HasP2 a where 22 | _V2 :: Lens' a P2 23 | 24 | instance HasP2 P2 where 25 | _V2 = _xy 26 | 27 | instance HasP2 (Complex Double) where 28 | _V2 = lens (\(a :+ b) -> V2 a b) (\_ (V2 x y) -> x :+ y) 29 | 30 | getP2 :: HasP2 a => a -> P2 31 | getP2 = (^. _V2) 32 | 33 | setP2 :: HasP2 a => a -> P2 -> a 34 | setP2 x p2 = x & _V2 .~ p2 35 | 36 | modifyP2 :: HasP2 a => a -> (P2 -> P2) -> a 37 | modifyP2 x f = x & _V2 %~ f 38 | 39 | class Intersects a b where 40 | intersectionPoints :: a -> b -> [P2] 41 | intersects :: a -> b -> Bool 42 | intersects a b = null (intersectionPoints a b) 43 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/P2.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Geometry.P2 2 | ( P2 3 | , pattern P2 4 | , translateP2 5 | , scaleP2 6 | , scaleP2Around 7 | ) 8 | where 9 | 10 | import Linear.V2 11 | 12 | -- | A monomorphized 'V2' 13 | type P2 = V2 Double 14 | 15 | -- | A @pattern@ to match 'V2's using 'P2' for consistency. 16 | -- 17 | -- Construction: 18 | -- 19 | -- > a :: P2 = P2 0 0 20 | -- 21 | -- Pattern matching: 22 | -- 23 | -- > for_ path $ \(P2 x y) -> {- ... -} 24 | -- 25 | pattern P2 :: Double -> Double -> P2 26 | pattern P2 x y = V2 x y 27 | {-# COMPLETE P2 #-} 28 | 29 | -- | Translate a 'P2' by an offset vector 30 | translateP2 :: P2 -> P2 -> P2 31 | translateP2 offset p2 = p2 + offset 32 | 33 | -- | Scale a 'P2' around the origin (@(0,0)@) by a 2d scalar 34 | scaleP2 :: P2 -> P2 -> P2 35 | scaleP2 (P2 x1 y1) (P2 x2 y2) = P2 (x1*x2) (y1*y2) 36 | 37 | -- | Scale a 'P2' around the specified point 38 | scaleP2Around 39 | :: P2 40 | -- ^ Point to scale around 41 | -> P2 42 | -- ^ Scalar 43 | -> P2 44 | -- ^ Point to scale 45 | -> P2 46 | scaleP2Around center amount p2 = translateP2 center (scaleP2 amount (translateP2 (-center) p2)) 47 | -------------------------------------------------------------------------------- /src/ChaosBox/Orphanage.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module ChaosBox.Orphanage 3 | () 4 | where 5 | 6 | import Control.Monad.Base 7 | import Data.Random ( Distribution 8 | , Distribution(..) 9 | , Normal 10 | , Normal(..) 11 | , StdUniform(..) 12 | ) 13 | import Linear.V2 14 | import GI.Cairo.Render 15 | 16 | -- These orphan instances do not leak to the end-user, since they're only used 17 | -- in wrapper functions. 18 | 19 | instance Distribution Normal a => Distribution Normal (V2 a) where 20 | rvarT StdNormal = V2 <$> rvarT StdNormal <*> rvarT StdNormal 21 | rvarT (Normal (V2 mx my) (V2 sx sy)) = 22 | V2 <$> rvarT (Normal mx sx) <*> rvarT (Normal my sy) 23 | 24 | instance Distribution StdUniform a => Distribution StdUniform (V2 a) where 25 | rvarT StdUniform = V2 <$> rvarT StdUniform <*> rvarT StdUniform 26 | 27 | instance MonadBase Render Render where 28 | liftBase = id 29 | -------------------------------------------------------------------------------- /src/ChaosBox/Math/Vector.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Math.Vector 2 | ( orient 3 | , lerpV 4 | , lerpManyV 5 | ) 6 | where 7 | 8 | import qualified Linear as L 9 | import Linear.Matrix (det33) 10 | import Linear.V2 (V2 (..)) 11 | import Linear.V3 (V3 (..)) 12 | 13 | -- brittany-disable-next-binding 14 | 15 | -- | Orient three points 16 | -- 17 | -- 'GT' means they are ordered counterclockwise. 18 | -- 'LT' means they are ordered clockwise. 19 | -- 'EQ' means they lie on the same line. 20 | -- 21 | orient :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Ordering 22 | orient (V2 px py) (V2 qx qy) (V2 rx ry) = compare orientation 0 23 | where 24 | orientation = det33 $ V3 25 | (V3 1 px py) 26 | (V3 1 qx qy) 27 | (V3 1 rx ry) 28 | 29 | -- | Lerp between two vectors 30 | lerpV :: (Num a, L.Additive f) => a -> f a -> f a -> f a 31 | lerpV = L.lerp 32 | 33 | -- | N lerps between two vectors, exclusive on upper bound 34 | lerpManyV 35 | :: (Num a, L.Additive f, Fractional a, Enum a) => Int -> f a -> f a -> [f a] 36 | lerpManyV n p q = map (\c -> L.lerp c p q) constants 37 | where 38 | step = 1 / fromIntegral n 39 | constants = [0, step .. (1 - step)] 40 | -------------------------------------------------------------------------------- /src/ChaosBox/AABB.hs: -------------------------------------------------------------------------------- 1 | -- | Minimally axis-aligned bounding boxes 2 | module ChaosBox.AABB 3 | ( HasAABB(..) 4 | , AABB(..) 5 | , boundary 6 | , aabbContains 7 | ) 8 | where 9 | 10 | import ChaosBox.Geometry.Class 11 | import ChaosBox.Geometry.P2 12 | import Control.Lens ( (^.) ) 13 | import Data.List.NonEmpty 14 | import Linear.V2 15 | 16 | -- | An Axis-Aligned Bounding Box 17 | data AABB = AABB 18 | { aabbTopLeft :: P2 19 | , aabbW :: Double 20 | , aabbH :: Double 21 | } 22 | deriving stock (Show, Eq, Ord) 23 | 24 | -- | Class of types that can be minimally bounded by an 'AABB' 25 | class HasAABB shape where 26 | aabb :: shape -> AABB 27 | 28 | instance HasAABB AABB where 29 | aabb = id 30 | 31 | -- | Get the bounds of a list of positioned objects. 32 | boundary :: HasP2 a => NonEmpty a -> AABB 33 | boundary xs = AABB tl w h 34 | where 35 | l = toList xs 36 | tl = minimum $ fmap (^. _V2) l 37 | br = maximum $ fmap (^. _V2) l 38 | (V2 w h) = br - tl 39 | 40 | -- | Check if an 'AABB' contains some 2d point ('P2') 41 | aabbContains :: AABB -> P2 -> Bool 42 | aabbContains AABB {..} (P2 x y) = 43 | x >= x0 && x < x0 + aabbW && y >= y0 && y < y0 + aabbH 44 | where V2 x0 y0 = aabbTopLeft 45 | 46 | instance Boundary AABB where 47 | containsPoint = aabbContains 48 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: random-extras-0.19@sha256:52579ee8653b17d8b19fb54833ecbab8df47b6cf61a77c9614df0c3155441d29,1137 9 | pantry-tree: 10 | size: 552 11 | sha256: 61daee57c0c3e55cb1056176c917bedb3b42315c023398c3f83c9bd75b5e891e 12 | original: 13 | hackage: random-extras-0.19 14 | - completed: 15 | hackage: gtk2hs-buildtools-0.13.5.4@sha256:0f18b0103fa7a3cbc28edc6a97bdaf08e1f9bd273ef26d2ad498630ec6d0ac9c,5288 16 | pantry-tree: 17 | size: 3588 18 | sha256: df6fdd3aaf8b9d3dd420b5c5906751d7399f1999607b396141d1493c76472e1b 19 | original: 20 | hackage: gtk2hs-buildtools-0.13.5.4 21 | - completed: 22 | hackage: gi-cairo-render-0.0.1@sha256:ff2ccc309c021c2c023fa0d380375ef36cff2df93e0c78ed733f052dd1aa9782,3502 23 | pantry-tree: 24 | size: 1603 25 | sha256: e05dbca4c5acaf73903c142fc586d42ac8e2b57aabcc890053f8b02b1067d60a 26 | original: 27 | hackage: gi-cairo-render-0.0.1@sha256:ff2ccc309c021c2c023fa0d380375ef36cff2df93e0c78ed733f052dd1aa9782,3502 28 | snapshots: 29 | - completed: 30 | size: 523700 31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/7.yaml 32 | sha256: 8e3f3c894be74d71fa4bf085e0a8baae7e4d7622d07ea31a52736b80f8b9bb1a 33 | original: lts-14.7 34 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ChaosBox 4 | 5 | import Data.List.NonEmpty (NonEmpty (..)) 6 | import qualified Data.List.NonEmpty as NE 7 | 8 | -- Run this example with 9 | -- 10 | -- @ 11 | -- > chaosbox-example 12 | -- @ 13 | -- 14 | main :: IO () 15 | main = runChaosBoxWith 16 | (\o -> o { optWidth = 10, optHeight = 10, optScale = 60 }) 17 | renderSketch 18 | 19 | setup :: Render () 20 | setup = setLineWidth 0.02 21 | 22 | renderSketch :: Generate () 23 | renderSketch = do 24 | cairo setup 25 | 26 | (w, h) <- getSize 27 | center <- getCenterPoint 28 | 29 | startingPoint <- normal center (P2 (w / 4) (h / 4)) 30 | pathRef <- newIORef (startingPoint :| []) 31 | noise <- newNoise2 32 | 33 | mousePositionRef <- heldMousePosition ButtonLeft 34 | 35 | eventLoop $ do 36 | nextPath <- modifyIORefM pathRef $ \ps@(p :| _) -> do 37 | c <- readIORefWith (maybe p (lerp 0.05 p)) mousePositionRef 38 | let deviation = 0.3 * noise (c / 100) 39 | nextPoint <- normal c (P2 deviation deviation) 40 | pure $ unsafeTake 100 $ nextPoint `NE.cons` ps 41 | 42 | fillScreenRGB black 43 | cairo $ do 44 | setSourceRGB white 45 | draw (ClosedCurve nextPath 10) *> stroke 46 | 47 | -- | An unsafe version of 'Data.List.NonEmpty.take' 48 | -- 49 | -- This will blow up if n < 1, but is perfectly fine for a static value > 1, 50 | -- such as @100@ (at the callsite above). 51 | -- 52 | unsafeTake :: Int -> NonEmpty a -> NonEmpty a 53 | unsafeTake n = NE.fromList . NE.take n 54 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: chaosbox 2 | version: 0.0.0.2 3 | synopsis: A Generative Art Framework 4 | description: A Generative Art Framework 5 | homepage: https://github.com/5outh/chaosbox#readme 6 | license: MIT 7 | author: Benjamin Kovach 8 | maintainer: bkovach13@gmail.com 9 | copyright: 2020 Benjamin Kovach 10 | category: Art 11 | extra-source-files: 12 | - README.md 13 | 14 | ghc-options: 15 | - -Wall 16 | 17 | default-extensions: 18 | - TypeApplications 19 | - RecordWildCards 20 | - LambdaCase 21 | - DeriveFoldable 22 | - DeriveFunctor 23 | - DeriveTraversable 24 | - DeriveGeneric 25 | - DerivingStrategies 26 | - GeneralizedNewtypeDeriving 27 | - TypeFamilies 28 | - MultiParamTypeClasses 29 | - FlexibleContexts 30 | - FlexibleInstances 31 | - PatternSynonyms 32 | - ScopedTypeVariables 33 | - RankNTypes 34 | 35 | dependencies: 36 | - base >= 4.7 && < 5 37 | - directory 38 | - colour 39 | - linear 40 | - MonadRandom 41 | - mtl 42 | - optparse-applicative 43 | - process 44 | - random 45 | - random-fu 46 | - random-source 47 | - semigroups 48 | - time 49 | - transformers 50 | - mersenne-random-pure64 51 | - vector 52 | - containers 53 | - array 54 | - rvar 55 | - semigroupoids 56 | - lens 57 | - sdl2 58 | - gi-cairo-render 59 | - monad-loops 60 | - unliftio 61 | - transformers-base 62 | 63 | library: 64 | source-dirs: src 65 | 66 | executables: 67 | chaosbox-example: 68 | source-dirs: example 69 | main: Main.hs 70 | dependencies: 71 | - chaosbox 72 | -------------------------------------------------------------------------------- /src/ChaosBox/Math.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Math 2 | ( lerp 3 | , lerpMany 4 | , average 5 | , clamp 6 | , resample 7 | , module X 8 | ) 9 | where 10 | 11 | import ChaosBox.Math.Matrix as X 12 | import ChaosBox.Math.Vector as X 13 | 14 | import Data.Foldable (toList) 15 | import Data.List (genericLength) 16 | 17 | -- | Linearly interpolate between two numbers 18 | -- 19 | -- prop> lerp 0.5 0 10 = 5 20 | -- 21 | lerp :: Num a => a -> a -> a -> a 22 | lerp perc a b = (1 - perc) * a + perc * b 23 | 24 | -- | @n@ lerps between two points, exclusive on upper bound 25 | -- 26 | -- prop> lerpMany 10 0 8 = [0.0,0.8,1.6,2.4,3.2,4.0,4.8,5.6,6.4,7.2] 27 | -- 28 | lerpMany :: (Num a, Fractional a, Enum a) => Int -> a -> a -> [a] 29 | lerpMany n p q = map (\c -> lerp c p q) constants 30 | where 31 | step = 1 / fromIntegral n 32 | constants = [0, step .. (1 - step)] 33 | 34 | -- | Average a 'Foldable' collection 35 | average :: (Num a, Fractional a, Foldable f) => f a -> a 36 | average xs = sum xs0 / genericLength xs0 where xs0 = toList xs 37 | 38 | -- | Resample a value in one interval to a value in another 39 | -- 40 | -- prop> resample (0,1) (10,20) 0.5 = 15 41 | -- 42 | resample :: (Double, Double) -> (Double, Double) -> Double -> Double 43 | resample (start, end) (newStart, newEnd) x = 44 | newStart + ((newEnd - newStart) * perc) 45 | where 46 | -- The size of the initial interval 47 | size = end - start 48 | -- amount "through" the intitial interval we are 49 | perc = (x - start) / size 50 | 51 | -- | Clamp a value in some range 52 | clamp :: Ord a => (a, a) -> a -> a 53 | clamp (rangeStart, rangeEnd) x = max rangeStart (min x rangeEnd) 54 | 55 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Angle.hs: -------------------------------------------------------------------------------- 1 | -- | Angles 2 | module ChaosBox.Geometry.Angle 3 | ( Angle(..) 4 | , fromRadians 5 | , fromDegrees 6 | , unit 7 | , addRadians 8 | , addDegrees 9 | , rotateP2 10 | , rotateP2Around 11 | ) 12 | where 13 | 14 | import ChaosBox.Geometry.P2 15 | import Data.Fixed (mod') 16 | import Linear.V2 17 | 18 | newtype Angle = Angle { getAngle :: Double } 19 | deriving stock (Eq, Ord, Show) 20 | deriving newtype (Num, Fractional, Enum) 21 | 22 | -- | Construct an angle in radians in the range [0, 2*pi) 23 | -- 24 | -- Modular arithmetic is used to limit angles out of range 25 | -- 26 | fromRadians :: Double -> Angle 27 | fromRadians theta = Angle $ theta `mod'` (2 * pi) 28 | 29 | -- | Construct an angle in degrees in the range [0, 360) 30 | -- 31 | -- Modular arithmetic is used to limit angles out of range 32 | -- 33 | fromDegrees :: Double -> Angle 34 | fromDegrees theta = fromRadians $ theta * pi / 180 35 | 36 | -- | The unit vector in the direction of 'Angle' 37 | unit :: Angle -> P2 38 | unit (Angle r) = angle r 39 | 40 | -- | Add radians to an 'Angle' 41 | -- 42 | -- Note: This is allowed to break the bounds of 0..2*pi radians 43 | -- 44 | addRadians :: Double -> Angle -> Angle 45 | addRadians theta (Angle a) = Angle (theta + a) 46 | 47 | -- | Add radians to an 'Angle' 48 | -- 49 | -- Note: This is allowed to break the bounds of 0..360 degrees 50 | -- 51 | addDegrees :: Double -> Angle -> Angle 52 | addDegrees theta (Angle a) = Angle (theta * pi / 180 + a) 53 | 54 | -- | Rotate a 'P2' about the origin (@(0,0)@) 55 | rotateP2 :: Angle -> P2 -> P2 56 | rotateP2 (Angle theta) (P2 x0 y0) = P2 x y 57 | where 58 | x = x0 * cos theta - y0 * sin theta 59 | y = x0 * sin theta + y0 * cos theta 60 | 61 | -- | Rotate a 'P2' around a specified point 62 | rotateP2Around 63 | :: P2 64 | -- ^ Point to rotate around 65 | -> Angle 66 | -- ^ Rotation angle 67 | -> P2 68 | -- ^ Point to rotate 69 | -> P2 70 | rotateP2Around center theta point = 71 | translateP2 center (rotateP2 theta (translateP2 (-center) point)) 72 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Path.hs: -------------------------------------------------------------------------------- 1 | -- | Open paths 2 | module ChaosBox.Geometry.Path 3 | ( PathOf(..) 4 | , Path 5 | , pattern Path 6 | , getPath 7 | , translatePath 8 | , scalePath 9 | , scalePathAround 10 | , rotatePath 11 | , rotatePathAround 12 | , pathCenter 13 | ) 14 | where 15 | 16 | import ChaosBox.Prelude 17 | 18 | import ChaosBox.Math (average) 19 | import ChaosBox.AABB 20 | import ChaosBox.Draw 21 | import ChaosBox.Geometry.Angle 22 | import ChaosBox.Geometry.Class 23 | import ChaosBox.Geometry.P2 24 | import ChaosBox.Geometry.Transform 25 | import Control.Lens ((^.)) 26 | import Data.Foldable (for_) 27 | import Data.List.NonEmpty (NonEmpty (..)) 28 | import GI.Cairo.Render hiding (Path) 29 | 30 | newtype PathOf a = PathOf { getPathOf :: NonEmpty a } 31 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 32 | deriving newtype (Applicative, Monad) 33 | 34 | -- | An open path 35 | type Path = PathOf P2 36 | 37 | pattern Path :: NonEmpty P2 -> Path 38 | pattern Path { getPath } = PathOf getPath 39 | {-# COMPLETE Path #-} 40 | 41 | instance HasP2 a => Draw (PathOf a) where 42 | draw (PathOf (start :| rest)) = do 43 | newPath 44 | moveTo (start ^. _V2 . _x) (start ^. _V2 . _y) 45 | for_ (map (^. _V2) rest) (\(V2 x y) -> lineTo x y) 46 | 47 | instance HasP2 a => HasAABB (PathOf a) where 48 | aabb = boundary . getPathOf 49 | 50 | translatePath :: HasP2 a => P2 -> PathOf a -> PathOf a 51 | translatePath = translatePoints 52 | 53 | scalePath :: HasP2 a => P2 -> PathOf a -> PathOf a 54 | scalePath = scalePoints 55 | 56 | scalePathAround :: HasP2 a => P2 -> P2 -> PathOf a -> PathOf a 57 | scalePathAround = scaleAroundPoints 58 | 59 | rotatePath :: HasP2 a => Angle -> PathOf a -> PathOf a 60 | rotatePath = rotatePoints 61 | 62 | rotatePathAround :: HasP2 a => P2 -> Angle -> PathOf a -> PathOf a 63 | rotatePathAround = rotateAroundPoints 64 | 65 | -- | The center of mass of a 'Path' 66 | pathCenter :: HasP2 a => PathOf a -> P2 67 | pathCenter = average . fmap (^._V2) 68 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Polygon.hs: -------------------------------------------------------------------------------- 1 | -- | Arbitrary polygons 2 | module ChaosBox.Geometry.Polygon 3 | ( PolygonOf(..) 4 | , Polygon 5 | , pattern Polygon 6 | , getPolygon 7 | , polygonOf 8 | , polygon 9 | , polygonCenter 10 | , translatePolygon 11 | , scalePolygon 12 | , scalePolygonAround 13 | , rotatePolygon 14 | , rotatePolygonAround 15 | ) 16 | where 17 | 18 | import ChaosBox.Prelude 19 | 20 | import ChaosBox.Math (average) 21 | import ChaosBox.AABB 22 | import ChaosBox.Draw 23 | import ChaosBox.Geometry.Angle 24 | import ChaosBox.Geometry.Class 25 | import ChaosBox.Geometry.P2 26 | import ChaosBox.Geometry.Transform 27 | import Control.Lens ((^.)) 28 | import Data.Foldable (for_) 29 | import Data.List.NonEmpty (NonEmpty (..)) 30 | import qualified Data.List.NonEmpty as NE 31 | import GI.Cairo.Render hiding (Path) 32 | 33 | -- | A closed path 34 | newtype PolygonOf a = PolygonOf { getPolygonOf :: NonEmpty a } 35 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 36 | deriving newtype (Applicative, Monad) 37 | 38 | type Polygon = PolygonOf P2 39 | 40 | pattern Polygon :: NonEmpty P2 -> Polygon 41 | pattern Polygon {getPolygon} = PolygonOf getPolygon 42 | {-# COMPLETE Polygon #-} 43 | 44 | instance HasP2 a => HasAABB (PolygonOf a) where 45 | aabb = boundary . getPolygonOf 46 | 47 | instance HasP2 a => Draw (PolygonOf a) where 48 | draw (PolygonOf (v :| rest)) = do 49 | let V2 startX startY = v ^. _V2 50 | newPath 51 | moveTo startX startY 52 | for_ (map (^. _V2) rest) (\(V2 x y) -> lineTo x y) 53 | closePath 54 | 55 | polygonOf :: [a] -> Maybe (PolygonOf a) 56 | polygonOf xs = PolygonOf <$> NE.nonEmpty xs 57 | 58 | polygon :: [P2] -> Maybe Polygon 59 | polygon = polygonOf 60 | 61 | translatePolygon :: HasP2 a => P2 -> PolygonOf a -> PolygonOf a 62 | translatePolygon = translatePoints 63 | 64 | scalePolygon :: HasP2 a => P2 -> PolygonOf a -> PolygonOf a 65 | scalePolygon = scalePoints 66 | 67 | scalePolygonAround :: HasP2 a => P2 -> P2 -> PolygonOf a -> PolygonOf a 68 | scalePolygonAround = scaleAroundPoints 69 | 70 | rotatePolygon :: HasP2 a => Angle -> PolygonOf a -> PolygonOf a 71 | rotatePolygon = rotatePoints 72 | 73 | rotatePolygonAround :: HasP2 a => P2 -> Angle -> PolygonOf a -> PolygonOf a 74 | rotatePolygonAround = rotateAroundPoints 75 | 76 | -- | The center of mass of a 'Polygon' 77 | polygonCenter :: HasP2 a => PolygonOf a -> P2 78 | polygonCenter = average . fmap (^._V2) 79 | -------------------------------------------------------------------------------- /src/ChaosBox/Math/Matrix.hs: -------------------------------------------------------------------------------- 1 | -- | Various raw transformation matrices 2 | module ChaosBox.Math.Matrix 3 | ( 4 | -- * Affine transformations 5 | rotation 6 | , translation 7 | , scalar 8 | , shearX 9 | , shearY 10 | , shear 11 | , reflectOrigin 12 | , reflectX 13 | , reflectY 14 | -- * Vector Operations 15 | , applyMatrix 16 | -- * Combinators 17 | , aroundMatrix 18 | -- * Re-exports 19 | , identity 20 | ) 21 | where 22 | 23 | import ChaosBox.Geometry.P2 24 | import Linear.Matrix hiding (translation) 25 | import Linear.V2 26 | import Linear.V3 27 | 28 | -- brittany --exact-print-only 29 | 30 | affine :: a -> a -> a 31 | -> a -> a -> a 32 | -> a -> a -> a 33 | -> M33 a 34 | affine 35 | a b c 36 | d e f 37 | g h i 38 | = V3 39 | (V3 a b c) 40 | (V3 d e f) 41 | (V3 g h i) 42 | 43 | -- | Rotation by @t@ radians counter-clockwise 44 | rotation :: Double -> M33 Double 45 | rotation t = affine 46 | (cos t) (sin t) 0 47 | (-(sin t)) (cos t) 0 48 | 0 0 1 49 | 50 | -- | Translation in two dimensions 51 | translation :: P2 -> M33 Double 52 | translation (V2 x y) = affine 53 | 1 0 x 54 | 0 1 y 55 | 0 0 1 56 | 57 | -- | Scale in two dimensions 58 | scalar :: P2 -> M33 Double 59 | scalar (V2 w h) = affine 60 | w 0 0 61 | 0 h 0 62 | 0 0 1 63 | 64 | -- | Shear along the x axis 65 | shearX :: Double -> M33 Double 66 | shearX t = affine 67 | 1 t 0 68 | 0 1 0 69 | 0 0 1 70 | 71 | -- | Shear along the y axis 72 | shearY :: Double -> M33 Double 73 | shearY t = affine 74 | 1 0 0 75 | t 1 0 76 | 0 0 1 77 | 78 | -- | Shear along the x and y axis 79 | shear :: P2 -> M33 Double 80 | shear (V2 x y) = shearX x !*! shearY y 81 | 82 | -- | Reflect about the origin 83 | reflectOrigin :: M33 Double 84 | reflectOrigin = affine 85 | (-1) 0 0 86 | 0 (-1) 0 87 | 0 0 1 88 | 89 | -- | Reflect about the x axis 90 | reflectX :: M33 Double 91 | reflectX = affine 92 | 1 0 0 93 | 0 (-1) 0 94 | 0 0 1 95 | 96 | -- | Reflect about the y axis 97 | reflectY :: M33 Double 98 | reflectY = affine 99 | (-1) 0 0 100 | 0 1 0 101 | 0 0 1 102 | 103 | -- | Apply a raw transformation matrix to a 'P2' 104 | applyMatrix :: M33 Double -> P2 -> P2 105 | applyMatrix m (V2 x y) = V2 x0 y0 106 | where 107 | v0 = V3 x y 0 108 | V3 x0 y0 _ = m !* v0 109 | 110 | -- | Perform a linear transformation around a certain point 111 | -- 112 | -- This is useful for rotation around the center, etc. 113 | -- 114 | aroundMatrix :: P2 -> M33 Double -> M33 Double 115 | aroundMatrix v m = translation (-v) !*! m !*! translation v 116 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Curve.hs: -------------------------------------------------------------------------------- 1 | -- | Open cubic b-splines 2 | module ChaosBox.Geometry.Curve 3 | ( CurveOf(..) 4 | , Curve 5 | , pattern Curve 6 | , getCurve 7 | , curveIterations 8 | , curve 9 | , curveOf 10 | , curveWithDetail 11 | , toPath 12 | , fromPath 13 | , curveCenter 14 | ) 15 | where 16 | 17 | import ChaosBox.AABB 18 | import ChaosBox.Draw 19 | import ChaosBox.Geometry.Class 20 | import ChaosBox.Geometry.P2 21 | import ChaosBox.Geometry.Path 22 | import Control.Lens 23 | import Data.List.NonEmpty (NonEmpty (..)) 24 | import qualified Data.List.NonEmpty as NE 25 | import GI.Cairo.Render (Render) 26 | import ChaosBox.Math (average) 27 | 28 | -- | Cubic B-Spline 29 | data CurveOf a = CurveOf { getCurveOf :: NonEmpty a, curveOfIterations :: Int } 30 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 31 | 32 | type Curve = CurveOf P2 33 | 34 | pattern Curve :: NonEmpty P2 -> Int -> Curve 35 | pattern Curve {getCurve, curveIterations} = CurveOf getCurve curveIterations 36 | {-# COMPLETE Curve #-} 37 | 38 | instance HasP2 a => HasAABB (CurveOf a) where 39 | aabb = aabb . toPath 40 | 41 | instance HasP2 a => Draw (CurveOf a) where 42 | draw = drawWithDetail 43 | 44 | -- | Draw with a specified level of detail (default 5; smaller is less detailed) 45 | drawWithDetail :: HasP2 a => CurveOf a -> Render () 46 | drawWithDetail = draw . toPath 47 | 48 | toPath :: HasP2 a => CurveOf a -> PathOf a 49 | toPath (CurveOf ps detail) = PathOf 50 | (NE.fromList $ iterateNLast detail (go . expand) (NE.toList ps)) 51 | where 52 | expand1 prev a = [prev & _V2 .~ (prev ^. _V2 + a ^. _V2) / 2, a] 53 | 54 | expand ys@(y : _) = y : concat (zipWith expand1 ys (tail ys)) 55 | expand [] = error "impossible" 56 | 57 | mask a b c = b & _V2 .~ (a ^. _V2 + 2 * b ^. _V2 + c ^. _V2) / 4 58 | 59 | go1 [] = [] 60 | go1 [c] = [c] 61 | go1 [_, c] = [c] 62 | go1 (a : b : c : xs) = mask a b c : go1 (b : c : xs) 63 | 64 | go [] = [] 65 | go xs@(a : _) = a : go1 xs 66 | 67 | fromPath :: PathOf a -> CurveOf a 68 | fromPath (PathOf p) = CurveOf p 5 69 | 70 | iterateNLast :: Int -> (a -> a) -> a -> a 71 | iterateNLast n f x = last . take n $ iterate f x 72 | 73 | curveOf :: [a] -> Maybe (CurveOf a) 74 | curveOf xs = CurveOf <$> NE.nonEmpty xs <*> pure 5 75 | 76 | curve :: [P2] -> Maybe Curve 77 | curve = curveOf @P2 78 | 79 | curveWithDetail :: [a] -> Int -> Maybe (CurveOf a) 80 | curveWithDetail xs detail = CurveOf <$> NE.nonEmpty xs <*> pure detail 81 | 82 | -- | The center of mass of a 'Curve' 83 | curveCenter :: HasP2 a => CurveOf a -> P2 84 | curveCenter = average . fmap (^._V2) 85 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Quad.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | -- | Quadrilaterals (four-sided polygons) 3 | module ChaosBox.Geometry.Quad 4 | ( QuadOf(..) 5 | , Quad 6 | , pattern Quad 7 | , fromRect 8 | , quadA 9 | , quadB 10 | , quadC 11 | , quadD 12 | , translateQuad 13 | , scaleQuad 14 | , scaleQuadAround 15 | , rotateQuad 16 | , rotateQuadAround 17 | , quadCenter 18 | , scaleRect 19 | , scaleRectAround 20 | ) 21 | where 22 | 23 | import ChaosBox.Prelude 24 | 25 | import ChaosBox.Math (average) 26 | import Control.Lens ((^.)) 27 | import ChaosBox.AABB 28 | import ChaosBox.Draw 29 | import ChaosBox.Geometry.Angle 30 | import ChaosBox.Geometry.Class 31 | import ChaosBox.Geometry.P2 32 | import ChaosBox.Geometry.Polygon (polygonOf) 33 | import ChaosBox.Geometry.Rect 34 | import ChaosBox.Geometry.Transform 35 | import Control.Lens ((&), (+~)) 36 | import Data.Foldable (for_) 37 | import Data.List.NonEmpty (NonEmpty (..)) 38 | 39 | data QuadOf a = QuadOf 40 | { quadOfA :: a 41 | , quadOfB :: a 42 | , quadOfC :: a 43 | , quadOfD :: a 44 | } 45 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 46 | 47 | type Quad = QuadOf P2 48 | 49 | pattern Quad :: P2 -> P2 -> P2 -> P2 -> Quad 50 | pattern Quad {quadA, quadB, quadC, quadD} = QuadOf quadA quadB quadC quadD 51 | {-# COMPLETE Quad #-} 52 | 53 | instance HasP2 a => HasAABB (QuadOf a) where 54 | aabb QuadOf {..} = boundary $ quadOfA :| [quadOfB, quadOfC, quadOfD] 55 | 56 | instance HasP2 a => Draw (QuadOf a) where 57 | draw QuadOf {..} = for_ (polygonOf [quadOfA, quadOfB, quadOfC, quadOfD]) draw 58 | 59 | fromRect :: HasP2 a => RectOf a -> QuadOf a 60 | fromRect RectOf {..} = QuadOf rectOfTopLeft 61 | (rectOfTopLeft & _V2 +~ V2 rectOfW 0) 62 | (rectOfTopLeft & _V2 +~ V2 rectOfW rectOfH) 63 | (rectOfTopLeft & _V2 +~ V2 0 rectOfH) 64 | 65 | scaleRect :: P2 -> Rect -> Rect 66 | scaleRect p = fromAABB . aabb . scaleQuad p . fromRect 67 | 68 | scaleRectAround :: P2 -> P2 -> Rect -> Rect 69 | scaleRectAround p1 p2 = fromAABB . aabb . scaleQuadAround p1 p2 . fromRect 70 | 71 | translateQuad :: HasP2 a => P2 -> QuadOf a -> QuadOf a 72 | translateQuad = translatePoints 73 | 74 | scaleQuad :: HasP2 a => P2 -> QuadOf a -> QuadOf a 75 | scaleQuad = scalePoints 76 | 77 | scaleQuadAround :: HasP2 a => P2 -> P2 -> QuadOf a -> QuadOf a 78 | scaleQuadAround = scaleAroundPoints 79 | 80 | rotateQuad :: HasP2 a => Angle -> QuadOf a -> QuadOf a 81 | rotateQuad = rotatePoints 82 | 83 | rotateQuadAround :: HasP2 a => P2 -> Angle -> QuadOf a -> QuadOf a 84 | rotateQuadAround = rotateAroundPoints 85 | 86 | -- | The center of mass of a 'Quad' 87 | quadCenter :: HasP2 a => QuadOf a -> P2 88 | quadCenter = average . fmap (^._V2) 89 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Rect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | -- | Axis-aligned rectangles 3 | module ChaosBox.Geometry.Rect 4 | ( RectOf(..) 5 | , Rect 6 | , pattern Rect 7 | , rectTopLeft 8 | , rectW 9 | , rectH 10 | , rectCenter 11 | -- * Smart constructors 12 | , squareOf 13 | , square 14 | -- * Conversions 15 | , fromAABB 16 | ) 17 | where 18 | 19 | import ChaosBox.Prelude 20 | 21 | import ChaosBox.AABB 22 | import ChaosBox.Draw 23 | import ChaosBox.Geometry.Class 24 | import ChaosBox.Geometry.P2 25 | import Control.Lens ((^.)) 26 | import GI.Cairo.Render hiding (Path, transform) 27 | 28 | -- | A Rectangle 29 | data RectOf a = RectOf 30 | { rectOfTopLeft :: a 31 | , rectOfW :: Double 32 | , rectOfH :: Double 33 | } 34 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 35 | 36 | instance HasP2 a => HasAABB (RectOf a) where 37 | aabb (RectOf tl w h) = AABB (tl ^. _V2) w h 38 | 39 | instance HasP2 a => Draw (RectOf a) where 40 | draw RectOf {..} = rectangle rectX rectY rectOfW rectOfH 41 | where V2 rectX rectY = rectOfTopLeft ^. _V2 42 | 43 | instance HasP2 a => Boundary (RectOf a) where 44 | RectOf{..} `containsPoint` (V2 x y) = x >= tlx && x < brx && y >= tly && y <= bry 45 | where 46 | V2 tlx tly = rectOfTopLeft ^. _V2 47 | V2 brx bry = rectOfTopLeft ^. _V2 + V2 rectOfW rectOfH 48 | 49 | squareOf :: a -> Double -> RectOf a 50 | squareOf c w = RectOf c w w 51 | 52 | square :: P2 -> Double -> Rect 53 | square = squareOf 54 | 55 | type Rect = RectOf P2 56 | 57 | pattern Rect :: P2 -> Double -> Double -> Rect 58 | pattern Rect { rectTopLeft, rectW, rectH} = RectOf rectTopLeft rectW rectH 59 | 60 | fromAABB :: AABB -> Rect 61 | fromAABB (AABB tl w h) = RectOf tl w h 62 | 63 | -- | The center of a 'Rect' 64 | rectCenter :: HasP2 a => RectOf a -> P2 65 | rectCenter RectOf{..} = (rectOfTopLeft^._V2) + (P2 rectOfW rectOfH / 2) 66 | 67 | -- 68 | -- There are a LOT of ways this can happen. let's enumerate them 69 | -- 70 | -- 1. do not intersect at all: tlb and brb does not fit within x or y coordinates of tla 71 | -- 3. top line intersects through the horizontal segments 72 | -- 4. bottom line intersects through the horizontal segments 73 | -- 5. left line intersects through the vertical segments 74 | -- 6. right line intersects through the vertical segments 75 | -- 76 | -- 2. intersect through a corner (one for each) 77 | 78 | -- +---------+ 79 | -- | | 80 | -- | | 81 | -- | +---*-----+ 82 | -- | | | | 83 | -- +-----*---+ | 84 | -- | | 85 | -- | | 86 | -- | | 87 | -- +---------+ 88 | -- 89 | 90 | -- TODO 91 | -- instance (HasP2 a, HasP2 b) => Intersects (RectOf a) (RectOf b) where 92 | -- intersectionPoints (fmap getP2 -> RectOf tla@(P2 tlax tlay) wa ha) (fmap getP2 -> RectOf tlb@(P2 tlbx tlby) wb hb) = undefined 93 | -- where 94 | -- doesNotIntersect = undefined 95 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry.hs: -------------------------------------------------------------------------------- 1 | -- | Geometry Primitives 2 | -- 3 | -- There is, in general, one submodule per shape re-exported here. 4 | -- 5 | -- Each shape module (@ChaosBox.Geometry.X@) defines a generalized shape 6 | -- (@XOf@), a shape positioned by 'P2's (@X@) and a @pattern@ @X@ which allows 7 | -- easier operation on the 'P2'-positioned shape. 8 | -- 9 | -- Let's look at "ChaosBox.Geometry.Line" as an example (@X = Line@): 10 | -- 11 | -- > data LineOf a = LineOf { lineOfStart :: a, lineOfEnd :: a} 12 | -- 13 | -- 'LineOf' contains a start and end of any type @a@. This gives us 'Functor', 14 | -- 'Foldable', and 'Traversable' instances for free. 15 | -- 16 | -- In addition, the type synonym 'Line' is provided, since this is the most 17 | -- common use case (A 'Line' is a line segment between two cartesian 18 | -- coordinates): 19 | -- 20 | -- > type Line = LineOf P2 21 | -- 22 | -- Each module also exports a pattern for the common case. For @Line@, it is: 23 | -- 24 | -- @ 25 | -- pattern Line :: P2 -> P2 -> Line 26 | -- pattern Line { lineStart, lineEnd } = LineOf lineStart lineEnd 27 | -- @ 28 | -- 29 | -- This allows the user to construct 'Line's with 'Line': 30 | -- 31 | -- @ 32 | -- myLine :: Line 33 | -- myLine = Line (P2 0 1) (P2 10 12) 34 | -- @ 35 | -- 36 | -- as well as pattern-match on 'Line': 37 | -- 38 | -- @ 39 | -- midpoint :: Line -> P2 40 | -- midPoint (Line s e) = (s + e) / 2 41 | -- @ 42 | -- 43 | -- You can also use @NamedFieldPuns@ or @RecordWildCards@ on the @pattern@: 44 | -- 45 | -- @ 46 | -- midpoint :: Line -> P2 47 | -- midPoint Line{..} = (lineStart + lineEnd) / 2 48 | -- @ 49 | -- 50 | -- This is an uncommon design choice, but it works well here. The user can sort 51 | -- of forget about the generalized data type when programming with the common 52 | -- case, but the flexibility is there to generalize if and when it is needed. 53 | -- 54 | -- All shapes instantiate the following when possible: 55 | -- 56 | -- - 'ChaosBox.AABB.HasAABB', which provides a minimal axis-aligned bounding box for the 57 | -- shape (see "ChaosBox.AABB") 58 | -- - 'ChaosBox.Affine.Affine', which allows transforming the shape linearly (see 59 | -- "ChaosBox.Affine") 60 | -- - 'ChaosBox.Draw.Draw', which allows the shape to be drawn to the user's canvas (See 61 | -- "ChaosBox.Draw") 62 | -- 63 | -- "ChaosBox.Geometry.Angle" and "ChaosBox.Geometry.P2" are not shapes, but 64 | -- useful geometric primitives nonetheless. 65 | -- 66 | module ChaosBox.Geometry 67 | ( module X 68 | ) 69 | where 70 | 71 | import ChaosBox.Geometry.Angle as X 72 | import ChaosBox.Geometry.Arc as X 73 | import ChaosBox.Geometry.Circle as X 74 | import ChaosBox.Geometry.ClosedCurve as X 75 | import ChaosBox.Geometry.Curve as X 76 | import ChaosBox.Geometry.Ellipse as X 77 | import ChaosBox.Geometry.Line as X 78 | import ChaosBox.Geometry.P2 as X 79 | import ChaosBox.Geometry.Path as X 80 | import ChaosBox.Geometry.Polygon as X 81 | import ChaosBox.Geometry.Quad as X 82 | import ChaosBox.Geometry.Rect as X 83 | import ChaosBox.Geometry.Triangle as X 84 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Line.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | -- | Line segments 3 | module ChaosBox.Geometry.Line 4 | ( LineOf(..) 5 | , Line 6 | , pattern Line 7 | , lineStart 8 | , lineEnd 9 | , lineCenter 10 | -- * Transforming 'Line's 11 | , translateLine 12 | , scaleLine 13 | , scaleLineAround 14 | , rotateLine 15 | , rotateLineAround 16 | ) 17 | where 18 | 19 | import ChaosBox.AABB 20 | import ChaosBox.Draw 21 | import ChaosBox.Geometry.Angle 22 | import ChaosBox.Geometry.Class 23 | import ChaosBox.Geometry.P2 24 | import ChaosBox.Geometry.Path 25 | import ChaosBox.Geometry.Transform 26 | import ChaosBox.Math (average) 27 | import Control.Lens ((^.)) 28 | import Data.List.NonEmpty 29 | import Data.Maybe (maybeToList) 30 | import Linear.V2 (V2 (..)) 31 | import Linear.Vector ((*^)) 32 | 33 | data LineOf a = LineOf { lineOfStart :: a, lineOfEnd :: a} 34 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 35 | 36 | type Line = LineOf P2 37 | 38 | pattern Line :: P2 -> P2 -> Line 39 | pattern Line { lineStart, lineEnd } = LineOf lineStart lineEnd 40 | {-# COMPLETE Line #-} 41 | 42 | instance HasP2 a => HasAABB (LineOf a) where 43 | aabb LineOf {..} = boundary $ lineOfStart :| [lineOfEnd] 44 | 45 | instance HasP2 a => Draw (LineOf a) where 46 | draw LineOf {..} = draw $ PathOf (lineOfStart :| [lineOfEnd]) 47 | 48 | instance (HasP2 a, HasP2 b) => Intersects (LineOf a) (LineOf b) where 49 | intersectionPoints a b = maybeToList $ segmentIntersectionPoint a b 50 | 51 | segmentIntersectionPoint :: (HasP2 a, HasP2 b) => LineOf a -> LineOf b -> Maybe P2 52 | segmentIntersectionPoint (fmap getP2 -> LineOf { lineOfStart = p, lineOfEnd = pr }) (fmap getP2 -> LineOf { lineOfStart = q, lineOfEnd = qs }) 53 | | r `cross2` s == 0 && (q - p) `cross2` r == 0 54 | = Nothing 55 | | -- Collinear; don't worry about the rest of this case. 56 | r `cross2` s == 0 && (q - p) `cross2` r /= 0 57 | = Nothing 58 | | -- Parallel 59 | r `cross2` s /= 0 && t `inRange` (0, 1) && u `inRange` (0, 1) 60 | = Just $ q + (u *^ s) 61 | | otherwise 62 | = Nothing -- Not intersecting, but not parallel 63 | where 64 | r = pr - p 65 | s = qs - q 66 | t = (q - p) `cross2` s / (r `cross2` s) 67 | u = (q - p) `cross2` r / (r `cross2` s) 68 | inRange x (a, b) = x >= a && x <= b 69 | 70 | cross2 :: P2 -> P2 -> Double 71 | V2 vx vy `cross2` V2 wx wy = (vx * wy) - (vy * wx) 72 | 73 | translateLine :: HasP2 a => P2 -> LineOf a -> LineOf a 74 | translateLine = translatePoints 75 | 76 | scaleLine :: HasP2 a => P2 -> LineOf a -> LineOf a 77 | scaleLine = scalePoints 78 | 79 | scaleLineAround :: HasP2 a => P2 -> P2 -> LineOf a -> LineOf a 80 | scaleLineAround = scaleAroundPoints 81 | 82 | rotateLine :: HasP2 a => Angle -> LineOf a -> LineOf a 83 | rotateLine = rotatePoints 84 | 85 | rotateLineAround :: HasP2 a => P2 -> Angle -> LineOf a -> LineOf a 86 | rotateLineAround = rotateAroundPoints 87 | 88 | -- | The center of mass of a 'Line' 89 | lineCenter :: HasP2 a => LineOf a -> P2 90 | lineCenter = average . fmap (^._V2) 91 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Triangle.hs: -------------------------------------------------------------------------------- 1 | -- | Triangles 2 | module ChaosBox.Geometry.Triangle 3 | ( TriangleOf(..) 4 | , Triangle 5 | , pattern Triangle 6 | , triangleA 7 | , triangleB 8 | , triangleC 9 | , triangleCenter 10 | , translateTriangle 11 | , scaleTriangle 12 | , scaleTriangleAround 13 | , rotateTriangle 14 | , rotateTriangleAround 15 | ) 16 | where 17 | 18 | import ChaosBox.Prelude 19 | 20 | import ChaosBox.Math (average) 21 | import ChaosBox.AABB 22 | import ChaosBox.Draw 23 | import ChaosBox.Geometry.Angle 24 | import ChaosBox.Geometry.Class 25 | import ChaosBox.Geometry.P2 26 | import ChaosBox.Geometry.Polygon 27 | import ChaosBox.Geometry.Transform 28 | import Control.Lens ((^.)) 29 | import Data.Function (on) 30 | import Data.List (sortBy) 31 | import Data.List.NonEmpty (NonEmpty (..)) 32 | 33 | data TriangleOf a = TriangleOf 34 | { triangleOfA :: a 35 | , triangleOfB :: a 36 | , triangleOfC :: a 37 | } 38 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 39 | 40 | instance HasP2 a => HasAABB (TriangleOf a) where 41 | aabb = aabb . toPolygon 42 | 43 | instance HasP2 a => Draw (TriangleOf a) where 44 | draw = draw . toPolygon 45 | 46 | type Triangle = TriangleOf P2 47 | 48 | pattern Triangle :: P2 -> P2 -> P2 -> Triangle 49 | pattern Triangle {triangleA, triangleB, triangleC} = TriangleOf triangleA triangleB triangleC 50 | {-# COMPLETE Triangle #-} 51 | 52 | -- TODO: This should exist in a typeclass IsPolygon or triangleToPolygon etc 53 | -- etc 54 | toPolygon :: TriangleOf a -> PolygonOf a 55 | toPolygon TriangleOf {..} = PolygonOf $ triangleOfA :| [triangleOfB, triangleOfC] 56 | 57 | instance HasP2 a => Boundary (TriangleOf a) where 58 | containsPoint t p = b1 == b2 && b2 == b3 59 | where 60 | [t1, t2, t3] = sortOnPolarAngle $ map (^. _V2) $ triangleList t 61 | sign p1 p2 p3 = 62 | (p1 ^. _x - p3 ^. _x) 63 | * (p2 ^. _y - p3 ^. _y) 64 | - (p2 ^. _x - p3 ^. _x) 65 | * (p1 ^. _y - p3 ^. _y) 66 | b1 = sign p t1 t2 < 0 67 | b2 = sign p t2 t3 < 0 68 | b3 = sign p t3 t1 < 0 69 | 70 | triangleList :: TriangleOf a -> [a] 71 | triangleList TriangleOf {..} = [triangleOfA, triangleOfB, triangleOfC] 72 | 73 | sortOnPolarAngle :: (Fractional a, Ord a) => [V2 a] -> [V2 a] 74 | sortOnPolarAngle [] = [] 75 | sortOnPolarAngle [x ] = [x] 76 | sortOnPolarAngle (x : xs) = x : sortBy (compare `on` polarAngle x) xs 77 | where polarAngle a b = negate $ (b ^. _x - a ^. _x) / (b ^. _y - a ^. _y) 78 | 79 | translateTriangle :: HasP2 a => P2 -> TriangleOf a -> TriangleOf a 80 | translateTriangle = translatePoints 81 | 82 | scaleTriangle :: HasP2 a => P2 -> TriangleOf a -> TriangleOf a 83 | scaleTriangle = scalePoints 84 | 85 | scaleTriangleAround :: HasP2 a => P2 -> P2 -> TriangleOf a -> TriangleOf a 86 | scaleTriangleAround = scaleAroundPoints 87 | 88 | rotateTriangle :: HasP2 a => Angle -> TriangleOf a -> TriangleOf a 89 | rotateTriangle = rotatePoints 90 | 91 | rotateTriangleAround :: HasP2 a => P2 -> Angle -> TriangleOf a -> TriangleOf a 92 | rotateTriangleAround = rotateAroundPoints 93 | 94 | -- | The center of mass of a 'Triangle' 95 | triangleCenter :: HasP2 a => TriangleOf a -> P2 96 | triangleCenter = average . fmap (^._V2) 97 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Arc.hs: -------------------------------------------------------------------------------- 1 | -- | Arcs (partial circles) 2 | module ChaosBox.Geometry.Arc 3 | ( ArcOf(..) 4 | , Arc 5 | , pattern Arc 6 | , arc 7 | , arcOf 8 | , arcPoints 9 | , arcCenter 10 | , arcRadius 11 | , arcStart 12 | , arcEnd 13 | , arcDetail 14 | , translateArc 15 | , scaleArc 16 | , scaleArcAround 17 | , rotateArc 18 | , rotateArcAround 19 | ) 20 | where 21 | 22 | import ChaosBox.Prelude hiding (unit) 23 | 24 | import ChaosBox.AABB 25 | import ChaosBox.Draw 26 | import ChaosBox.Geometry.Angle 27 | import ChaosBox.Geometry.Class 28 | import ChaosBox.Geometry.P2 29 | import ChaosBox.Math (lerpMany) 30 | import Control.Lens ((&), (.~), (^.)) 31 | import Data.List.NonEmpty (NonEmpty (..)) 32 | import qualified GI.Cairo.Render as Cairo 33 | 34 | -- | Arc (partial Circle) 35 | data ArcOf a = ArcOf 36 | { arcOfCenter :: a 37 | -- ^ Center of the arc's circle 38 | , arcOfRadius :: Double 39 | -- ^ Radius of the arc's circle 40 | , arcOfStart :: Angle 41 | -- ^ Start 'Angle' 42 | , arcOfEnd :: Angle 43 | -- ^ End 'Angle' 44 | , arcOfDetail :: Int 45 | -- ^ Detail in number of points 46 | } 47 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 48 | 49 | type Arc = ArcOf P2 50 | 51 | pattern Arc :: P2 -> Double -> Angle -> Angle -> Int -> Arc 52 | pattern Arc {arcCenter,arcRadius,arcStart,arcEnd,arcDetail} = ArcOf arcCenter arcRadius arcStart arcEnd arcDetail 53 | {-# COMPLETE Arc #-} 54 | 55 | instance HasP2 a => Draw (ArcOf a) where 56 | draw ArcOf {..} = Cairo.arc x 57 | y 58 | arcOfRadius 59 | (getAngle arcOfStart) 60 | (getAngle arcOfEnd) 61 | where V2 x y = arcOfCenter ^. _V2 62 | 63 | instance HasP2 a => HasAABB (ArcOf a) where 64 | aabb ArcOf {..} = boundary $ p1 :| [p2] 65 | where 66 | c = arcOfCenter ^. _V2 67 | p1 = c + unit arcOfStart ^* arcOfRadius 68 | p2 = c + unit arcOfEnd ^* arcOfRadius 69 | 70 | -- | An 'Arc' with default detail (200) 71 | arcOf :: a -> Double -> Angle -> Angle -> ArcOf a 72 | arcOf c r s e = ArcOf c r s e 200 73 | 74 | -- | An 'Arc' with default detail (200) 75 | arc :: P2 -> Double -> Angle -> Angle -> Arc 76 | arc = arcOf @P2 77 | 78 | arcPoints :: HasP2 a => ArcOf a -> [a] 79 | arcPoints ArcOf {..} = points 80 | where 81 | angles = lerpMany arcOfDetail arcOfStart arcOfEnd 82 | points = flip map angles $ \theta -> 83 | arcOfCenter & _V2 .~ (arcOfCenter ^. _V2 + (unit theta ^* arcOfRadius)) 84 | 85 | translateArc :: P2 -> Arc -> Arc 86 | translateArc p2 = fmap (translateP2 p2) 87 | 88 | scaleArc :: P2 -> Arc -> Arc 89 | scaleArc amount = fmap (scaleP2 amount) 90 | 91 | scaleArcAround :: P2 -> P2 -> Arc -> Arc 92 | scaleArcAround center amount = fmap (scaleP2Around center amount) 93 | 94 | rotateArc :: Angle -> Arc -> Arc 95 | rotateArc theta a = newArc { arcStart = newStart, arcEnd = newEnd } 96 | where 97 | newArc = fmap (rotateP2 theta) a 98 | newStart = addRadians (getAngle theta) (arcStart a) 99 | newEnd = addRadians (getAngle theta) (arcEnd a) 100 | 101 | rotateArcAround :: P2 -> Angle -> Arc -> Arc 102 | rotateArcAround center theta a = translateArc center (rotateArc theta (translateArc (-center) a)) 103 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Circle.hs: -------------------------------------------------------------------------------- 1 | -- | Circles 2 | module ChaosBox.Geometry.Circle 3 | ( CircleOf(..) 4 | , Circle 5 | , pattern Circle 6 | , circleCenter 7 | , circleRadius 8 | , circleDetail 9 | , circle 10 | , circleOf 11 | , point 12 | , circlePoints 13 | , pointsOnCircle 14 | , circleToPolygon 15 | , translateCircle 16 | , scaleCircle 17 | , scaleCircleAround 18 | , rotateCircle 19 | , rotateCircleAround 20 | ) 21 | where 22 | 23 | import ChaosBox.Prelude hiding (point) 24 | 25 | import ChaosBox.AABB 26 | import ChaosBox.Draw 27 | import ChaosBox.Geometry.Angle 28 | import ChaosBox.Geometry.Class 29 | import ChaosBox.Geometry.P2 30 | import ChaosBox.Geometry.Polygon 31 | import ChaosBox.Geometry.Transform 32 | import Control.Lens ((&), (.~), (^.)) 33 | import Data.List.NonEmpty (NonEmpty (..)) 34 | import GI.Cairo.Render hiding (transform) 35 | 36 | -- | A circle with radius 'circleOfRadius' centered at 'circleOfCenter' 37 | data CircleOf a = CircleOf { circleOfCenter :: a, circleOfRadius :: Double, circleOfDetail :: Int } 38 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 39 | 40 | type Circle = CircleOf P2 41 | 42 | pattern Circle :: P2 -> Double -> Int -> Circle 43 | pattern Circle {circleCenter, circleRadius, circleDetail} = CircleOf circleCenter circleRadius circleDetail 44 | {-# COMPLETE Circle #-} 45 | 46 | instance HasP2 a => HasAABB (CircleOf a) where 47 | aabb CircleOf {..} = boundary $ tl :| [br] 48 | where 49 | c = circleOfCenter ^. _V2 50 | tl = c - (circleOfRadius *^ 1) 51 | br = c + (circleOfRadius *^ 1) 52 | 53 | instance HasP2 a => Draw (CircleOf a) where 54 | draw CircleOf {..} = do 55 | let V2 x y = circleOfCenter ^. _V2 56 | moveTo (x + circleOfRadius) y 57 | arc x y circleOfRadius 0 (2 * pi) 58 | 59 | -- | A 'Circle' with default detail (200) 60 | circleOf :: a -> Double -> CircleOf a 61 | circleOf v r = CircleOf v r 200 62 | 63 | circle :: P2 -> Double -> Circle 64 | circle = circleOf @P2 65 | 66 | -- | A circle with diameter 1 67 | point :: a -> CircleOf a 68 | point center = CircleOf center 0.5 200 69 | 70 | circleToPolygon :: HasP2 a => CircleOf a -> Maybe (PolygonOf a) 71 | circleToPolygon = polygonOf . circlePoints 72 | 73 | circlePoints :: HasP2 a => CircleOf a -> [a] 74 | circlePoints CircleOf {..} = tail $ flip map points $ \v -> 75 | circleOfCenter & _V2 .~ v 76 | where 77 | step = 2 * pi / fromIntegral circleOfDetail 78 | intervals = [0, step .. (2 * pi)] 79 | points = map ((+ circleOfCenter ^. _V2) . (^* circleOfRadius) . angle) intervals 80 | 81 | pointsOnCircle :: HasP2 a => Int -> CircleOf a -> [a] 82 | n `pointsOnCircle` c = circlePoints $ c { circleOfDetail = n } 83 | 84 | translateCircle :: HasP2 a => P2 -> CircleOf a -> CircleOf a 85 | translateCircle = translatePoints 86 | 87 | scaleCircle :: HasP2 a => Double -> CircleOf a -> CircleOf a 88 | scaleCircle amount c = c { circleOfRadius = circleOfRadius c * amount } 89 | 90 | scaleCircleAround :: HasP2 a => P2 -> Double -> CircleOf a -> CircleOf a 91 | scaleCircleAround center amount c = scaleCircle amount (scaleAroundPoints center (P2 amount amount) c) 92 | 93 | rotateCircle :: HasP2 a => Angle -> CircleOf a -> CircleOf a 94 | rotateCircle = rotatePoints 95 | 96 | rotateCircleAround :: HasP2 a => P2 -> Angle -> CircleOf a -> CircleOf a 97 | rotateCircleAround = rotateAroundPoints 98 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/Ellipse.hs: -------------------------------------------------------------------------------- 1 | -- | Axis-aligned ellipses 2 | module ChaosBox.Geometry.Ellipse 3 | ( EllipseOf(..) 4 | , Ellipse 5 | , pattern Ellipse 6 | , ellipseCenter 7 | , ellipseWidth 8 | , ellipseHeight 9 | , ellipseDetail 10 | , ellipse 11 | , ellipseOf 12 | , ellipsePoints 13 | , scaleEllipseAround 14 | , scaleEllipse 15 | , translateEllipse 16 | ) 17 | where 18 | 19 | import ChaosBox.Prelude hiding (scaled) 20 | 21 | import ChaosBox.AABB 22 | import ChaosBox.Draw 23 | import ChaosBox.Geometry.Circle 24 | import ChaosBox.Geometry.Class 25 | import ChaosBox.Geometry.P2 26 | import ChaosBox.Geometry.Polygon 27 | import ChaosBox.Geometry.Transform 28 | import ChaosBox.Math (lerpMany) 29 | import qualified ChaosBox.Math.Matrix as Matrix 30 | import Control.Lens (set, (&), (^.)) 31 | import Data.Foldable (for_) 32 | import Data.List.NonEmpty (NonEmpty (..)) 33 | 34 | -- | Axis-bound ellipse 35 | data EllipseOf a = EllipseOf 36 | { ellipseOfCenter :: a 37 | , ellipseOfWidth :: Double 38 | , ellipseOfHeight :: Double 39 | , ellipseOfDetail :: Int 40 | } 41 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 42 | 43 | type Ellipse = EllipseOf P2 44 | 45 | pattern Ellipse :: P2 -> Double -> Double -> Int -> Ellipse 46 | pattern Ellipse {ellipseCenter, ellipseWidth, ellipseHeight, ellipseDetail } 47 | = EllipseOf ellipseCenter ellipseWidth ellipseHeight ellipseDetail 48 | {-# COMPLETE Ellipse #-} 49 | 50 | instance HasP2 a => HasAABB (EllipseOf a) where 51 | aabb EllipseOf {..} = boundary $ tl :| [ br] 52 | where 53 | c = ellipseOfCenter ^. _V2 54 | tl = c - V2 ellipseOfWidth ellipseOfHeight 55 | br = c + V2 ellipseOfWidth ellipseOfHeight 56 | 57 | -- | An ellipse with default detail (200) and no rotation 58 | ellipseOf :: a -> Double -> Double -> EllipseOf a 59 | ellipseOf c w h = EllipseOf c w h 200 60 | 61 | -- | An ellipse with default detail (200) and no rotation 62 | ellipse :: P2 -> Double -> Double -> Ellipse 63 | ellipse c w h = EllipseOf c w h 200 64 | 65 | instance HasP2 a => Draw (EllipseOf a) where 66 | draw e = for_ (ellipseToPolygon e) draw 67 | 68 | -- | Sample 'N' evenly spaced points along the ellipse's path 69 | ellipsePoints :: HasP2 a => EllipseOf a -> [a] 70 | ellipsePoints EllipseOf {..} = 71 | map ((\p -> ellipseOfCenter & set _V2 p) . ellipsePoint) 72 | $ lerpMany ellipseOfDetail 0 (2 * pi) 73 | where 74 | V2 x y = ellipseOfCenter ^. _V2 75 | mat = Matrix.scalar (V2 ellipseOfWidth ellipseOfHeight) 76 | * Matrix.translation (ellipseOfCenter ^. _V2) 77 | ellipsePoint t = Matrix.applyMatrix mat $ V2 (x + cos t) (y + sin t) 78 | 79 | ellipseToPolygon :: forall a. HasP2 a => EllipseOf a -> Maybe (PolygonOf a) 80 | ellipseToPolygon EllipseOf {..} 81 | = scalePolygonAround (ellipseOfCenter^._V2) (P2 ellipseOfWidth ellipseOfHeight) <$> mPolygon 82 | where 83 | mPolygon :: Maybe (PolygonOf a) 84 | mPolygon = circleToPolygon 85 | $ CircleOf ellipseOfCenter 1 ellipseOfDetail 86 | 87 | translateEllipse :: HasP2 a => P2 -> EllipseOf a -> EllipseOf a 88 | translateEllipse = translatePoints 89 | 90 | scaleEllipse :: HasP2 a => P2 -> EllipseOf a -> EllipseOf a 91 | scaleEllipse (V2 x y) e = e { ellipseOfWidth = ellipseOfWidth e * x, ellipseOfHeight = ellipseOfHeight e * y } 92 | 93 | scaleEllipseAround :: HasP2 a => P2 -> P2 -> EllipseOf a -> EllipseOf a 94 | scaleEllipseAround center amount e = scaleEllipse amount (scaleAroundPoints center amount e) 95 | -------------------------------------------------------------------------------- /src/ChaosBox/PNG.hs: -------------------------------------------------------------------------------- 1 | -- | PNG image parsing 2 | -- 3 | -- Currently, this only supports 24 bit ARGB PNGs with transparency. 4 | -- 5 | module ChaosBox.PNG 6 | ( 7 | -- * Data Typs 8 | PixelArray(..) 9 | , Pixel(..) 10 | -- * Parse @PNG@ files 11 | , parsePixelsFromFile 12 | -- * Read portions of @PixelArray@s 13 | , readPixelAt 14 | , readColumn 15 | , readRow 16 | ) 17 | where 18 | 19 | import ChaosBox.Color ( rgb255 ) 20 | 21 | import Data.Array.MArray ( readArray ) 22 | import Data.Bits 23 | import Data.Colour.RGBSpace 24 | import Data.Maybe ( fromMaybe ) 25 | import Data.Sequence ( Seq ) 26 | import qualified Data.Sequence as Seq 27 | import Data.Traversable 28 | import Data.Word 29 | import GI.Cairo.Render hiding ( Path ) 30 | import Linear.V2 31 | 32 | -- | A single 'RGB' pixel 33 | newtype Pixel = Pixel { getPixel :: RGB Double } 34 | deriving (Show, Eq) 35 | 36 | -- | A 2d array of 'Pixel's 37 | newtype PixelArray = PixelArray{ getPixelArray :: Seq (Seq Pixel) } 38 | deriving (Show, Eq) 39 | 40 | -- | Read the pixel at the provided coordinate. 41 | readPixelAt :: V2 Int -> PixelArray -> Pixel 42 | readPixelAt (V2 x y) pixelArray = 43 | fromMaybe (error $ "Column " <> show y <> " out of bounds") 44 | $ readColumn x pixelArray 45 | Seq.!? y 46 | 47 | -- | Read one column of a 'PixelArray' 48 | readColumn :: Int -> PixelArray -> Seq Pixel 49 | readColumn y PixelArray {..} = 50 | fromMaybe (error $ "Column " <> show y <> " out of bounds") 51 | $ getPixelArray 52 | Seq.!? y 53 | 54 | -- | Read one row of a 'PixelArray' 55 | readRow :: Int -> PixelArray -> Seq Pixel 56 | readRow x PixelArray {..} = 57 | fromMaybe (error $ "Row " <> show x <> " out of bounds") 58 | $ traverse (Seq.!? x) getPixelArray 59 | 60 | -- | Parse pixels from a png file with transparency into a 2d array 61 | -- 62 | -- @ 63 | -- pixels <- parsePixelsFromFile "image.png" 64 | -- let 65 | -- firstColumn = pixels ! 0 -- Leftmost column of image. 66 | -- firstRow = fmap (! 0) pixels -- Top row of image. 67 | -- pixel = pixels ! 5 ! 0 -- Pixel at (0,5) 68 | -- @ 69 | -- 70 | parsePixelsFromFile :: FilePath -> IO PixelArray 71 | parsePixelsFromFile filePath = PixelArray <$> do 72 | surface <- imageSurfaceCreateFromPNG filePath 73 | stride <- imageSurfaceGetStride surface 74 | pixels <- imageSurfaceGetPixels @Word32 surface 75 | 76 | width <- imageSurfaceGetWidth surface 77 | height <- imageSurfaceGetHeight surface 78 | 79 | let xs = Seq.fromList [0, 1 .. width - 1] 80 | ys = Seq.fromList [0, 1 .. height - 1] 81 | 82 | for xs 83 | $ \x -> for ys $ \y -> Pixel . lowerRGB <$> pixelAt (V2 x y) stride pixels 84 | 85 | pixelIndex :: V2 Int -> Int -> Int 86 | pixelIndex (V2 x y) stride = y * (stride `div` 4) + x 87 | 88 | pixelAt :: V2 Int -> Int -> SurfaceData Int Word32 -> IO (RGBA Int) 89 | pixelAt v stride surfaceData = do 90 | word <- readArray surfaceData (pixelIndex v stride) 91 | pure $ toRGBA word 92 | 93 | data RGBA a = RGBA a a a a 94 | deriving (Show, Eq) 95 | 96 | toRGBA :: Word32 -> RGBA Int 97 | toRGBA word = RGBA (c red) (c green) (c blue) (c alpha) 98 | where 99 | alpha = (0xFF000000 .&. word) `shiftR` (8 * 3) 100 | red = (0x00FF0000 .&. word) `shiftR` (8 * 2) 101 | green = (0x0000FF00 .&. word) `shiftR` 8 102 | blue = 0x000000FF .&. word 103 | 104 | c = fromIntegral . toInteger 105 | 106 | lowerRGB :: RGBA Int -> RGB Double 107 | lowerRGB (RGBA r g b _) = 108 | rgb255 (fromIntegral r) (fromIntegral g) (fromIntegral b) 109 | -------------------------------------------------------------------------------- /src/ChaosBox/Color.hs: -------------------------------------------------------------------------------- 1 | module ChaosBox.Color 2 | ( 3 | -- * HSV Values (Hue-Saturation-Value) 4 | HSV(..) 5 | , WithAlpha(..) 6 | , setSourceHSV 7 | , setSourceHSVA 8 | 9 | -- * RGB Values (Red-Green-Blue) 10 | , rgbFromHex 11 | , setSourceRGB 12 | , rgb255 13 | , grayscale 14 | , black 15 | , white 16 | 17 | -- * Conversion functions 18 | , toHSV 19 | , toRGB 20 | 21 | -- * Context-sensitive actions 22 | , fillScreenHSV 23 | , fillScreenRGB 24 | , module X 25 | ) 26 | where 27 | 28 | import ChaosBox.Generate 29 | 30 | import Data.Colour.RGBSpace as X 31 | import Data.Colour.RGBSpace.HSV 32 | import Data.Colour.SRGB 33 | import GI.Cairo.Render hiding ( setSourceRGB ) 34 | import qualified GI.Cairo.Render as Cairo 35 | 36 | -- | Hue-saturation-value color space 37 | data HSV = HSV 38 | { hsvHue :: Double 39 | -- ^ Between 0 and 1 40 | , hsvSaturation :: Double 41 | -- ^ Between 0 and 1 42 | , hsvValue :: Double 43 | -- ^ Between 0 and 1 44 | } deriving (Show, Read, Eq, Ord) 45 | 46 | -- | A color with transparency 47 | data WithAlpha color = WithAlpha 48 | { waColor :: color 49 | , waAlpha :: Double 50 | -- ^ Between 0 and 1 51 | } deriving (Show, Read, Eq, Ord) 52 | 53 | -- | Set the current source to an 'HSV' color 54 | setSourceHSV :: HSV -> Render () 55 | setSourceHSV = setSourceRGB . toRGB 56 | 57 | -- | Set the current source to an 'HSVA' color 58 | setSourceHSVA :: WithAlpha HSV -> Render () 59 | setSourceHSVA (WithAlpha color alpha) = setSourceRGBA r g b alpha 60 | where RGB r g b = toRGB color 61 | 62 | -- | Parse an RGB value from hexadecimal form 63 | -- 64 | -- prop> rgbFromHex "ffffff" = RGB 1 1 1 65 | -- 66 | rgbFromHex :: String -> RGB Double 67 | rgbFromHex = toSRGB . sRGB24read 68 | 69 | -- | Set the current source to an RGB color 70 | setSourceRGB :: RGB Double -> Render () 71 | setSourceRGB (RGB r g b) = Cairo.setSourceRGB r g b 72 | 73 | -- | Construct an 'RGB' value from components in the range (0,255) 74 | rgb255 :: Fractional a => a -> a -> a -> RGB a 75 | rgb255 r g b = RGB (r / 255) (g / 255) (b / 255) 76 | 77 | -- | Convert an 'RGB' value to 'HSV' 78 | toHSV :: RGB Double -> HSV 79 | toHSV rgb = let (h, s, v) = hsvView rgb in HSV h s v 80 | 81 | -- | Grayscale with some value between 0 and 1 82 | -- 83 | -- prop> grayscale 0 = black 84 | -- prop> grayscale 1 = white 85 | -- 86 | grayscale :: Num a => a -> RGB a 87 | grayscale v = RGB v v v 88 | 89 | black :: Num a => RGB a 90 | black = grayscale 0 91 | 92 | white :: Num a => RGB a 93 | white = grayscale 1 94 | 95 | -- | Convert an 'HSV' value to 'RGB' 96 | toRGB :: HSV -> RGB Double 97 | toRGB HSV {..} = hsv2rgb hsvHue hsvSaturation hsvValue 98 | 99 | hsv2rgb :: RealFrac a => a -> a -> a -> RGB a 100 | hsv2rgb h s v = case i `mod` 6 of 101 | 0 -> RGB v t p 102 | 1 -> RGB q v p 103 | 2 -> RGB p v t 104 | 3 -> RGB p q v 105 | 4 -> RGB t p v 106 | 5 -> RGB v p q 107 | _ -> error "mod 6 returned something out of range" 108 | where 109 | i :: Int 110 | i = floor $ h * 6 111 | f = h * 6 - fromIntegral i 112 | p = v * (1 - s) 113 | q = v * (1 - f * s) 114 | t = v * (1 - (1 - f) * s) 115 | 116 | -- | Fill the whole window with an 'HSV' color 117 | fillScreenHSV :: HSV -> Generate () 118 | fillScreenHSV color = do 119 | (w, h) <- getSize 120 | cairo $ do 121 | rectangle 0 0 w h 122 | setSourceHSV color *> fill 123 | 124 | -- | Fill the whole window with an 'RGB' color with components between 0 and 1 125 | fillScreenRGB :: RGB Double -> Generate () 126 | fillScreenRGB color = do 127 | (w, h) <- getSize 128 | cairo $ do 129 | rectangle 0 0 w h 130 | setSourceRGB color *> fill 131 | -------------------------------------------------------------------------------- /src/ChaosBox/Geometry/ClosedCurve.hs: -------------------------------------------------------------------------------- 1 | -- | Closed cubic b-splines 2 | module ChaosBox.Geometry.ClosedCurve 3 | ( ClosedCurveOf(..) 4 | , ClosedCurve 5 | , pattern ClosedCurve 6 | , getClosedCurve 7 | , closedCurveIterations 8 | , closedCurve 9 | , closedCurveOf 10 | , closedCurveCenter 11 | , drawWithDetail 12 | , fromPolygon 13 | , toPolygon 14 | , translateClosedCurve 15 | , scaleClosedCurve 16 | , scaleClosedCurveAround 17 | , rotateClosedCurve 18 | , rotateClosedCurveAround 19 | ) 20 | where 21 | 22 | import ChaosBox.Math (average) 23 | import ChaosBox.AABB 24 | import ChaosBox.Draw 25 | import ChaosBox.Geometry.Angle 26 | import ChaosBox.Geometry.Class 27 | import ChaosBox.Geometry.P2 28 | import ChaosBox.Geometry.Polygon 29 | import ChaosBox.Geometry.Transform 30 | import Control.Lens 31 | import Data.Foldable 32 | import Data.List.NonEmpty (NonEmpty) 33 | import qualified Data.List.NonEmpty as NE 34 | import GI.Cairo.Render (Render) 35 | 36 | -- | Closed Cubic B-Spline 37 | data ClosedCurveOf a = ClosedCurveOf { getClosedCurveOf :: NonEmpty a, closedCurveOfIterations :: Int } 38 | deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) 39 | 40 | type ClosedCurve = ClosedCurveOf P2 41 | 42 | pattern ClosedCurve :: NonEmpty P2 -> Int -> ClosedCurve 43 | pattern ClosedCurve {getClosedCurve, closedCurveIterations} = ClosedCurveOf getClosedCurve closedCurveIterations 44 | {-# COMPLETE ClosedCurve #-} 45 | 46 | closedCurveOf :: [a] -> Maybe (ClosedCurveOf a) 47 | closedCurveOf xs = ClosedCurveOf <$> NE.nonEmpty xs <*> pure 5 48 | 49 | closedCurve :: [P2] -> Maybe ClosedCurve 50 | closedCurve = closedCurveOf @P2 51 | 52 | instance HasP2 a => HasAABB (ClosedCurveOf a) where 53 | aabb = boundary .getClosedCurveOf 54 | 55 | instance HasP2 a => Draw (ClosedCurveOf a) where 56 | draw = drawWithDetail 57 | 58 | -- | Draw with a specified level of detail (default 5; smaller is less detailed) 59 | drawWithDetail :: HasP2 a => ClosedCurveOf a -> Render () 60 | drawWithDetail c = for_ (toPolygon c) draw 61 | 62 | toPolygon :: HasP2 a => ClosedCurveOf a -> Maybe (PolygonOf a) 63 | toPolygon (ClosedCurveOf ps detail) 64 | = fmap PolygonOf 65 | . NE.nonEmpty 66 | $ newPath 67 | where 68 | newPath = iterateNLast 69 | detail 70 | (go . expand) 71 | (NE.last ps : (NE.toList ps <> NE.take 2 (NE.cycle ps))) 72 | 73 | expand1 prev a = [prev & _V2 .~ (prev ^. _V2 + a ^. _V2) / 2, a] 74 | 75 | expand ys@(y : _) = y : concat (zipWith expand1 ys (tail ys)) 76 | expand [] = error "impossible" 77 | 78 | mask a b c = b & _V2 .~ ((a ^. _V2 + 2 * b ^. _V2 + c ^. _V2) / 4) 79 | 80 | go (a : b : c : xs) = mask a b c : go (b : c : xs) 81 | go _ = [] 82 | 83 | fromPolygon :: PolygonOf a -> ClosedCurveOf a 84 | fromPolygon (PolygonOf p) = ClosedCurveOf p 5 85 | 86 | -- TODO: Consolidate 87 | iterateNLast :: Int -> (a -> a) -> a -> a 88 | iterateNLast n f x = last . take n $ iterate f x 89 | 90 | translateClosedCurve :: HasP2 a => P2 -> ClosedCurveOf a -> ClosedCurveOf a 91 | translateClosedCurve = translatePoints 92 | 93 | scaleClosedCurve :: HasP2 a => P2 -> ClosedCurveOf a -> ClosedCurveOf a 94 | scaleClosedCurve = scalePoints 95 | 96 | scaleClosedCurveAround :: HasP2 a => P2 -> P2 -> ClosedCurveOf a -> ClosedCurveOf a 97 | scaleClosedCurveAround = scaleAroundPoints 98 | 99 | rotateClosedCurve :: HasP2 a => Angle -> ClosedCurveOf a -> ClosedCurveOf a 100 | rotateClosedCurve = rotatePoints 101 | 102 | rotateClosedCurveAround :: HasP2 a => P2 -> Angle -> ClosedCurveOf a -> ClosedCurveOf a 103 | rotateClosedCurveAround = rotateAroundPoints 104 | 105 | -- | The center of mass of a 'ClosedCurve' 106 | closedCurveCenter :: HasP2 a => ClosedCurveOf a -> P2 107 | closedCurveCenter = average . fmap (^._V2) 108 | -------------------------------------------------------------------------------- /src/ChaosBox.hs: -------------------------------------------------------------------------------- 1 | -- | The Main "ChaosBox" module 2 | -- 3 | -- "ChaosBox" is a generative art framework. It ties together many well-known 4 | -- and powerful tools and builds on them to provide an intuitive, extensible 5 | -- experience developing artwork powered by algorithms and procedural 6 | -- generation, interactively. 7 | -- 8 | -- Let's take a look at an example program. First, a description of the program: 9 | -- 10 | -- A white curve grows from the center of a black canvas. A new control point 11 | -- is generated in every frame. The curve is limited to 100 control points; 12 | -- once that limit is exceeded, the curve drops points from the end. 13 | -- 14 | -- The amount the curve grows is determined by a backing simplex noise field. 15 | -- It will grow more quickly in some spots than others. 16 | -- 17 | -- The user can interact with the program by clicking and holding the mouse. 18 | -- While the mouse is held, the front of the curve slowly interpolates to the 19 | -- cursor's location. 20 | -- 21 | -- There's quite a bit going on. Here's the code: 22 | -- 23 | -- @ 24 | -- import ChaosBox 25 | -- 26 | -- import Data.List.NonEmpty (NonEmpty (..)) 27 | -- import qualified Data.List.NonEmpty as NE 28 | -- 29 | -- main :: IO () 30 | -- main = 'runChaosBoxWith' (\o -> o { 'optWidth' = 10, 'optHeight' = 10, 'optScale' = 60 }) 'renderSketch' 31 | -- 32 | -- renderSketch :: Generate () 33 | -- renderSketch = do 34 | -- 'cairo' setup 35 | -- 36 | -- (w, h) <- 'getSize' 37 | -- center <- 'getCenterPoint' 38 | -- 39 | -- startingPoint <- 'normal' center \$ 'P2' (w \/ 4) (h \/ 4) 40 | -- pathRef <- 'newIORef' \$ startingPoint :| [] 41 | -- noise <- 'newNoise2' 42 | -- 43 | -- mousePositionRef <- 'heldMousePosition' 'ButtonLeft' 44 | -- 45 | -- 'eventLoop' $ do 46 | -- nextPath \<- 'modifyIORefM' pathRef \$ \ps@(p :| _) -\> do 47 | -- c <- 'forIORef' mousePositionRef \$ maybe p ('lerp' 0.05 p) 48 | -- let deviation = 0.3 * noise (c / 100) 49 | -- nextPoint <- 'normal' c $ 'P2' deviation deviation 50 | -- pure $ unsafeTake 100 $ nextPoint \`NE.cons\` ps 51 | -- 52 | -- 'fillScreenRGB' 'black' 53 | -- 'cairo' $ do 54 | -- 'setSourceRGB' 'white' 55 | -- 'draw' ('ClosedCurve' nextPath 2) *> 'stroke' 56 | -- 57 | -- -- setup :: 'Render' () 58 | -- -- setup = 'setLineWidth' 0.02 59 | -- 60 | -- -- | An unsafe version of 'Data.List.NonEmpty.take' 61 | -- -- 62 | -- unsafeTake :: Int -> NonEmpty a -> NonEmpty a 63 | -- unsafeTake n = NE.fromList . NE.take n 64 | -- @ 65 | -- 66 | -- This example has been annotated with links in order to make exploring its 67 | -- functionality easy. This short example covers myriad concepts in "ChaosBox". 68 | -- Notably: 69 | -- 70 | -- - All drawing is done through @libcairo@ via 'cairo'. 71 | -- - We can query the world ('getSize' and 'getCenterPoint') 72 | -- - "ChaosBox" supports non-uniform random sampling ('normal') 73 | -- - "ChaosBox" handles variable mutation using 'IORef's and provides helpers 74 | -- around common operations ('modifyIORefM', 'forIORef') 75 | -- - Interactive "ChaosBox" programs run in an /Event Loop/. This gets called 76 | -- once per frame. 77 | -- - We can 'draw' various data types, including 'ClosedCurve's, to the canvas. 78 | -- (see "ChaosBox.Geometry" for more) 79 | -- - Some common event handling is abstracted away ('heldMousePosition') 80 | -- 81 | -- In addition to what is visible here, 'eventLoop' also provides a couple 82 | -- global keybindings: 83 | -- 84 | -- - Pressing 's' will save the current image at any time. 85 | -- - Pressing 'q' will immediately quit the window and save the image. 86 | -- 87 | -- More can be added at any time using facilities provided in 88 | -- "ChaosBox.Interactive". 89 | -- 90 | -- To get a feel for how "ChaosBox" works using this documentation, check out 91 | -- "ChaosBox.CLI", "ChaosBox.Generate", "ChaosBox.Interactive", 92 | -- "ChaosBox.Geometry" and "ChaosBox.Affine". 93 | -- 94 | -- Additionally, it is recommended to get up to speed with @libcairo@ and its 95 | -- haskell bindings. Since the actual drawing is done using @libcairo@, 96 | -- learning these bindings will allow you to customize your art much more 97 | -- easily by digging down a level below this high-level interface. 98 | -- 99 | -- Have fun! 100 | -- 101 | module ChaosBox 102 | ( module X 103 | -- * Re-exports 104 | , module Linear.V2 105 | , module UnliftIO.IORef 106 | , module Ext 107 | ) 108 | where 109 | 110 | import ChaosBox.AABB as X 111 | import ChaosBox.CLI as X 112 | import ChaosBox.Color as X 113 | import ChaosBox.Draw as X 114 | import ChaosBox.Generate as X 115 | import ChaosBox.Geometry as X 116 | import ChaosBox.Interactive as X 117 | import ChaosBox.Math as X 118 | import ChaosBox.Noise as X 119 | import ChaosBox.PNG as X 120 | import ChaosBox.Random as X 121 | import GI.Cairo.Render as Ext (LineCap (..), LineJoin (..), 122 | Render, fill, fillPreserve, 123 | setLineCap, setLineJoin, 124 | setLineWidth, stroke, 125 | strokePreserve) 126 | import Linear.V2 127 | import UnliftIO.IORef 128 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # chaosbox 2 | 3 | `chaosbox` is a generative art framework. It ties together many well-known 4 | and powerful tools and builds on them to provide an intuitive, extensible 5 | experience developing artwork powered by algorithms and procedural 6 | generation, interactively. 7 | 8 | ## Setup 9 | 10 | ### Prerequisites 11 | 12 | You'll need `cairo` and `sdl` version 2.0+ to run a `chaosbox` program. 13 | 14 | Follow the platform-specific instructions to get these installed: 15 | 16 | - [Install `cairo`](https://www.cairographics.org/download) 17 | - [Setup `sdl2` by LazyFoo](http://lazyfoo.net/tutorials/SDL/01_hello_SDL/index.php) 18 | 19 | ### Installing the library 20 | 21 | `chaosbox` uses `stack` as a build tool. This is pre-release software, so 22 | you'll need to point your `stack.yaml` to the right git commit in your 23 | project's root directory. Additionally you'll need a few extra-deps that don't 24 | exist in recent stackage snapshots: 25 | 26 | `stack.yaml` 27 | 28 | ```yaml 29 | extra-deps: 30 | - random-extras-0.19 31 | - gtk2hs-buildtools-0.13.5.4 32 | - gi-cairo-render-0.0.1@sha256:ff2ccc309c021c2c023fa0d380375ef36cff2df93e0c78ed733f052dd1aa9782,3502 33 | - github: 5outh/chaosbox 34 | commit: 93093054cfdf2af0f5d72546aada2c5d474b8c27 35 | ``` 36 | 37 | And add the dependency `chaosbox` to your `cabal` (or `package.yaml` if using hpack) file 38 | 39 | `package.yaml` 40 | 41 | ``` 42 | dependencies: 43 | - chaosbox 44 | ``` 45 | 46 | `project.cabal` 47 | 48 | ``` 49 | executable example-project 50 | -- ... 51 | build-depends: 52 | - chaosbox 53 | ``` 54 | 55 | Then `stack build` your project as normal. 56 | 57 | If you run into any issues with these setup instructions, [please file an 58 | issue](https://github.com/5outh/chaosbox/issues). 59 | 60 | ## Example `chaosbox` Program 61 | 62 | Let's take a look at an example program. First, a description of the program: 63 | 64 | > A white curve grows from the center of a black canvas. A new control point 65 | > is generated in every frame. The curve is limited to 100 control points; 66 | > once that limit is exceeded, the curve drops points from the end. 67 | > 68 | > The amount the curve grows is determined by a backing simplex noise field. 69 | > It will grow more quickly in some spots than others. 70 | > 71 | > The user can interact with the program by clicking and holding the mouse. 72 | > While the mouse is held, the front of the curve slowly interpolates to the 73 | > cursor's location. 74 | 75 | There's quite a bit going on. Here's the code: 76 | 77 | ```haskell 78 | module Main where 79 | 80 | import ChaosBox 81 | 82 | import Data.List.NonEmpty (NonEmpty (..)) 83 | import qualified Data.List.NonEmpty as NE 84 | 85 | -- Run this example with 86 | -- 87 | -- @ 88 | -- > chaosbox-example -- --scale=60 89 | -- @ 90 | -- 91 | main :: IO () 92 | main = runChaosBoxWith (\o -> o { optWidth = 10, optHeight = 10 }) renderSketch 93 | 94 | setup :: Render () 95 | setup = setLineWidth 0.02 96 | 97 | renderSketch :: Generate () 98 | renderSketch = do 99 | cairo setup 100 | 101 | (w, h) <- getSize 102 | center <- getCenterPoint 103 | 104 | startingPoint <- normal center (P2 (w / 4) (h / 4)) 105 | pathRef <- newIORef (startingPoint :| []) 106 | noise <- newNoise2 107 | 108 | mousePositionRef <- heldMousePosition ButtonLeft 109 | 110 | eventLoop $ do 111 | nextPath <- modifyIORefM pathRef $ \ps@(p :| _) -> do 112 | c <- readIORefWith (maybe p (lerp 0.05 p)) mousePositionRef 113 | let deviation = 0.3 * noise (c / 100) 114 | nextPoint <- normal c (P2 deviation deviation) 115 | pure $ unsafeTake 100 $ nextPoint `NE.cons` ps 116 | 117 | fillScreenRGB black 118 | cairo $ do 119 | setSourceRGB white 120 | draw (ClosedCurve nextPath 10) *> stroke 121 | 122 | -- | An unsafe version of 'Data.List.NonEmpty.take' 123 | -- 124 | -- This will blow up if n < 1, but is perfectly fine for a static value > 1, 125 | -- such as @100@ (at the callsite above). 126 | -- 127 | unsafeTake :: Int -> NonEmpty a -> NonEmpty a 128 | unsafeTake n = NE.fromList . NE.take n 129 | ``` 130 | 131 | Note: this example is taken directly from `chaosbox-example`, an executable 132 | shipped along with `chaosbox`. See the haddock documentation for a 133 | link-annotated version of this program. 134 | 135 | This short example covers myriad concepts in `chaosbox`. Notably: 136 | 137 | - All drawing is done through `libcairo` via `cairo`. 138 | - We can query the world (`getSize` and `getCenterPoint`) 139 | - `chaosbox` supports non-uniform random sampling (`normal`) 140 | - `chaosbox` handles variable mutation using `IORef`s and provides helpers 141 | around common operations (`modifyIORefM`, `forIORef`) 142 | - Interactive `chaosbox` programs run in an _Event Loop_. This gets called 143 | once per frame. 144 | - We can 'draw' various data types, including `ClosedCurve`s, to the canvas. 145 | (see `ChaosBox.Geometry` for more) 146 | - Some common event handling is abstracted away (`heldMousePosition`) 147 | 148 | In addition to what is visible here, `eventLoop` also provides a couple 149 | global keybindings: 150 | 151 | - Pressing `s` will save the current image at any time. 152 | - Pressing `q` will immediately quit the window and save the image. 153 | 154 | More can be added at any time using facilities provided in 155 | `ChaosBox.Interactive`. 156 | 157 | To get a feel for how `ChaosBox` works using this documentation, check out 158 | `ChaosBox.CLI`, `ChaosBox.Generate`, `ChaosBox.Interactive`, 159 | `ChaosBox.Geometry` and `ChaosBox.Affine`. 160 | 161 | Additionally, it is recommended to get up to speed with `libcairo` and its 162 | haskell bindings. Since the actual drawing is done using `libcairo`, 163 | learning these bindings will allow you to customize your art much more 164 | easily by digging down a level below this high-level interface. 165 | 166 | Have fun! 167 | -------------------------------------------------------------------------------- /src/ChaosBox/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module ChaosBox.Random 3 | ( 4 | -- * Distribution sampling 5 | uniform 6 | , uniformBounded 7 | , weighted 8 | , unsafeWeighted 9 | , normal 10 | , stdNormal 11 | , gamma 12 | , triangular 13 | , bernoulli 14 | , sometimes 15 | -- * Collection operations 16 | , shuffle 17 | , sample 18 | , sampleN 19 | , unsafeSample 20 | -- * Higher-order functions 21 | , suchThat 22 | , unsafeSuchThat 23 | , uniformPointIn 24 | , unsafeUniformPointIn 25 | -- * Re-Exports 26 | , MonadRandom.uniformMay 27 | , MonadRandom.weightedMay 28 | ) 29 | where 30 | 31 | import ChaosBox.AABB 32 | import ChaosBox.Generate 33 | import ChaosBox.Geometry.Class 34 | import ChaosBox.Geometry.P2 35 | import ChaosBox.Orphanage () 36 | 37 | import Control.Monad.Random (MonadRandom) 38 | import qualified Control.Monad.Random as MonadRandom 39 | import Data.Maybe (fromJust) 40 | import Data.Random (Distribution, 41 | Distribution (..), Normal, 42 | Normal (..), StdUniform, 43 | Uniform) 44 | import qualified Data.Random as Random 45 | import Data.Random.Distribution.Bernoulli (boolBernoulli) 46 | import Data.Random.Distribution.Triangular (floatingTriangular) 47 | import Data.RVar (sampleRVar) 48 | import Data.Semigroup.Foldable 49 | import Linear.V2 50 | 51 | -- | Sample a uniformly distributed element of a non-empty collection. 52 | sample :: (Foldable1 f, MonadRandom m) => f a -> m a 53 | sample = MonadRandom.uniform 54 | 55 | -- | Sample a uniformly distributed element of a collection. 56 | unsafeSample :: (Foldable f, MonadRandom m) => f a -> m a 57 | unsafeSample = MonadRandom.uniform 58 | 59 | -- | A uniformly distributed random variable of a 'Bounded' 'Enum'. 60 | uniformBounded :: (Monad m, Enum a, Bounded a) => GenerateT m a 61 | uniformBounded = MonadRandom.uniform [minBound .. maxBound] 62 | 63 | -- | Sample a uniformly distributed element from a non-empty weighted collection. 64 | weighted :: (Foldable1 f, MonadRandom m) => f (a, Rational) -> m a 65 | weighted = MonadRandom.weighted 66 | 67 | -- | Sample a uniformly distributed element from a weighted collection. 68 | unsafeWeighted :: (Foldable f, MonadRandom m) => f (a, Rational) -> m a 69 | unsafeWeighted = MonadRandom.weighted 70 | 71 | -- | A uniformly distributed random variable between a lower and upper bound. 72 | -- 73 | -- - For 'Enum' and 'Integral' types, this function is inclusive. 74 | -- - For 'Fractional' types, this function is exclusive on the upper bound. 75 | -- 76 | uniform :: (Distribution Uniform a, Monad m) => a -> a -> GenerateT m a 77 | uniform a b = sampleRVar (Random.uniform a b) 78 | 79 | -- | A normally distributed random variable. 80 | normal 81 | :: (Distribution Normal a, Monad m) 82 | => a 83 | -- ^ Mean 84 | -> a 85 | -- ^ Standard Deviation 86 | -> GenerateT m a 87 | normal a dev = sampleRVar (Random.normal a dev) 88 | 89 | -- | A normally distributed random variable with mean 0 & standard deviation 1. 90 | stdNormal :: (Distribution Normal a, Monad m) => GenerateT m a 91 | stdNormal = sampleRVar Random.stdNormal 92 | 93 | -- | A gamma-distributed variable 94 | gamma 95 | :: ( Floating a 96 | , Ord a 97 | , Distribution Normal a 98 | , Distribution StdUniform a 99 | , Monad m 100 | ) 101 | => a 102 | -> a 103 | -> GenerateT m a 104 | gamma a b = sampleRVar (Random.gamma a b) 105 | 106 | -- | A triangular distributed random variable. 107 | triangular 108 | :: (Floating a, Ord a, Distribution StdUniform a, Monad m) 109 | => a 110 | -- ^ Lower bound 111 | -> a 112 | -- ^ Midpoint 113 | -> a 114 | -- ^ Upper bound 115 | -> GenerateT m a 116 | triangular lo mid hi = sampleRVar (floatingTriangular lo mid hi) 117 | 118 | -- True or False with probability @P@. 119 | bernoulli 120 | :: (Fractional a, Ord a, Distribution StdUniform a, Monad m) 121 | => a 122 | -- ^ @P@ (between 0 and 1) 123 | -> GenerateT m Bool 124 | bernoulli = sampleRVar . boolBernoulli 125 | 126 | -- | Alias for 'bernoulli'. 127 | sometimes 128 | :: (Fractional a, Ord a, Distribution StdUniform a, Monad m) 129 | => a 130 | -> GenerateT m Bool 131 | sometimes = bernoulli 132 | 133 | -- | Shuffle a list. 134 | shuffle :: Monad m => [a] -> GenerateT m [a] 135 | shuffle = sampleRVar . Random.shuffle 136 | 137 | -- | Sample @N@ elements of a list without replacement. 138 | sampleN :: Monad m => Int -> [a] -> GenerateT m [a] 139 | sampleN n xs = sampleRVar $ Random.shuffleNofM n (length xs) xs 140 | 141 | -- | Generate a random variable satisfying a given predicate safely. 142 | -- 143 | -- Attempts to generate a variable a maximum of @1,000@ times. If the 144 | -- predicate is never satisfied, returns 'Nothing'. 145 | -- 146 | suchThat :: Monad m => GenerateT m a -> (a -> Bool) -> GenerateT m (Maybe a) 147 | suchThat gen predicate = go (1000 :: Int) 148 | where 149 | go 0 = pure Nothing 150 | go n = do 151 | a <- gen 152 | if predicate a then pure (Just a) else go (n - 1) 153 | 154 | -- | Generate a random variable satisfying a given predicate. 155 | -- 156 | -- Will 'error' after @1,000@ failed generations. 157 | -- 158 | unsafeSuchThat :: Monad m => GenerateT m a -> (a -> Bool) -> GenerateT m a 159 | unsafeSuchThat gen predicate = do 160 | ma <- gen `suchThat` predicate 161 | case ma of 162 | Nothing -> 163 | error 164 | "Error in 'unsafeSuchThat': Maximum generation attempts (1000) exceeded." 165 | Just x -> pure x 166 | 167 | -- | Generate a uniformly distributed point within a bounded shape 168 | uniformPointIn 169 | :: (Boundary a, HasAABB a, Monad m) => a -> GenerateT m (Maybe P2) 170 | uniformPointIn a = genPointInAABB (aabb a) `suchThat` containsPoint a 171 | where 172 | genPointInAABB (AABB (V2 tx ty) w h) = do 173 | x <- MonadRandom.getRandomR (tx, tx + w) 174 | y <- MonadRandom.getRandomR (ty, ty + h) 175 | pure $ V2 x y 176 | 177 | unsafeUniformPointIn :: (Boundary a, HasAABB a, Monad m) => a -> GenerateT m P2 178 | unsafeUniformPointIn = fmap fromJust . uniformPointIn 179 | -------------------------------------------------------------------------------- /src/ChaosBox/Generate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module ChaosBox.Generate 4 | ( 5 | -- * Generate's 'Reader' context 6 | GenerateCtx(..) 7 | , VideoManager(..) 8 | -- * 'ChaosBoxEvent' management 9 | , EventHandler(..) 10 | , ChaosBoxEvent(..) 11 | , overSDLEvent 12 | -- * Hooks 13 | , beforeSave 14 | -- * Effects 15 | , Generate 16 | , GenerateT 17 | -- * Context-sensitive rendering utilities 18 | , renderProgress 19 | , getSize 20 | , getCenterPoint 21 | , getBounds 22 | -- * Useful aliases 23 | , cairo 24 | ) 25 | where 26 | 27 | import ChaosBox.Orphanage ( ) 28 | import ChaosBox.AABB 29 | import ChaosBox.Geometry.P2 30 | 31 | import Control.Monad.Base 32 | import System.Directory 33 | import Control.Arrow ( (&&&) ) 34 | import Control.Monad.Random 35 | import Control.Monad.Reader 36 | import UnliftIO.IORef 37 | import Data.List.NonEmpty ( NonEmpty(..) ) 38 | import Data.Random.Internal.Source 39 | import Data.Random.Source as Source 40 | import GHC.Word ( Word64 ) 41 | import GI.Cairo.Render 42 | import Linear.V2 43 | import qualified SDL 44 | import System.Random.Mersenne.Pure64 45 | import Text.Printf 46 | 47 | data GenerateCtx = GenerateCtx 48 | { gcWidth :: Int 49 | -- ^ Width of the canvas 50 | , gcHeight :: Int 51 | -- ^ Height of the canvas 52 | , gcSeed :: Word64 53 | -- ^ Seed for random generation 54 | , gcScale :: Double 55 | -- ^ Scaling factor for 'gcWidth' and 'gcHeight' to generate the final pixel 56 | -- size of the output 57 | , gcName :: String 58 | -- ^ Name of the current project 59 | , gcProgress :: IORef Int 60 | -- ^ Current progress "tick" 61 | , gcBeforeSaveHook :: IORef (Maybe (Generate ())) 62 | -- ^ Action to perform before saving the image. 63 | , gcCairoSurface :: Surface 64 | -- ^ Raw mutable cairo Surface 65 | , gcWindow :: Maybe SDL.Window 66 | -- ^ SDL 'Window' to display image in 67 | , gcVideoManager :: VideoManager 68 | -- ^ Video manager 69 | , gcEventHandler :: IORef EventHandler 70 | -- ^ Mutable Event Handler 71 | , gcMetadataString :: Maybe String 72 | -- ^ Optional string to append to file name 73 | } 74 | 75 | data ChaosBoxEvent 76 | = Tick 77 | -- ^ A single loop of 'ChaosBox.Video.eventLoop' has passed 78 | | SDLEvent SDL.Event 79 | -- ^ An 'SDL.Event' has occurred 80 | deriving (Show, Eq) 81 | 82 | -- | Build an event handler for an 'SDL.Event' 83 | overSDLEvent :: Applicative f => (SDL.Event -> f ()) -> ChaosBoxEvent -> f () 84 | overSDLEvent f = \case 85 | Tick -> pure () 86 | SDLEvent event -> f event 87 | 88 | -- TODO: Implement this interface 89 | -- 90 | -- newtype EventHandler = EventHandler { ehEventHandlers :: IntMap (ChaosBoxEvent -> Generate ())} 91 | -- newtype EventHandlerId = EventHandlerId !Int 92 | -- registerEventHandler :: (ChaosboxEvent -> Generate ()) -> Generate EventHandlerId 93 | -- unregisterEventHandler :: EventHandlerId -> Generate () 94 | 95 | -- | How to handle 'ChaosBoxEvent's 96 | -- 97 | -- New event handlers can be registered with 98 | -- 'ChaosBox.Interactive.registerEventHandler' and other functions in that 99 | -- module. 100 | -- 101 | newtype EventHandler = EventHandler { ehHandleEvent :: ChaosBoxEvent -> Generate () } 102 | 103 | -- | Interactive video data 104 | data VideoManager = VideoManager 105 | { vmFps :: Int 106 | -- ^ How many frames to render per second 107 | , vmLastRenderedTimeRef :: IORef Integer 108 | -- ^ The number of picoseconds since the last frame was rendered 109 | } 110 | 111 | -- | Register an action to be performed before an image is saved 112 | beforeSave :: Generate () -> Generate () 113 | beforeSave hook = do 114 | beforeSaveHookRef <- asks gcBeforeSaveHook 115 | writeIORef beforeSaveHookRef (Just hook) 116 | 117 | type GenerateT m a = RandT PureMT (ReaderT GenerateCtx m) a 118 | instance MonadBase Render m => MonadBase Render (RandT PureMT (ReaderT GenerateCtx m)) where 119 | liftBase = liftBaseDefault 120 | 121 | -- | The main 'ChaosBox' Monad 122 | -- 123 | -- Supports the following effects: 124 | -- 125 | -- - Writing to a cairo canvas via 'Render' 126 | -- - Reading the 'GenerateCtx' 127 | -- - Randomly generating values via 'RandT' 'PureMT', which hooks nicely into 128 | -- @MonadRandom@ and @random-fu@. 129 | -- 130 | type Generate a = GenerateT Render a 131 | 132 | $(monadRandom [d| 133 | instance Monad m => Source.MonadRandom (RandT PureMT (ReaderT GenerateCtx m)) where 134 | getRandomWord64 = liftRandT (pure . randomWord64) 135 | |]) 136 | 137 | -- | Get the @(width, height)@ pair of the current surface in user-space 138 | getSize :: Num a => Generate (a, a) 139 | getSize = do 140 | (w, h) <- asks (gcWidth &&& gcHeight) 141 | pure (fromIntegral w, fromIntegral h) 142 | 143 | -- | Get the center 'P2' of the current surface in user-space 144 | getCenterPoint :: Generate P2 145 | getCenterPoint = do 146 | (w, h) <- asks (gcWidth &&& gcHeight) 147 | pure $ V2 (fromIntegral w / 2) (fromIntegral h / 2) 148 | 149 | -- | Render an "in-progress" image to @./images/$name/$seed/$progress/$N@ 150 | -- 151 | -- @N@ is the number of times 'renderProgress' has been previously called. 152 | -- For example: 153 | -- 154 | -- @ 155 | -- center <- getCenterPoint 156 | -- circleRef <- newIORef $ Circle center 1 157 | -- 158 | -- replicateM_ 100 $ do 159 | -- fillScreenRGB white 160 | -- cairo $ setSourceRGB black 161 | -- modifyIORef circleRef $ \c -> c { circleRadius = circleRadius c + 1 } 162 | -- circle <- readIORef circleRef 163 | -- cairo $ 164 | -- draw circle *> stroke 165 | -- renderProgress 166 | -- @ 167 | -- 168 | -- This will render a sequence of images that show a circle growing from the 169 | -- center of the image from 2 units in diameter to 50 units in diameter. 170 | -- 171 | -- This function is useful for writing @ffmpeg@ scripts to render videos from 172 | -- @ChaosBox@ output -- the sequence generated in the @progress@ folder is 173 | -- suitable for @ffmpeg@. 174 | -- 175 | renderProgress :: Generate () 176 | renderProgress = do 177 | (name, progressRef) <- asks (gcName &&& gcProgress) 178 | liftIO $ createDirectoryIfMissing False $ "./images/" <> name <> "/progress" 179 | let padInt :: Int -> String 180 | padInt = printf "%.8v" 181 | 182 | progress <- readIORef progressRef 183 | 184 | cairo . withTargetSurface $ \surface -> do 185 | liftIO . putStrLn $ "Rendering progress surface #" <> show progress 186 | liftIO 187 | $ surfaceWriteToPNG surface 188 | $ "images/" 189 | <> name 190 | <> "/progress/" 191 | <> padInt progress 192 | <> ".png" 193 | 194 | modifyIORef progressRef (+ 1) 195 | 196 | -- | Lift a 'Render' (cairo) action into a 'GenerateT' action 197 | cairo :: MonadBase Render m => Render a -> GenerateT m a 198 | cairo = lift . lift . liftBase 199 | 200 | -- | Get the bounding 'ChaosBox.Geometry.AABB' for the screen or image 201 | getBounds :: Generate AABB 202 | getBounds = do 203 | (w, h) <- getSize 204 | pure $ boundary $ 0 :| [P2 w h] 205 | -------------------------------------------------------------------------------- /src/ChaosBox/CLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | CLI entrypoints for @ChaosBox@ 3 | -- 4 | -- Most @ChaosBox@ programs will start with either 'runChaosBox', 5 | -- 'runChaosBoxWith' or 'runChaosBoxDirectly'. These functions build a 6 | -- command-line interface to start the art generation program. 7 | -- 8 | -- For example, the following @main@: 9 | -- 10 | -- @ 11 | -- main = runChaosBoxWith 12 | -- (\o -> o { optWidth = 10, optHeight = 10, optFps = 60 }) 13 | -- renderSketch 14 | -- @ 15 | -- 16 | -- will spawn the following command-line interface, and override the default or 17 | -- user-supplied @width@, @height@, and @fps@: 18 | -- 19 | -- @ 20 | -- ChaosBox 21 | -- 22 | -- Usage: chaosbox-example [--seed SEED] [--scale SCALE] [-w|--width WIDTH] 23 | -- [-h|--height HEIGHT] [--times TIMES] [--name NAME] 24 | -- [--metadata METADATA] [--fps FPS] [-s|--static] 25 | -- Generate art with ChaosBox 26 | -- 27 | -- Available options: 28 | -- --seed SEED Seed for the global PRNG 29 | -- --scale SCALE Scaling factor from user space to image space 30 | -- -w,--width WIDTH Width of the canvas in user space 31 | -- -h,--height HEIGHT Width of the canvas in user space 32 | -- --times TIMES How many times to run the program 33 | -- --name NAME Name of the output 34 | -- --metadata METADATA Optional metadata string to append to output file 35 | -- name 36 | -- --fps FPS How many frames per second to render in interactive 37 | -- mode 38 | -- -s,--static Render an image directly instead of in an interactive 39 | -- window 40 | -- -h,--help Show this help text 41 | -- @ 42 | -- 43 | module ChaosBox.CLI 44 | ( 45 | -- * ChaosBox options 46 | Opts(..) 47 | , RenderMode(..) 48 | , getDefaultOpts 49 | -- * Running ChaosBox programs 50 | , runChaosBox 51 | , runChaosBoxWith 52 | , runChaosBoxDirectly 53 | -- * Saving images 54 | , saveImage 55 | , saveImageWith 56 | ) 57 | where 58 | 59 | import ChaosBox.Generate 60 | 61 | import ChaosBox.Orphanage ( ) 62 | import Data.Foldable ( for_ ) 63 | import Control.Monad.Random 64 | import Control.Monad.Reader 65 | import UnliftIO.IORef 66 | import Data.Char ( toLower ) 67 | import Data.Maybe ( fromMaybe ) 68 | import Data.Semigroup ( (<>) ) 69 | import Data.Time.Clock.POSIX 70 | import GHC.Word 71 | import GI.Cairo.Render 72 | import Options.Applicative 73 | import System.Directory 74 | import System.Random.Mersenne.Pure64 75 | 76 | import Foreign.Ptr ( castPtr ) 77 | import SDL 78 | 79 | data RenderMode = Static | Interactive 80 | deriving (Eq, Show) 81 | 82 | data FileFormat = PNG 83 | | SVG 84 | | PS 85 | | PDF 86 | deriving (Read, Show, Eq) 87 | 88 | -- | ChaosBox's options 89 | data Opts = Opts 90 | { optSeed :: Maybe Word64 91 | -- ^ Random seed used for all PRNG. 92 | , optScale :: Double 93 | -- ^ Scale applied to user-space to produce final image 94 | , optWidth :: Int 95 | -- ^ Width in user-space 96 | , optHeight :: Int 97 | -- ^ Height in user-space 98 | , optRenderTimes :: Int 99 | -- ^ How many times to repeat rendering, helpful for fast experimentation 100 | , optName :: String 101 | -- ^ Name of the process. Images will be stored at 102 | -- @images/${optName}.${optName}-${optSeed}.png@ 103 | , optMetadataString :: Maybe String 104 | -- ^ Optional string to append to file name, useful for tagging 105 | , optFps :: Int 106 | -- ^ How many frames an interactive video should render per second 107 | , optRenderMode :: RenderMode 108 | -- ^ Should the program render a png directly or spawn an interactive video? 109 | , optFileFormat :: FileFormat 110 | -- ^ Which file format to use for saving images in static mode 111 | } 112 | 113 | getDefaultOpts :: IO Opts 114 | getDefaultOpts = do 115 | seed <- round . (* 1000) <$> getPOSIXTime 116 | pure Opts { optSeed = Just seed 117 | , optScale = 1 118 | , optWidth = 100 119 | , optHeight = 100 120 | , optRenderTimes = 1 121 | , optName = "sketch" 122 | , optMetadataString = Nothing 123 | , optFps = 30 124 | , optRenderMode = Interactive 125 | , optFileFormat = PNG 126 | } 127 | 128 | opts :: Parser Opts 129 | opts = 130 | Opts 131 | <$> optional (option auto $ long "seed" <> metavar "SEED" <> help seedHelp) 132 | <*> option auto 133 | (long "scale" <> metavar "SCALE" <> value 1 <> help scaleHelp) 134 | <*> option 135 | auto 136 | ( long "width" 137 | <> short 'w' 138 | <> metavar "WIDTH" 139 | <> value 100 140 | <> help widthHelp 141 | ) 142 | <*> option 143 | auto 144 | ( long "height" 145 | <> short 'h' 146 | <> metavar "HEIGHT" 147 | <> value 100 148 | <> help heightHelp 149 | ) 150 | <*> option auto 151 | (long "times" <> metavar "TIMES" <> value 1 <> help timesHelp) 152 | <*> strOption 153 | (long "name" <> metavar "NAME" <> value "sketch" <> help nameHelp) 154 | <*> optional 155 | (strOption 156 | (long "metadata" <> metavar "METADATA" <> help metadataHelp) 157 | ) 158 | <*> option auto (long "fps" <> metavar "FPS" <> value 30 <> help fpsHelp) 159 | <*> flag Interactive Static (long "static" <> short 's' <> help staticHelp) 160 | <*> option 161 | auto 162 | ( long "fileformat" 163 | <> short 'f' 164 | <> metavar "FILEFORMAT" 165 | <> help fileformatHelp 166 | <> value PNG 167 | ) 168 | where 169 | seedHelp = "Seed for the global PRNG (optional)" 170 | scaleHelp = "Scaling factor from user space to image space (default: 1)" 171 | widthHelp = "Width of the canvas in user space (default: 100)" 172 | heightHelp = "Width of the canvas in user space (default: 100)" 173 | timesHelp = "How many times to run the program (default: 1)" 174 | nameHelp = "Name of the output (default: \"sketch\")" 175 | metadataHelp = "Metadata string to append to output file name (optional)" 176 | fpsHelp = 177 | "How many frames per second to render in interactive mode (default: 30)" 178 | staticHelp 179 | = "Render an image directly instead of in an interactive window (default: False)" 180 | fileformatHelp 181 | = "Fileformat used for images rendered in static mode: PNG, SVG, PS or PDF (default: PNG)" 182 | 183 | optsInfo :: ParserInfo Opts 184 | optsInfo = info 185 | (opts <**> helper) 186 | (fullDesc <> progDesc "Generate art with ChaosBox" <> header "ChaosBox") 187 | 188 | -- | Run 'ChaosBox' with 'Opts' parsed from the CLI 189 | -- 190 | -- For the following program (assume it's called @sketch@): 191 | -- 192 | -- @ 193 | -- main = runChaosBox generate 194 | -- 195 | -- generate :: Generate () 196 | -- generate = -- blah blah blah 197 | -- @ 198 | -- 199 | -- Run @sketch --help@ to view all available options. 200 | -- 201 | runChaosBox 202 | :: Generate a 203 | -- ^ Render function 204 | -> IO () 205 | runChaosBox = runChaosBoxWith id 206 | 207 | -- | Run 'ChaosBox' with 'Opts' parsed from the CLI, allowing overrides. 208 | -- 209 | -- You might want to parse some options from the CLI, but not all of them. For 210 | -- example, it's relatively common to fix 'optHeight' and 'optWidth', but vary 211 | -- other factors. 'runChaosBoxWith' allows this flexibility: 212 | -- 213 | -- @ 214 | -- runChaosBoxWith (opts -> opts { optWidth = 16, optHeight = 20)) generate 215 | -- @ 216 | -- 217 | runChaosBoxWith 218 | :: (Opts -> Opts) 219 | -- ^ Option modifier 220 | -> Generate a 221 | -- ^ Render function 222 | -> IO () 223 | runChaosBoxWith fn render = do 224 | options <- execParser optsInfo 225 | runChaosBoxDirectly (fn options) render 226 | 227 | -- | Run 'ChaosBox' with the given 'Opts' 228 | -- 229 | -- Does not produce a CLI interface, just an executable with no arguments or 230 | -- options. 231 | -- 232 | runChaosBoxDirectly 233 | :: Opts 234 | -- ^ Art options 235 | -> Generate a 236 | -- ^ Render function 237 | -> IO () 238 | runChaosBoxDirectly Opts {..} doRender = replicateM_ optRenderTimes $ do 239 | seed <- case optSeed of 240 | Just seed' -> pure seed' 241 | Nothing -> round . (* 1000) <$> getPOSIXTime 242 | 243 | let stdGen = pureMT seed 244 | w = round $ fromIntegral optWidth * optScale 245 | h = round $ fromIntegral optHeight * optScale 246 | 247 | (surface, window) <- case optRenderMode of 248 | Static -> (,) <$> createImageSurface FormatARGB32 w h <*> pure Nothing 249 | Interactive -> do 250 | SDL.initialize [SDL.InitVideo] 251 | window <- SDL.createWindow 252 | "ChaosBox" 253 | SDL.defaultWindow 254 | { SDL.windowInitialSize = V2 (fromIntegral w) (fromIntegral h) 255 | , SDL.windowHighDPI = True 256 | } 257 | SDL.showWindow window 258 | screenSurface <- SDL.getWindowSurface window 259 | let white = V4 maxBound maxBound maxBound maxBound 260 | SDL.surfaceFillRect screenSurface Nothing white 261 | pixels <- castPtr <$> surfacePixels screenSurface 262 | 263 | surface <- createImageSurfaceForData pixels FormatRGB24 w h (w * 4) 264 | pure (surface, Just window) 265 | 266 | progressRef <- newIORef 0 267 | beforeSaveHookRef <- newIORef Nothing 268 | lastRenderedTimeRef <- newIORef 0 269 | gcEventHandlerRef <- newIORef (EventHandler $ const $ pure ()) 270 | 271 | let 272 | ctx = GenerateCtx 273 | { gcWidth = optWidth 274 | , gcHeight = optHeight 275 | , gcSeed = seed 276 | , gcScale = optScale 277 | , gcName = optName 278 | , gcProgress = progressRef 279 | , gcBeforeSaveHook = beforeSaveHookRef 280 | , gcCairoSurface = surface 281 | , gcWindow = window 282 | , gcVideoManager = VideoManager 283 | { vmFps = optFps 284 | , vmLastRenderedTimeRef = lastRenderedTimeRef 285 | } 286 | , gcEventHandler = gcEventHandlerRef 287 | , gcMetadataString = optMetadataString 288 | } 289 | 290 | let write ff withSurface = flip (writeImage ctx ff) Nothing $ \filePath -> 291 | withSurface filePath (fromIntegral w) (fromIntegral h) 292 | $ \imageSurface -> do 293 | _ <- 294 | renderWith imageSurface 295 | . flip runReaderT ctx 296 | . flip runRandT stdGen 297 | $ do 298 | cairo $ scale optScale optScale 299 | doRender 300 | surfaceFinish imageSurface 301 | 302 | case (optFileFormat, optRenderMode) of 303 | (PNG, _) -> 304 | void 305 | . renderWith surface 306 | . flip runReaderT ctx 307 | . flip runRandT stdGen 308 | $ do 309 | cairo $ scale optScale optScale 310 | void doRender 311 | 312 | ref <- asks gcBeforeSaveHook 313 | mHook <- liftIO $ readIORef ref 314 | fromMaybe (pure ()) mHook 315 | 316 | saveImage 317 | 318 | (ff@SVG, Static) -> write ff withSVGSurface 319 | (ff@PS , Static) -> write ff withPSSurface 320 | (ff@PDF, Static) -> write ff withPDFSurface 321 | (fileFormat, renderMode) -> 322 | error 323 | $ show renderMode 324 | <> " mode does not support rendering to " 325 | <> show fileFormat 326 | 327 | 328 | -- | Save the current image at @./images/$name/$seed@ 329 | saveImage :: Generate () 330 | saveImage = saveImageWith Nothing 331 | 332 | -- | Save the current image at @./images/$name/$seed/$random-string@ 333 | saveImageWith :: Maybe String -> Generate () 334 | saveImageWith mStr = do 335 | ctx@GenerateCtx {..} <- ask 336 | mHook <- readIORef gcBeforeSaveHook 337 | for_ mHook $ \hook -> hook 338 | 339 | let writer = surfaceWriteToPNG gcCairoSurface 340 | liftIO $ writeImage ctx PNG writer mStr 341 | 342 | type Writer = FilePath -> IO () 343 | writeImage :: GenerateCtx -> FileFormat -> Writer -> Maybe String -> IO () 344 | writeImage ctx fileFormat writer mStr = do 345 | let GenerateCtx {..} = ctx 346 | let dotExtension = '.' : map toLower (show fileFormat) 347 | 348 | putStrLn "Saving Image" 349 | createDirectoryIfMissing True $ "./images/" <> gcName 350 | for_ mStr $ \_ -> 351 | createDirectoryIfMissing True $ "./images/" <> gcName <> "/" <> show gcSeed 352 | 353 | putStrLn "Generating art..." 354 | let regularFile = 355 | "images/" 356 | <> gcName 357 | <> "/" 358 | <> show gcSeed 359 | <> "-" 360 | <> show gcScale 361 | <> fromMaybe "" gcMetadataString 362 | <> dotExtension 363 | latest = "images/" <> gcName <> "/latest" <> dotExtension 364 | 365 | putStrLn $ "Writing " <> latest 366 | writer latest 367 | 368 | putStrLn $ "Writing " <> regularFile 369 | copyFile latest regularFile 370 | 371 | for_ mStr $ \s -> do 372 | let extraFile = 373 | "images/" 374 | <> gcName 375 | <> "/" 376 | <> show gcSeed 377 | <> "/" 378 | <> show gcSeed 379 | <> "-" 380 | <> show gcScale 381 | <> "-" 382 | <> s 383 | <> fromMaybe "" gcMetadataString 384 | <> dotExtension 385 | 386 | putStrLn $ "Writing " <> extraFile 387 | copyFile latest extraFile 388 | -------------------------------------------------------------------------------- /src/ChaosBox/Interactive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | -- | The Interactive Guts of ChaosBox 3 | -- 4 | -- This module contains the bits and pieces needed to wire up an interactive 5 | -- ChaosBox program. Internally, ChaosBox renders a @cairo@ 'Surface' to an 6 | -- 'SDL.window'. To make a program interactive, 'ChaosBox' requires the user to 7 | -- write an 'eventLoop'. This 'eventLoop' has two key functions: 8 | -- 9 | -- 1. It renders a single frame at the user-provided fps 10 | -- 2. It processes all new 'ChaosBoxEvent's each frame 11 | -- 12 | -- ChaosBox heavily leverages 'SDL', so most 'ChaosBoxEvent's are just 13 | -- 'SDL.Event's (See 'SDLEvent'). This module provides some basic 14 | -- functionality for registering event handlers for various user actions, like 15 | -- keyboard and mouse input. 16 | -- 17 | -- Because an event loop is naturally stateful, 'IORef's are a key player in 18 | -- interactive ChaosBox programs. A typical interactive ChaosBox program 19 | -- might look something like this: 20 | -- 21 | -- @ 22 | -- center <- 'getCenterPoint' 23 | -- let centerCircle = 'Circle' center 0 24 | -- circleRef <- 'newIORef' centerCircle 25 | -- 26 | -- 'onMouseDown' ButtonLeft $ \p -> do 27 | -- 'modifyIORefM_' circleRef $ \c -> do 28 | -- newCenter <- 'normal' p 1 29 | -- let newRadius = 'circleRadius' c + 0.1 30 | -- pure $ 'Circle' newCenter newRadius 31 | -- 32 | -- 'cairo' $ 'setSourceRGB' 'black' 33 | -- 'eventLoop' $ do 34 | -- c <- 'readIORef' circleRef 35 | -- 'cairo' $ do 36 | -- 'draw' c *> 'stroke' 37 | -- @ 38 | -- 39 | -- This will draw a 'Circle' each time the mouse is clicked. The center of that 40 | -- 'Circle' will be nearby where the user clicks, and each new circle drawn 41 | -- will have a radius @0.1@ units larger than the previous circle drawn. 42 | -- 43 | -- See 'eventLoop' for more information, including a list of default event 44 | -- handlers / key bindings. 45 | -- 46 | module ChaosBox.Interactive 47 | ( 48 | -- * Dealing with events 49 | eventLoop 50 | , eventLoopN 51 | , idle 52 | , registerEventHandler 53 | -- * One-off rendering 54 | , renderFrame 55 | -- * Mouse events 56 | , onMouseDown 57 | , onMouseUp 58 | , onMouseMotion 59 | , heldMousePosition 60 | -- * Keyboard events 61 | , onKeyDown 62 | , bindKey 63 | , onKeyUp 64 | , syncKeyDown 65 | , syncKeyUp 66 | , whileKeyDown 67 | , whileKeyUp 68 | -- * 'Tick' 69 | , everyTick 70 | -- * Debugging 71 | , debugEvents 72 | -- * 'IORef' combinators 73 | , readIORefWith 74 | , forIORef 75 | , readIORefWithM 76 | , forIORefM 77 | , modifyIORefM 78 | , modifyIORefM_ 79 | -- * Re-exports 80 | , MouseButton(..) 81 | , module SDL.Input.Keyboard.Codes 82 | ) 83 | where 84 | 85 | import ChaosBox.CLI ( saveImageWith ) 86 | import ChaosBox.Generate 87 | import ChaosBox.Geometry.P2 88 | import ChaosBox.Random ( unsafeSample ) 89 | 90 | import Control.Concurrent ( threadDelay ) 91 | import Control.Monad ( unless 92 | , void 93 | , when 94 | ) 95 | import Control.Monad.IO.Class 96 | import Control.Monad.Reader 97 | import Data.Foldable ( for_ ) 98 | import qualified SDL 99 | import SDL.Input.Keyboard.Codes 100 | 101 | 102 | import SDL.Event 103 | import System.CPUTime 104 | import UnliftIO.IORef 105 | 106 | -- | The main video rendering loop 107 | -- 108 | -- This function causes the provided action to loop until the user expliclitly 109 | -- exits ChaosBox. It will render one frame per loop according to the global 110 | -- frame rate and handle each event according to any event handlers (registered 111 | -- with 'registerEventHandler' or a variety of other functions in this module). 112 | -- 113 | -- Beyond handling any user-specified events, there are a couple of default 114 | -- behaviors registered here: 115 | -- 116 | -- - One 'Tick' is processed per loop. 117 | -- - Pressing @s@ saves the current image on-screen. 118 | -- - Pressing @q@ or clicking the @x@ button will immediately quit 'ChaosBox'. 119 | -- 120 | eventLoop :: Generate a -> Generate () 121 | eventLoop act = do 122 | bindKey SDL.ScancodeS $ do 123 | str <- replicateM 6 $ unsafeSample ['a' .. 'z'] 124 | saveImageWith (Just str) 125 | -- TODO: This isn't perfect, could bind the key down event directly to the 126 | -- "quit" action 127 | shouldQuitRef <- syncKeyDown SDL.ScancodeQ 128 | loop shouldQuitRef 129 | where 130 | loop shouldQuitRef = do 131 | EventHandler {..} <- readIORef =<< asks gcEventHandler 132 | 133 | -- Handle a single 'Tick' 134 | ehHandleEvent Tick 135 | 136 | -- Handle all 'SDL.Event's 137 | events <- liftIO SDL.pollEvents 138 | for_ events (ehHandleEvent . SDLEvent) 139 | shouldQuit <- readIORef shouldQuitRef 140 | unless (SDL.QuitEvent `elem` map SDL.eventPayload events || shouldQuit) $ do 141 | void act 142 | renderFrame 143 | loop shouldQuitRef 144 | 145 | -- | Keep the window open, but don't accept any more user input\* 146 | -- 147 | -- \* Excluding default event handlers (@Q@ still quits, for example) 148 | -- 149 | idle :: Generate () 150 | idle = eventLoop $ pure () 151 | 152 | -- | Same as 'eventLoop', but only run for some specified number of frames. 153 | eventLoopN :: Int -> Generate a -> Generate () 154 | eventLoopN n act = do 155 | bindKey SDL.ScancodeS $ do 156 | str <- replicateM 6 $ unsafeSample ['a' .. 'z'] 157 | saveImageWith (Just str) 158 | shouldQuitRef <- syncKeyDown SDL.ScancodeQ 159 | 160 | loop n shouldQuitRef 161 | where 162 | loop 0 _ = pure () 163 | loop m shouldQuitRef = do 164 | EventHandler {..} <- readIORef =<< asks gcEventHandler 165 | 166 | -- Handle a single 'Tick' 167 | ehHandleEvent Tick 168 | 169 | -- Handle all 'SDL.Event's 170 | events <- liftIO SDL.pollEvents 171 | for_ events (ehHandleEvent . SDLEvent) 172 | shouldQuit <- readIORef shouldQuitRef 173 | unless (SDL.QuitEvent `elem` map SDL.eventPayload events || shouldQuit) $ do 174 | void act 175 | renderFrame 176 | loop (pred m) shouldQuitRef 177 | 178 | -- | Register a new event handler for an 'SDL.Event' 179 | registerEventHandler :: (ChaosBoxEvent -> Generate ()) -> Generate () 180 | registerEventHandler handleEvent = do 181 | eventHandlerRef <- asks gcEventHandler 182 | modifyIORef eventHandlerRef $ \EventHandler {..} -> 183 | EventHandler $ \event -> ehHandleEvent event >> handleEvent event 184 | 185 | -- | Print every 'SDL.Event' flowing through 'ChaosBox' 186 | debugEvents :: Generate () 187 | debugEvents = registerEventHandler $ \event -> liftIO $ print event 188 | 189 | -- | Perform some action once per 'Tick' 190 | everyTick :: Generate () -> Generate () 191 | everyTick act = registerEventHandler $ \case 192 | Tick -> act 193 | _ -> pure () 194 | 195 | -- | Do something when the specified 'MouseButton' is 'Pressed' 196 | onMouseDown :: MouseButton -> (P2 -> Generate ()) -> Generate () 197 | onMouseDown button act = registerEventHandler . overSDLEvent $ \event -> 198 | case eventPayload event of 199 | MouseButtonEvent MouseButtonEventData {..} -> do 200 | windowScale <- asks gcScale 201 | when 202 | (mouseButtonEventMotion == Pressed && mouseButtonEventButton == button 203 | ) 204 | $ do 205 | let SDL.P mouseLoc = mouseButtonEventPos 206 | act (fmap ((/ windowScale) . fromIntegral) mouseLoc) 207 | _ -> pure () 208 | 209 | -- | Do something when the specified 'MouseButton' is 'Released' 210 | onMouseUp :: MouseButton -> (P2 -> Generate ()) -> Generate () 211 | onMouseUp button act = registerEventHandler . overSDLEvent $ \event -> 212 | case eventPayload event of 213 | MouseButtonEvent MouseButtonEventData {..} -> do 214 | windowScale <- asks gcScale 215 | when 216 | ( mouseButtonEventMotion 217 | == Released 218 | && mouseButtonEventButton 219 | == button 220 | ) 221 | $ do 222 | let SDL.P mouseLoc = mouseButtonEventPos 223 | act (fmap ((/ windowScale) . fromIntegral) mouseLoc) 224 | _ -> pure () 225 | 226 | -- | Do something with the mouse's user-space position when the mouse moves 227 | -- 228 | -- For example, this registers an event handler that prints the mouse's 229 | -- position every time it moves: 230 | -- 231 | -- @onMouseMotion act (\p -> liftIO (print p))@ 232 | -- 233 | onMouseMotion :: (P2 -> Generate ()) -> Generate () 234 | onMouseMotion act = registerEventHandler . overSDLEvent $ \event -> 235 | case eventPayload event of 236 | MouseMotionEvent MouseMotionEventData {..} -> do 237 | windowScale <- asks gcScale 238 | let SDL.P mouseLoc = mouseMotionEventPos 239 | act (fmap ((/ windowScale) . fromIntegral) mouseLoc) 240 | _ -> pure () 241 | 242 | -- | Holds the current position of the Mouse while it is held down 243 | -- 244 | -- When the specified 'MouseButton' is held down, this returns 'Just mousePos' 245 | -- in user-space coordinates. Otherwise, it returns 'Nothing'. 246 | -- 247 | heldMousePosition :: MouseButton -> Generate (IORef (Maybe P2)) 248 | heldMousePosition button = newSignal Nothing $ \ref -> do 249 | onMouseDown button $ writeIORef ref . Just 250 | onMouseUp button $ \_ -> writeIORef ref Nothing 251 | -- only update when mouse is down 252 | onMouseMotion $ \p -> do 253 | mPoint <- readIORef ref 254 | for_ mPoint $ \_ -> writeIORef ref (Just p) 255 | 256 | -- | Do something when a key is 'Released' 257 | onKeyUp :: SDL.Scancode -> Generate () -> Generate () 258 | onKeyUp scancode act = registerEventHandler . overSDLEvent $ \event -> 259 | case eventPayload event of 260 | KeyboardEvent KeyboardEventData {..} 261 | | ( SDL.keysymScancode keyboardEventKeysym 262 | == scancode 263 | && keyboardEventKeyMotion 264 | == Released 265 | ) 266 | -> act 267 | _ -> pure () 268 | 269 | -- | Do something when a key is 'Pressed' 270 | onKeyDown :: SDL.Scancode -> Generate () -> Generate () 271 | onKeyDown scancode act = registerEventHandler . overSDLEvent $ \event -> 272 | case eventPayload event of 273 | KeyboardEvent KeyboardEventData {..} 274 | | ( SDL.keysymScancode keyboardEventKeysym 275 | == scancode 276 | && keyboardEventKeyMotion 277 | == Pressed 278 | ) 279 | -> act 280 | _ -> pure () 281 | 282 | -- | Alias for 'onKeyDown' 283 | bindKey :: SDL.Scancode -> Generate () -> Generate () 284 | bindKey = onKeyDown 285 | 286 | -- | Return a an 'IORef' containing whether a key is currently 'Pressed' 287 | syncKeyDown :: SDL.Scancode -> Generate (IORef Bool) 288 | syncKeyDown scancode = newSignal False $ \ref -> do 289 | onKeyDown scancode $ writeIORef ref True 290 | onKeyUp scancode $ writeIORef ref False 291 | 292 | -- | Return a an 'IORef' containing whether a key is currently 'Released' 293 | syncKeyUp :: SDL.Scancode -> Generate (IORef Bool) 294 | syncKeyUp scancode = newSignal True $ \ref -> do 295 | onKeyDown scancode $ writeIORef ref False 296 | onKeyUp scancode $ writeIORef ref True 297 | 298 | -- | Do something each 'Tick' while a key is 'Pressed' 299 | whileKeyDown :: SDL.Scancode -> Generate () -> Generate () 300 | whileKeyDown scancode act = do 301 | isKeyDown <- syncKeyDown scancode 302 | everyTick $ do 303 | isDown <- readIORef isKeyDown 304 | when isDown act 305 | 306 | -- | Do something each 'Tick' while a key is 'Released' 307 | whileKeyUp :: SDL.Scancode -> Generate () -> Generate () 308 | whileKeyUp scancode act = do 309 | isKeyDown <- syncKeyUp scancode 310 | everyTick $ do 311 | isDown <- readIORef isKeyDown 312 | when isDown act 313 | 314 | -- | Render a frame one-off 315 | -- 316 | -- By default, 'eventLoop' will render one frame at the end of each iteration 317 | -- of the loop. If you want to render a frame one-off, you can use this 318 | -- function to do so. 319 | -- 320 | -- The rendered frame will be synced to the global frame rate. 321 | -- 322 | renderFrame :: MonadIO m => GenerateT m () 323 | renderFrame = do 324 | mWindow <- asks gcWindow 325 | 326 | for_ mWindow $ \window -> do 327 | VideoManager {..} <- asks gcVideoManager 328 | liftIO $ do 329 | now <- getCPUTime 330 | lastFrameRenderedTime <- readIORef vmLastRenderedTimeRef 331 | 332 | let targetSeconds :: Double 333 | targetSeconds = 1 / fromIntegral vmFps 334 | lastFrameRenderedTimeSeconds = 335 | fromIntegral lastFrameRenderedTime * 10 ** (-12) 336 | targetTimeSeconds = lastFrameRenderedTimeSeconds + targetSeconds 337 | waitDiffSeconds = targetTimeSeconds - lastFrameRenderedTimeSeconds 338 | waitNs = max 0 $ floor (waitDiffSeconds * 1000000) 339 | 340 | threadDelay waitNs 341 | SDL.updateWindowSurface window 342 | writeIORef vmLastRenderedTimeRef now 343 | 344 | -- | Monadic 'modifyIORef' which returns the value written. 345 | modifyIORefM :: MonadIO m => IORef a -> (a -> m a) -> m a 346 | modifyIORefM ref f = do 347 | a <- readIORef ref 348 | b <- f a 349 | b <$ writeIORef ref b 350 | 351 | -- | Monadic 'modifyIORef' 352 | modifyIORefM_ :: MonadIO m => IORef a -> (a -> m a) -> m () 353 | modifyIORefM_ ref = void . modifyIORefM ref 354 | 355 | -- | 'readIORef', running a function on the output 356 | readIORefWith :: MonadIO m => (t -> b) -> IORef t -> m b 357 | readIORefWith f b = do 358 | b0 <- readIORef b 359 | pure (f b0) 360 | 361 | -- | Flipped 'readIORef', sometimes reads better 362 | forIORef :: MonadIO m => IORef t -> (t -> b) -> m b 363 | forIORef = flip readIORefWith 364 | 365 | -- | Monadic 'readIORefWith' 366 | readIORefWithM :: MonadIO m => (t -> m b) -> IORef t -> m b 367 | readIORefWithM f b = do 368 | b0 <- readIORef b 369 | f b0 370 | 371 | -- | Flipped 'readIORefWithM', sometimes reads better 372 | forIORefM :: MonadIO m => IORef t -> (t -> m b) -> m b 373 | forIORefM = flip readIORefWithM 374 | 375 | -- Utilities 376 | 377 | newSignal :: a -> (IORef a -> Generate ()) -> Generate (IORef a) 378 | newSignal def act = do 379 | ref <- newIORef def 380 | ref <$ act ref 381 | -------------------------------------------------------------------------------- /src/ChaosBox/Noise.hs: -------------------------------------------------------------------------------- 1 | -- Much of this module was adapted from 2 | -- 3 | module ChaosBox.Noise 4 | ( noise1 5 | , newNoise1 6 | , noise2 7 | , newNoise2 8 | , noise3 9 | , newNoise3 10 | , noise4 11 | , newNoise4 12 | ) 13 | where 14 | 15 | import Prelude hiding (init) 16 | 17 | import ChaosBox.Generate 18 | import ChaosBox.Geometry.P2 19 | import Control.Monad.Random 20 | import Data.Vector (Vector, init, (!)) 21 | import qualified Data.Vector as V 22 | import Linear 23 | 24 | -- | One dimensional simplex noise 25 | noise1 :: Double -> Double 26 | noise1 x = noise2D x 0 27 | 28 | -- | Generate one dimensional simplex noise with a random seed. 29 | newNoise1 :: Generate (Double -> Double) 30 | newNoise1 = do 31 | seed <- getRandom 32 | pure $ \x -> noise1 (x + seed) 33 | 34 | -- | Two dimensional simplex noise 35 | noise2 :: P2 -> Double 36 | noise2 (V2 x y) = noise2D x y 37 | 38 | -- | Generate two dimensional simplex noise with a random seed. 39 | newNoise2 :: Generate (P2 -> Double) 40 | newNoise2 = do 41 | seed <- V2 <$> getRandom <*> getRandom 42 | pure $ \x -> noise2 (x + seed) 43 | 44 | -- | Three dimensional simplex noise 45 | noise3 :: V3 Double -> Double 46 | noise3 (V3 x y z) = noise3D x y z 47 | 48 | -- | Generate three dimensional simplex noise with a random seed. 49 | newNoise3 :: Generate (V3 Double -> Double) 50 | newNoise3 = do 51 | seed <- V3 <$> getRandom <*> getRandom <*> getRandom 52 | pure $ \x -> noise3 (x + seed) 53 | 54 | -- | Four dimensional simplex noise 55 | noise4 :: V4 Double -> Double 56 | noise4 (V4 x y z w) = noise4D x y z w 57 | 58 | -- | Generate four dimensional simplex noise with a random seed. 59 | newNoise4 :: Generate (V4 Double -> Double) 60 | newNoise4 = do 61 | seed <- V4 <$> getRandom <*> getRandom <*> getRandom <*> getRandom 62 | pure $ \x -> noise4 (x + seed) 63 | 64 | vector2 :: [[a]] -> Vector (Vector a) 65 | vector2 = V.fromList . fmap V.fromList 66 | 67 | gradients3d :: Vector (Vector Double) 68 | gradients3d = vector2 69 | [ [1, 1, 0] 70 | , [-1, 1, 0] 71 | , [1, -1, 0] 72 | , [-1, -1, 0] 73 | , [1, 0, 1] 74 | , [-1, 0, 1] 75 | , [1, 0, -1] 76 | , [-1, 0, -1] 77 | , [0, 1, 1] 78 | , [0, -1, 1] 79 | , [0, 1, -1] 80 | , [0, -1, -1] 81 | ] 82 | 83 | gradients4d :: Vector (Vector Double) 84 | gradients4d = vector2 85 | [ [0, 1, 1, 1] 86 | , [0, 1, 1, -1] 87 | , [0, 1, -1, 1] 88 | , [0, 1, -1, -1] 89 | , [0, -1, 1, 1] 90 | , [0, -1, 1, -1] 91 | , [0, -1, -1, 1] 92 | , [0, -1, -1, -1] 93 | , [1, 0, 1, 1] 94 | , [1, 0, 1, -1] 95 | , [1, 0, -1, 1] 96 | , [1, 0, -1, -1] 97 | , [-1, 0, 1, 1] 98 | , [-1, 0, 1, -1] 99 | , [-1, 0, -1, 1] 100 | , [-1, 0, -1, -1] 101 | , [1, 1, 0, 1] 102 | , [1, 1, 0, -1] 103 | , [1, -1, 0, 1] 104 | , [1, -1, 0, -1] 105 | , [-1, 1, 0, 1] 106 | , [-1, 1, 0, -1] 107 | , [-1, -1, 0, 1] 108 | , [-1, -1, 0, -1] 109 | , [1, 1, 1, 0] 110 | , [1, 1, -1, 0] 111 | , [1, -1, 1, 0] 112 | , [1, -1, -1, 0] 113 | , [-1, 1, 1, 0] 114 | , [-1, 1, -1, 0] 115 | , [-1, -1, 1, 0] 116 | , [-1, -1, -1, 0] 117 | ] 118 | 119 | 120 | perm :: Vector Int 121 | perm = V.fromList 122 | [ 151 123 | , 160 124 | , 137 125 | , 91 126 | , 90 127 | , 15 128 | , 131 129 | , 13 130 | , 201 131 | , 95 132 | , 96 133 | , 53 134 | , 194 135 | , 233 136 | , 7 137 | , 225 138 | , 140 139 | , 36 140 | , 103 141 | , 30 142 | , 69 143 | , 142 144 | , 8 145 | , 99 146 | , 37 147 | , 240 148 | , 21 149 | , 10 150 | , 23 151 | , 190 152 | , 6 153 | , 148 154 | , 247 155 | , 120 156 | , 234 157 | , 75 158 | , 0 159 | , 26 160 | , 197 161 | , 62 162 | , 94 163 | , 252 164 | , 219 165 | , 203 166 | , 117 167 | , 35 168 | , 11 169 | , 32 170 | , 57 171 | , 177 172 | , 33 173 | , 88 174 | , 237 175 | , 149 176 | , 56 177 | , 87 178 | , 174 179 | , 20 180 | , 125 181 | , 136 182 | , 171 183 | , 168 184 | , 68 185 | , 175 186 | , 74 187 | , 165 188 | , 71 189 | , 134 190 | , 139 191 | , 48 192 | , 27 193 | , 166 194 | , 77 195 | , 146 196 | , 158 197 | , 231 198 | , 83 199 | , 111 200 | , 229 201 | , 122 202 | , 60 203 | , 211 204 | , 133 205 | , 230 206 | , 220 207 | , 105 208 | , 92 209 | , 41 210 | , 55 211 | , 46 212 | , 245 213 | , 40 214 | , 244 215 | , 102 216 | , 143 217 | , 54 218 | , 65 219 | , 25 220 | , 63 221 | , 161 222 | , 1 223 | , 216 224 | , 80 225 | , 73 226 | , 209 227 | , 76 228 | , 132 229 | , 187 230 | , 208 231 | , 89 232 | , 18 233 | , 169 234 | , 200 235 | , 196 236 | , 135 237 | , 130 238 | , 116 239 | , 188 240 | , 159 241 | , 86 242 | , 164 243 | , 100 244 | , 109 245 | , 198 246 | , 173 247 | , 186 248 | , 3 249 | , 64 250 | , 52 251 | , 217 252 | , 226 253 | , 250 254 | , 124 255 | , 123 256 | , 5 257 | , 202 258 | , 38 259 | , 147 260 | , 118 261 | , 126 262 | , 255 263 | , 82 264 | , 85 265 | , 212 266 | , 207 267 | , 206 268 | , 59 269 | , 227 270 | , 47 271 | , 16 272 | , 58 273 | , 17 274 | , 182 275 | , 189 276 | , 28 277 | , 42 278 | , 223 279 | , 183 280 | , 170 281 | , 213 282 | , 119 283 | , 248 284 | , 152 285 | , 2 286 | , 44 287 | , 154 288 | , 163 289 | , 70 290 | , 221 291 | , 153 292 | , 101 293 | , 155 294 | , 167 295 | , 43 296 | , 172 297 | , 9 298 | , 129 299 | , 22 300 | , 39 301 | , 253 302 | , 19 303 | , 98 304 | , 108 305 | , 110 306 | , 79 307 | , 113 308 | , 224 309 | , 232 310 | , 178 311 | , 185 312 | , 112 313 | , 104 314 | , 218 315 | , 246 316 | , 97 317 | , 228 318 | , 251 319 | , 34 320 | , 242 321 | , 193 322 | , 238 323 | , 210 324 | , 144 325 | , 12 326 | , 191 327 | , 179 328 | , 162 329 | , 241 330 | , 81 331 | , 51 332 | , 145 333 | , 235 334 | , 249 335 | , 14 336 | , 239 337 | , 107 338 | , 49 339 | , 192 340 | , 214 341 | , 31 342 | , 181 343 | , 199 344 | , 106 345 | , 157 346 | , 184 347 | , 84 348 | , 204 349 | , 176 350 | , 115 351 | , 121 352 | , 50 353 | , 45 354 | , 127 355 | , 4 356 | , 150 357 | , 254 358 | , 138 359 | , 236 360 | , 205 361 | , 93 362 | , 222 363 | , 114 364 | , 67 365 | , 29 366 | , 24 367 | , 72 368 | , 243 369 | , 141 370 | , 128 371 | , 195 372 | , 78 373 | , 66 374 | , 215 375 | , 61 376 | , 156 377 | , 180 378 | , 151 379 | , 160 380 | , 137 381 | , 91 382 | , 90 383 | , 15 384 | , 131 385 | , 13 386 | , 201 387 | , 95 388 | , 96 389 | , 53 390 | , 194 391 | , 233 392 | , 7 393 | , 225 394 | , 140 395 | , 36 396 | , 103 397 | , 30 398 | , 69 399 | , 142 400 | , 8 401 | , 99 402 | , 37 403 | , 240 404 | , 21 405 | , 10 406 | , 23 407 | , 190 408 | , 6 409 | , 148 410 | , 247 411 | , 120 412 | , 234 413 | , 75 414 | , 0 415 | , 26 416 | , 197 417 | , 62 418 | , 94 419 | , 252 420 | , 219 421 | , 203 422 | , 117 423 | , 35 424 | , 11 425 | , 32 426 | , 57 427 | , 177 428 | , 33 429 | , 88 430 | , 237 431 | , 149 432 | , 56 433 | , 87 434 | , 174 435 | , 20 436 | , 125 437 | , 136 438 | , 171 439 | , 168 440 | , 68 441 | , 175 442 | , 74 443 | , 165 444 | , 71 445 | , 134 446 | , 139 447 | , 48 448 | , 27 449 | , 166 450 | , 77 451 | , 146 452 | , 158 453 | , 231 454 | , 83 455 | , 111 456 | , 229 457 | , 122 458 | , 60 459 | , 211 460 | , 133 461 | , 230 462 | , 220 463 | , 105 464 | , 92 465 | , 41 466 | , 55 467 | , 46 468 | , 245 469 | , 40 470 | , 244 471 | , 102 472 | , 143 473 | , 54 474 | , 65 475 | , 25 476 | , 63 477 | , 161 478 | , 1 479 | , 216 480 | , 80 481 | , 73 482 | , 209 483 | , 76 484 | , 132 485 | , 187 486 | , 208 487 | , 89 488 | , 18 489 | , 169 490 | , 200 491 | , 196 492 | , 135 493 | , 130 494 | , 116 495 | , 188 496 | , 159 497 | , 86 498 | , 164 499 | , 100 500 | , 109 501 | , 198 502 | , 173 503 | , 186 504 | , 3 505 | , 64 506 | , 52 507 | , 217 508 | , 226 509 | , 250 510 | , 124 511 | , 123 512 | , 5 513 | , 202 514 | , 38 515 | , 147 516 | , 118 517 | , 126 518 | , 255 519 | , 82 520 | , 85 521 | , 212 522 | , 207 523 | , 206 524 | , 59 525 | , 227 526 | , 47 527 | , 16 528 | , 58 529 | , 17 530 | , 182 531 | , 189 532 | , 28 533 | , 42 534 | , 223 535 | , 183 536 | , 170 537 | , 213 538 | , 119 539 | , 248 540 | , 152 541 | , 2 542 | , 44 543 | , 154 544 | , 163 545 | , 70 546 | , 221 547 | , 153 548 | , 101 549 | , 155 550 | , 167 551 | , 43 552 | , 172 553 | , 9 554 | , 129 555 | , 22 556 | , 39 557 | , 253 558 | , 19 559 | , 98 560 | , 108 561 | , 110 562 | , 79 563 | , 113 564 | , 224 565 | , 232 566 | , 178 567 | , 185 568 | , 112 569 | , 104 570 | , 218 571 | , 246 572 | , 97 573 | , 228 574 | , 251 575 | , 34 576 | , 242 577 | , 193 578 | , 238 579 | , 210 580 | , 144 581 | , 12 582 | , 191 583 | , 179 584 | , 162 585 | , 241 586 | , 81 587 | , 51 588 | , 145 589 | , 235 590 | , 249 591 | , 14 592 | , 239 593 | , 107 594 | , 49 595 | , 192 596 | , 214 597 | , 31 598 | , 181 599 | , 199 600 | , 106 601 | , 157 602 | , 184 603 | , 84 604 | , 204 605 | , 176 606 | , 115 607 | , 121 608 | , 50 609 | , 45 610 | , 127 611 | , 4 612 | , 150 613 | , 254 614 | , 138 615 | , 236 616 | , 205 617 | , 93 618 | , 222 619 | , 114 620 | , 67 621 | , 29 622 | , 24 623 | , 72 624 | , 243 625 | , 141 626 | , 128 627 | , 195 628 | , 78 629 | , 66 630 | , 215 631 | , 61 632 | , 156 633 | , 180 634 | ] 635 | 636 | simplex :: Vector (Vector Double) 637 | simplex = vector2 638 | [ [0, 1, 2, 3] 639 | , [0, 1, 3, 2] 640 | , [0, 0, 0, 0] 641 | , [0, 2, 3, 1] 642 | , [0, 0, 0, 0] 643 | , [0, 0, 0, 0] 644 | , [0, 0, 0, 0] 645 | , [1, 2, 3, 0] 646 | , [0, 2, 1, 3] 647 | , [0, 0, 0, 0] 648 | , [0, 3, 1, 2] 649 | , [0, 3, 2, 1] 650 | , [0, 0, 0, 0] 651 | , [0, 0, 0, 0] 652 | , [0, 0, 0, 0] 653 | , [1, 3, 2, 0] 654 | , [0, 0, 0, 0] 655 | , [0, 0, 0, 0] 656 | , [0, 0, 0, 0] 657 | , [0, 0, 0, 0] 658 | , [0, 0, 0, 0] 659 | , [0, 0, 0, 0] 660 | , [0, 0, 0, 0] 661 | , [0, 0, 0, 0] 662 | , [1, 2, 0, 3] 663 | , [0, 0, 0, 0] 664 | , [1, 3, 0, 2] 665 | , [0, 0, 0, 0] 666 | , [0, 0, 0, 0] 667 | , [0, 0, 0, 0] 668 | , [2, 3, 0, 1] 669 | , [2, 3, 1, 0] 670 | , [1, 0, 2, 3] 671 | , [1, 0, 3, 2] 672 | , [0, 0, 0, 0] 673 | , [0, 0, 0, 0] 674 | , [0, 0, 0, 0] 675 | , [2, 0, 3, 1] 676 | , [0, 0, 0, 0] 677 | , [2, 1, 3, 0] 678 | , [0, 0, 0, 0] 679 | , [0, 0, 0, 0] 680 | , [0, 0, 0, 0] 681 | , [0, 0, 0, 0] 682 | , [0, 0, 0, 0] 683 | , [0, 0, 0, 0] 684 | , [0, 0, 0, 0] 685 | , [0, 0, 0, 0] 686 | , [2, 0, 1, 3] 687 | , [0, 0, 0, 0] 688 | , [0, 0, 0, 0] 689 | , [0, 0, 0, 0] 690 | , [3, 0, 1, 2] 691 | , [3, 0, 2, 1] 692 | , [0, 0, 0, 0] 693 | , [3, 1, 2, 0] 694 | , [2, 1, 0, 3] 695 | , [0, 0, 0, 0] 696 | , [0, 0, 0, 0] 697 | , [0, 0, 0, 0] 698 | , [3, 1, 0, 2] 699 | , [0, 0, 0, 0] 700 | , [3, 2, 0, 1] 701 | , [3, 2, 1, 0] 702 | ] 703 | 704 | noise2D :: Double -> Double -> Double 705 | noise2D x y = 706 | --space-skewing factors 707 | let 708 | f2 = 0.5 * ((sqrt 3) - 1) 709 | s = (x + y) * f2 710 | i = floor (x + s) 711 | j = floor (y + s) 712 | g2 = ((3 - (sqrt 3)) / 6) 713 | 714 | --calculate the positions of the vertices of the simplex 715 | t = (fromIntegral (i + j)) * g2 716 | x0 = x - (fromIntegral i - t) 717 | y0 = y - (fromIntegral j - t) 718 | 719 | i1 = if (x0 > y0) then 1 else 0 720 | j1 = if (x0 > y0) then 0 else 1 721 | 722 | x1 = x0 - fromIntegral i1 + g2 723 | y1 = y0 - fromIntegral j1 + g2 724 | x2 = x0 - 1 + 2 * g2 725 | y2 = y0 - 1 + 2 * g2 726 | 727 | --get the gradients at each corner from the arrays above 728 | ii = i `mod` 256 729 | jj = j `mod` 256 730 | 731 | gi0 = (perm ! (ii + (perm ! jj))) `mod` 12 732 | gi1 = (perm ! (ii + i1 + (perm ! (jj + j1)))) `mod` 12 733 | gi2 = (perm ! (ii + 1 + (perm ! (jj + 1)))) `mod` 12 734 | 735 | --calculate the contributions form the corners of the simplex 736 | t0 = 0.5 - x0 * x0 - y0 * y0 737 | t1 = 0.5 - x1 * x1 - y1 * y1 738 | t2 = 0.5 - x2 * x2 - y2 * y2 739 | 740 | n0 = if (t0 < 0) 741 | then 0 742 | else ((t0 ** 4) * dot (init (gradients3d ! gi0)) (V.fromList [x0, y0])) 743 | n1 = if (t1 < 0) 744 | then 0 745 | else ((t1 ** 4) * dot (init (gradients3d ! gi1)) (V.fromList [x1, y1])) 746 | n2 = if (t2 < 0) 747 | then 0 748 | else ((t2 ** 4) * dot (init (gradients3d ! gi2)) (V.fromList [x2, y2])) 749 | in 750 | 70.0 * (n0 + n1 + n2) --sum the contributions 751 | 752 | noise3D :: Double -> Double -> Double -> Double 753 | noise3D x y z 754 | = 755 | --space skewing-factors 756 | let 757 | f3 = 1 / 3 758 | s = (x + y + z) * f3 759 | i = floor (x + s) 760 | j = floor (y + s) 761 | k = floor (z + s) 762 | 763 | g3 = 1 / 6 764 | t = fromIntegral (i + j + k) * g3 765 | 766 | --cell origin coordinates 767 | x0 = (x - (fromIntegral i - t)) 768 | y0 = (y - (fromIntegral j - t)) 769 | z0 = (z - (fromIntegral k - t)) 770 | 771 | --ordering of other coordinates 772 | (i1, j1, k1, i2, j2, k2) = if (x0 >= y0) 773 | then if (y0 >= z0) 774 | then (1, 0, 0, 1, 1, 0) 775 | else (if (x0 >= z0) then (1, 0, 0, 1, 0, 1) else (0, 0, 1, 1, 0, 1)) 776 | else 777 | (if (y0 < z0) 778 | then (0, 0, 1, 0, 1, 1) 779 | else (if (x0 < z0) then (0, 1, 0, 0, 1, 1) else (0, 1, 0, 1, 1, 0)) 780 | ) 781 | 782 | --coordinates of the other 3 vertices 783 | x1 = x0 - fromIntegral i1 + g3 784 | y1 = y0 - fromIntegral j1 + g3 785 | z1 = z0 - fromIntegral k1 + g3 786 | 787 | x2 = x0 - fromIntegral i2 + 2 * g3 788 | y2 = y0 - fromIntegral j2 + 2 * g3 789 | z2 = z0 - fromIntegral k2 + 2 * g3 790 | 791 | x3 = x0 - 1 + 3 * g3 792 | y3 = y0 - 1 + 3 * g3 793 | z3 = z0 - 1 + 3 * g3 794 | 795 | --locate gradient 796 | ii = i `mod` 256 797 | jj = j `mod` 256 798 | kk = k `mod` 256 799 | 800 | gi0 = (perm ! (ii + (perm ! (jj + (perm ! kk))))) `mod` 12 801 | gi1 = 802 | (perm ! (ii + i1 + (perm ! (jj + j1 + (perm ! (kk + k1)))))) `mod` 12 803 | gi2 = 804 | (perm ! (ii + i2 + (perm ! (jj + j2 + (perm ! (kk + k2)))))) `mod` 12 805 | gi3 = (perm ! (ii + 1 + (perm ! (jj + 1 + (perm ! (kk + 1)))))) `mod` 12 806 | 807 | --contributions from each corner 808 | t0 = 0.5 - x0 * x0 - y0 * y0 - z0 * z0 809 | t1 = 0.5 - x1 * x1 - y1 * y1 - z1 * z1 810 | t2 = 0.5 - x2 * x2 - y2 * y2 - z2 * z2 811 | t3 = 0.5 - x3 * x3 - y3 * y3 - z3 * z3 812 | 813 | n0 = if (t0 < 0) 814 | then 0 815 | else (t0 ** 4) * (gradients3d ! gi0 `dot` V.fromList ([x0, y0, z0])) 816 | n1 = if (t1 < 0) 817 | then 0 818 | else (t1 ** 4) * (gradients3d ! gi1 `dot` V.fromList ([x1, y1, z1])) 819 | n2 = if (t2 < 0) 820 | then 0 821 | else (t2 ** 4) * (gradients3d ! gi2 `dot` V.fromList ([x2, y2, z2])) 822 | n3 = if (t3 < 0) 823 | then 0 824 | else (t3 ** 4) * (gradients3d ! gi3 `dot` V.fromList ([x3, y3, z3])) 825 | in 826 | 32 * (n0 + n1 + n2 + n3) 827 | 828 | --sum the contributions 829 | 830 | noise4D :: Double -> Double -> Double -> Double -> Double 831 | noise4D x y z w = 832 | --coordinate skewwing/unskewwing 833 | let 834 | f4 = ((sqrt 5) - 1) / 4 835 | g4 = (5 - sqrt 5) / 20 836 | 837 | s = (x + y + z + w) * f4 838 | i = floor (x + s) 839 | j = floor (y + s) 840 | k = floor (z + s) 841 | l = floor (w + s) 842 | 843 | --find first corner 844 | t = fromIntegral (i + j + k + l) * g4 845 | x0 = x - (fromIntegral i - t) 846 | y0 = y - (fromIntegral j - t) 847 | z0 = z - (fromIntegral k - t) 848 | w0 = w - (fromIntegral l - t) 849 | 850 | --figure out corner order via comparisons and then lookup table 851 | c1 = if (x0 > y0) then 32 else 1 852 | c2 = if (x0 > z0) then 16 else 1 853 | c3 = if (y0 > z0) then 8 else 1 854 | c4 = if (x0 > w0) then 4 else 1 855 | c5 = if (y0 > w0) then 2 else 1 856 | c6 = if (z0 > w0) then 1 else 1 857 | c = c1 + c2 + c3 + c4 + c5 + c6 858 | 859 | --the actual lookups... 860 | i1 = (if ((simplex ! c) ! 0 >= 3) then 1 else 0) 861 | j1 = (if ((simplex ! c) ! 1 >= 3) then 1 else 0) 862 | k1 = (if ((simplex ! c) ! 2 >= 3) then 1 else 0) 863 | l1 = (if ((simplex ! c) ! 3 >= 3) then 1 else 0) 864 | 865 | i2 = (if ((simplex ! c) ! 0 >= 2) then 1 else 0) 866 | j2 = (if ((simplex ! c) ! 1 >= 2) then 1 else 0) 867 | k2 = (if ((simplex ! c) ! 2 >= 2) then 1 else 0) 868 | l2 = (if ((simplex ! c) ! 3 >= 2) then 1 else 0) 869 | 870 | i3 = (if ((simplex ! c) ! 0 >= 1) then 1 else 0) 871 | j3 = (if ((simplex ! c) ! 1 >= 1) then 1 else 0) 872 | k3 = (if ((simplex ! c) ! 2 >= 1) then 1 else 0) 873 | l3 = (if ((simplex ! c) ! 3 >= 1) then 1 else 0) 874 | 875 | --actual coordinate calculations 876 | x1 = x0 - fromIntegral i1 + g4 877 | y1 = y0 - fromIntegral j1 + g4 878 | z1 = z0 - fromIntegral k1 + g4 879 | w1 = w0 - fromIntegral l1 + g4 880 | 881 | x2 = x0 - i2 + 2 * g4 882 | y2 = y0 - fromIntegral j2 + 2 * g4 883 | z2 = z0 - fromIntegral k2 + 2 * g4 884 | w2 = w0 - fromIntegral l2 + 2 * g4 885 | 886 | x3 = x0 - i3 + 3 * g4 887 | y3 = y0 - fromIntegral j3 + 3 * g4 888 | z3 = z0 - fromIntegral k3 + 3 * g4 889 | w3 = w0 - fromIntegral l3 + 3 * g4 890 | 891 | x4 = x0 - 1 + 4 * g4 892 | y4 = y0 - 1 + 4 * g4 893 | z4 = z0 - 1 + 4 * g4 894 | w4 = w0 - 1 + 4 * g4 895 | 896 | --find the gradient 897 | ii = i `mod` 256 898 | jj = j `mod` 256 899 | kk = k `mod` 256 900 | ll = l `mod` 256 901 | 902 | gi0 = perm ! (ii + (perm ! (jj + (perm ! (kk + (perm ! ll)))))) `mod` 32 903 | gi1 = 904 | perm 905 | ! ( ii 906 | + i1 907 | + (perm ! (jj + j1 + (perm ! (kk + k1 + (perm ! (ll + l1)))))) 908 | ) 909 | `mod` 32 910 | gi2 = 911 | perm 912 | ! ( ii 913 | + i1 914 | + (perm ! (jj + j2 + (perm ! (kk + k2 + (perm ! (ll + l2)))))) 915 | ) 916 | `mod` 32 917 | gi3 = 918 | perm 919 | ! ( ii 920 | + i1 921 | + (perm ! (jj + j3 + (perm ! (kk + k3 + (perm ! (ll + l3)))))) 922 | ) 923 | `mod` 32 924 | gi4 = 925 | perm 926 | ! (ii + i1 + (perm ! (jj + 1 + (perm ! (kk + 1 + (perm ! (ll + 1))))))) 927 | `mod` 32 928 | 929 | --contributions form each corner 930 | t0 = 0.5 - x0 * x0 - y0 * y0 - z0 * z0 - w0 * w0 931 | t1 = 0.5 - x1 * x1 - y1 * y1 - z1 * z1 - w1 * w1 932 | t2 = 0.5 - x2 * x2 - y2 * y2 - z2 * z2 - w2 * w2 933 | t3 = 0.5 - x3 * x3 - y3 * y3 - z3 * z3 - w3 * w3 934 | t4 = 0.5 - x4 * x4 - y4 * y4 - z4 * z4 - w4 * w4 935 | 936 | n0 = if (t0 < 0) 937 | then 0 938 | else (t0 ** 4) * ((gradients4d ! gi0) `dot` V.fromList [x0, y0, z0, w0]) 939 | n1 = if (t1 < 0) 940 | then 0 941 | else (t1 ** 4) * ((gradients4d ! gi1) `dot` V.fromList [x1, y1, z1, w1]) 942 | n2 = if (t2 < 0) 943 | then 0 944 | else (t2 ** 4) * ((gradients4d ! gi2) `dot` V.fromList [x2, y2, z2, w2]) 945 | n3 = if (t3 < 0) 946 | then 0 947 | else (t3 ** 4) * ((gradients4d ! gi3) `dot` V.fromList [x3, y3, z3, w3]) 948 | n4 = if (t4 < 0) 949 | then 0 950 | else (t4 ** 4) * ((gradients4d ! gi4) `dot` V.fromList [x4, y4, z4, w4]) 951 | in 952 | 27 * (n0 + n1 + n2 + n3 + n4) 953 | --------------------------------------------------------------------------------