reanimate-0.1.9.0: examples/simulate_equation.hs
#!/usr/bin/env stack
-- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Chiphunk.Low
import Control.Monad
import Graphics.SvgTree (Tree)
import Linear.V2
import Reanimate.Chiphunk
import Reanimate
import Reanimate.PolyShape
import System.IO.Unsafe
test :: Animation
test = unsafePerformIO $ do
bodyStore <- newBodyStore
let gravity = Vect 0 (-1)
-- Create an empty space.
space <- spaceNew
-- spaceCollisionSlop space $= (screenWidth/2560)
spaceGravity space $= gravity
-- Add a static line segment shape for the ground.
-- We'll make it slightly tilted so the ball will roll off.
-- We attach it to a static body to tell Chipmunk it shouldn't be movable.
static <- get $ spaceStaticBody space
ground <- segmentShapeNew static
(Vect (-screenWidth/2) (screenHeight/2))
(Vect (screenWidth/2) (-screenHeight/2)) 0
shapeFriction ground $= 1
spaceAddShape space ground
-- Now let's make a ball that falls onto the line and rolls off.
-- First we need to make a cpBody to hold the physical properties of the object.
-- These include the mass, position, velocity, angle, etc. of the object.
-- Then we attach collision shapes to the Body to give it a size and shape.
let toVect (V2 x y) = Vect x y
let svg = center $ scale 2 $ latex "$\\Phi$"
poly = svgToPolyShapes svg
vectGroup = plDecompose' 1 poly
--mkCircle (Num radius)
-- vects = svgToVects svg
-- vects' = fst $ convexHull vects 0
-- svg' =
-- withFillOpacity 0 $ withStrokeColor "white" $
-- withStrokeWidth 0.01 $
-- renderPolyShapes (map plFromPolygon vectGroup)
--
-- ballBody <- polyShapesToBody space poly
-- bodyPosition ballBody $= Vect (-screenWidth/4) (screenHeight/2)
--
-- addToBodyStore bodyStore ballBody $
-- withFillColor "white" $
-- mkGroup
-- [ svg' ]
-- let splitPolys = vectGroup
forM_ vectGroup $ \polygon -> do
bd <- polygonsToBody space [map toVect polygon]
bodyPosition bd $= Vect 0 (screenHeight/3)
addToBodyStore bodyStore bd $
renderPolyShape $ plFromPolygon polygon
-- withFillColor "white" $
-- mkGroup
-- [ --withStrokeWidth (Num 0.005) $
-- -- withStrokeWidth (Num 0.00) $
-- -- withStrokeColor "white" $
-- -- withFillOpacity 1 $
-- renderPolyShape $ plFromPolygon polygon
-- ]
ani <- simulate space bodyStore 60 10 10
spaceFreeRecursive space
return ani
-- data LineCommand
-- = LineMove RPoint
-- -- | LineDraw RPoint
-- | LineBezier [RPoint]
-- | LineEnd
-- vectsToSVG :: [Vect] -> Tree
-- vectsToSVG (Vect x y:rest) =
-- mkPath $
-- MoveTo OriginAbsolute [V2 x y] :
-- [ LineTo OriginAbsolute [V2 a b] | Vect a b <- rest ] ++
-- [ EndPath ]
-- where
-- mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds
-- polygonsToSVG :: [[Vect]] -> Tree
-- polygonsToSVG = merge . mkGroup . map vectsToSVG
-- where
-- merge svg = PathTree $ defaultSvg & pathDefinition .~ extractPath svg
-- svgToVects :: Tree -> [Vect]
-- svgToVects svg = map worker (lineToPoints 200 cmds)
-- where
-- worker (V2 x y) = Vect x y
-- cmds = toLineCommands $ wibble $ extractPath svg
-- wibble xs = takeWhile (/=EndPath) xs ++ [EndPath]
chunkPolyshapes :: Tree -> Tree
chunkPolyshapes t =
mkGroup
[
-- withFillColor "white" $
-- withFillOpacity 1 $
-- withStrokeWidth (Num 0.01) $
-- withStrokeColor "blue" $
-- mkGroup $ map renderPolyShape $
-- map mergePolyShapeHoles $
-- plGroupShapes $
-- -- unionPolyShapes $
-- traceUnion $
-- svgToPolyShapes t
withStrokeWidth 0.001 $
withStrokeColor "red" $
withFillOpacity 0 $
mkGroup $ map renderPolyShape $
svgToPolyShapes t
-- withStrokeWidth 0.001 $
-- withStrokeColor "red" $
-- mkGroup $ map renderPolyShape [pl12,pl13]
]
-- plArea :: PolyShape -> Double
-- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0
-- where
-- toVect (Point x y) = Vect x y
reorient :: Tree -> Tree
reorient = scale 6 . translate 0 (-0.9)
-- traceUnion t =
-- let out = unionPolyShapes t
-- in trace (unlines $
-- ("Trace: " ++ show (sum $ map plArea t)) :
-- ("Check: " ++ show (sum $ map plArea out)) :
-- map show t ++ ["Out:"] ++ map show out) out
-- pl1 = PolyShape {unPolyShape = ClosedPath [(Point 9.076152025049407e-2 0.8793158714390639,JoinLine),(Point 0.48865783997158957 0.5875446050720555,JoinLine),(Point 0.6291445682322502 0.560956966929786,JoinLine),(Point 0.684414274089106 0.6254399758525935,JoinLine),(Point 8.549729225029659e-2 0.9226054512958702,JoinLine)]}
-- pl2 = PolyShape {unPolyShape = ClosedPath [(Point 0.3174796674934045 (-0.17830385091116296),JoinLine),(Point 0.3930521201476444 (-0.22384314349780887),JoinLine),(Point 0.42400439387727545 (-0.17026635397131717),JoinLine),(Point 0.367180526197663 (-0.13743818486413273),JoinLine)]}
-- pl3 = PolyShape {unPolyShape = ClosedPath [(Point 3.818529643334073e-2 4.994390978944008e-2,JoinLine),(Point 3.5509598929490127e-3 3.0061273354143103e-2,JoinLine),(Point 2.6643683455205014e-2 (-1.3314171733262437e-2),JoinLine)]}
-- pl4 = PolyShape {unPolyShape = ClosedPath [(Point 8.041123459068245e-2 (-4.592522065745819e-2),JoinLine),(Point 0.29675416515553454 (-0.17235110729572378),JoinLine),(Point 0.34590008699238584 (-0.13081971694800998),JoinLine),(Point 0.22737727571852562 4.513304505856075e-2,JoinLine),(Point 0.10498823211784264 (-3.373201779345303e-3),JoinLine)]}
-- pl5 = PolyShape {unPolyShape = ClosedPath [(Point 4.1547772506933034e-2 0.10908491253751296,JoinLine),(Point 5.7556283592893165e-2 (-2.2936657573235042e-2),JoinLine),(Point 0.18645395693905423 2.887370173550552e-2,JoinLine),(Point 0.24063435970720265 0.12675372820097613,JoinLine),(Point 0.19807899284556882 0.17285980812856805,JoinLine),(Point 8.45668830191807e-2 0.18680141998908184,JoinLine)]}
-- pl6 = PolyShape {unPolyShape = ClosedPath [(Point (-0.2574090456009813) 0.22352645168090446,JoinLine),(Point (-0.27139525022076605) 0.16073053060077958,JoinLine),(Point (-9.444562231853837e-2) 4.994785063168361e-2,JoinLine),(Point (-4.012849544398306e-2) 6.733655689772311e-2,JoinLine),(Point (-4.6550067413171026e-2) 0.20017002713448606,JoinLine)]}
-- pl7 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3714373753139388) 0.20874389306710772,JoinLine),(Point (-0.29452803703157854) 0.1655072120141602,JoinLine),(Point (-0.2835217605861194) 0.22889335799870397,JoinLine),(Point (-0.34012040364470725) 0.2621083279509192,JoinLine)]}
-- pl8 = PolyShape {unPolyShape = ClosedPath [(Point 0.1712163207191154 0.2149766965620984,JoinLine),(Point 0.19616659305280632 0.1905738263277067,JoinLine),(Point 0.6315796735654418 0.5328570813993471,JoinLine),(Point 0.49895896036053317 0.5862908698518825,JoinLine)]}
-- pl9 = PolyShape {unPolyShape = ClosedPath [(Point 0.10739670009207455 0.19390054402859663,JoinLine),(Point 0.16776933204268935 0.17681618959615353,JoinLine),(Point 0.19166035517967667 0.1970425575035583,JoinLine),(Point 0.16584071117957827 0.2205236594561943,JoinLine)]}
-- pl10 = PolyShape {unPolyShape = ClosedPath [(Point (-0.3669271639958152) 1.1382616686769857,JoinLine),(Point (-0.30169633405804164) 1.1454435521784956,JoinLine),(Point (-0.2858326377769962) 1.2078015601462844,JoinLine),(Point (-0.3736986541543818) 1.199765022618315,JoinLine)]}
-- pl11 = PolyShape {unPolyShape = ClosedPath [(Point (-3.0061173114158422e-2) 1.1779482589541495,JoinLine),(Point 5.4907529076574785e-3 1.2315286122957358,JoinLine),(Point (-3.4177530164954735e-2) 1.2269151735259667,JoinLine)]}
-- pl12 = PolyShape {unPolyShape = ClosedPath
-- [(Point (-0.301730083226429*10) 1.1457103198223786,JoinLine)
-- ,(Point (-0.10299641326632633*10) 1.0714677466302471,JoinLine)
-- ,(Point (-3.162369257155477e-2*10) 1.182092647608354,JoinLine)
-- ,(Point (-3.636877035247056e-2*10) 1.2310026399913667,JoinLine)
-- ,(Point (-0.28589249688644447*10) 1.208074964264014,JoinLine)]}
-- pl13 = PolyShape {unPolyShape = ClosedPath
-- [(Point (-9.39646610882567e-2*10) 0.96018603098516,JoinLine)
-- ,(Point (-6.465077411411442e-2*10) 0.9514465910530718,JoinLine)
-- ,(Point (0.14134955357291654*10) 1.2461928296570437,JoinLine)
-- ,(Point (8.29425965486209e-3*10) 1.2330682613363688,JoinLine)
-- ,(Point (-0.10287959610529117*10) 1.0717052650151784,JoinLine)]}
-- pl14 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6410657779553459) 0.5634659418454123,JoinLine),(Point (-0.641345175626591) 0.555247219163176,JoinLine),(Point (-0.4420444191709594) 0.5513358399243028,JoinLine),(Point (-0.10594072095664082) 0.9023816092645105,JoinLine),(Point (-7.577913627887163e-2) 0.9355404742795719,JoinLine),(Point (-0.10373629906690308) 0.9479533236181756,JoinLine)]}
-- pl15 = PolyShape {unPolyShape = ClosedPath [(Point (-3.523485505752828e-2) 0.1998408875682416,JoinLine),(Point 1.2546982880291841e-2 0.15208851089779252,JoinLine),(Point 0.13018455413761065 0.208301106923033,JoinLine),(Point 8.433578523127425e-2 0.9418697065712005,JoinLine),(Point (-7.884702019521485e-2) 0.932428903501462,JoinLine),(Point (-8.084970167352624e-2) 0.9296667902794287,JoinLine)]}
-- pl16 = PolyShape {unPolyShape = ClosedPath [(Point (-7.878197627394322e-2) 0.9319709148544943,JoinLine),(Point 8.438182768423004e-2 0.941734614325483,JoinLine),(Point 8.518191684165782e-2 0.9853357574063363,JoinLine),(Point 8.15663333974107e-2 0.9853939259545145,JoinLine),(Point (-4.936159754845773e-2) 0.9727171460725276,JoinLine)]}
-- pl17 = PolyShape {unPolyShape = ClosedPath [(Point (-4.99911351869741e-2) 0.9726181699897635,JoinLine),(Point 8.094809532371453e-2 0.9851776987711782,JoinLine),(Point 7.384845354621125e-2 1.0968271981504014,JoinLine),(Point 4.400324523877765e-2 1.1025518925313644,JoinLine)]}
-- pl18 = PolyShape {unPolyShape = ClosedPath [(Point 4.8482888984171635e-2 1.1105768787999895,JoinLine),(Point 7.512899062784217e-2 1.0959654499901599,JoinLine),(Point 0.2822087302816073 1.1420633097553252,JoinLine),(Point 0.27513287205836434 1.2060076125068004,JoinLine),(Point 0.20204313118994668 1.2231219927110881,JoinLine)]}
-- pl19 = PolyShape {unPolyShape = ClosedPath [(Point 0.2748784478150325 1.2078902086770202,JoinLine),(Point 0.2820822061918643 1.1439601884266248,JoinLine),(Point 0.3457225261391361 1.127943000720636,JoinLine),(Point 0.36082444597621127 1.187946730956635,JoinLine)]}
-- pl20 = PolyShape {unPolyShape = ClosedPath [(Point (-0.6864531908080556) 0.5032767356555317,JoinLine),(Point (-9.929294916146593e-2) 0.20829491627795255,JoinLine),(Point (-8.483230342755331e-2) 0.23523598173633797,JoinLine),(Point (-0.49217693932265094) 0.547917843618004,JoinLine)]}
-- pl21 = PolyShape {unPolyShape = ClosedPath [(Point (-9.274301086931341e-2) 0.2153671046631685,JoinLine),(Point (-4.68781647762479e-2) 0.2005165600411279,JoinLine),(Point (-4.790067311086227e-2) 0.23865704773924823,JoinLine),(Point (-7.795810209993242e-2) 0.2330461435659677,JoinLine)]}
-- unionTest = parsed
-- where
-- svg = center $ scale 2 $ latex "I"
-- poly = svgToPolyShapes svg
-- vectGroup = plDecompose' 1 poly
-- rendered = mkGroup $ take 100 $ map (renderPolyShape . plFromPolygon) vectGroup
-- parsed = svgToPolyShapes rendered
--
-- myDecompose tol =
-- concatMap decomposePolygon .
-- map (plPolygonify tol) .
-- map mergePolyShapeHoles .
-- plGroupShapes .
-- unionPolyShapes
main :: IO ()
main = reanimate $ bg `parA` mapA reorient (line `parA` mapA chunkPolyshapes test)
where
bg = animate $ const $ mkBackground "black"
line = animate $ const $ withStrokeColor "white" $
withStrokeWidth 0.01 $
mkLine (-screenWidth/2, screenHeight/2)
(screenWidth/2, -screenHeight/2)