mirror of
https://github.com/reanimate/reanimate.git
synced 2026-09-10 23:52:22 +00:00
135 lines
4.2 KiB
Haskell
Executable file
135 lines
4.2 KiB
Haskell
Executable file
#!/usr/bin/env stack
|
|
-- stack runghc --package reanimate
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Main (main) where
|
|
|
|
import Chiphunk.Low
|
|
import Control.Monad
|
|
import Graphics.SvgTree (Tree)
|
|
import Linear.V2
|
|
import Reanimate
|
|
import Reanimate.Chiphunk
|
|
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) 0)
|
|
(Vect (screenWidth/2) (-screenHeight/2)) 0
|
|
-- ground <- polyShapeNewRaw static
|
|
-- [ Vect (-screenWidth/2) (screenHeight/2)
|
|
-- , Vect (screenWidth/2) (-screenHeight/2)
|
|
-- , 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 "\\LaTeX"
|
|
poly = svgToPolyShapes svg
|
|
vectGroup = plDecompose 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 60 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 =
|
|
withStrokeColor "white" $
|
|
withStrokeWidth 0.01 $
|
|
withFillColor "white" $ t
|
|
|
|
-- plArea :: PolyShape -> Double
|
|
-- plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0
|
|
-- where
|
|
-- toVect (Point x y) = Vect x y
|
|
|
|
reorient :: Tree -> Tree
|
|
reorient = id -- scale 4 . translate 0 (-0.9)
|
|
|
|
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, 0)
|
|
(screenWidth/2, -screenHeight/2)
|