{-# 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
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 :: 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
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 :: 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
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 :: 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
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)
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])
]