{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.ColorQuant
( palettize
, palettizeWithAlpha
, defaultPaletteOptions
, PaletteCreationMethod(..)
, PaletteOptions( .. )
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative (..), (<$>))
#endif
import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))
import Data.List (elemIndex)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word32)
import Data.Vector (Vector, (!))
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Storable as VS
import Codec.Picture.Types
import Codec.Picture.Gif (GifFrame(..), GifDisposalMethod, GifDelay)
data PaletteCreationMethod =
MedianMeanCut
| Uniform
data PaletteOptions = PaletteOptions
{
PaletteOptions -> PaletteCreationMethod
paletteCreationMethod :: PaletteCreationMethod
, PaletteOptions -> Bool
enableImageDithering :: Bool
, PaletteOptions -> Int
paletteColorCount :: Int
}
defaultPaletteOptions :: PaletteOptions
defaultPaletteOptions :: PaletteOptions
defaultPaletteOptions = PaletteOptions
{ paletteCreationMethod :: PaletteCreationMethod
paletteCreationMethod = PaletteCreationMethod
MedianMeanCut
, enableImageDithering :: Bool
enableImageDithering = Bool
True
, paletteColorCount :: Int
paletteColorCount = Int
256
}
alphaToBlack :: Image PixelRGBA8 -> Image PixelRGB8
alphaToBlack :: Image PixelRGBA8 -> Image PixelRGB8
alphaToBlack = forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGBA8 -> PixelRGB8
f
where f :: PixelRGBA8 -> PixelRGB8
f (PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
a) =
if Pixel8
a forall a. Eq a => a -> a -> Bool
== Pixel8
0 then Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
0
else Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b
alphaTo255 :: Image Pixel8 -> Image PixelRGBA8 -> Pixel8 -> Image Pixel8
alphaTo255 :: Image Pixel8 -> Image PixelRGBA8 -> Pixel8 -> Image Pixel8
alphaTo255 Image Pixel8
img1 Image PixelRGBA8
img2 Pixel8
transparentIndex = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> Pixel8
f (forall a. Image a -> Int
imageWidth Image Pixel8
img1) (forall a. Image a -> Int
imageHeight Image PixelRGBA8
img2)
where f :: Int -> Int -> Pixel8
f Int
x Int
y =
if Pixel8
a forall a. Eq a => a -> a -> Bool
== Pixel8
0 then Pixel8
transparentIndex
else Pixel8
v
where v :: Pixel8
v = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image Pixel8
img1 Int
x Int
y
PixelRGBA8 Pixel8
_ Pixel8
_ Pixel8
_ Pixel8
a = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
img2 Int
x Int
y
palettizeWithAlpha :: [(GifDelay, Image PixelRGBA8)] -> GifDisposalMethod -> [GifFrame]
palettizeWithAlpha :: [(Int, Image PixelRGBA8)] -> GifDisposalMethod -> [GifFrame]
palettizeWithAlpha [] GifDisposalMethod
_ = []
palettizeWithAlpha ((Int, Image PixelRGBA8)
x:[(Int, Image PixelRGBA8)]
xs) GifDisposalMethod
dispose =
Int
-> Int
-> Maybe (Image PixelRGB8)
-> Maybe Int
-> Int
-> GifDisposalMethod
-> Image Pixel8
-> GifFrame
GifFrame
Int
0
Int
0
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Image PixelRGB8
palet)
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
transparentIndex)
Int
delay
GifDisposalMethod
dispose
(Image Pixel8 -> Image PixelRGBA8 -> Pixel8 -> Image Pixel8
alphaTo255 Image Pixel8
pixels Image PixelRGBA8
i (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
transparentIndex))
forall a. a -> [a] -> [a]
: [(Int, Image PixelRGBA8)] -> GifDisposalMethod -> [GifFrame]
palettizeWithAlpha [(Int, Image PixelRGBA8)]
xs GifDisposalMethod
dispose
where (Int
delay, Image PixelRGBA8
i) = (Int, Image PixelRGBA8)
x
img :: Image PixelRGB8
img = Image PixelRGBA8 -> Image PixelRGB8
alphaToBlack Image PixelRGBA8
i
(Image PixelRGB8
palet, Image Pixel8
pixels) =
if Bool
isBelow
then (Vector PixelRGB8 -> Image PixelRGB8
vecToPalette (Vector PixelRGB8
belowPaletteVec forall a. Vector a -> a -> Vector a
`V.snoc` Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
0), forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
belowPaletteIndex Image PixelRGB8
img)
else (Vector PixelRGB8 -> Image PixelRGB8
vecToPalette (Vector PixelRGB8
genPaletteVec forall a. Vector a -> a -> Vector a
`V.snoc` Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
0), forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
genPaletteIndex Image PixelRGB8
img)
(Set PixelRGB8
belowPalette, Bool
isBelow) = Int -> Image PixelRGB8 -> (Set PixelRGB8, Bool)
isColorCountBelow Int
255 Image PixelRGB8
img
belowPaletteVec :: Vector PixelRGB8
belowPaletteVec = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PixelRGB8
belowPalette
belowPaletteIndex :: PixelRGB8 -> Pixel8
belowPaletteIndex PixelRGB8
p = PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx PixelRGB8
p Vector PixelRGB8
belowPaletteVec
cs :: [Cluster]
cs = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Image PixelRGB8 -> Set Cluster
clusters Int
255 forall a b. (a -> b) -> a -> b
$ Image PixelRGB8
img
genPaletteVec :: Vector PixelRGB8
genPaletteVec = [Cluster] -> Vector PixelRGB8
mkPaletteVec [Cluster]
cs
genPaletteIndex :: PixelRGB8 -> Pixel8
genPaletteIndex PixelRGB8
p = PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx PixelRGB8
p Vector PixelRGB8
genPaletteVec
transparentIndex :: Int
transparentIndex = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ if Bool
isBelow then Vector PixelRGB8
belowPaletteVec else Vector PixelRGB8
genPaletteVec
palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)
palettize :: PaletteOptions
-> Image PixelRGB8 -> (Image Pixel8, Image PixelRGB8)
palettize opts :: PaletteOptions
opts@PaletteOptions { paletteCreationMethod :: PaletteOptions -> PaletteCreationMethod
paletteCreationMethod = PaletteCreationMethod
method } =
case PaletteCreationMethod
method of
PaletteCreationMethod
MedianMeanCut -> PaletteOptions
-> Image PixelRGB8 -> (Image Pixel8, Image PixelRGB8)
medianMeanCutQuantization PaletteOptions
opts
PaletteCreationMethod
Uniform -> PaletteOptions
-> Image PixelRGB8 -> (Image Pixel8, Image PixelRGB8)
uniformQuantization PaletteOptions
opts
medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8
-> (Image Pixel8, Palette)
medianMeanCutQuantization :: PaletteOptions
-> Image PixelRGB8 -> (Image Pixel8, Image PixelRGB8)
medianMeanCutQuantization PaletteOptions
opts Image PixelRGB8
img
| Bool
isBelow =
(forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
okPaletteIndex Image PixelRGB8
img, Vector PixelRGB8 -> Image PixelRGB8
vecToPalette Vector PixelRGB8
okPaletteVec)
| PaletteOptions -> Bool
enableImageDithering PaletteOptions
opts = (forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
paletteIndex Image PixelRGB8
dImg, Image PixelRGB8
palette)
| Bool
otherwise = (forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
paletteIndex Image PixelRGB8
img, Image PixelRGB8
palette)
where
maxColorCount :: Int
maxColorCount = PaletteOptions -> Int
paletteColorCount PaletteOptions
opts
(Set PixelRGB8
okPalette, Bool
isBelow) = Int -> Image PixelRGB8 -> (Set PixelRGB8, Bool)
isColorCountBelow Int
maxColorCount Image PixelRGB8
img
okPaletteVec :: Vector PixelRGB8
okPaletteVec = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PixelRGB8
okPalette
okPaletteIndex :: PixelRGB8 -> Pixel8
okPaletteIndex PixelRGB8
p = PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx PixelRGB8
p Vector PixelRGB8
okPaletteVec
palette :: Image PixelRGB8
palette = Vector PixelRGB8 -> Image PixelRGB8
vecToPalette Vector PixelRGB8
paletteVec
paletteIndex :: PixelRGB8 -> Pixel8
paletteIndex PixelRGB8
p = PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx PixelRGB8
p Vector PixelRGB8
paletteVec
paletteVec :: Vector PixelRGB8
paletteVec = [Cluster] -> Vector PixelRGB8
mkPaletteVec [Cluster]
cs
cs :: [Cluster]
cs = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Image PixelRGB8 -> Set Cluster
clusters Int
maxColorCount forall a b. (a -> b) -> a -> b
$ Image PixelRGB8
img
dImg :: Image PixelRGB8
dImg = forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY Int -> Int -> PixelRGB8 -> PixelRGB8
dither Image PixelRGB8
img
uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)
uniformQuantization :: PaletteOptions
-> Image PixelRGB8 -> (Image Pixel8, Image PixelRGB8)
uniformQuantization PaletteOptions
opts Image PixelRGB8
img
| PaletteOptions -> Bool
enableImageDithering PaletteOptions
opts =
(forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
paletteIndex (forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY Int -> Int -> PixelRGB8 -> PixelRGB8
dither Image PixelRGB8
img), Image PixelRGB8
palette)
| Bool
otherwise = (forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGB8 -> Pixel8
paletteIndex Image PixelRGB8
img, Image PixelRGB8
palette)
where
maxCols :: Int
maxCols = PaletteOptions -> Int
paletteColorCount PaletteOptions
opts
palette :: Image PixelRGB8
palette = [PixelRGB8] -> Image PixelRGB8
listToPalette [PixelRGB8]
paletteList
paletteList :: [PixelRGB8]
paletteList = [Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b | Pixel8
r <- [Pixel8
0,Pixel8
dr..Pixel8
255]
, Pixel8
g <- [Pixel8
0,Pixel8
dg..Pixel8
255]
, Pixel8
b <- [Pixel8
0,Pixel8
db..Pixel8
255]]
(Int
bg, Int
br, Int
bb) = Int -> (Int, Int, Int)
bitDiv3 Int
maxCols
(Pixel8
dr, Pixel8
dg, Pixel8
db) = (Pixel8
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
8forall a. Num a => a -> a -> a
-Int
br), Pixel8
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
8forall a. Num a => a -> a -> a
-Int
bg), Pixel8
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
8forall a. Num a => a -> a -> a
-Int
bb))
paletteIndex :: PixelRGB8 -> Pixel8
paletteIndex (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
0 (forall a. Eq a => a -> [a] -> Maybe Int
elemIndex
(Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 (Pixel8
r forall a. Bits a => a -> a -> a
.&. forall a. Num a => a -> a
negate Pixel8
dr) (Pixel8
g forall a. Bits a => a -> a -> a
.&. forall a. Num a => a -> a
negate Pixel8
dg) (Pixel8
b forall a. Bits a => a -> a -> a
.&. forall a. Num a => a -> a
negate Pixel8
db))
[PixelRGB8]
paletteList)
isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool)
isColorCountBelow :: Int -> Image PixelRGB8 -> (Set PixelRGB8, Bool)
isColorCountBelow Int
maxColorCount Image PixelRGB8
img = Int -> Set PixelRGB8 -> (Set PixelRGB8, Bool)
go Int
0 forall a. Set a
Set.empty
where rawData :: Vector (PixelBaseComponent PixelRGB8)
rawData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGB8
img
maxIndex :: Int
maxIndex = forall a. Storable a => Vector a -> Int
VS.length Vector (PixelBaseComponent PixelRGB8)
rawData
go :: Int -> Set PixelRGB8 -> (Set PixelRGB8, Bool)
go !Int
idx !Set PixelRGB8
allColors
| forall a. Set a -> Int
Set.size Set PixelRGB8
allColors forall a. Ord a => a -> a -> Bool
> Int
maxColorCount = (forall a. Set a
Set.empty, Bool
False)
| Int
idx forall a. Ord a => a -> a -> Bool
>= Int
maxIndex forall a. Num a => a -> a -> a
- Int
2 = (Set PixelRGB8
allColors, Bool
True)
| Bool
otherwise = Int -> Set PixelRGB8 -> (Set PixelRGB8, Bool)
go (Int
idx forall a. Num a => a -> a -> a
+ Int
3) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert PixelRGB8
px Set PixelRGB8
allColors
where px :: PixelRGB8
px = forall a. Pixel a => Vector (PixelBaseComponent a) -> Int -> a
unsafePixelAt Vector (PixelBaseComponent PixelRGB8)
rawData Int
idx
vecToPalette :: Vector PixelRGB8 -> Palette
vecToPalette :: Vector PixelRGB8 -> Image PixelRGB8
vecToPalette Vector PixelRGB8
ps = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
x Int
_ -> Vector PixelRGB8
ps forall a. Vector a -> Int -> a
! Int
x) (forall a. Vector a -> Int
V.length Vector PixelRGB8
ps) Int
1
listToPalette :: [PixelRGB8] -> Palette
listToPalette :: [PixelRGB8] -> Image PixelRGB8
listToPalette [PixelRGB8]
ps = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
x Int
_ -> [PixelRGB8]
ps forall a. [a] -> Int -> a
!! Int
x) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PixelRGB8]
ps) Int
1
bitDiv3 :: Int -> (Int, Int, Int)
bitDiv3 :: Int -> (Int, Int, Int)
bitDiv3 Int
n = case Int
r of
Int
0 -> (Int
q, Int
q, Int
q)
Int
1 -> (Int
qforall a. Num a => a -> a -> a
+Int
1, Int
q, Int
q)
Int
_ -> (Int
qforall a. Num a => a -> a -> a
+Int
1, Int
qforall a. Num a => a -> a -> a
+Int
1, Int
q)
where
r :: Int
r = Int
m forall a. Integral a => a -> a -> a
`mod` Int
3
q :: Int
q = Int
m forall a. Integral a => a -> a -> a
`div` Int
3
m :: Int
m = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a -> a
logBase (Double
2 :: Double) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
dither :: Int -> Int -> PixelRGB8 -> PixelRGB8
dither :: Int -> Int -> PixelRGB8 -> PixelRGB8
dither Int
x Int
y (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r')
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g')
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b')
where
r' :: Int
r' = forall a. Ord a => a -> a -> a
min Int
255 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r forall a. Num a => a -> a -> a
+ (Int
x' forall a. Num a => a -> a -> a
+ Int
y') forall a. Bits a => a -> a -> a
.&. Int
16)
g' :: Int
g' = forall a. Ord a => a -> a -> a
min Int
255 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g forall a. Num a => a -> a -> a
+ (Int
x' forall a. Num a => a -> a -> a
+ Int
y' forall a. Num a => a -> a -> a
+ Int
7973) forall a. Bits a => a -> a -> a
.&. Int
16)
b' :: Int
b' = forall a. Ord a => a -> a -> a
min Int
255 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b forall a. Num a => a -> a -> a
+ (Int
x' forall a. Num a => a -> a -> a
+ Int
y' forall a. Num a => a -> a -> a
+ Int
15946) forall a. Bits a => a -> a -> a
.&. Int
16)
x' :: Int
x' = Int
119 forall a. Num a => a -> a -> a
* Int
x
y' :: Int
y' = Int
28084 forall a. Num a => a -> a -> a
* Int
y
data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)
fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b
fold :: forall b. Fold PackedRGB b -> Vector PackedRGB -> b
fold (Fold x -> PackedRGB -> x
step x
begin x -> b
done) = x -> b
done forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
VU.foldl' x -> PackedRGB -> x
step x
begin
{-# INLINE fold #-}
data Pair a b = Pair !a !b
instance Functor (Fold a) where
fmap :: forall a b. (a -> b) -> Fold a a -> Fold a b
fmap a -> b
f (Fold x -> a -> x
step x
begin x -> a
done) = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold x -> a -> x
step x
begin (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> a
done)
{-# INLINABLE fmap #-}
instance Applicative (Fold a) where
pure :: forall a. a -> Fold a a
pure a
b = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold (\() a
_ -> ()) () (\() -> a
b)
{-# INLINABLE pure #-}
(Fold x -> a -> x
stepL x
beginL x -> a -> b
doneL) <*> :: forall a b. Fold a (a -> b) -> Fold a a -> Fold a b
<*> (Fold x -> a -> x
stepR x
beginR x -> a
doneR) =
let step :: Pair x x -> a -> Pair x x
step (Pair x
xL x
xR) a
a = forall a b. a -> b -> Pair a b
Pair (x -> a -> x
stepL x
xL a
a) (x -> a -> x
stepR x
xR a
a)
begin :: Pair x x
begin = forall a b. a -> b -> Pair a b
Pair x
beginL x
beginR
done :: Pair x x -> b
done (Pair x
xL x
xR) = x -> a -> b
doneL x
xL forall a b. (a -> b) -> a -> b
$ x -> a
doneR x
xR
in forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold Pair x x -> a -> Pair x x
step Pair x x
begin Pair x x -> b
done
{-# INLINABLE (<*>) #-}
intLength :: Fold a Int
intLength :: forall a. Fold a Int
intLength = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold (\Int
n a
_ -> Int
n forall a. Num a => a -> a -> a
+ Int
1) Int
0 forall a. a -> a
id
mkPaletteVec :: [Cluster] -> Vector PixelRGB8
mkPaletteVec :: [Cluster] -> Vector PixelRGB8
mkPaletteVec = forall a. [a] -> Vector a
V.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (PixelRGBF -> PixelRGB8
toRGB8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cluster -> PixelRGBF
meanColor)
type PackedRGB = Word32
data Cluster = Cluster
{ Cluster -> PixelF
value :: {-# UNPACK #-} !Float
, Cluster -> PixelRGBF
meanColor :: !PixelRGBF
, Cluster -> PixelRGBF
dims :: !PixelRGBF
, Cluster -> Vector PackedRGB
colors :: VU.Vector PackedRGB
}
instance Eq Cluster where
Cluster
a == :: Cluster -> Cluster -> Bool
== Cluster
b =
(Cluster -> PixelF
value Cluster
a, Cluster -> PixelRGBF
meanColor Cluster
a, Cluster -> PixelRGBF
dims Cluster
a) forall a. Eq a => a -> a -> Bool
== (Cluster -> PixelF
value Cluster
b, Cluster -> PixelRGBF
meanColor Cluster
b, Cluster -> PixelRGBF
dims Cluster
b)
instance Ord Cluster where
compare :: Cluster -> Cluster -> Ordering
compare Cluster
a Cluster
b =
forall a. Ord a => a -> a -> Ordering
compare (Cluster -> PixelF
value Cluster
a, Cluster -> PixelRGBF
meanColor Cluster
a, Cluster -> PixelRGBF
dims Cluster
a) (Cluster -> PixelF
value Cluster
b, Cluster -> PixelRGBF
meanColor Cluster
b, Cluster -> PixelRGBF
dims Cluster
b)
data Axis = RAxis | GAxis | BAxis
inf :: Float
inf :: PixelF
inf = forall a. Read a => String -> a
read String
"Infinity"
fromRGB8 :: PixelRGB8 -> PixelRGBF
fromRGB8 :: PixelRGB8 -> PixelRGBF
fromRGB8 (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) =
PixelF -> PixelF -> PixelF -> PixelRGBF
PixelRGBF (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b)
toRGB8 :: PixelRGBF -> PixelRGB8
toRGB8 :: PixelRGBF -> PixelRGB8
toRGB8 (PixelRGBF PixelF
r PixelF
g PixelF
b) =
Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 (forall a b. (RealFrac a, Integral b) => a -> b
round PixelF
r) (forall a b. (RealFrac a, Integral b) => a -> b
round PixelF
g) (forall a b. (RealFrac a, Integral b) => a -> b
round PixelF
b)
meanRGB :: Fold PixelRGBF PixelRGBF
meanRGB :: Fold PixelRGBF PixelRGBF
meanRGB = forall {a} {a}.
(Integral a, Pixel a, Fractional (PixelBaseComponent a)) =>
a -> a -> a
mean forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Fold a Int
intLength forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fold PixelRGBF PixelRGBF
pixelSum
where
pixelSum :: Fold PixelRGBF PixelRGBF
pixelSum = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold (forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
mixWith forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Num a => a -> a -> a
(+)) (PixelF -> PixelF -> PixelF -> PixelRGBF
PixelRGBF PixelF
0 PixelF
0 PixelF
0) forall a. a -> a
id
mean :: a -> a -> a
mean a
n = forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (forall a. Fractional a => a -> a -> a
/ PixelBaseComponent a
nf)
where nf :: PixelBaseComponent a
nf = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
minimal :: Fold PixelRGBF PixelRGBF
minimal :: Fold PixelRGBF PixelRGBF
minimal = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold PixelRGBF -> PixelRGBF -> PixelRGBF
mini (PixelF -> PixelF -> PixelF -> PixelRGBF
PixelRGBF PixelF
inf PixelF
inf PixelF
inf) forall a. a -> a
id
where mini :: PixelRGBF -> PixelRGBF -> PixelRGBF
mini = forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
mixWith forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Ord a => a -> a -> a
min
maximal :: Fold PixelRGBF PixelRGBF
maximal :: Fold PixelRGBF PixelRGBF
maximal = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold PixelRGBF -> PixelRGBF -> PixelRGBF
maxi (PixelF -> PixelF -> PixelF -> PixelRGBF
PixelRGBF (-PixelF
inf) (-PixelF
inf) (-PixelF
inf)) forall a. a -> a
id
where maxi :: PixelRGBF -> PixelRGBF -> PixelRGBF
maxi = forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
mixWith forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Ord a => a -> a -> a
max
extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF)
extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF)
extrems = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fold PixelRGBF PixelRGBF
minimal forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fold PixelRGBF PixelRGBF
maximal
volAndDims :: Fold PixelRGBF (Float, PixelRGBF)
volAndDims :: Fold PixelRGBF (PixelF, PixelRGBF)
volAndDims = (PixelRGBF, PixelRGBF) -> (PixelF, PixelRGBF)
deltify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fold PixelRGBF (PixelRGBF, PixelRGBF)
extrems
where deltify :: (PixelRGBF, PixelRGBF) -> (PixelF, PixelRGBF)
deltify (PixelRGBF
mini, PixelRGBF
maxi) = (PixelF
dr forall a. Num a => a -> a -> a
* PixelF
dg forall a. Num a => a -> a -> a
* PixelF
db, PixelRGBF
delta)
where delta :: PixelRGBF
delta@(PixelRGBF PixelF
dr PixelF
dg PixelF
db) =
forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> a -> a -> a
mixWith (forall a b. a -> b -> a
const (-)) PixelRGBF
maxi PixelRGBF
mini
unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a
unpackFold :: forall a. Fold PixelRGBF a -> Fold PackedRGB a
unpackFold (Fold x -> PixelRGBF -> x
step x
start x -> a
done) = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold (\x
acc -> x -> PixelRGBF -> x
step x
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedRGB -> PixelRGBF
transform) x
start x -> a
done
where transform :: PackedRGB -> PixelRGBF
transform = PixelRGB8 -> PixelRGBF
fromRGB8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedRGB -> PixelRGB8
rgbIntUnpack
mkCluster :: VU.Vector PackedRGB -> Cluster
mkCluster :: Vector PackedRGB -> Cluster
mkCluster Vector PackedRGB
ps = Cluster
{ value :: PixelF
value = PixelF
v forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
, meanColor :: PixelRGBF
meanColor = PixelRGBF
m
, dims :: PixelRGBF
dims = PixelRGBF
ds
, colors :: Vector PackedRGB
colors = Vector PackedRGB
ps
}
where
worker :: Fold PixelRGBF ((PixelF, PixelRGBF), PixelRGBF, Int)
worker = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fold PixelRGBF (PixelF, PixelRGBF)
volAndDims forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fold PixelRGBF PixelRGBF
meanRGB forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Fold a Int
intLength
((PixelF
v, PixelRGBF
ds), PixelRGBF
m, Int
l) = forall b. Fold PackedRGB b -> Vector PackedRGB -> b
fold (forall a. Fold PixelRGBF a -> Fold PackedRGB a
unpackFold Fold PixelRGBF ((PixelF, PixelRGBF), PixelRGBF, Int)
worker) Vector PackedRGB
ps
maxAxis :: PixelRGBF -> Axis
maxAxis :: PixelRGBF -> Axis
maxAxis (PixelRGBF PixelF
r PixelF
g PixelF
b) =
case (PixelF
r forall a. Ord a => a -> a -> Ordering
`compare` PixelF
g, PixelF
r forall a. Ord a => a -> a -> Ordering
`compare` PixelF
b, PixelF
g forall a. Ord a => a -> a -> Ordering
`compare` PixelF
b) of
(Ordering
GT, Ordering
GT, Ordering
_) -> Axis
RAxis
(Ordering
LT, Ordering
GT, Ordering
_) -> Axis
GAxis
(Ordering
GT, Ordering
LT, Ordering
_) -> Axis
BAxis
(Ordering
LT, Ordering
LT, Ordering
GT) -> Axis
GAxis
(Ordering
EQ, Ordering
GT, Ordering
_) -> Axis
RAxis
(Ordering
_, Ordering
_, Ordering
_) -> Axis
BAxis
subdivide :: Cluster -> (Cluster, Cluster)
subdivide :: Cluster -> (Cluster, Cluster)
subdivide Cluster
cluster = (Vector PackedRGB -> Cluster
mkCluster Vector PackedRGB
px1, Vector PackedRGB -> Cluster
mkCluster Vector PackedRGB
px2)
where
(PixelRGBF PixelF
mr PixelF
mg PixelF
mb) = Cluster -> PixelRGBF
meanColor Cluster
cluster
(Vector PackedRGB
px1, Vector PackedRGB
px2) = forall a.
Unbox a =>
(a -> Bool) -> Vector a -> (Vector a, Vector a)
VU.partition (PixelRGB8 -> Bool
cond forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedRGB -> PixelRGB8
rgbIntUnpack) forall a b. (a -> b) -> a -> b
$ Cluster -> Vector PackedRGB
colors Cluster
cluster
cond :: PixelRGB8 -> Bool
cond = case PixelRGBF -> Axis
maxAxis forall a b. (a -> b) -> a -> b
$ Cluster -> PixelRGBF
dims Cluster
cluster of
Axis
RAxis -> \(PixelRGB8 Pixel8
r Pixel8
_ Pixel8
_) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r forall a. Ord a => a -> a -> Bool
< PixelF
mr
Axis
GAxis -> \(PixelRGB8 Pixel8
_ Pixel8
g Pixel8
_) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g forall a. Ord a => a -> a -> Bool
< PixelF
mg
Axis
BAxis -> \(PixelRGB8 Pixel8
_ Pixel8
_ Pixel8
b) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b forall a. Ord a => a -> a -> Bool
< PixelF
mb
rgbIntPack :: PixelRGB8 -> PackedRGB
rgbIntPack :: PixelRGB8 -> PackedRGB
rgbIntPack (PixelRGB8 Pixel8
r Pixel8
g Pixel8
b) =
PackedRGB
wr forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
2 forall a. Num a => a -> a -> a
* Int
8) forall a. Bits a => a -> a -> a
.|. PackedRGB
wg forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8 forall a. Bits a => a -> a -> a
.|. PackedRGB
wb
where wr :: PackedRGB
wr = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r
wg :: PackedRGB
wg = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g
wb :: PackedRGB
wb = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b
rgbIntUnpack :: PackedRGB -> PixelRGB8
rgbIntUnpack :: PackedRGB -> PixelRGB8
rgbIntUnpack PackedRGB
v = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b
where
r :: Pixel8
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PackedRGB
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` (Int
2 forall a. Num a => a -> a -> a
* Int
8)
g :: Pixel8
g = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PackedRGB
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8
b :: Pixel8
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral PackedRGB
v
initCluster :: Image PixelRGB8 -> Cluster
initCluster :: Image PixelRGB8 -> Cluster
initCluster Image PixelRGB8
img = Vector PackedRGB -> Cluster
mkCluster forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Int -> (Int -> a) -> Vector a
VU.generate ((Int
w forall a. Num a => a -> a -> a
* Int
h) forall a. Integral a => a -> a -> a
`div` Int
subSampling) Int -> PackedRGB
packer
where samplingFactor :: Int
samplingFactor = Int
3
subSampling :: Int
subSampling = Int
samplingFactor forall a. Num a => a -> a -> a
* Int
samplingFactor
compCount :: Int
compCount = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: PixelRGB8)
w :: Int
w = forall a. Image a -> Int
imageWidth Image PixelRGB8
img
h :: Int
h = forall a. Image a -> Int
imageHeight Image PixelRGB8
img
rawData :: Vector (PixelBaseComponent PixelRGB8)
rawData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGB8
img
packer :: Int -> PackedRGB
packer Int
ix =
PixelRGB8 -> PackedRGB
rgbIntPack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pixel a => Vector (PixelBaseComponent a) -> Int -> a
unsafePixelAt Vector (PixelBaseComponent PixelRGB8)
rawData forall a b. (a -> b) -> a -> b
$ Int
ix forall a. Num a => a -> a -> a
* Int
subSampling forall a. Num a => a -> a -> a
* Int
compCount
split :: Set Cluster -> Set Cluster
split :: Set Cluster -> Set Cluster
split Set Cluster
cs = forall a. Ord a => a -> Set a -> Set a
Set.insert Cluster
c1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> Set a -> Set a
Set.insert Cluster
c2 forall a b. (a -> b) -> a -> b
$ Set Cluster
cs'
where
(Cluster
c, Set Cluster
cs') = forall a. Set a -> (a, Set a)
Set.deleteFindMax Set Cluster
cs
(Cluster
c1, Cluster
c2) = Cluster -> (Cluster, Cluster)
subdivide Cluster
c
clusters :: Int -> Image PixelRGB8 -> Set Cluster
clusters :: Int -> Image PixelRGB8 -> Set Cluster
clusters Int
maxCols Image PixelRGB8
img = Int -> Set Cluster
clusters' (Int
maxCols forall a. Num a => a -> a -> a
- Int
1)
where
clusters' :: Int -> Set Cluster
clusters' :: Int -> Set Cluster
clusters' Int
0 = forall a. a -> Set a
Set.singleton Cluster
c
clusters' Int
n = Set Cluster -> Set Cluster
split (Int -> Set Cluster
clusters' (Int
nforall a. Num a => a -> a -> a
-Int
1))
c :: Cluster
c = Image PixelRGB8 -> Cluster
initCluster Image PixelRGB8
img
dist2Px :: PixelRGB8 -> PixelRGB8 -> Int
dist2Px :: PixelRGB8 -> PixelRGB8 -> Int
dist2Px (PixelRGB8 Pixel8
r1 Pixel8
g1 Pixel8
b1) (PixelRGB8 Pixel8
r2 Pixel8
g2 Pixel8
b2) = Int
drforall a. Num a => a -> a -> a
*Int
dr forall a. Num a => a -> a -> a
+ Int
dgforall a. Num a => a -> a -> a
*Int
dg forall a. Num a => a -> a -> a
+ Int
dbforall a. Num a => a -> a -> a
*Int
db
where
(Int
dr, Int
dg, Int
db) =
( forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
r2
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
g2
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
b2 )
nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8
nearestColorIdx PixelRGB8
p Vector PixelRGB8
ps = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Vector a -> Int
V.minIndex (forall a b. (a -> b) -> Vector a -> Vector b
V.map (PixelRGB8 -> PixelRGB8 -> Int
`dist2Px` PixelRGB8
p) Vector PixelRGB8
ps)