perspective.hs

newtype Face = Face { getFace :: Polygon }
newtype Box = Box { getBox :: [Face] }

drawFace face = do
  brightness <- getRandomR (0.4,0.6)
  cairo $ do
    draw (getFace face)
    setSourceHsv (HSV 0 0 brightness) *> fillPreserve
    setSourceHsv (HSV 0 0 0) *> stroke

drawRandomBoxIn :: ContainsPoints shape => shape -> P -> P -> Generate ()
drawRandomBoxIn shape vp1 vp2 = do
  point <- genPointIn shape
  lerp1 <- getRandomR (0.05,0.15)
  lerp2 <- getRandomR (0.05,0.15)

  let
    height = 20

  let
    isUpper = point ^. _y < 50
    isLower = point ^. _y > 60

    midLine = LineSegment point bottomPoint

    ls1 = LineSegment vp1 point
    ls2 = LineSegment vp2 point
    bottomPoint = point - V2 0 height
    lsb1 = LineSegment vp1 bottomPoint
    lsb2 = LineSegment vp2 bottomPoint

    vPoint1 = lerpSegment lerp1 ls1
    vPoint2 = lerpSegment lerp2 ls2

    vs1 = clipIntersection (LineSegment vPoint1 (vPoint1 - V2 0 height)) lsb1
    vs2 = clipIntersection (LineSegment vPoint2 (vPoint2 - V2 0 height)) lsb2

    op1
      | isUpper = Just $ LineSegment (lineStart vs1) vp2
      | isLower = Just $ LineSegment (lineEnd vs1) vp2
      | otherwise = Nothing

    op2
      | isUpper = Just $ LineSegment (lineStart vs2) vp1
      | isLower = Just $ LineSegment (lineEnd vs2) vp1
      | otherwise = Nothing

    opIntersectionPoint = case (op1,op2) of
      (Just seg1, Just seg2) -> segmentIntersectionPoint seg1 seg2
      _                      -> Nothing

    faces = catMaybes
      [ Just . Face . Polygon $ [point, vPoint1, lineEnd vs1, bottomPoint]
      , Just . Face . Polygon $ [point, vPoint2, lineEnd vs2, bottomPoint]
      , flip fmap opIntersectionPoint $ \pt ->
          Face . Polygon $ if isLower then
            [bottomPoint, lineEnd vs1, pt, lineEnd vs2]
            else [point, vPoint1, pt, vPoint2]
      ]

  for_ faces drawFace