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
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 :: f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData) -> m (Maybe (Line 2 r))
separatingLine f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = do Maybe (Line 2 r)
l <- f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData) -> m (Maybe (Line 2 r))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r redData
blueData.
(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' f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues
Maybe (Line 2 r)
m <- g (Point 2 r :+ blueData)
-> f (Point 2 r :+ redData) -> m (Maybe (Line 2 r))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r redData
blueData.
(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' g (Point 2 r :+ blueData)
blues f (Point 2 r :+ redData)
reds
Maybe (Line 2 r) -> m (Maybe (Line 2 r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Line 2 r) -> m (Maybe (Line 2 r)))
-> Maybe (Line 2 r) -> m (Maybe (Line 2 r))
forall a b. (a -> b) -> a -> b
$ Maybe (Line 2 r)
l Maybe (Line 2 r) -> Maybe (Line 2 r) -> Maybe (Line 2 r)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Line 2 r)
m
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' :: f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData) -> m (Maybe (Line 2 r))
separatingLine' f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = case f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> SP
(Maybe (Line 2 r)) (Point 2 r :+ redData, Point 2 r :+ blueData)
forall (f :: * -> *) (g :: * -> *) r redData blueData.
(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 f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues of
SP Maybe (Line 2 r)
Nothing (Point 2 r
r:+redData
_,Point 2 r
b :+ blueData
_) -> Point 2 r
-> Point 2 r
-> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r redData
blueData.
(MonadRandom m, Foldable1 f, Foldable1 g, Fractional r, Ord r) =>
Point 2 r
-> Point 2 r
-> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine'' Point 2 r
r Point 2 r
b f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues
SP ml :: Maybe (Line 2 r)
ml@(Just Line 2 r
_) (Point 2 r :+ redData, Point 2 r :+ blueData)
_ -> Maybe (Line 2 r) -> m (Maybe (Line 2 r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Line 2 r)
ml
separatingLine'' :: (MonadRandom m, Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> Point 2 r
-> Point 2 r
-> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine'' :: Point 2 r
-> Point 2 r
-> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> m (Maybe (Line 2 r))
separatingLine'' Point 2 r
r Point 2 r
b f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = (Point 2 r -> Line 2 r) -> Maybe (Point 2 r) -> Maybe (Line 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point 2 r -> Line 2 r
forall r. Num r => Point 2 r -> Line 2 r
mkLine (Maybe (Point 2 r) -> Maybe (Line 2 r))
-> m (Maybe (Point 2 r)) -> m (Maybe (Line 2 r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LinearProgram 2 r -> m (Maybe (Point 2 r))
forall (m :: * -> *) r.
(MonadRandom m, Ord r, Fractional r) =>
LinearProgram 2 r -> m (Maybe (Point 2 r))
solveBoundedLinearProgram LinearProgram 2 r
lp
where
lp :: LinearProgram 2 r
lp = Vector 2 r -> [HalfSpace 2 r] -> LinearProgram 2 r
forall (d :: Nat) r.
Vector d r -> [HalfSpace d r] -> LinearProgram d r
LinearProgram Vector 2 r
c ([Point 2 r -> HalfSpace 2 r
forall r. Num r => Point 2 r -> HalfPlane r
mkRed Point 2 r
r, Point 2 r -> HalfSpace 2 r
forall r. Num r => Point 2 r -> HalfPlane r
mkBlue Point 2 r
b] [HalfSpace 2 r] -> [HalfSpace 2 r] -> [HalfSpace 2 r]
forall a. Semigroup a => a -> a -> a
<> [HalfSpace 2 r]
hs)
c :: Vector 2 r
c = case (Point 2 r
rPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Point 2 r
bPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) of
Ordering
LT -> r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 (-r
1) r
0
Ordering
GT -> r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 r
0
Ordering
EQ -> [Char] -> Vector 2 r
forall a. HasCallStack => [Char] -> a
error [Char]
"separatingLine'': precondition failed. r and b vertically above each other"
mkLine :: Point 2 r -> Line 2 r
mkLine (Point2 r
aa r
bb) = r -> r -> Line 2 r
forall r. Num r => r -> r -> Line 2 r
fromLinearFunction r
aa r
bb
mkRed :: Point 2 r -> HalfPlane r
mkRed (Point2 r
rx r
ry) = Line 2 r -> HalfPlane r
forall r. Num r => Line 2 r -> HalfPlane r
above (Line 2 r -> HalfPlane r) -> Line 2 r -> HalfPlane r
forall a b. (a -> b) -> a -> b
$ r -> r -> Line 2 r
forall r. Num r => r -> r -> Line 2 r
fromLinearFunction ((-r
1)r -> r -> r
forall a. Num a => a -> a -> a
*r
rx) r
ry
mkBlue :: Point 2 r -> HalfPlane r
mkBlue (Point2 r
bx r
by) = Line 2 r -> HalfPlane r
forall r. Num r => Line 2 r -> HalfPlane r
below (Line 2 r -> HalfPlane r) -> Line 2 r -> HalfPlane r
forall a b. (a -> b) -> a -> b
$ r -> r -> Line 2 r
forall r. Num r => r -> r -> Line 2 r
fromLinearFunction ((-r
1)r -> r -> r
forall a. Num a => a -> a -> a
*r
bx) r
by
hs :: [HalfSpace 2 r]
hs = [Point 2 r -> HalfSpace 2 r
forall r. Num r => Point 2 r -> HalfPlane r
mkRed Point 2 r
rr | (Point 2 r
rr :+ redData
_) <- f (Point 2 r :+ redData) -> [Point 2 r :+ redData]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f (Point 2 r :+ redData)
reds] [HalfSpace 2 r] -> [HalfSpace 2 r] -> [HalfSpace 2 r]
forall a. Semigroup a => a -> a -> a
<> [Point 2 r -> HalfSpace 2 r
forall r. Num r => Point 2 r -> HalfPlane r
mkBlue Point 2 r
bb | (Point 2 r
bb :+ blueData
_) <- g (Point 2 r :+ blueData) -> [Point 2 r :+ blueData]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList g (Point 2 r :+ blueData)
blues]
strictVerticalSeparatingLine :: (Foldable1 f, Foldable1 g, Fractional r, Ord r)
=> f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> Maybe (Line 2 r)
strictVerticalSeparatingLine :: f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData) -> Maybe (Line 2 r)
strictVerticalSeparatingLine f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = do let (Point 2 r :+ redData
r,Point 2 r :+ blueData
b) = f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> (Point 2 r :+ redData, Point 2 r :+ blueData)
forall (f :: * -> *) (g :: * -> *) r redData blueData.
(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 f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues
rx :: r
rx = Point 2 r :+ redData
r(Point 2 r :+ redData) -> Getting r (Point 2 r :+ redData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ redData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord
bx :: r
bx = Point 2 r :+ blueData
b(Point 2 r :+ blueData) -> Getting r (Point 2 r :+ blueData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ blueData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord
if r
bx r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
rx
then Line 2 r -> Maybe (Line 2 r)
forall a. a -> Maybe a
Just (Line 2 r -> Maybe (Line 2 r))
-> (r -> Line 2 r) -> r -> Maybe (Line 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Line 2 r
forall r. Num r => r -> Line 2 r
verticalLine (r -> Maybe (Line 2 r)) -> r -> Maybe (Line 2 r)
forall a b. (a -> b) -> a -> b
$ (r
rx r -> r -> r
forall a. Num a => a -> a -> a
+ r
bx) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
2
else Maybe (Line 2 r)
forall a. Maybe a
Nothing
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 :: f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> SP
(Maybe (Line 2 r)) (Point 2 r :+ redData, Point 2 r :+ blueData)
verticalSeparatingLine f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = Maybe (Line 2 r)
-> (Point 2 r :+ redData, Point 2 r :+ blueData)
-> SP
(Maybe (Line 2 r)) (Point 2 r :+ redData, Point 2 r :+ blueData)
forall a b. a -> b -> SP a b
SP Maybe (Line 2 r)
ml (Point 2 r :+ redData, Point 2 r :+ blueData)
es
where
es :: (Point 2 r :+ redData, Point 2 r :+ blueData)
es@(Point 2 r :+ redData
r,Point 2 r :+ blueData
b) = f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> (Point 2 r :+ redData, Point 2 r :+ blueData)
forall (f :: * -> *) (g :: * -> *) r redData blueData.
(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 f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues
ml :: Maybe (Line 2 r)
ml = if Point 2 r :+ blueData
b(Point 2 r :+ blueData) -> Getting r (Point 2 r :+ blueData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ blueData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= Point 2 r :+ redData
r(Point 2 r :+ redData) -> Getting r (Point 2 r :+ redData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ redData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord then Line 2 r -> Maybe (Line 2 r)
forall a. a -> Maybe a
Just (Line 2 r -> Maybe (Line 2 r))
-> (r -> Line 2 r) -> r -> Maybe (Line 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Line 2 r
forall r. Num r => r -> Line 2 r
verticalLine (r -> Maybe (Line 2 r)) -> r -> Maybe (Line 2 r)
forall a b. (a -> b) -> a -> b
$ (Point 2 r :+ blueData
b(Point 2 r :+ blueData) -> Getting r (Point 2 r :+ blueData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ blueData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)
else Maybe (Line 2 r)
forall a. Maybe a
Nothing
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 :: f (Point 2 r :+ redData)
-> g (Point 2 r :+ blueData)
-> (Point 2 r :+ redData, Point 2 r :+ blueData)
extremalPoints f (Point 2 r :+ redData)
reds g (Point 2 r :+ blueData)
blues = (((Point 2 r :+ redData) -> (Point 2 r :+ redData) -> Ordering)
-> f (Point 2 r :+ redData) -> Point 2 r :+ redData
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.minimumBy (((Point 2 r :+ redData) -> r)
-> (Point 2 r :+ redData) -> (Point 2 r :+ redData) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ redData) -> Getting r (Point 2 r :+ redData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ redData) -> Const r (Point 2 r :+ redData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ redData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)) f (Point 2 r :+ redData)
reds
,((Point 2 r :+ blueData) -> (Point 2 r :+ blueData) -> Ordering)
-> g (Point 2 r :+ blueData) -> Point 2 r :+ blueData
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.maximumBy (((Point 2 r :+ blueData) -> r)
-> (Point 2 r :+ blueData) -> (Point 2 r :+ blueData) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ blueData) -> Getting r (Point 2 r :+ blueData) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ blueData) -> Const r (Point 2 r :+ blueData))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ blueData) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)) g (Point 2 r :+ blueData)
blues)