Sutherland-Hodgman polygon clipping

Main.elm

module Main exposing (..)

import Point2d exposing (Point2d)
import Svg exposing (Svg)
import Svg.Attributes exposing (fill, strokeWidth, stroke, width, height, viewBox, cx, cy, r, strokeOpacity)
import Html exposing (text)
import Geometry.Svg
import Polygon2d
import Html.Attributes exposing (style, defaultValue)
import BoundingBox2d
import Polygon2d exposing (Polygon2d)
import Html.Events
import Json.Decode as Decode
import SutherlandHodgman


main =
    view ()


myPolygon =
    Polygon2d.singleLoop <|
        List.map Point2d.fromCoordinates
            [ ( 10, 10 )
            , ( 100, 10 )
            , ( 120, 50 )
            , ( 120, 100 )
            , ( 60, 100 )
            , ( 20, 120 )
            ]


bbox1 =
    BoundingBox2d.fromExtrema
        { minX = 0
        , maxX = 75
        , minY = 0
        , maxY = 150
        }


bbox2 =
    BoundingBox2d.fromExtrema
        { minX = 0
        , maxX = 75
        , minY = 0
        , maxY = 50
        }


view _ =
    let
        targetValueFloat =
            Html.Events.targetValue
                |> Decode.andThen
                    (\value ->
                        case String.toFloat value of
                            Ok v ->
                                Decode.succeed v

                            Err e ->
                                Decode.fail e
                    )
    in
        Html.div []
            [ Svg.svg [ fill "none", stroke "black", strokeWidth "2", width "200", height "200" ] [ Geometry.Svg.polygon2d [] myPolygon ]
            , Svg.svg [ fill "none", stroke "black", strokeWidth "2", width "200", height "200" ]
                [ Geometry.Svg.polygon2d [ Svg.Attributes.strokeDasharray "2" ] (myPolygon)
                , Geometry.Svg.polygon2d [] (SutherlandHodgman.clipToBoundingBox bbox1 myPolygon)
                , Geometry.Svg.boundingBox2d [ Svg.Attributes.strokeDasharray "4" ] bbox1
                ]
            , Svg.svg [ fill "none", stroke "black", strokeWidth "2", width "200", height "200" ]
                [ Geometry.Svg.polygon2d [ Svg.Attributes.strokeDasharray "2" ] (myPolygon)
                , Geometry.Svg.polygon2d [] (SutherlandHodgman.clipToBoundingBox bbox2 myPolygon)
                , Geometry.Svg.boundingBox2d [ Svg.Attributes.strokeDasharray "4" ] bbox2
                ]
            ]

SutherlandHodgman.elm

module SutherlandHodgman exposing (..)

import Point2d exposing (Point2d)
import BoundingBox2d exposing (BoundingBox2d)
import LineSegment2d exposing (LineSegment2d)
import Polygon2d exposing (Polygon2d)
import Direction2d exposing (Direction2d)
import Axis2d exposing (Axis2d)


lineSegmentToAxis : LineSegment2d -> Maybe Axis2d
lineSegmentToAxis lineSegment =
    let
        ( start, end ) =
            LineSegment2d.endpoints lineSegment
    in
        case Direction2d.from start end of
            Nothing ->
                Nothing

            Just direction ->
                Just (Axis2d.through start direction)


{-| Intersect the line segment (p0,p1) with the clipping line's left halfspace,
   returning the point closest to p1.  In the special case where p0 lies outside
   the halfspace and p1 lies inside we return both the intersection point and
   p1.  This ensures we will have the necessary segment along the clipping line.
-}
intersectWithClippingLine : LineSegment2d -> Axis2d -> List Point2d
intersectWithClippingLine lineSegment clipAxis =
    let
        ( start, end ) =
            LineSegment2d.endpoints lineSegment
    in
        case ( Point2d.signedDistanceFrom clipAxis start >= 0, Point2d.signedDistanceFrom clipAxis end >= 0 ) of
            ( False, False ) ->
                []

            ( False, True ) ->
                case intersectionWithAxis clipAxis lineSegment of
                    Nothing ->
                        -- impossible
                        []

                    Just isect ->
                        [ isect, end ]

            ( True, False ) ->
                case intersectionWithAxis clipAxis lineSegment of
                    Nothing ->
                        -- impossible
                        []

                    Just isect ->
                        [ isect ]

            ( True, True ) ->
                [ end ]


intersectWithLeftHalfspace : Polygon2d -> Axis2d -> Polygon2d
intersectWithLeftHalfspace poly axis =
    Polygon2d.singleLoop <| List.concatMap (\segment -> intersectWithClippingLine segment axis) (Polygon2d.edges poly)


{-| Intersect a target polygon with a clipping polygon.  The latter is assumed to
be convex.
-}
clipTo : Polygon2d -> Polygon2d -> Polygon2d
clipTo clipPolygon polygon =
    let
        clipLines =
            Polygon2d.edges clipPolygon
                |> List.filterMap lineSegmentToAxis
    in
        List.foldl (flip intersectWithLeftHalfspace) polygon clipLines


{-| Clip a polygon to a bounding box
-}
clipToBoundingBox : BoundingBox2d -> Polygon2d -> Polygon2d
clipToBoundingBox boundingBox polygon =
    let
        { minX, maxX, minY, maxY } =
            BoundingBox2d.extrema boundingBox

        boundingBoxPolygon =
            Polygon2d.singleLoop
                [ Point2d.fromCoordinates ( minX, minY )
                , Point2d.fromCoordinates ( minX, maxY )
                , Point2d.fromCoordinates ( maxX, maxY )
                , Point2d.fromCoordinates ( maxX, minY )
                ]
    in
        clipTo boundingBoxPolygon polygon



-- backport


intersectionWithAxis : Axis2d -> LineSegment2d -> Maybe Point2d
intersectionWithAxis axis lineSegment =
    let
        ( p1, p2 ) =
            LineSegment2d.endpoints lineSegment

        d1 =
            Point2d.signedDistanceFrom axis p1

        d2 =
            Point2d.signedDistanceFrom axis p2

        product =
            d1 * d2
    in
        if product < 0 then
            -- The two points are on opposite sides of the axis, so there is a
            -- unique intersection point in between them
            Just (Point2d.interpolateFrom p1 p2 (d1 / (d1 - d2)))
        else if product > 0 then
            -- Both points are on the same side of the axis, so no intersection
            -- point exists
            Nothing
        else if d1 /= 0 then
            -- d2 must be zero since the product is zero, so only p2 is on the axis
            Just p2
        else if d2 /= 0 then
            -- d1 must be zero since the product is zero, so only p1 is on the axis
            Just p1
        else if p1 == p2 then
            -- Both d1 and d2 are zero, so both p1 and p2 are on the axis but also
            -- happen to be equal to each other, so the line segment is actually
            -- just a single point on the axis
            Just p1
        else
            -- Both endpoints lie on the axis and are not equal to each other - no
            -- unique intersection point
            Nothing