This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment