diff --git a/NLP/Alphabet/IMMC.hs b/NLP/Alphabet/IMMC.hs new file mode 100644 --- /dev/null +++ b/NLP/Alphabet/IMMC.hs @@ -0,0 +1,70 @@ + +-- | An implementation of @Int@-mapped @MultiChar@s with internalization. + +module NLP.Alphabet.IMMC where + +import Control.DeepSeq (NFData(..)) +import Data.Hashable +import Data.Stringable as SA +import Data.String as IS +import Data.Vector.Unboxed.Deriving +import GHC.Generics +import qualified Data.ByteString.Short as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import NLP.Alphabet.IMMC.Internal +import NLP.Alphabet.MultiChar (InternedMultiChar) + + + +-- * A somewhat fragile (?) encoding of multichars using the internalized +-- @Id@. Should only be used via it's wrapper. The mapped @Int@s are not +-- consecutive. + +newtype IMMC = IMMC { getIMMC :: Int } + deriving (Eq,Generic) + +derivingUnbox "IMMC" + [t| IMMC -> Int |] + [| getIMMC |] + [| IMMC |] + +instance Ord IMMC where + IMMC l `compare` IMMC r = immcBimapLookupInt l `compare` immcBimapLookupInt r + {-# Inline compare #-} + +immc :: InternedMultiChar -> IMMC +immc s = IMMC $! immcBimapAdd s +{-# Inline immc #-} + +instance IsString IMMC where + fromString = immc . IS.fromString + {-# Inline fromString #-} + +instance Show IMMC where + showsPrec p i r = showsPrec p (toString i) r + {-# Inline showsPrec #-} + +instance Read IMMC where + readsPrec p str = [ (immc $ IS.fromString s, y) | (s,y) <- readsPrec p str ] + {-# Inline readsPrec #-} + +instance Hashable IMMC + +instance Stringable IMMC where + toString = toString . immcBimapLookupInt . getIMMC + fromString = immc . SA.fromString + length = SA.length . immcBimapLookupInt . getIMMC + toText = toText . immcBimapLookupInt . getIMMC + fromText = immc . fromText + {-# Inline toString #-} + {-# Inline fromString #-} + {-# Inline length #-} + {-# Inline toText #-} + {-# Inline fromText #-} + +instance NFData IMMC where + rnf = rnf . getIMMC + {-# Inline rnf #-} + diff --git a/NLP/Alphabet/IMMC/Internal.hs b/NLP/Alphabet/IMMC/Internal.hs new file mode 100644 --- /dev/null +++ b/NLP/Alphabet/IMMC/Internal.hs @@ -0,0 +1,47 @@ + +-- | This module keeps a persistent @bimap@ between @InternedMultiChar@s +-- and @Int@s +-- +-- TODO make this a bimap @Text <-> Vector@. Compare performance when +-- printing backtracking results. (Do this after the Builder-based +-- backtracking is online) + +module NLP.Alphabet.IMMC.Internal where + +import Data.IORef (newIORef,IORef,readIORef,atomicWriteIORef,atomicModifyIORef') +import System.IO.Unsafe (unsafePerformIO,unsafeDupablePerformIO) + +import Data.Bijection.Hash (Bimap,empty,lookupL,lookupR,size,insert) + +import NLP.Alphabet.MultiChar + + + +immcBimap :: IORef (Bimap InternedMultiChar Int) +immcBimap = unsafePerformIO $ newIORef empty +{-# NoInline immcBimap #-} + +-- | Add @InternedMultiChar@ and return @Int@ key. Will return key for +-- existing string and thereby serves for lookup in left-to-right +-- direction. + +immcBimapAdd :: InternedMultiChar -> Int +immcBimapAdd k = unsafeDupablePerformIO $ do + m <- readIORef immcBimap + case lookupL m k of + Just i -> return i + Nothing -> do let s = size m + atomicModifyIORef' immcBimap $ \m -> (insert m (k,s) , s) +{-# Inline immcBimapAdd #-} + +-- | Lookup the @InternedMultiChar@ based on an @Int@ key. Unsafe totality +-- assumption. + +immcBimapLookupInt :: Int -> InternedMultiChar +immcBimapLookupInt r = seq r . unsafeDupablePerformIO $ do -- need to @seq r@, otherwise the lookup will sometimes find Nothing. + m <- readIORef immcBimap + case lookupR m r of + Just l -> return l + Nothing -> error "immcBimapLookupInt: totality assumption invalidated" +{-# Inline immcBimapLookupInt #-} + diff --git a/NLP/Alphabet/MultiChar.hs b/NLP/Alphabet/MultiChar.hs --- a/NLP/Alphabet/MultiChar.hs +++ b/NLP/Alphabet/MultiChar.hs @@ -1,78 +1,144 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | An alphabet, where each character is a short bytestring. -- -- Due to the overhead this incurs, we use 'ShortByteString's internally. We -- also provide an 'Interned' instance to further reduce overhead using -- hash-consing. --- --- TODO we'd like to use the @stringable@ library but it depends on --- @system-filepath@ which is not yet compatible with @text>=1@. module NLP.Alphabet.MultiChar where +import Control.DeepSeq (NFData(..)) import Data.Function (on) import Data.Hashable import Data.Interned -import Data.String -import qualified Data.ByteString.Short as S -import qualified Data.ByteString.Short.Internal as S +import Data.Interned.Internal (getCache) +import Data.Stringable +import Data.String (IsString) +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BS +import qualified Data.String as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Generics +import qualified Data.HashMap.Strict as HM +import qualified Data.Array as A +import Data.Typeable (Typeable) +import Data.Data (Data) +-- * 'MultiChar's capture UTF characters that are encoded using one or more +-- symbols. + -- | Interns a 'MultiChar' character. internMultiChar :: MultiChar -> MultiChar internMultiChar = uninternMultiChar . intern +{-# Inline internMultiChar #-} -- | Wrap a short bytestring. Read and Show instances behave like for normal -- strings. -newtype MultiChar = MultiChar { unMultiChar :: S.ShortByteString } - deriving (Eq,Ord) +newtype MultiChar = MultiChar { getMultiChar :: T.Text } + deriving (Eq,Ord,Generic,Data,Typeable) instance Show MultiChar where - showsPrec p (MultiChar ps) r = showsPrec p ps r + showsPrec p (MultiChar mc) r = showsPrec p (toString mc) r + {-# Inline showsPrec #-} instance Read MultiChar where readsPrec p str = [ (MultiChar x, y) | (x,y) <- readsPrec p str ] + {-# Inline readsPrec #-} -instance Hashable MultiChar where - hashWithSalt salt (MultiChar s@(S.SBS sbs)) = hashByteArrayWithSalt sbs 0 (S.length s) salt +instance Hashable MultiChar instance IsString MultiChar where - fromString = MultiChar . fromString + fromString = MultiChar . S.fromString + {-# Inline fromString #-} +instance Stringable MultiChar where + toString = T.unpack . getMultiChar + fromString = MultiChar . T.pack + length = T.length . getMultiChar + fromText = MultiChar + toText = getMultiChar + {-# Inline toString #-} + {-# Inline fromString #-} + {-# Inline length #-} + {-# Inline fromText #-} + {-# Inline toText #-} +instance NFData MultiChar where + rnf = rnf . getMultiChar + {-# Inline rnf #-} + + -- * Interned +-- | Interned 'MultiChar'. +-- +-- TODO Check 'Ord' instance. We @compare `on` uninternMultiChar@. + data InternedMultiChar = InternedMultiChar { internedMultiCharId :: {-# UNPACK #-} !Id , uninternMultiChar :: {-# UNPACK #-} !MultiChar } + deriving (Generic,Data,Typeable) instance IsString InternedMultiChar where - fromString = intern . fromString + fromString = intern . S.fromString + {-# Inline fromString #-} instance Eq InternedMultiChar where (==) = (==) `on` internedMultiCharId + {-# Inline (==) #-} instance Ord InternedMultiChar where - compare = compare `on` internedMultiCharId + compare = compare `on` uninternMultiChar -- internedMultiCharId + {-# Inline compare #-} +instance Read InternedMultiChar where + readsPrec p str = [ (intern x, y) | (x,y) <- readsPrec p str ] + {-# Inline readsPrec #-} + instance Show InternedMultiChar where showsPrec d (InternedMultiChar _ mc) = showsPrec d mc + {-# Inline showsPrec #-} +instance Hashable InternedMultiChar where + hashWithSalt salt = hashWithSalt salt . internedMultiCharId + hash = hash . internedMultiCharId + {-# Inline hashWithSalt #-} + {-# Inline hash #-} + instance Interned InternedMultiChar where type Uninterned InternedMultiChar = MultiChar newtype Description InternedMultiChar = DMC MultiChar deriving (Eq,Hashable) - describe = DMC + describe = DMC -- . MultiChar . T.copy . getMultiChar -- @DMC@ alone is type-correct. With 'T.copy' we make sure not to keep long @Text@s. TODO benchmark! identify = InternedMultiChar - cache = imcCache + cache = imcCache + {-# Inline describe #-} + {-# Inline identify #-} + {-# Inline cache #-} imcCache :: Cache InternedMultiChar imcCache = mkCache {-# NOINLINE imcCache #-} + +instance Stringable InternedMultiChar where + toString = toString . uninternMultiChar + fromString = intern . fromString + length = Data.Stringable.length . uninternMultiChar + toText = toText . uninternMultiChar + fromText = intern . fromText + {-# Inline toString #-} + {-# Inline fromString #-} + {-# Inline length #-} + {-# Inline toText #-} + {-# Inline fromText #-} + +instance NFData InternedMultiChar where + rnf (InternedMultiChar i c) = rnf i `seq` rnf c + {-# Inline rnf #-} diff --git a/NLP/Scoring/SimpleUnigram.hs b/NLP/Scoring/SimpleUnigram.hs new file mode 100644 --- /dev/null +++ b/NLP/Scoring/SimpleUnigram.hs @@ -0,0 +1,37 @@ + +-- | This module defines a simple scoring scheme based on pairs of unigrams. + +module NLP.Scoring.SimpleUnigram where + +import Data.HashTable.IO (BasicHashTable) +import qualified Data.HashTable.IO as H +import System.IO.Unsafe (unsafePerformIO) + +import NLP.Alphabet.IMMC + + + +-- | Score 'MultiChar's @x@ and @y@ based on the simple scoring system: (i) +-- lookup (x,y) and use the score if found; (ii) if (x,y) is not in the +-- database, then return the default matching 'defMatch' score if @x==y@, +-- otherwise return the default mismatch 'defMismatch' score. + +scoreUnigram :: SimpleScoring -> IMMC -> IMMC -> Double +scoreUnigram SimpleScoring {..} x y = + maybe (if x==y then defMatch else defMismatch) + id + (unsafePerformIO $ H.lookup simpleScore (x,y)) +{-# INLINE scoreUnigram #-} + +-- | Collect the hashtable and scalar values for simple scoring. + +data SimpleScoring = SimpleScoring + { simpleScore :: !(BasicHashTable (IMMC,IMMC) Double) + , gapScore :: !Double + , gapOpen :: !Double + , gapExtend :: !Double + , defMatch :: !Double + , defMismatch :: !Double + } + deriving (Show) + diff --git a/NLP/Scoring/SimpleUnigram/Default.hs b/NLP/Scoring/SimpleUnigram/Default.hs new file mode 100644 --- /dev/null +++ b/NLP/Scoring/SimpleUnigram/Default.hs @@ -0,0 +1,16 @@ + +module NLP.Scoring.SimpleUnigram.Default where + +import Data.FileEmbed (embedFile) +import Data.Text.Encoding (decodeUtf8) + +import NLP.Scoring.SimpleUnigram +import NLP.Scoring.SimpleUnigram.Import + + + +-- | Default simple unigram scores for a system of consonants, liquid +-- consonants, and vowels of arbitrary scale. + +clvDefaults = genSimpleScoring $ decodeUtf8 $(embedFile "scoring/simpleunigram.txt") + diff --git a/NLP/Scoring/SimpleUnigram/Import.hs b/NLP/Scoring/SimpleUnigram/Import.hs new file mode 100644 --- /dev/null +++ b/NLP/Scoring/SimpleUnigram/Import.hs @@ -0,0 +1,107 @@ + +module NLP.Scoring.SimpleUnigram.Import where + +import Control.Applicative +--import Data.ByteString.Char8 (ByteString) +import Data.HashTable.IO (BasicHashTable) +import Data.Stringable +--import qualified Data.Attoparsec.ByteString as AB +--import qualified Data.Attoparsec.ByteString.Char8 as AB hiding (takeWhile1,skipWhile) +--import qualified Data.ByteString.Char8 as B +import qualified Data.HashTable.IO as H +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.Attoparsec.Text as AT +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import NLP.Alphabet.IMMC +import NLP.Scoring.SimpleUnigram + + + +-- | Each parsed line gives a set of characters, or tells us a score. +-- +-- TODO add @LPimport@ which starts a recursive import (note: start by storing +-- the hash or whatever of the file to be imported so that we can comment on +-- circular imports) + +data ParsedLine + = PLset Text [IMMC] + | PLeq Text Double + | PLeqset Text [IMMC] + | PLinset Text Text Double + | PLgap Double + | PLgapopen Double + | PLgapextend Double + | PLdefmatch Double + | PLdefmismatch Double + | PLcomment Text + deriving (Show,Eq,Ord) + +-- | Here we simple parse individual lines. + +parseLine :: Text -> ParsedLine +parseLine l = case AT.parseOnly (go <* AT.endOfInput) l of + Left err -> error $ err ++ " " ++ show l + Right p -> p + where go = PLset <$ "Set" <*> wd <*> mc `AT.sepBy1` AT.skipSpace -- AB.skipWhile AB.isHorizontalSpace + <|> PLeq <$ "Eq" <*> wd <*> nm + <|> PLinset <$ "InSet" <*> wd <*> wd <*> nm + <|> PLgap <$ "Gap" <*> nm + <|> PLgapopen <$ "GapOpen" <*> nm + <|> PLgapextend <$ "GapExtend" <*> nm + <|> PLdefmatch <$ "Match" <*> nm + <|> PLdefmismatch <$ "Mismatch" <*> nm + <|> PLeqset <$ "EqSet" <*> wd <*> mc `AT.sepBy1` AT.skipSpace + <|> PLcomment <$ "--" <*> AT.takeText + wd = AT.skipSpace *> AT.takeWhile1 (not . AT.isHorizontalSpace) + mc = fromText <$> wd + nm = AT.skipSpace *> AT.double + +-- | Parses a bytestring to create a simple scoring. We don't do much error +-- checking, many of the bindings below will easily fail. +-- +-- TODO obviously: implement error-checking + +genSimpleScoring :: Text -> SimpleScoring +genSimpleScoring l = SimpleScoring t g go ge dm di + where + t = unsafePerformIO $ H.fromListWithSizeHint (Prelude.length ys) ys + ls = T.lines l + xs = map parseLine ls + ys = concatMap genPairs $ iss ++ eqs + sets = [s | s@(PLset _ _) <- xs] + eqss = [e | e@(PLeqset _ _) <- xs] + eqs = [e | e@(PLeq _ _) <- xs] + iss = [i | i@(PLinset _ _ _) <- xs] + [dm] = [dm | PLdefmatch dm <- xs] + [di] = [di | PLdefmismatch di <- xs] + [g] = [g | PLgap g <- xs] + [go] = [go | PLgapopen go <- xs] + [ge] = [ge | PLgapextend ge <- xs] + -- this generates all "equality pairs", i.e. that 'a' == 'a' + -- the second list generates all equivalence classes, say that 'a' == 'ã' + genPairs (PLeq x d) = let ss = lookupSet x + tt = lookupEqSet x + in [ ((s,s),d) | s <- ss ] ++ + [ ((s,t),d) | ts <- tt, s<-ts,t<-ts ] + -- this creates all variants of, say, vowel against vowel (but unequal) + genPairs (PLinset x y d) = let ss = lookupSet x + tt = lookupSet y in [ ((s,t),d) | s <- ss, t <- tt ] + -- find every character from an equivalence set + lookupEqSet k = let go [] = [] + go (PLeqset n xs:ss) = if k==n then xs : go ss else go ss + in go eqss + -- find every character from a certain class + lookupSet k = let go [] = [] + go (PLset n xs:ss) = if k==n then xs : go ss else go ss + go (PLeqset n xs:ss) = if k==n then xs : go ss else go ss + in case go $ sets ++ eqss of + xs -> concat xs + +-- | parse a simple scoring file. + +simpleScoreFromFile f = T.readFile f >>= return . genSimpleScoring + diff --git a/NaturalLanguageAlphabets.cabal b/NaturalLanguageAlphabets.cabal --- a/NaturalLanguageAlphabets.cabal +++ b/NaturalLanguageAlphabets.cabal @@ -1,38 +1,121 @@ name: NaturalLanguageAlphabets -version: 0.0.0.1 +version: 0.0.1.0 author: Christian Hoener zu Siederdissen -maintainer: choener@tbi.univie.ac.at -homepage: http://www.tbi.univie.ac.at/~choener/ -copyright: Christian Hoener zu Siederdissen, 2014 +maintainer: choener@bioinf.uni-leipzig.de +homepage: http://www.bioinf.uni-leipzig.de/~choener/ +copyright: Christian Hoener zu Siederdissen, 2014-2015 category: Natural Language Processing -synopsis: Alphabet and word representations license: BSD3 license-file: LICENSE build-type: Simple stability: experimental -cabal-version: >= 1.6.0 +cabal-version: >= 1.10.0 +tested-with: GHC == 7.8.4, GHC == 7.10.1 +synopsis: Alphabet and word representations description: Provides different encoding for characters and words in natural language processing. A character will often be encoded as a - bytestring as we deal with multi-symbol characters. + unicode text string as we deal with multi-symbol characters. + . + Internal encoding of IMMC symbols are 0-based integers, which + allows for the use of unboxed containers. + . + A very simple unigram-based scoring scheme is also provided. extra-source-files: - changelog + README.md + changelog.md + scoring/simpleunigram.txt + + +flag llvm + description: build the benchmark using LLVM + default: False + manual: True + + + library - build-depends: - base >3 && <5 , - bytestring >= 0.10.4 , - hashable >= 1.2 , - intern >= 0.9 , - unordered-containers >= 0.2.3 + build-depends: base > 4.7 && < 4.9 + , array >= 0.5 && < 0.6 + , attoparsec >= 0.10 && < 0.13 + , bimaps >= 0.0.0 && < 0.0.1 + , bytestring >= 0.10.4 + , deepseq >= 1.3 && < 1.5 + , file-embed >= 0.0.6 && < 0.0.9 + , hashable >= 1.2 && < 1.3 + , hashtables >= 1.1 && < 1.3 + , intern >= 0.9 && < 0.10 + , stringable >= 0.1.2 && < 0.2 + , system-filepath >= 0.4.9 && < 0.5 + , text >= 0.11 && < 1.3 + , unordered-containers >= 0.2.3 && < 0.3 + , vector >= 0.10 && < 0.11 + , vector-th-unbox >= 0.2 && < 0.3 exposed-modules: + NLP.Alphabet.IMMC + NLP.Alphabet.IMMC.Internal NLP.Alphabet.MultiChar + NLP.Scoring.SimpleUnigram + NLP.Scoring.SimpleUnigram.Default + NLP.Scoring.SimpleUnigram.Import + default-language: + Haskell2010 + + default-extensions: BangPatterns + , DeriveGeneric + , DeriveDataTypeable + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , OverloadedStrings + , RecordWildCards + , TemplateHaskell + , TypeFamilies + ghc-options: + -O2 -funbox-strict-fields + + + +benchmark BenchmarkNLA + build-depends: base + , containers + , criterion >= 1.0.2 && < 1.1.1 + , deepseq + , hashtables + , mwc-random >= 0.13 && < 0.14 + , NaturalLanguageAlphabets + , random >= 1.0 && < 1.2 + , unordered-containers + , vector + hs-source-dirs: + src + main-is: + Benchmark.hs + type: + exitcode-stdio-1.0 + default-language: + Haskell2010 + default-extensions: BangPatterns + , ScopedTypeVariables + ghc-options: + -O2 + -rtsopts + -funbox-strict-fields + -funfolding-use-threshold1000 + -funfolding-keeness-factor1000 + if flag(llvm) + ghc-options: + -fllvm + -optlo-O3 -optlo-std-compile-opts + -fllvm-tbaa + + source-repository head type: git diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +Natural Language Alphabets +========================== + +[![Build Status](https://travis-ci.org/choener/NaturalLanguageAlphabets.svg?branch=master)](https://travis-ci.org/choener/NaturalLanguageAlphabets) + +Efficient, alphabet symbols. The symbols are interned, and hashed. This is +quite useful for k-gram scoring, where we have different sets of symbols with +different scores. IMMC symbols are internally represented via Ints in the range +[0..]. This makes it possible to use unboxed containers when handling IMMC +symbols. + + + +#### Contact + +Christian Hoener zu Siederdissen +choener@bioinf.uni-leipzig.de +Leipzig University, Leipzig, Germany + diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,6 +0,0 @@ -0.0.0.1 -------- - -- initial checkin -- internable MultiChar characters - diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,19 @@ +0.0.1.0 +------- + +- cleanup for GHC 7.10 +- travis-ci integration + +0.0.0.2 +------- + +- thanks to a new system-filepath, we now have Stringable instances +- NFData instances +- added a simple scoring system + +0.0.0.1 +------- + +- initial checkin +- internable MultiChar characters + diff --git a/scoring/simpleunigram.txt b/scoring/simpleunigram.txt new file mode 100644 --- /dev/null +++ b/scoring/simpleunigram.txt @@ -0,0 +1,42 @@ +-- !!! THIS FILE ASSUMES UTF-8 ENCODING !!! +-- +-- These are all vowels, but all 'a's are equivalent with respect to this +-- scoring. It is only required to give 'EqSet's if you have more than one +-- equivalent character. In this EqSet, everything gets a score of 'Eq Vowel' +-- (==2). +EqSet Vowel a â ã +EqSet Vowel e +EqSet Vowel i +EqSet Vowel o +EqSet Vowel u +-- These are sets of characters belonging to a certain class. In this case, we +-- have consonants. +Set Conso b c d f g h j k m n p q s t v w x y z +Set Liquid l r +Set Vowel a\' e\' i\' o\' u\' ə ɐ æ œ æh ɔh ɒ ɔ +-- Here we say that whenever we see a consonant aligned to the same consonant +-- in the other word, give this score. +Eq Conso 4 +Eq Liquid 3 +Eq Vowel 2 +-- Whenever we align two consonants that are not equal (or equivalent) we give +-- this score. +InSet Conso Conso 0 +InSet Conso Liquid -1 +InSet Conso Vowel -999999 +InSet Liquid Conso -1 +InSet Liquid Liquid -1 +InSet Liquid Vowel -1 +InSet Vowel Conso -999999 +InSet Vowel Liquid -1 +InSet Vowel Vowel 0 +-- How to score a gap in a sequence +Gap -4 +-- Later on we want affine gap scoring, it's already here but not used +GapOpen -4 +GapExtend -4 +-- This score is used when we align the same character but it's one we didn't +-- specify in our sets +Match 1 +-- And finally how to score a mismatch that doesn't fit into the above +Mismatch -999999 diff --git a/src/Benchmark.hs b/src/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark.hs @@ -0,0 +1,88 @@ + +-- | Working with natural languages entails having large, sparse scoring +-- matrices. Here, we run through a bunch of options for these. +-- +-- We create a table to look things up, and two sets of queries: one of +-- known elements, one of unknown elements. + +module Main where + +import Criterion.Main +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector as VV +import Text.Printf +import Data.Tuple (swap) +import Control.Applicative ((<$>)) +import System.Random.MWC +import System.Random +import Control.DeepSeq +import Control.Monad +import qualified Data.HashMap.Strict as UCHS +import qualified Data.IntMap.Strict as CIS +import Data.String +import qualified Data.HashTable.IO as HT +import System.IO.Unsafe (unsafePerformIO) + +import NLP.Alphabet.IMMC + + + +main :: IO () +main = do ( !keys , !unks , (!hmsH,!cisH,!htH) , (!hmsK,!cisK,!htK) ) <- setupEnv + printf "We have %d keys, and %d / %d / %d resp. %d / %d / %d keys in the lookup maps\n" + (VU.length keys) + (UCHS.size hmsH) (CIS.size cisH) (-1 :: Int) + (UCHS.size hmsK) (CIS.size cisK) (-1 :: Int) + defaultMain + [ bgroup " 100 keys" [ bench "uchs" $ whnf (\k -> UCHS.lookupDefault 0 k hmsH) (VU.head keys) + , bench " cis" $ whnf (\k -> CIS.findWithDefault 0 k cisH) (getIMMC $ VU.head keys) + , bench " htB" $ whnf (\k -> htLookup htH k) (VU.head keys) + ] + , bgroup "10000 keys" [ bench "uchs" $ whnf (\k -> UCHS.lookupDefault 0 k hmsK) (VU.head keys) + , bench " cis" $ whnf (\k -> CIS.findWithDefault 0 k cisK) (getIMMC $ VU.head keys) + , bench " htB" $ whnf (\k -> htLookup htK k) (VU.head keys) + ] +-- , bgroup " 100 known" [ bench "uchsH" $ whnf (\ks -> VU.sum $ VU.map (\k -> UCHS.lookupDefault 0 k hmsH) ks) (VU.take 100 keys) +-- , bench " cisH" $ whnf (\ks -> VU.sum $ VU.map (\k -> CIS.findWithDefault 0 k cisH) ks) (VU.map getIMMC $ VU.take 100 keys) +-- ] +-- , bgroup " 1 unknown" [ bench "uchsH" $ whnf (\k -> UCHS.lookupDefault 0 k hmsH) (VU.head unks) +-- , bench " cisH" $ whnf (\k -> CIS.findWithDefault 0 k cisH) (getIMMC $ VU.head unks) +-- ] + ] + +htLookup ht k = unsafePerformIO $ do + l <- HT.lookup ht k + case l of + Nothing -> return 0 + Just v -> return v +{-# Inline htLookup #-} + + +type HTB = HT.BasicHashTable IMMC Double + +setupEnv = do + -- create keys + strs :: [String] <- replicateM 10000 rString + -- scores to look up + scrs :: [Double] <- replicateM 10000 $ randomRIO (0 , 9) + -- create IMMC keys + let keys = map (immc . fromString) strs + -- create random keys, mostly not in strs + unks :: [String] <- replicateM 10000 rString + let sknu = map (immc . fromString) unks + -- for 100 keys + let hmsK = UCHS.fromList $ take 100 $ zip keys scrs + let cisK = CIS.fromList $ take 100 $ zip (map getIMMC keys) scrs + htH :: HTB <- HT.fromList $ take 100 $ zip keys scrs + -- for 10 000 keys + let hmsM = UCHS.fromList $ zip keys scrs + let cisM = CIS.fromList $ zip (map getIMMC keys) scrs + htK :: HTB <- HT.fromList $ zip keys scrs + return (VU.fromList keys , VU.fromList sknu , (hmsK,cisK,htH) , (hmsM,cisM,htK) ) + +rString :: IO String +rString = do + k :: Int <- randomRIO (1,4) + replicateM k $ randomRIO ('A','Z') +