Guest User

Untitled

a guest
May 21st, 2018
139
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 1.71 KB | None | 0 0
  1. type SpringMesh = Space2d Mover
  2.  
  3. updateSpringMesh :: Rect -> SpringMesh -> SpringMesh
  4. updateSpringMesh rect springMesh = Space2d.mapWithKey springify springMesh
  5. where
  6. springify index mover =
  7. let movers = Space2d.neighbors index springMesh
  8. in update
  9. . bounceRect rect
  10. . applyFriction 0.05
  11. . applyGravity 0.2 (V2 0 0.1)
  12. . addForces (map springForce movers)
  13. $ mover
  14. springForce mover = SpringForce
  15. (mass mover / 50)
  16. Spring { springAnchor = location mover, springLength = 2 * fromRational (spaceSize springMesh) }
  17.  
  18. drawSpace :: Space2d Mover -> Render ()
  19. drawSpace space = do
  20. let
  21. drawMover mover = do
  22. drawV2 (mass mover / 20) (location mover)
  23. setSourceHsv charcoal *> fill
  24.  
  25. setLineWidth 0.2
  26. void . flip M.traverseWithKey (getSpace2d space) $ \index mover -> do
  27. for_ (Space2d.neighbors index space) $ \neighbor -> do
  28.  
  29. drawLineSegment $ LineSegment (location mover) (location neighbor)
  30. setSourceHsv charcoal *> stroke
  31.  
  32. drawMover mover
  33.  
  34. genMesh :: Generate SpringMesh
  35. genMesh = do
  36. rect <- scaleRect 0.8 <$> getBoundingRect
  37. fromShapeM rect 3 $ \index -> do
  38. newMover <$> runRVar (D.normal 3 0.5) <*> pure (fromRational <$> index)
  39.  
  40. renderSketch :: Generate ()
  41. renderSketch = do
  42. let ghostWhite = HSV 240 0.03 1
  43. fillScreenHsv ghostWhite
  44.  
  45. cairo $ setLineCap LineCapRound
  46. cairo $ setLineJoin LineJoinRound
  47.  
  48. mesh <- genMesh
  49. rect <- getBoundingRect
  50.  
  51. let
  52. updatedMeshes = iterate (updateSpringMesh rect) mesh
  53.  
  54. for_ (take 200 updatedMeshes) $ \mesh -> do
  55. fillScreenHsva (ghostWhite `WithAlpha` 0.1)
  56. cairo $ drawSpace mesh
  57. renderProgress
  58.  
  59. render :: IO ()
  60. render = mainIOWith (\opts -> opts{ optWidth = 100, optHeight = 100 }) renderSketch
Add Comment
Please, Sign In to add comment