KMeansCommon.hs

{-# LANGUAGE DeriveDataTypeable #-}
module KMeansCommon where

import Data.List (foldl')
import Data.Typeable (Typeable)
import Data.Data (Data)
import Data.Binary
import Data.Array.Unboxed
import qualified Data.ByteString.Lazy as B
import Debug.Trace

-- Change this and recompile to change the cardinality of the data set!
vectorSize :: Int
vectorSize = 100

type ClusterId = Int
data Vector = Vector !(UArray Int Double) deriving (Typeable,Eq)
instance Binary Vector where put (Vector a) = put a
                             get = do a<-get
                                      return $ Vector a

instance Read Vector where
  readsPrec i a = let f = readsPrec i a
              in [(Vector $! listArray (0,vectorSize-1) (fst $ head f),snd $ head f)]

instance Show Vector where
   showsPrec _ (Vector a) = showList $ elems a
  

data Cluster = Cluster
               {
                  clId :: !ClusterId,
                  clCount :: !Int,
                  clSum :: !Vector
               } deriving (Show,Read,Typeable,Eq)
instance Binary Cluster where put (Cluster a b c) = put a>>put b>>put c
                              get = do a<-get
                                       b<-get
                                       c<-get
                                       return $ Cluster a b c

clusterCenter :: Cluster -> Vector
clusterCenter cl = let (Vector arr) = clSum cl
                       count = fromIntegral $ clCount cl
                       newelems = case count of
                                     0 -> replicate (vectorSize) 0
                                     _ -> map (\d -> d / count) (elems arr)
                    in Vector $ listArray (bounds arr) newelems

sqDistance :: Vector -> Vector -> Double
sqDistance (Vector a1) (Vector a2) = sum $ map (\(a,b) -> let dif = a-b in dif*dif) (zip (elems a1) (elems a2))

makeCluster :: ClusterId -> [Vector] -> Cluster
makeCluster clid vecs = Cluster {clId = clid, clCount = length vecs, clSum = vecsum}
   where vecsum = Vector sumArray
         sumArray = listArray (0,vectorSize-1) [ sum $ map ((flip(!))i) (map unVector vecs) | i<-[0..vectorSize-1] ]
         unVector (Vector x) = x


addCluster :: Cluster -> Cluster -> Cluster
addCluster (Cluster aclid acount asum) (Cluster bclid bcount bsum) = Cluster aclid (acount+bcount) (addVector asum bsum)

addToCluster :: Cluster -> Vector -> Cluster
addToCluster (Cluster aclid acount asum) v = Cluster aclid (acount+1) (addVector asum v)

addVector :: Vector -> Vector -> Vector
addVector (Vector a ) (Vector b) = Vector $! listArray (bounds a) (map (\(a,b) -> a+b) (zip (elems a) (elems b)))

zeroVector :: Vector -> Vector
zeroVector (Vector a) = Vector $! listArray (bounds a) (repeat 0)

getPoints :: FilePath -> IO [Vector]
getPoints fp = do c <- readFile fp
                  return $ read c

getPoints2 :: FilePath -> IO [Vector]
getPoints2 fp = do c <- readFile fp
                   return $ glom (lines c)
     where glom [] = []
           glom (line:rest) = read line : glom rest

getClusters :: FilePath -> IO [Cluster]
getClusters fp = do c <- readFile fp
                    return $ read c