packages feed

NaturalLanguageAlphabets 0.0.0.1 → 0.0.1.0

raw patch · 12 files changed

+626/−38 lines, 12 filesdep +NaturalLanguageAlphabetsdep +arraydep +attoparsecdep ~basedep ~hashabledep ~intern

Dependencies added: NaturalLanguageAlphabets, array, attoparsec, bimaps, containers, criterion, deepseq, file-embed, hashtables, mwc-random, random, stringable, system-filepath, text, vector, vector-th-unbox

Dependency ranges changed: base, hashable, intern, unordered-containers

Files

+ NLP/Alphabet/IMMC.hs view
@@ -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 #-}+
+ NLP/Alphabet/IMMC/Internal.hs view
@@ -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 #-}+
NLP/Alphabet/MultiChar.hs view
@@ -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 #-}
+ NLP/Scoring/SimpleUnigram.hs view
@@ -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)+
+ NLP/Scoring/SimpleUnigram/Default.hs view
@@ -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")+
+ NLP/Scoring/SimpleUnigram/Import.hs view
@@ -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+
NaturalLanguageAlphabets.cabal view
@@ -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
+ README.md view
@@ -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+
− changelog 
@@ -1,6 +0,0 @@-0.0.0.1----------- initial checkin-- internable MultiChar characters-
+ changelog.md view
@@ -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+
+ scoring/simpleunigram.txt view
@@ -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
+ src/Benchmark.hs view
@@ -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')+