{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Examples.Flowers where

import Proton

import Data.Profunctor.Rep
import Data.Profunctor.Strong
import Data.Profunctor.Sieve
import Data.Foldable

import qualified Data.Map as M
import Data.List
import Data.Ord
import Data.Function
import Control.Applicative
import Debug.Trace
import Data.Functor.Identity
import Proton.Algebraic
import Data.Profunctor

data Species = Setosa | Versicolor | Virginica
  deriving Int -> Species -> ShowS
[Species] -> ShowS
Species -> String
(Int -> Species -> ShowS)
-> (Species -> String) -> ([Species] -> ShowS) -> Show Species
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Species] -> ShowS
$cshowList :: [Species] -> ShowS
show :: Species -> String
$cshow :: Species -> String
showsPrec :: Int -> Species -> ShowS
$cshowsPrec :: Int -> Species -> ShowS
Show

data Measurements = Measurements {Measurements -> [Float]
getMeasurements :: [Float]}
  deriving Int -> Measurements -> ShowS
[Measurements] -> ShowS
Measurements -> String
(Int -> Measurements -> ShowS)
-> (Measurements -> String)
-> ([Measurements] -> ShowS)
-> Show Measurements
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Measurements] -> ShowS
$cshowList :: [Measurements] -> ShowS
show :: Measurements -> String
$cshow :: Measurements -> String
showsPrec :: Int -> Measurements -> ShowS
$cshowsPrec :: Int -> Measurements -> ShowS
Show

data Flower = Flower {Flower -> Species
flowerSpecies :: Species, Flower -> Measurements
flowerMeasurements :: Measurements}
  deriving Int -> Flower -> ShowS
[Flower] -> ShowS
Flower -> String
(Int -> Flower -> ShowS)
-> (Flower -> String) -> ([Flower] -> ShowS) -> Show Flower
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flower] -> ShowS
$cshowList :: [Flower] -> ShowS
show :: Flower -> String
$cshow :: Flower -> String
showsPrec :: Int -> Flower -> ShowS
$cshowsPrec :: Int -> Flower -> ShowS
Show

-- measurements' :: p [Float] [Float] -> p Measurements Measurements
-- measurements' :: Lens' Measurements [Float]
-- measurements' p =

measurementDistance :: Measurements -> Measurements -> Float
measurementDistance :: Measurements -> Measurements -> Float
measurementDistance (Measurements xs :: [Float]
xs) (Measurements ys :: [Float]
ys) =
    Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float) -> ([Float] -> Float) -> [Float] -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Float] -> Float) -> [Float] -> Float
forall a b. (a -> b) -> a -> b
$ (Float -> Float -> Float) -> [Float] -> [Float] -> [Float]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Float -> Float -> Float
forall a. Floating a => a -> a -> a
diff [Float]
xs [Float]
ys
  where
    diff :: a -> a -> a
diff a :: a
a b :: a
b = (a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
b) a -> a -> a
forall a. Floating a => a -> a -> a
** 2

-- aggregate :: Kaleidoscope' Measurements Float
aggregate :: Kaleidoscope' Measurements Float
aggregate :: p Float Float -> p Measurements Measurements
aggregate = (Measurements -> [Float])
-> ([Float] -> Measurements)
-> Iso Measurements Measurements [Float] [Float]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Measurements -> [Float]
getMeasurements [Float] -> Measurements
Measurements (p [Float] [Float] -> p Measurements Measurements)
-> (p Float Float -> p [Float] [Float])
-> p Float Float
-> p Measurements Measurements
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Float Float -> p [Float] [Float]
forall a b. Kaleidoscope [a] [b] a b
pointWise

-- measureLens :: Lens' Measurements [Float]
-- measureLens = lens getMeasurements setter
--   where
--     setter _ b = Measurements b

classify :: [Flower] -> Measurements -> Maybe Flower
classify :: [Flower] -> Measurements -> Maybe Flower
classify flowers :: [Flower]
flowers m :: Measurements
m
  | [Flower] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Flower]
flowers = Maybe Flower
forall a. Maybe a
Nothing
  | Bool
otherwise =
  let Flower species :: Species
species _ = (Flower -> Flower -> Ordering) -> [Flower] -> Flower
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy
                          ((Flower -> Float) -> Flower -> Flower -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Measurements -> Measurements -> Float
measurementDistance Measurements
m (Measurements -> Float)
-> (Flower -> Measurements) -> Flower -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flower -> Measurements
flowerMeasurements))
                          [Flower]
flowers
   in Flower -> Maybe Flower
forall a. a -> Maybe a
Just (Flower -> Maybe Flower) -> Flower -> Maybe Flower
forall a b. (a -> b) -> a -> b
$ Species -> Measurements -> Flower
Flower Species
species Measurements
m

-- measurements :: (Corepresentable p, Foldable (Corep p)) => Optic' p Flower Measurements
-- measurements = listLens flowerMeasurements classify

measurements :: AlgebraicLens Flower (Maybe Flower) Measurements Measurements
measurements :: p Measurements Measurements -> p Flower (Maybe Flower)
measurements = (Flower -> Measurements)
-> ([Flower] -> Measurements -> Maybe Flower)
-> p Measurements Measurements
-> p Flower (Maybe Flower)
forall (p :: * -> * -> *) s a b t.
MStrong p =>
(s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens Flower -> Measurements
flowerMeasurements [Flower] -> Measurements -> Maybe Flower
classify

-- strained :: forall s b. ListLens s [s] s Bool
-- strained = listLens id go
--   where
--     -- go :: ([s], [Bool]) -> [s]
--     -- go  = fmap fst . filter snd . uncurry zip
--     go  (x, True)  = x
--     go  (x, False) = []

versicolor :: Flower
versicolor :: Flower
versicolor = Species -> Measurements -> Flower
Flower Species
Versicolor ([Float] -> Measurements
Measurements [2, 3, 4, 2])

setosa :: Flower
setosa :: Flower
setosa = Species -> Measurements -> Flower
Flower Species
Setosa ([Float] -> Measurements
Measurements [5, 4, 3, 2.5])

flowers :: [Flower]
flowers :: [Flower]
flowers = [Flower
versicolor, Flower
setosa]

mean :: Fractional a => [a] -> a
mean :: [a] -> a
mean [] =  0
mean xs :: [a]
xs = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)


infixr 4 >--
(>--) :: [s] -> Optic (Costar []) s t a a -> t
>-- :: [s] -> Optic (Costar []) s t a a -> t
(>--) xs :: [s]
xs opt :: Optic (Costar []) s t a a
opt = (Costar [] s t -> [s] -> t
forall (f :: * -> *) d c. Costar f d c -> f d -> c
runCostar (Costar [] s t -> [s] -> t) -> Costar [] s t -> [s] -> t
forall a b. (a -> b) -> a -> b
$ Optic (Costar []) s t a a
opt (([a] -> a) -> Costar [] a a
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar [a] -> a
forall a. [a] -> a
head)) [s]
xs

aggregateWith :: Functor f => (f Float -> Float) -> Optic (Costar []) Measurements Measurements Float Float
aggregateWith :: (f Float -> Float)
-> Optic (Costar []) Measurements Measurements Float Float
aggregateWith aggregator :: f Float -> Float
aggregator p :: Costar [] Float Float
p = ([Measurements] -> Measurements)
-> Costar [] Measurements Measurements
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar ([Float] -> Measurements
Measurements ([Float] -> Measurements)
-> ([Measurements] -> [Float]) -> [Measurements] -> Measurements
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Float] -> Float) -> [[Float]] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Costar [] Float Float -> [Float] -> Float
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve Costar [] Float Float
p) ([[Float]] -> [Float])
-> ([Measurements] -> [[Float]]) -> [Measurements] -> [Float]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Float]] -> [[Float]]
forall a. [[a]] -> [[a]]
transpose ([[Float]] -> [[Float]])
-> ([Measurements] -> [[Float]]) -> [Measurements] -> [[Float]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Measurements -> [Float]) -> [Measurements] -> [[Float]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Measurements -> [Float]
getMeasurements)

avgMeasurement :: Foldable f => f Measurements -> Measurements
avgMeasurement :: f Measurements -> Measurements
avgMeasurement ms :: f Measurements
ms = [Float] -> Measurements
Measurements ([Float] -> Float
mean ([Float] -> Float) -> [[Float]] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Float]]
groupedMeasurements)
  where
    groupedMeasurements :: [[Float]]
    groupedMeasurements :: [[Float]]
groupedMeasurements = [[Float]] -> [[Float]]
forall a. [[a]] -> [[a]]
transpose (Measurements -> [Float]
getMeasurements (Measurements -> [Float]) -> [Measurements] -> [[Float]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Measurements -> [Measurements]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Measurements
ms)
    mean :: [Float] -> Float
    mean :: [Float] -> Float
mean xs :: [Float]
xs = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float]
xs Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Float] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
xs)

applyWeight :: Float -> Measurements -> Measurements
applyWeight :: Float -> Measurements -> Measurements
applyWeight w :: Float
w (Measurements m :: [Float]
m) = [Float] -> Measurements
Measurements ((Float -> Float) -> [Float] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
w) [Float]
m)

partitioned :: forall f a. (Ord a) => AlgebraicLens a ([a], [a]) a a
partitioned :: AlgebraicLens a ([a], [a]) a a
partitioned = (a -> a) -> ([a] -> a -> ([a], [a])) -> Optic p a ([a], [a]) a a
forall (p :: * -> * -> *) s a b t.
MStrong p =>
(s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens a -> a
forall a. a -> a
id [a] -> a -> ([a], [a])
forall a (t :: * -> *).
(Ord a, Foldable t) =>
t a -> a -> ([a], [a])
splitter
  where
    -- splitter :: f a -> a -> ([a], [a])
    splitter :: t a -> a -> ([a], [a])
splitter xs :: t a
xs ref :: a
ref
      = ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
ref) (t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs), (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
ref) (t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs))

onFirst :: Eq a => AlgebraicLens (a, b) (Maybe b) a a
onFirst :: AlgebraicLens (a, b) (Maybe b) a a
onFirst = ((a, b) -> a)
-> ([(a, b)] -> a -> Maybe b) -> Optic p (a, b) (Maybe b) a a
forall (p :: * -> * -> *) s a b t.
MStrong p =>
(s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)] -> a -> Maybe b
forall a (t :: * -> *) b.
(Eq a, Foldable t) =>
t (a, b) -> a -> Maybe b
picker
  where
    picker :: t (a, b) -> a -> Maybe b
picker xs :: t (a, b)
xs a :: a
a = a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a ([(a, b)] -> Maybe b) -> [(a, b)] -> Maybe b
forall a b. (a -> b) -> a -> b
$ t (a, b) -> [(a, b)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (a, b)
xs

selectingOn :: (s -> a) -> AlgebraicLens s (Maybe s) a (Maybe Int)
selectingOn :: (s -> a) -> AlgebraicLens s (Maybe s) a (Maybe Int)
selectingOn project :: s -> a
project = (s -> a)
-> ([s] -> Maybe Int -> Maybe s)
-> Optic p s (Maybe s) a (Maybe Int)
forall (p :: * -> * -> *) s a b t.
MStrong p =>
(s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens s -> a
project [s] -> Maybe Int -> Maybe s
forall (f :: * -> *) (t :: * -> *) b.
(Functor f, Foldable t) =>
t b -> f Int -> f b
picker
  where
    picker :: t b -> f Int -> f b
picker xs :: t b
xs i :: f Int
i = (t b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t b
xs [b] -> Int -> b
forall a. [a] -> Int -> a
!!) (Int -> b) -> f Int -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int
i

indexOf :: Eq s => AlgebraicLens s (Maybe Int) s s
indexOf :: AlgebraicLens s (Maybe Int) s s
indexOf = (s -> s) -> ([s] -> s -> Maybe Int) -> Optic p s (Maybe Int) s s
forall (p :: * -> * -> *) s a b t.
MStrong p =>
(s -> a) -> ([s] -> b -> t) -> Optic p s t a b
listLens s -> s
forall a. a -> a
id ((s -> [s] -> Maybe Int) -> [s] -> s -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip s -> [s] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex ([s] -> s -> Maybe Int) -> ([s] -> [s]) -> [s] -> s -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> [s]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)

test :: IO ()
test :: IO ()
test = do
    -- print $ [1..10] & partitioned ?- (5 :: Int)
    -- print $ [1..10] & partitioned >- mean
    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length >- elemIndex 11
    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length . indexOf ?- 11
    -- print $ Identity "banana" & selectingOn length . indexOf %~ (+10)
    -- print $ (flowers >-- (measurements . aggregateWith mean))
    Maybe Flower -> IO ()
forall a. Show a => a -> IO ()
print (Maybe Flower -> IO ()) -> Maybe Flower -> IO ()
forall a b. (a -> b) -> a -> b
$ [Flower]
flowers [Flower] -> ([Flower] -> Maybe Flower) -> Maybe Flower
forall a b. a -> (a -> b) -> b
& (Costar [] Measurements Measurements
-> Costar [] Flower (Maybe Flower)
AlgebraicLens Flower (Maybe Flower) Measurements Measurements
measurements (Costar [] Measurements Measurements
 -> Costar [] Flower (Maybe Flower))
-> Optic (Costar []) Measurements Measurements Float Float
-> Costar [] Float Float
-> Costar [] Flower (Maybe Flower)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic (Costar []) Measurements Measurements Float Float
Kaleidoscope' Measurements Float
aggregate (Costar [] Float Float -> Costar [] Flower (Maybe Flower))
-> ([Float] -> Float) -> [Flower] -> Maybe Flower
forall (f :: * -> *) s t a b.
Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
>- [Float] -> Float
forall a. Fractional a => [a] -> a
mean)
    -- We can use a list-lens as a setter over a single element
    -- print $ versicolor & measurements . aggregate %~ negate

    -- -- We can explicitly compare to a specific result
    -- print $ (flowers !! 1) ^. measurements
    -- print $ (flowers ?. measurements) $ Measurements [5, 4, 3, 1]
    -- print $ Measurements [5, 4, 3, 1] & (measurements .* flowers)
    -- print $ Measurements [5, 4, 3, 1] & measurements .* flowers

    -- -- We can provide an aggregator explicitly
    -- print $ mean & (flowers >- measurements . aggregate)
    -- print $ flowers & measurements >- avgMeasurement
    -- print $ M.fromList [(1.2, setosa), (0.6, versicolor)] & measurements >- avgMeasurement . fmap (uncurry applyWeight) . M.toList
    -- print $ flowers & (measurements . aggregate *% mean)
    -- print $ flowers & (measurements . aggregate *% mean)
    -- print $ flowers & (measurements . aggregate *% maximum)
    -- print $ [[1, 2, 3], [1, 2, 3], [1, 2, 3]] & convolving *% id
    --


allMeasurements :: [[Float]]
allMeasurements :: [[Float]]
allMeasurements =
      [ [1  , 2  , 3  , 4  ]
      , [10 , 20 , 30 , 40 ]
      , [100, 200, 300, 400]
      ]

measurementMap :: M.Map String (ZipList Float)
measurementMap :: Map String (ZipList Float)
measurementMap = [(String, ZipList Float)] -> Map String (ZipList Float)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ ("setosa"    , [Float] -> ZipList Float
forall a. [a] -> ZipList a
ZipList [1  , 2  , 3  , 4  ])
      , ("versicolor", [Float] -> ZipList Float
forall a. [a] -> ZipList a
ZipList [10 , 20 , 30 , 40 ])
      , ("virginica" , [Float] -> ZipList Float
forall a. [a] -> ZipList a
ZipList [100, 200, 300, 400])
      ]