Skip to content

Instantly share code, notes, and snippets.

@sloosch

sloosch/Main.js

Last active February 28, 2016 21:10
Show Gist options
  • Save sloosch/6f52ac1754c2d35949c9 to your computer and use it in GitHub Desktop.
Save sloosch/6f52ac1754c2d35949c9 to your computer and use it in GitHub Desktop.
Download ZIP
Purescript Gravity
Raw
bower.json
{
"name": "quad",
"version": "1.0.0",
"moduleType": [
"node"
],
"ignore": [
"**/.*",
"node_modules",
"bower_components",
"output"
],
"dependencies": {
"purescript-console": "^0.1.0",
"purescript-eff": "^0.1.2",
"purescript-maybe": "^0.3.5",
"purescript-canvas": "^0.4.0",
"purescript-math": "^0.2.0",
"purescript-random": "^0.2.3",
"purescript-prelude": "^0.1.4",
"purescript-tuples": "^0.4.0",
"purescript-integers": "^0.2.1",
"purescript-arrays": "^0.4.5"
}
}
Raw
index.html
<!DOCTYPE html>
<html>
<head>
<meta charset="utf-8">
<title></title>
</head>
<body style="background: #000;">
<canvas id="gravity" style="margin: 0 auto;"></canvas>
<script src="app.js" charset="utf-8"></script>
</body>
</html>
Raw
Main.js
//module Main
exports.requestAnimationFrame = function (eff) {
return function requestFrame() {
return window.requestAnimationFrame(eff());
};
};
Raw
Main.purs
module Main where
import Prelude
import Control.Monad.Eff
import Data.Array (catMaybes, uncons, snoc, filter)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable (foldl, for_)
import Data.Tuple (Tuple(..))
import Math as Math
import Data.Bifunctor (bimap)
import Data.Int as I
import Graphics.Canvas
import Control.Monad.Eff.Random as R
type Mass = Number
type Diameter = Number
type Force = Number
type Distance = Number
type TimeStep = Number
data Point = Point Number Number
data MassPoint = MassPoint Point Mass
data ForceOn a = ForceOn a (Tuple Force Force)
data Node a = Branch (Array (Node a)) MassPoint Diameter | Leaf a MassPoint
data Bounds = Bounds Point Point
data Color = Color Int Int Int Number
data NaturalObject = NaturalObject MassPoint (Tuple Force Force) Color | FixObject NaturalObject
class HasCenter a where
centerPoint :: a -> Point
class HasMass a where
massOf :: a -> Mass
class CanMove a where
moveBy :: (Tuple Distance Distance) -> a -> a
class HasForce a where
forceOf :: a -> Tuple Force Force
applyForceTo :: Tuple Force Force -> a -> a
class CanDraw a where
drawToCanvas :: ∀ eff. Context2D -> a -> Eff (canvas :: Canvas | eff) Context2D
class (HasCenter a, HasMass a, HasForce a, CanMove a, CanDraw a) <= TangibleObject a
instance hasCenterPoint :: HasCenter (Point) where
centerPoint = id
instance hasCenterMassPoint :: HasCenter (MassPoint) where
centerPoint (MassPoint p _) = p
instance hasMassMassPoint :: HasMass (MassPoint) where
massOf (MassPoint _ m) = m
instance hasCenterNode :: HasCenter (Node a) where
centerPoint (Branch _ mp _) = centerPoint mp
centerPoint (Leaf _ mp) = centerPoint mp
instance hasMassNode :: HasMass (Node a) where
massOf (Branch _ mp _) = massOf mp
massOf (Leaf _ mp) = massOf mp
instance canMovePoint :: CanMove (Point) where
moveBy (Tuple dx dy) (Point x y) = Point (x + dx) (y + dy)
instance canMoveMassPoint :: CanMove (MassPoint) where
moveBy d (MassPoint mp m) = MassPoint (moveBy d mp) m
instance hasCenterNaturalObject :: HasCenter (NaturalObject) where
centerPoint (NaturalObject mp _ _) = centerPoint mp
centerPoint (FixObject o) = centerPoint o
instance hasMassNaturalObject :: HasMass (NaturalObject) where
massOf (NaturalObject mp _ _) = massOf mp
massOf (FixObject o) = massOf o
instance hasForceNaturalObject :: HasForce (NaturalObject) where
forceOf (NaturalObject _ f _) = f
forceOf _ = Tuple 0.0 0.0
applyForceTo (Tuple fx2 fy2) (NaturalObject mp (Tuple fx1 fy1) c) = NaturalObject mp (Tuple (fx1 + fx2) (fy1 + fy2)) c
applyForceTo _ o = o
instance canMoveNaturalObject :: CanMove (NaturalObject) where
moveBy d (NaturalObject mp f c) = NaturalObject (moveBy d mp) f c
moveBy _ o = o
instance canDrawNaturalObject :: CanDraw (NaturalObject) where
drawToCanvas ctx (NaturalObject (MassPoint (Point x y) m) (Tuple fx fy) (Color r g b a)) = do
setFillStyle fillstyle ctx :: ∀ eff. Eff (canvas :: Canvas| eff) Context2D
fillRect ctx {x: x - radius / 2.0, y: y - radius / 2.0, w: radius, h: radius}
where
-- dense places are glowing...
-- assuming density correlates with the force : small force -> high density
rmsf = Math.min 1.0 $ (Math.abs fx + Math.abs fy) * 9E3 -- magic number...
rbMix = r - b
fillstyle = "rgba(" ++ (show $ intScale rbMix (1.0 - rmsf)) ++ "," ++ (show g) ++ "," ++ (show $ intScale rbMix rmsf) ++ "," ++ (show $ a * (1.0 - rmsf)) ++ ")"
radius = Math.min 10.0 $ Math.max 1.0 $ m / 10000.0
intScale :: Int -> Number -> Int
intScale i d = I.round $ d * I.toNumber i
drawToCanvas ctx (FixObject o) = drawToCanvas ctx o
instance tangibleObjectNaturalObject :: TangibleObject (NaturalObject)
pointX :: Point -> Number
pointX (Point x _) = x
pointY :: Point -> Number
pointY (Point _ y) = y
boundsWidth :: Bounds -> Number
boundsWidth (Bounds (Point x1 _) (Point x2 _)) = x2 - x1
boundsHeight :: Bounds -> Number
boundsHeight (Bounds (Point _ y1) (Point _ y2)) = y2 - y1
isInBounds :: ∀ p. (HasCenter p) => Bounds -> p -> Boolean
isInBounds (Bounds (Point x1 y1) (Point x2 y2)) p = case centerPoint p of
(Point cpx cpy) -> cpx >= x1 && cpx < x2 && cpy >= y1 && cpy < y2
intersectWithBounds :: ∀ p. (HasCenter p) => Array p -> Bounds -> Maybe (Array p)
intersectWithBounds pc b =
case filter (isInBounds b) pc of
[] -> Nothing
pcs -> Just pcs
massPointOfPoints :: ∀ p. (HasCenter p, HasMass p) => Array p -> MassPoint
massPointOfPoints pc = case uncons pc of
Nothing -> MassPoint zeroPoint 0.0
Just {head: p, tail: ps} ->
let startPoint = centerPoint p
startMass = massOf p
startMassPoint = MassPoint (Point (pointX startPoint * startMass) (pointY startPoint * startMass)) startMass in
case foldl f startMassPoint ps of
MassPoint (Point x y) m -> MassPoint (Point (x / m) (y / m)) m
where
f :: MassPoint -> p -> MassPoint
f (MassPoint (Point x y) mass) p =
MassPoint (Point (x + pointX cPoint * cMass) (y + pointY cPoint * cMass)) (cMass + mass)
where
cPoint = centerPoint p
cMass = massOf p
quadBounds :: Bounds -> Array Bounds
quadBounds bb@(Bounds top@(Point x1 y1) bottom@(Point x2 y2)) = [q1, q2, q3, q4]
where
midX = x1 + (boundsWidth bb) / 2.0
midY = y1 + (boundsHeight bb) / 2.0
midPoint = Point midX midY
q1 = Bounds top midPoint
q2 = Bounds (Point midX y1) (Point x2 midY)
q3 = Bounds (Point x1 midY) (Point midX y2)
q4 = Bounds midPoint bottom
mkQuadTree :: ∀ p. (HasCenter p, HasMass p) => Bounds -> Array p -> Node p
mkQuadTree _ [p] = Leaf p $ MassPoint (centerPoint p) (massOf p)
mkQuadTree b pc = Branch childNodes (massPointOfPoints pc) (boundsHeight b)
where
childNodes = catMaybes $ splitBranch <$> quadBounds b
splitBranch :: Bounds -> Maybe (Node p)
splitBranch bb = mkQuadTree bb <$> intersectWithBounds pc bb
gConst :: Number
gConst = 6.67408E-11
gSmooth :: Number
gSmooth = 6E8
diameterDistanceRatio :: Number
diameterDistanceRatio = 1.3
approxDistance :: ∀ a b. (HasCenter a, HasCenter b) => a -> b -> Distance
approxDistance p1 p2 = approxDistance' (centerPoint p1) (centerPoint p2)
where
approxDistance' p1 p2 =
approxDistanceDelta dx dy
where
dx = pointX p2 - pointX p1
dy = pointY p2 - pointY p1
approxDistanceDelta :: Number -> Number -> Distance
approxDistanceDelta a b = Math.abs a + Math.abs b
gForce :: ∀ a b. (HasCenter a, HasMass a, HasCenter b, HasMass b) => a -> b -> Tuple Force Force
gForce p1 p2 = calcForce distance
where
cp1 = centerPoint p1
cp2 = centerPoint p2
dx = pointX cp2 - pointX cp1
dy = pointY cp2 - pointY cp1
distance = approxDistanceDelta dx dy
calcForce :: Distance -> Tuple Force Force
calcForce 0.0 = Tuple 0.0 0.0
calcForce d = Tuple xp yp
where
f = (massOf p1) * (massOf p2) / (d * d + gSmooth) * gConst
phi = Math.atan2 dy dx
xp = f * Math.cos phi
yp = f * Math.sin phi
calcGForce :: ∀ p. (HasCenter p, HasMass p) => Bounds -> Number -> Array p -> Array (ForceOn p)
calcGForce treeBounds dr pc = calcForceOn <$> pc
where
root = mkQuadTree treeBounds pc
calcForceOn :: p -> ForceOn p
calcForceOn p = ForceOn p $ goCalcForce p root
where
goCalcForce :: p -> Node p -> Tuple Force Force
goCalcForce act n@(Leaf _ _) = gForce act n
goCalcForce act n@(Branch children _ diameter)
| diameter / (approxDistance act n) < dr = gForce act n
| otherwise = foldl (\(Tuple fx fy) -> bimap (+ fx) (+ fy)) (Tuple 0.0 0.0) (goCalcForce act <$> children)
applyKineticForce :: ∀ p. (HasMass p, CanMove p, HasForce p) => Number -> TimeStep -> Array (ForceOn p) -> Array p
applyKineticForce efficency t pc = move <$> pc
where
move :: ForceOn p -> p
move (ForceOn p ff) = moveBy (bimap delta delta $ forceOf pWithForce) pWithForce
where
mass = massOf p
pWithForce = applyForceTo (bimap (* efficency) (* efficency) ff) p
delta :: Force -> Distance
delta f = (f / mass) / 2.0 * t * t
zeroPoint :: Point
zeroPoint = Point 0.0 0.0
mkNaturalObject :: Number -> Number -> Number -> Color -> NaturalObject
mkNaturalObject x y m c = NaturalObject (MassPoint (Point x y) m) (Tuple 0.0 0.0) c
canvasWidth :: Number
canvasWidth = 1280.0
canvasHeight :: Number
canvasHeight = 720.0
getContext :: ∀ eff. String -> Eff (canvas :: Canvas | eff) Context2D
getContext name =
fromJust <$> getCanvasElementById name
>>= setCanvasWidth canvasWidth
>>= setCanvasHeight canvasHeight
>>= getContext2D
foreign import data FRAME :: !
foreign import requestAnimationFrame :: ∀ eff1 eff2 a. (Unit -> Eff eff1 a) -> Eff (frame :: FRAME | eff2) Unit
animate :: ∀ p eff. (TangibleObject p) => Context2D -> Array p -> Eff (frame :: FRAME, canvas :: Canvas | eff) Unit
animate ctx pc = requestAnimationFrame $ const do
setFillStyle "rgba(0,0,0,0.5)" ctx
fillRect ctx {x: 0.0, y: 0.0, w: canvasWidth, h: canvasHeight}
for_ pc $ drawToCanvas ctx
requestAnimationFrame \_ -> animate ctx $ applyKineticForce 0.8 100000.0 $ calcGForce treeBounds diameterDistanceRatio pc
where
treeBounds = Bounds (Point 0.0 0.0) (Point canvasWidth canvasHeight)
particleSpot :: ∀ eff. Number -> Number -> Int -> Diameter -> Color -> Eff (random :: R.RANDOM | eff) (Array NaturalObject)
particleSpot massLo massHi = go []
where
go :: Array NaturalObject -> Int -> Diameter -> Color -> Eff (random :: R.RANDOM | eff) (Array NaturalObject)
go os 0 _ _ = return os
go os num radius color = do
r1 <- R.random
r2 <- R.random
r3 <- R.random
m1 <- R.random
m2 <- R.random
m3 <- R.random
phi <- R.randomRange 0.0 $ 2.0 * Math.pi
let rr = (r1 + r2 + r3) / 3.0
r = rr * radius
m = (1.3 - rr) * (m1 + m2 + m3) / 3.0 * massHi + massLo
f = rr * (1.0 / gSmooth) * m * 1.3 -- magic numbers...
ff = Tuple (Math.cos (phi - Math.pi / 2.0) * f) (Math.sin (phi - Math.pi / 2.0) * f)
obj = applyForceTo ff $ mkNaturalObject (r * Math.cos phi) (r * Math.sin phi) m color
go (snoc os obj) (num - 1) radius color
main :: ∀ eff. Eff (random :: R.RANDOM, frame :: FRAME, canvas :: Canvas | eff) Unit
main = do
ctx <- getContext "gravity"
objs1 <- particleSpot 10.0 100000.0 1200 0.25 (Color 255 0 0 1.0)
-- objs2 <- particleSpot 10.0 100000.0 750 0.1 (Color 200 0 0 1.0)
let galaxy1 = translate 0.5 0.5 <$> scale 1.5 1.0 <$> objs1 <> [mkNaturalObject 0.0 0.0 350000000.0 (Color 255 255 255 1.0)]
-- galaxy2 = translate 0.6 0.6 <$> scale 1.0 1.8 <$> objs2 <> [mkNaturalObject 0.0 0.0 10000000.0 (Color 255 255 255 1.0)]
animate ctx $ scale canvasWidth canvasHeight <$> (galaxy1 {-- <> galaxy2 –-})
where
translate :: Number -> Number -> NaturalObject -> NaturalObject
translate xx yy (NaturalObject (MassPoint (Point x y) m) ff c) = NaturalObject (MassPoint (Point (x + xx) (y + yy)) m) ff c
translate xx yy (FixObject o) = FixObject $ translate xx yy o
scale :: Number -> Number -> NaturalObject -> NaturalObject
scale w h (NaturalObject (MassPoint (Point x y) m) ff c) = NaturalObject (MassPoint (Point (x * w) (y * h)) m) ff c
scale w h (FixObject o) = FixObject $ scale w h o
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment