{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}

module RiskWeaver.DSL.Core where

import Control.Monad.Trans.Reader (ReaderT, ask, runReader)
import Control.Parallel.Strategies
import Data.Kind (Type)
import Data.Map (Map)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Data.List qualified as List

class Rectangle a where
  rX :: a -> Double
  rY :: a -> Double
  rW :: a -> Double
  rH :: a -> Double

-- | Bounding box type class of ground truth
class (Eq (ClassG a), Eq (ClassD a)) => BoundingBox a where
  -- | Detection type
  data Detection a :: Type

  -- | Ground truth class type
  type ClassG a :: Type

  -- | Detection class type
  type ClassD a :: Type

  -- | Error type
  data ErrorType a :: Type

  -- | Interest area type
  type InterestArea a :: Type

  -- | Interest object type
  type InterestObject a :: Type

  -- | Environment type of the image
  data Env a :: Type

  -- | Index type of bounding box annotations
  type Idx a :: Type

  -- | Image index type of bounding box annotations
  type ImgIdx a :: Type

  -- | Risk type
  data Risk a :: Type

  -- | Risk of the environment
  riskE :: Env a -> [Risk a]
  riskE Env a
env = Reader (Env a) [Risk a] -> Env a -> [Risk a]
forall r a. Reader r a -> r -> a
runReader Reader (Env a) [Risk a]
myRisk Env a
env
    where
      myRisk :: Reader (Env a) [Risk a]
myRisk = do
        ![Risk a]
riskG <- Reader (Env a) [Risk a]
forall a (m :: * -> *).
(BoundingBox a, Monad m) =>
ReaderT (Env a) m [Risk a]
forall (m :: * -> *). Monad m => ReaderT (Env a) m [Risk a]
riskForGroundTruth
        ![Risk a]
riskD <- Reader (Env a) [Risk a]
forall a (m :: * -> *).
(BoundingBox a, Monad m) =>
ReaderT (Env a) m [Risk a]
forall (m :: * -> *). Monad m => ReaderT (Env a) m [Risk a]
riskForDetection
        [Risk a] -> Reader (Env a) [Risk a]
forall a. a -> ReaderT (Env a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Risk a] -> Reader (Env a) [Risk a])
-> [Risk a] -> Reader (Env a) [Risk a]
forall a b. (a -> b) -> a -> b
$ [Risk a]
riskG [Risk a] -> [Risk a] -> [Risk a]
forall a. Semigroup a => a -> a -> a
<> [Risk a]
riskD

  -- | Risk of groundtruth
  riskForGroundTruth :: Monad m => ReaderT (Env a) m [Risk a]

  -- | Risk of detection
  riskForDetection :: Monad m => ReaderT (Env a) m [Risk a]

  -- | Interest area of the environment
  interestArea :: Env a -> InterestArea a

  -- | Interest object of the environment
  interestObject :: Env a -> InterestObject a

  -- | Ground truth of the environment
  groundTruth :: Env a -> Vector a

  -- | Detection of the environment
  detection :: Env a -> Vector (Detection a)

  -- | Confidence score threshold
  confidenceScoreThresh :: Env a -> Double

  -- | IoU threshold
  ioUThresh :: Env a -> Double

  -- | Confidence score of the detection
  scoreD :: Detection a -> Double

  -- | Size of the detection
  sizeD :: Detection a -> Double
  default sizeD :: (Rectangle (Detection a)) => Detection a -> Double
  sizeD Detection a
v = Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
v

  -- | Class of the detection
  classD :: Detection a -> ClassG a

  -- | Index of the detection
  idD :: Detection a -> Idx a

  -- | Index of the image
  imageId :: Env a -> ImgIdx a

  -- | True if the detection is in front of the other detection
  isFrontD :: Detection a -> Detection a -> Bool
  default isFrontD :: (Rectangle (Detection a)) => Detection a -> Detection a -> Bool
  isFrontD Detection a
dtBack Detection a
dtFront =
    let intersection :: Double
intersection =
          (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
dtBack Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
dtBack) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
dtFront Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
dtFront) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
dtBack) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
dtFront))
            Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
dtBack Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
dtBack) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
dtFront Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
dtFront) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
dtBack) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
dtFront))
     in (Double
intersection Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
dtFront Double -> Double -> Double
forall a. Num a => a -> a -> a
* Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
dtFront)) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.99

  -- | True if the detection is in back of the other detection
  isBackD :: Detection a -> Detection a -> Bool

  -- | True if the detection is in left of the other detection
  isLeftD :: Detection a -> Detection a -> Bool

  -- | True if the detection is in right of the other detection
  isRightD :: Detection a -> Detection a -> Bool

  -- | True if the detection is in top of the other detection
  isTopD :: Detection a -> Detection a -> Bool

  -- | True if the detection is in bottom of the other detection
  isBottomD :: Detection a -> Detection a -> Bool

  -- | True if the detection is background
  isBackGroundD :: ClassD a -> Bool

  -- | Detect the ground truth of the detection
  detectD :: Env a -> Detection a -> Maybe a
  detectD Env a
env Detection a
dt =
    let gts :: Vector a
gts = Env a -> Vector a
forall a. BoundingBox a => Env a -> Vector a
groundTruth Env a
env
        gts'' :: [a]
gts'' = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
gt -> forall a. BoundingBox a => Detection a -> ClassG a
classD @a Detection a
dt ClassG a -> ClassG a -> Bool
forall a. Eq a => a -> a -> Bool
== forall a. BoundingBox a => a -> ClassG a
classG @a a
gt) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList Vector a
gts
        -- Get max IOU detection with ioUThresh
        gts''' :: [(Double, a)]
gts''' = ((Double, a) -> Bool) -> [(Double, a)] -> [(Double, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Double
iou', a
_) -> Double
iou' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Env a -> Double
forall a. BoundingBox a => Env a -> Double
ioUThresh Env a
env) ([(Double, a)] -> [(Double, a)]) -> [(Double, a)] -> [(Double, a)]
forall a b. (a -> b) -> a -> b
$ (a -> (Double, a)) -> [a] -> [(Double, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
gt -> (a -> Detection a -> Double
forall a. BoundingBox a => a -> Detection a -> Double
ioU a
gt Detection a
dt, a
gt)) [a]
gts''
     in case [(Double, a)]
gts''' of
          [] -> Maybe a
forall a. Maybe a
Nothing
          [(Double, a)]
gts_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (Double, a) -> a
forall a b. (a, b) -> b
snd ((Double, a) -> a) -> (Double, a) -> a
forall a b. (a -> b) -> a -> b
$ ((Double, a) -> (Double, a) -> Ordering)
-> [(Double, a)] -> (Double, a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.maximumBy (\(Double
iou1, a
_) (Double
iou2, a
_) -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
iou1 Double
iou2) [(Double, a)]
gts_

  -- | Get error type from risk
  toErrorType :: Risk a -> ErrorType a

  -- | Get a score from risk
  toRiskScore :: Risk a -> Double

  -- | Size of the ground truth
  sizeG :: a -> Double
  default sizeG :: (Rectangle a) => a -> Double
  sizeG a
v = a -> Double
forall a. Rectangle a => a -> Double
rW a
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* a -> Double
forall a. Rectangle a => a -> Double
rH a
v

  -- | Class of the ground truth
  classG :: a -> ClassG a

  -- | Angle of detection to the ground truth
  angle :: a -> Detection a -> Double

  -- | Index of the ground truth
  idG :: a -> Idx a

  -- | IoU(Intersection Over Union) of the ground truth and the detection
  ioU :: a -> Detection a -> Double
  default ioU :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double
  ioU a
g Detection a
d =
    let intersection :: Double
intersection =
          (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rX a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rW a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rX a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d))
            Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rY a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rH a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rY a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d))
     in Double
intersection Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (a -> Double
forall a. Rectangle a => a -> Double
rW a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
* a -> Double
forall a. Rectangle a => a -> Double
rH a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
intersection)

  -- | IoG(Intersection Over Ground truth) of the ground truth and the detection
  ioG :: a -> Detection a -> Double
  default ioG :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double
  ioG a
g Detection a
d =
    let intersection :: Double
intersection =
          (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rX a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rW a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rX a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d))
            Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rY a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rH a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rY a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d))
     in Double
intersection Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (a -> Double
forall a. Rectangle a => a -> Double
rW a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
* a -> Double
forall a. Rectangle a => a -> Double
rH a
g)

  -- | IoD(Intersection Over Detection) of the ground truth and the detection
  ioD :: a -> Detection a -> Double
  default ioD :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double
  ioD a
g Detection a
d =
    let intersection :: Double
intersection =
          (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rX a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rW a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rX a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rX Detection a
d))
            Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (a -> Double
forall a. Rectangle a => a -> Double
rY a
g Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Rectangle a => a -> Double
rH a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (a -> Double
forall a. Rectangle a => a -> Double
rY a
g) (Detection a -> Double
forall a. Rectangle a => a -> Double
rY Detection a
d))
     in Double
intersection Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Detection a -> Double
forall a. Rectangle a => a -> Double
rW Detection a
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Detection a -> Double
forall a. Rectangle a => a -> Double
rH Detection a
d)

  -- | Detect the detection of the ground truth
  detectG :: Env a -> a -> Maybe (Detection a)
  detectG Env a
env a
gt =
    let dts :: Vector (Detection a)
dts = Env a -> Vector (Detection a)
forall a. BoundingBox a => Env a -> Vector (Detection a)
detection Env a
env
        dts' :: [Detection a]
dts' = (Detection a -> Bool) -> [Detection a] -> [Detection a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Detection a
dt -> forall a. BoundingBox a => Detection a -> Double
scoreD @a Detection a
dt Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Env a -> Double
forall a. BoundingBox a => Env a -> Double
confidenceScoreThresh Env a
env) ([Detection a] -> [Detection a]) -> [Detection a] -> [Detection a]
forall a b. (a -> b) -> a -> b
$ Vector (Detection a) -> [Detection a]
forall a. Vector a -> [a]
Vector.toList Vector (Detection a)
dts
        dts'' :: [Detection a]
dts'' = (Detection a -> Bool) -> [Detection a] -> [Detection a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Detection a
dt -> forall a. BoundingBox a => Detection a -> ClassG a
classD @a Detection a
dt ClassG a -> ClassG a -> Bool
forall a. Eq a => a -> a -> Bool
== forall a. BoundingBox a => a -> ClassG a
classG @a a
gt) [Detection a]
dts'
        -- Get max IOU detection with ioUThresh
        dts''' :: [(Double, Detection a)]
dts''' = ((Double, Detection a) -> Bool)
-> [(Double, Detection a)] -> [(Double, Detection a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Double
iou', Detection a
_) -> Double
iou' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Env a -> Double
forall a. BoundingBox a => Env a -> Double
ioUThresh Env a
env) ([(Double, Detection a)] -> [(Double, Detection a)])
-> [(Double, Detection a)] -> [(Double, Detection a)]
forall a b. (a -> b) -> a -> b
$ (Detection a -> (Double, Detection a))
-> [Detection a] -> [(Double, Detection a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Detection a
dt -> (a -> Detection a -> Double
forall a. BoundingBox a => a -> Detection a -> Double
ioU a
gt Detection a
dt, Detection a
dt)) [Detection a]
dts''
     in case [(Double, Detection a)]
dts''' of
          [] -> Maybe (Detection a)
forall a. Maybe a
Nothing
          [(Double, Detection a)]
dts_ -> Detection a -> Maybe (Detection a)
forall a. a -> Maybe a
Just (Detection a -> Maybe (Detection a))
-> Detection a -> Maybe (Detection a)
forall a b. (a -> b) -> a -> b
$ (Double, Detection a) -> Detection a
forall a b. (a, b) -> b
snd ((Double, Detection a) -> Detection a)
-> (Double, Detection a) -> Detection a
forall a b. (a -> b) -> a -> b
$ ((Double, Detection a) -> (Double, Detection a) -> Ordering)
-> [(Double, Detection a)] -> (Double, Detection a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.maximumBy (\(Double
iou1, Detection a
_) (Double
iou2, Detection a
_) -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
iou1 Double
iou2) [(Double, Detection a)]
dts_

  -- | True if the detection is in the interest area
  isInIeterestAreaD :: InterestArea a -> Detection a -> Bool

  -- | True if the ground truth is in the interest area
  isInIeterestAreaG :: InterestArea a -> a -> Bool

  -- | True if the detection is in the interest object
  isInterestObjectD :: InterestObject a -> Detection a -> Bool

  -- | True if the ground truth is in the interest object
  isInterestObjectG :: InterestObject a -> a -> Bool

-- | b includes ground-truth images and detection images.
class (NFData (ImgIdx a), NFData (Risk a), BoundingBox a) => World b a where
  -- | Environments of the image
  envs :: b -> [Env a]
  envs b
context =
    (ImgIdx a -> Env a) -> [ImgIdx a] -> [Env a]
forall a b. (a -> b) -> [a] -> [b]
map
      (\ImgIdx a
imageId' -> forall b a. World b a => b -> ImgIdx a -> Env a
toEnv @b @a b
context ImgIdx a
imageId')
      (forall b a. World b a => b -> [ImgIdx a]
toImageIds @b @a b
context)

  -- | An environment of the image
  toEnv :: b -> ImgIdx a -> Env a

  -- | An environment of the image
  toImageIds :: b -> [ImgIdx a]

  -- | mAP of the images
  mAP :: b -> Double

  -- | AP of the images for each class
  ap :: b -> Map (ClassG a) Double

  -- | mF1 of the images
  mF1 :: b -> Double

  -- | F1 of the images for each class
  f1 :: b -> Map (ClassG a) Double

  -- | Risk of the images
  risk :: b -> [Risk a]
  risk b
context = [[Risk a]] -> [Risk a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Risk a]] -> [Risk a]) -> [[Risk a]] -> [Risk a]
forall a b. (a -> b) -> a -> b
$ ((ImgIdx a, [Risk a]) -> [Risk a])
-> [(ImgIdx a, [Risk a])] -> [[Risk a]]
forall a b. (a -> b) -> [a] -> [b]
map (ImgIdx a, [Risk a]) -> [Risk a]
forall a b. (a, b) -> b
snd ([(ImgIdx a, [Risk a])] -> [[Risk a]])
-> [(ImgIdx a, [Risk a])] -> [[Risk a]]
forall a b. (a -> b) -> a -> b
$ b -> [(ImgIdx a, [Risk a])]
forall context a.
World context a =>
context -> [(ImgIdx a, [Risk a])]
runRiskWithError b
context

  -- | Confusion matrix of recall
  confusionMatrixRecall :: b -> Map (ClassG a, ClassD a) [Risk a]

  -- | Confusion matrix of precision
  confusionMatrixPrecision :: b -> Map (ClassD a, ClassG a) [Risk a]

-- | Loop for ground truth
loopG :: forall a m b. (BoundingBox a, Monad m) => (b -> b -> b) -> b -> (a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b
loopG :: forall a (m :: * -> *) b.
(BoundingBox a, Monad m) =>
(b -> b -> b)
-> b -> (a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b
loopG b -> b -> b
add b
init' a -> ReaderT (Env a) m b
fn = do
  Env a
env <- ReaderT (Env a) m (Env a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  (b -> b -> b) -> b -> Vector b -> b
forall b a. (b -> a -> b) -> b -> Vector a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> b -> b
add b
init' (Vector b -> b)
-> ReaderT (Env a) m (Vector b) -> ReaderT (Env a) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> ReaderT (Env a) m b)
-> Vector a -> ReaderT (Env a) m (Vector b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM a -> ReaderT (Env a) m b
fn (forall a. BoundingBox a => Env a -> Vector a
groundTruth @a Env a
env)
{-# INLINEABLE loopG #-}

-- | Loop for detection
loopD :: forall a m b. (BoundingBox a, Monad m) => (b -> b -> b) -> b -> (Detection a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b
loopD :: forall a (m :: * -> *) b.
(BoundingBox a, Monad m) =>
(b -> b -> b)
-> b -> (Detection a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b
loopD b -> b -> b
add b
init' Detection a -> ReaderT (Env a) m b
fn = do
  Env a
env <- ReaderT (Env a) m (Env a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  (b -> b -> b) -> b -> Vector b -> b
forall b a. (b -> a -> b) -> b -> Vector a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> b -> b
add b
init' (Vector b -> b)
-> ReaderT (Env a) m (Vector b) -> ReaderT (Env a) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Detection a -> ReaderT (Env a) m b)
-> Vector (Detection a) -> ReaderT (Env a) m (Vector b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM Detection a -> ReaderT (Env a) m b
fn (forall a. BoundingBox a => Env a -> Vector (Detection a)
detection @a Env a
env)
{-# INLINEABLE loopD #-}

detectMaxIouG :: BoundingBox a => Env a -> a -> Maybe (Detection a)
detectMaxIouG :: forall a. BoundingBox a => Env a -> a -> Maybe (Detection a)
detectMaxIouG Env a
env a
gt =
  let dts :: Vector (Detection a)
dts = Env a -> Vector (Detection a)
forall a. BoundingBox a => Env a -> Vector (Detection a)
detection Env a
env
      dts' :: [(Double, Detection a)]
dts' = (Detection a -> (Double, Detection a))
-> [Detection a] -> [(Double, Detection a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Detection a
dt -> (a -> Detection a -> Double
forall a. BoundingBox a => a -> Detection a -> Double
ioU a
gt Detection a
dt, Detection a
dt)) ([Detection a] -> [(Double, Detection a)])
-> [Detection a] -> [(Double, Detection a)]
forall a b. (a -> b) -> a -> b
$ Vector (Detection a) -> [Detection a]
forall a. Vector a -> [a]
Vector.toList Vector (Detection a)
dts
   in case [(Double, Detection a)]
dts' of
        [] -> Maybe (Detection a)
forall a. Maybe a
Nothing
        [(Double, Detection a)]
dts_ -> Detection a -> Maybe (Detection a)
forall a. a -> Maybe a
Just (Detection a -> Maybe (Detection a))
-> Detection a -> Maybe (Detection a)
forall a b. (a -> b) -> a -> b
$ (Double, Detection a) -> Detection a
forall a b. (a, b) -> b
snd ((Double, Detection a) -> Detection a)
-> (Double, Detection a) -> Detection a
forall a b. (a -> b) -> a -> b
$ ((Double, Detection a) -> (Double, Detection a) -> Ordering)
-> [(Double, Detection a)] -> (Double, Detection a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.maximumBy (\(Double
iou1, Detection a
_) (Double
iou2, Detection a
_) -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
iou1 Double
iou2) [(Double, Detection a)]
dts_

detectMaxIouD :: BoundingBox a => Env a -> (Detection a) -> Maybe a
detectMaxIouD :: forall a. BoundingBox a => Env a -> Detection a -> Maybe a
detectMaxIouD Env a
env Detection a
dt =
  let gts :: Vector a
gts = Env a -> Vector a
forall a. BoundingBox a => Env a -> Vector a
groundTruth Env a
env
      gts' :: [(Double, a)]
gts' = (a -> (Double, a)) -> [a] -> [(Double, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
gt -> (a -> Detection a -> Double
forall a. BoundingBox a => a -> Detection a -> Double
ioU a
gt Detection a
dt, a
gt)) ([a] -> [(Double, a)]) -> [a] -> [(Double, a)]
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList Vector a
gts
   in case [(Double, a)]
gts' of
        [] -> Maybe a
forall a. Maybe a
Nothing
        [(Double, a)]
gts_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (Double, a) -> a
forall a b. (a, b) -> b
snd ((Double, a) -> a) -> (Double, a) -> a
forall a b. (a -> b) -> a -> b
$ ((Double, a) -> (Double, a) -> Ordering)
-> [(Double, a)] -> (Double, a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.maximumBy (\(Double
iou1, a
_) (Double
iou2, a
_) -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
iou1 Double
iou2) [(Double, a)]
gts_

whenInterestAreaD :: forall m a b. (Monad m, BoundingBox a) => Bool -> Detection a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]
whenInterestAreaD :: forall (m :: * -> *) a b.
(Monad m, BoundingBox a) =>
Bool
-> Detection a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]
whenInterestAreaD Bool
cond Detection a
dt ReaderT (Env a) m [b]
func = do
  Env a
env <- ReaderT (Env a) m (Env a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  if Bool
cond
  then do
    if InterestArea a -> Detection a -> Bool
forall a. BoundingBox a => InterestArea a -> Detection a -> Bool
isInIeterestAreaD (Env a -> InterestArea a
forall a. BoundingBox a => Env a -> InterestArea a
interestArea Env a
env) Detection a
dt Bool -> Bool -> Bool
&& InterestObject a -> Detection a -> Bool
forall a. BoundingBox a => InterestObject a -> Detection a -> Bool
isInterestObjectD (Env a -> InterestObject a
forall a. BoundingBox a => Env a -> InterestObject a
interestObject Env a
env) Detection a
dt
      then ReaderT (Env a) m [b]
func
      else [b] -> ReaderT (Env a) m [b]
forall a. a -> ReaderT (Env a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  else ReaderT (Env a) m [b]
func

whenInterestAreaG :: forall m a b. (Monad m, BoundingBox a) => Bool -> a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]
whenInterestAreaG :: forall (m :: * -> *) a b.
(Monad m, BoundingBox a) =>
Bool -> a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]
whenInterestAreaG Bool
cond a
gt ReaderT (Env a) m [b]
func = do
  Env a
env <- ReaderT (Env a) m (Env a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  if Bool
cond
  then do
    if InterestArea a -> a -> Bool
forall a. BoundingBox a => InterestArea a -> a -> Bool
isInIeterestAreaG (Env a -> InterestArea a
forall a. BoundingBox a => Env a -> InterestArea a
interestArea Env a
env) a
gt Bool -> Bool -> Bool
&& InterestObject a -> a -> Bool
forall a. BoundingBox a => InterestObject a -> a -> Bool
isInterestObjectG (Env a -> InterestObject a
forall a. BoundingBox a => Env a -> InterestObject a
interestObject Env a
env) a
gt
      then ReaderT (Env a) m [b]
func
      else [b] -> ReaderT (Env a) m [b]
forall a. a -> ReaderT (Env a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  else ReaderT (Env a) m [b]
func

runRisk :: forall context a. (World context a) => context -> [(ImgIdx a, Double)]
runRisk :: forall context a.
World context a =>
context -> [(ImgIdx a, Double)]
runRisk context
context =
  ((ImgIdx a, [Risk a]) -> (ImgIdx a, Double))
-> [(ImgIdx a, [Risk a])] -> [(ImgIdx a, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ImgIdx a
imageId', [Risk a]
risks) -> (ImgIdx a
imageId', [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Risk a -> Double) -> [Risk a] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Risk a
r -> Risk a -> Double
forall a. BoundingBox a => Risk a -> Double
toRiskScore Risk a
r) [Risk a]
risks)) (forall context a.
World context a =>
context -> [(ImgIdx a, [Risk a])]
runRiskWithError @context @a context
context)
    [(ImgIdx a, Double)]
-> Strategy [(ImgIdx a, Double)] -> [(ImgIdx a, Double)]
forall a. a -> Strategy a -> a
`using` Strategy (ImgIdx a, Double) -> Strategy [(ImgIdx a, Double)]
forall a. Strategy a -> Strategy [a]
parList Strategy (ImgIdx a, Double)
forall a. NFData a => Strategy a
rdeepseq

runRiskWithError :: forall context a. (World context a) => context -> [(ImgIdx a, [Risk a])]
runRiskWithError :: forall context a.
World context a =>
context -> [(ImgIdx a, [Risk a])]
runRiskWithError context
context =
  (ImgIdx a -> (ImgIdx a, [Risk a]))
-> [ImgIdx a] -> [(ImgIdx a, [Risk a])]
forall a b. (a -> b) -> [a] -> [b]
map (\ImgIdx a
imageId' -> (ImgIdx a
imageId', Env a -> [Risk a]
forall a. BoundingBox a => Env a -> [Risk a]
riskE (context -> ImgIdx a -> Env a
forall b a. World b a => b -> ImgIdx a -> Env a
toEnv context
context ImgIdx a
imageId'))) (forall b a. World b a => b -> [ImgIdx a]
toImageIds @context @a context
context)
    [(ImgIdx a, [Risk a])]
-> Strategy [(ImgIdx a, [Risk a])] -> [(ImgIdx a, [Risk a])]
forall a. a -> Strategy a -> a
`using` Strategy (ImgIdx a, [Risk a]) -> Strategy [(ImgIdx a, [Risk a])]
forall a. Strategy a -> Strategy [a]
parList Strategy (ImgIdx a, [Risk a])
forall a. NFData a => Strategy a
rdeepseq

generateRiskWeightedImages :: forall b a. World b a => b -> [ImgIdx a]
generateRiskWeightedImages :: forall b a. World b a => b -> [ImgIdx a]
generateRiskWeightedImages b
context =
  let risks :: [(ImgIdx a, Double)]
risks = forall context a.
World context a =>
context -> [(ImgIdx a, Double)]
runRisk @b @a b
context
      sumRisks :: Double
sumRisks = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ ((ImgIdx a, Double) -> Double) -> [(ImgIdx a, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (ImgIdx a, Double) -> Double
forall a b. (a, b) -> b
snd [(ImgIdx a, Double)]
risks
      probs :: [Double]
probs = ((ImgIdx a, Double) -> Double) -> [(ImgIdx a, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\(ImgIdx a
_, Double
risk') -> Double
risk' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sumRisks) [(ImgIdx a, Double)]
risks
      acc_probs :: [(Double, Double)]
acc_probs =
        let loop :: [t] -> t -> [(t, t)]
loop [] t
_ = []
            loop (t
x : [t]
xs) t
s = (t
s, t
s t -> t -> t
forall a. Num a => a -> a -> a
+ t
x) (t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [t] -> t -> [(t, t)]
loop [t]
xs (t
s t -> t -> t
forall a. Num a => a -> a -> a
+ t
x)
         in [Double] -> Double -> [(Double, Double)]
forall {t}. Num t => [t] -> t -> [(t, t)]
loop [Double]
probs Double
0
      numDatasets :: Int
numDatasets = [ImgIdx a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ImgIdx a] -> Int) -> [ImgIdx a] -> Int
forall a b. (a -> b) -> a -> b
$ forall b a. World b a => b -> [ImgIdx a]
toImageIds @b @a b
context
      imageSets :: [((Double, Double), ImgIdx a)]
      imageSets :: [((Double, Double), ImgIdx a)]
imageSets = [(Double, Double)] -> [ImgIdx a] -> [((Double, Double), ImgIdx a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Double, Double)]
acc_probs ([ImgIdx a] -> [((Double, Double), ImgIdx a)])
-> [ImgIdx a] -> [((Double, Double), ImgIdx a)]
forall a b. (a -> b) -> a -> b
$ ((ImgIdx a, Double) -> ImgIdx a)
-> [(ImgIdx a, Double)] -> [ImgIdx a]
forall a b. (a -> b) -> [a] -> [b]
map (ImgIdx a, Double) -> ImgIdx a
forall a b. (a, b) -> a
fst [(ImgIdx a, Double)]
risks
      resample :: [((Double, Double), ImgIdx a)] -> Int -> Int -> [ImgIdx a]
resample [] Int
_ Int
_ = []
      resample s :: [((Double, Double), ImgIdx a)]
s@(((Double
x, Double
y), ImgIdx a
img) : [((Double, Double), ImgIdx a)]
xs) Int
n Int
end =
        if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
end
          then []
          else
            let p :: Double
p = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Double) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numDatasets :: Double)
             in if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
p Bool -> Bool -> Bool
&& Double
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
y
                  then ImgIdx a
img ImgIdx a -> [ImgIdx a] -> [ImgIdx a]
forall a. a -> [a] -> [a]
: [((Double, Double), ImgIdx a)] -> Int -> Int -> [ImgIdx a]
resample [((Double, Double), ImgIdx a)]
s (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
end
                  else [((Double, Double), ImgIdx a)] -> Int -> Int -> [ImgIdx a]
resample [((Double, Double), ImgIdx a)]
xs Int
n Int
end
  in [((Double, Double), ImgIdx a)] -> Int -> Int -> [ImgIdx a]
resample [((Double, Double), ImgIdx a)]
imageSets Int
0 Int
numDatasets