hgeometry-0.12.0.0: src/Algorithms/Geometry/RedBlueSeparator/RIC.hs
--------------------------------------------------------------------------------
-- |
-- Module : Algorithms.Geometry.RedBlueSeparator.RIC
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--
-- Given a set of red points and a set of blue points in \(\mathbb{R}^2\) finds
-- a separating line in \(O(n)\) expected time, where \(n\) is the total number
-- of points.
--
--------------------------------------------------------------------------------
module Algorithms.Geometry.RedBlueSeparator.RIC where
import Algorithms.Geometry.LinearProgramming.LP2DRIC
import Algorithms.Geometry.LinearProgramming.Types
import Control.Applicative ((<|>))
import Control.Lens hiding (below)
import Control.Monad.Random.Class
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.HalfSpace
import Data.Geometry.Line
import Data.Geometry.Point
import Data.Geometry.Vector
import Data.Ord (comparing)
import Data.Semigroup.Foldable
import Data.Util
--------------------------------------------------------------------------------
-- -- | Given a set of red points and a set of blue points in \(\mathbb{R}^2\)
-- -- finds a separating line (if it exists). The result is strict in the
-- -- sense that there will not be any points on the line.
-- --
-- --
-- -- running time: \(O(n)\) expected time, where \(n\) is the total number
-- -- of points.
-- strictSeparatingLine = undefined
-- | Given a set of red points and a set of blue points in \(\mathbb{R}^2\)
-- finds a separating line (if it exists). The result is non-strict in the
-- sense that there may be points *on* the line.
--
--
-- running time: \(O(n)\) expected time, where \(n\) is the total number
-- of points.
separatingLine :: (MonadRandom m, Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine reds blues = do l <- separatingLine' reds blues
m <- separatingLine' blues reds
pure $ l <|> m
-- | Given a set of red points and a set of blue points in \(\mathbb{R}^2\)
-- finds a separating line (if it exists) that has all red points *right* (or
-- on) the line, and all blue points left (or on) the line.
--
-- running time: \(O(n)\) expected time, where \(n\) is the total number
-- of points.
separatingLine' :: (MonadRandom m, Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine' reds blues = case verticalSeparatingLine reds blues of
SP Nothing (r:+_,b :+ _) -> separatingLine'' r b reds blues
-- observe that if r and b were vertically above each other then we would
-- have found a separating line. So r and b are not vertically
-- aligned. Hence we satisfy the precondition.
SP ml@(Just _) _ -> pure ml -- already found a line
-- | given a red and blue point that are *NOT* vertically alligned, and all red
-- and all blue points, try to find a non-vertical separating line.
--
-- running time: \(O(n)\) expected time, where \(n\) is the total number
-- of points.
separatingLine'' :: (MonadRandom m, Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> Point 2 r -- ^ red point r
-> Point 2 r -- ^ a blue point b
-> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine'' r b reds blues = fmap mkLine <$> solveBoundedLinearProgram lp
where
lp = LinearProgram c ([mkRed r, mkBlue b] <> hs)
c = case (r^.xCoord) `compare` (b^.xCoord) of
LT -> Vector2 (-1) 0 -- minimize a
GT -> Vector2 1 0 -- maximize a
EQ -> error "separatingLine'': precondition failed. r and b vertically above each other"
mkLine (Point2 aa bb) = fromLinearFunction aa bb
-- red points generate the constraint: ry <= a*rx + b <=> b >= (-rx)a + ry
mkRed (Point2 rx ry) = above $ fromLinearFunction ((-1)*rx) ry
-- blue points generate the constraint: by >= a*bx + b <=> b <= (-bx)a + by
mkBlue (Point2 bx by) = below $ fromLinearFunction ((-1)*bx) by
hs = [mkRed rr | (rr :+ _) <- F.toList reds] <> [mkBlue bb | (bb :+ _) <- F.toList blues]
--------------------------------------------------------------------------------
-- * Vertical Separators
-- | Computes a strict vertical separating line, if one exists
strictVerticalSeparatingLine :: (Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> Maybe (Line 2 r)
strictVerticalSeparatingLine reds blues = do let (r,b) = extremalPoints reds blues
rx = r^.core.xCoord
bx = b^.core.xCoord
if bx < rx
then Just . verticalLine $ (rx + bx) / 2
else Nothing -- no vertical separator
-- | Test if there is a vertical separating line that has all red points to its
-- right (or on it) and all blue points to its left (or on it). This function
-- also returns the two extremal points; in case a line is returned, the line
-- actually goes through the blue (second) point, if there is no line, this
-- pair provides evidence that there is no vertical separating line.
--
-- The line we return actually goes through one blue point.
verticalSeparatingLine :: (Foldable1 f, Foldable1 g, Num r, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> SP (Maybe (Line 2 r))
(Point 2 r :+ redData, Point 2 r :+ blueData)
verticalSeparatingLine reds blues = SP ml es
where
es@(r,b) = extremalPoints reds blues
ml = if b^.core.xCoord <= r^.core.xCoord then Just . verticalLine $ (b^.core.xCoord)
else Nothing
-- | Get the the leftmost red point and the rightmost blue point.
extremalPoints :: (Foldable1 f, Foldable1 g, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> (Point 2 r :+ redData, Point 2 r :+ blueData)
extremalPoints reds blues = (F.minimumBy (comparing (^.core.xCoord)) reds
,F.maximumBy (comparing (^.core.xCoord)) blues)
--------------------------------------------------------------------------------