sloosch/Main.js

## 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"
  }
}

## 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>

## Main.js
//module Main

exports.requestAnimationFrame = function (eff) {
    return function requestFrame() {
        return window.requestAnimationFrame(eff());
    };
};

## 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
	{
	"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"
	}
	}
	<!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>
	//module Main

	exports.requestAnimationFrame = function (eff) {
	return function requestFrame() {
	return window.requestAnimationFrame(eff());
	};
	};
	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