Move Bucket code to a separate file ♻️

palette-generator/Bucket.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Bucket
+  ( Bucket
+  , emptyBucket
+  , insertToBucket
+  , bucketSize
+  , bucketAverage
+  , Buckets
+  , emptyBuckets
+  , makeBuckets
+  , makeBuckets'
+  ) where
+
+import Data.Map ( Map )
+import qualified Data.Map as Map
+import RGBHSV ( HSV(HSV) )
+
+data Bucket a = Bucket Int a a a
+
+emptyBucket :: (Num a) => Bucket a
+emptyBucket = Bucket 0 0 0 0
+
+insertToBucket :: (Num a) => HSV a -> Bucket a -> Bucket a
+insertToBucket (HSV h s v) (Bucket count h' s' v')
+  = Bucket (count + 1) (h' + h) (s' + s) (v' + v)
+
+bucketSize :: Bucket a -> Int
+bucketSize (Bucket size _ _ _) = size
+
+bucketAverage :: (Fractional a) => Bucket a -> HSV a
+bucketAverage (Bucket size h' s' v')
+  = HSV (h' / size') (s' / size') (v' / size')
+  where size' = fromIntegral size
+
+type Buckets a = Map Int (Bucket a)
+
+emptyBuckets :: (Num a) => Buckets a
+emptyBuckets = Map.fromList [(x, emptyBucket) | x <- [0..8]]
+
+makeBuckets :: forall a. (Fractional a, Num a, RealFrac a) =>
+               (HSV a -> a) -> Int -> [HSV a] -> Buckets a
+makeBuckets f numberOfBuckets = foldr allocateToBucket emptyBuckets
+
+  where allocateToBucket :: (Fractional a, Num a, RealFrac a) =>
+                            HSV a -> Buckets a -> Buckets a
+        allocateToBucket colour = Map.adjust (insertToBucket colour) bucket
+          where bucket = floor $ fromIntegral numberOfBuckets * f colour
+
+makeBuckets' :: forall a. (Fractional a, Num a, RealFrac a) =>
+                (HSV a -> a) -> Int -> [HSV a] -> [Bucket a]
+makeBuckets' f numberOfBuckets = Map.elems . makeBuckets f numberOfBuckets

palette-generator/Main.hs

@@ -1,8 +1,7 @@
+import Bucket ( Bucket, bucketAverage, bucketSize, makeBuckets' )
 import Codec.Picture ( DynamicImage, Image(imageWidth, imageHeight), PixelRGB8(PixelRGB8), convertRGB8, pixelAt, readImage )
 import Data.Bifunctor ( second )
 import Data.List ( sortOn )
-import Data.Map ( Map )
-import qualified Data.Map as Map
 import Data.Word ( Word8 )
 import RGBHSV ( HSV(HSV), RGB(RGB), hsvToRgb, rgbToHsv )
 import System.Environment ( getArgs )
@@ -36,43 +35,17 @@ makeOutputTable = toJSObject . concatMap makeOutputs
                   b' :: Word8
                   b' = round b
 
-data Bin a = Bin Int a a a
-type Bins a = Map Int (Bin a)
-
 selectColours :: [HSV Float] -> [(String, HSV Float)]
 selectColours image = zip names palette
 
   where names :: [String]
         names = map (printf "base%02X") ([0..15] :: [Int])
 
-        emptyBin :: (Num a) => Bin a
-        emptyBin = Bin 0 0 0 0
-
-        emptyBins :: (Num a) => Bins a
-        emptyBins = Map.fromList [(x, emptyBin) | x <- [0..8]]
-
-        insertToBin :: (Num a) => HSV a -> Bin a -> Bin a
-        insertToBin (HSV h s v) (Bin count h' s' v')
-          = Bin (count + 1) (h' + h) (s' + s) (v' + v)
-
-        allocateToBin :: (Fractional a, Num a, RealFrac a) => HSV a -> Bins a -> Bins a
-        allocateToBin colour = Map.adjust (insertToBin colour) bin
-          where (HSV h _ _) = colour
-                bin = floor $ (h / 6) * 9
-
-        bins :: Bins Float
-        bins = foldr allocateToBin emptyBins image
-
-        binSize :: Bin a -> Int
-        binSize (Bin size _ _ _) = size
-
-        averageColour :: (Fractional a) => Bin a -> HSV a
-        averageColour (Bin size h' s' v')
-          = HSV (h' / size') (s' / size') (v' / size')
-          where size' = fromIntegral size
+        buckets :: [Bucket Float]
+        buckets = makeBuckets' (\(HSV h _ _) -> h / 6) 9 image
 
         shortlist :: [HSV Float]
-        shortlist = map averageColour $ sortOn binSize $ Map.elems bins
+        shortlist = map bucketAverage $ sortOn bucketSize buckets
 
         primaryScale :: [HSV Float]
         primaryScale = [HSV h s (v / 8) | v <- [1..8]]