Skip to content

P
purescript-gargantext
Verified Commit baca05ec authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[karp-rabin] migrate this algorithm to a separate repository 

Also, performance is fixed now.
parent be456f9c
Pipeline #3703 canceled with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 28 additions and 222 deletions
    packages.dhall
    View file @ baca05ec
    ......@@ -136,6 +136,24 @@ let additions =
    , repo = "https://github.com/purescript-spec/purescript-spec-quickcheck"
    , version = "v3.1.0"
    }
    , string-search =
    { dependencies =
    [ "arrays"
    , "enums"
    , "foldable-traversable"
    , "integers"
    , "lists"
    , "maybe"
    , "ordered-collections"
    , "partial"
    , "prelude"
    , "strings"
    , "tuples"
    , "uint"
    ]
    , repo = "https://git.sr.ht/~cgenie/purescript-string-search"
    , version = "v0.1.3"
    }
    , dom-filereader =
    { dependencies = [ "aff", "arraybuffer-types", "web-file", "web-html" ]
    , repo = "https://github.com/nwolverson/purescript-dom-filereader"
    ......
    shell.nix
    View file @ baca05ec
    ......@@ -97,10 +97,10 @@ let
    echo "Compiling"
    yarn
    spago build
    #spago build
    #build-purs
    echo "Testing"
    spago test
    spago -x test.dhall test --main Test.Main
    # pulp browserify --skip-compile -t dist/bundle.js --src-path output
    # pulp test --src-path output --test-path output
    #NODE_PATH=output node -e "require('Test.Main').main();"
    ......
    spago.dhall
    View file @ baca05ec
    ......@@ -33,7 +33,6 @@ to generate this file without the comments in this block.
    , "dom-simple"
    , "effect"
    , "either"
    , "enums"
    , "exceptions"
    , "ffi-simple"
    , "foldable-traversable"
    ......@@ -75,6 +74,7 @@ to generate this file without the comments in this block.
    , "simple-json"
    , "simple-json-generics"
    , "simplecrypto"
    , "string-search"
    , "strings"
    , "strings-extra"
    , "stringutils"
    ......@@ -85,7 +85,6 @@ to generate this file without the comments in this block.
    , "tuples-native"
    , "typelevel"
    , "typelevel-prelude"
    , "uint"
    , "unfoldable"
    , "unordered-collections"
    , "unsafe-coerce"
    ......
    src/Gargantext/Core/NgramsTable/Functions.purs
    View file @ baca05ec
    ......@@ -23,6 +23,7 @@ import Data.String as S
    import Data.String.Common as DSC
    import Data.String.Regex (Regex, regex, replace) as R
    import Data.String.Regex.Flags (global, multiline) as R
    import Data.String.Search.KarpRabin as SSKR
    import Data.String.Utils as SU
    import Data.These (These(..))
    import Data.Traversable (for, traverse_, traverse)
    ......@@ -42,7 +43,7 @@ import Gargantext.Routes (SessionRoute(..))
    import Gargantext.Sessions (Session, get, post, put)
    import Gargantext.Types (AsyncTask, AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), FrontendError, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
    import Gargantext.Utils.Either (eitherMap)
    import Gargantext.Utils.KarpRabin (indicesOfAny)
    --import Gargantext.Utils.KarpRabin (indicesOfAny)
    import Gargantext.Utils.Reactix as R2
    import Partial (crashWith)
    import Partial.Unsafe (unsafePartial)
    ......@@ -138,7 +139,8 @@ highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
    undb = R.replace wordBoundaryReg2 "$1"
    input = spR input0
    pats = A.fromFoldable (Map.keys elts)
    ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input)
    hashStruct = SSKR.hashStruct (sp <<< ngramsTermText <$> pats)
    ixs = SSKR.indicesOfAnyHashStruct hashStruct (normNgramInternal ntype input)
    splitAcc :: Partial => Int -> HighlightAccumulator
    -> Tuple HighlightAccumulator HighlightAccumulator
    ......
    src/Gargantext/Data/Array.purs
    View file @ baca05ec
    ......@@ -7,7 +7,7 @@ import Data.List as List
    import Data.Maybe
    import Data.Sequence as Seq
    import Data.Tuple (Tuple(..))
    import Prelude (bind, flip, identity, (<<<), ($), (<), (-), (<$>))
    import Prelude
    ----------------------------------------------------------------------
    -- | Split arrays tools
    ......@@ -72,9 +72,4 @@ slidingWindow lst len =
    let diff = DA.length lst - len
    in
    if diff < 0 then []
    else (\idx -> DA.take len $ DA.drop idx lst) <$> 0 .. diff
    -- slidingWindow lst len = DA.fromFoldable $ go lst
    -- where
    -- go l =
    -- if (DA.length l) < len then List.Nil
    -- else (DA.take len l) List.: (go $ DA.drop 1 l)
    else (\idx -> DA.slice idx (idx + len) lst) <$> 0 .. diff
    src/Gargantext/Utils/KarpRabin.purs deleted 100644 → 0
    View file @ be456f9c
    -- |
    -- The present module has been ported from Haskell to PureScript
    -- by Nicolas Pouillard for the Gargantext projet.
    --
    -- Original Haskell code:
    -- Copyright : (c) 2010 Daniel Fischer
    -- Licence : BSD3
    -- Maintainer : Daniel Fischer <daniel.is.fischer@googlemail.com>
    --
    -- Simultaneous search for multiple patterns in a 'String'
    -- using the Karp-Rabin algorithm.
    --
    -- A description of the algorithm for a single pattern can be found at
    -- <http://www-igm.univ-mlv.fr/~lecroq/string/node5.html#SECTION0050>.
    module Gargantext.Utils.KarpRabin ( -- * Overview
    -- $overview
    -- ** Caution
    -- $caution
    -- * Function
    indicesOfAny
    ) where
    import Data.Array as A
    import Data.Array ((..))
    import Data.Enum (fromEnum)
    import Data.Foldable (class Foldable, minimum, foldl)
    import Data.FunctorWithIndex (mapWithIndex)
    import Data.Int (quot)
    import Data.List as L
    import Data.Map as M
    import Data.Maybe (Maybe(..), isJust)
    import Data.String as S
    import Data.String (CodePoint)
    import Data.Tuple (Tuple(..), snd)
    import Data.UInt (UInt, shl, fromInt)
    import Partial.Unsafe (unsafePartial)
    import Gargantext.Data.Array as GDA
    import Prelude
    fromCodePoint :: CodePoint -> UInt
    fromCodePoint c = fromInt (fromEnum c)
    -- $overview
    --
    -- The Karp-Rabin algorithm works by calculating a hash of the pattern and
    -- comparing that hash with the hash of a slice of the target string with
    -- the same length as the pattern. If the hashes are equal, the slice of the
    -- target is compared to the pattern byte for byte (since the hash
    -- function generally isn't injective).
    --
    -- For a single pattern, this tends to be more efficient than the na&#239;ve
    -- algorithm, but it cannot compete with algorithms like
    -- Knuth-Morris-Pratt or Boyer-Moore.
    --
    -- However, the algorithm can be generalised to search for multiple patterns
    -- simultaneously. If the shortest pattern has length @k@, hash the prefix of
    -- length @k@ of all patterns and compare the hash of the target's slices of
    -- length @k@ to them. If there's a match, check whether the slice is part
    -- of an occurrence of the corresponding pattern.
    --
    -- With a hash-function that
    --
    -- * allows to compute the hash of one slice in constant time from the hash
    -- of the previous slice, the new and the dropped character, and
    --
    -- * produces few spurious matches,
    --
    -- searching for occurrences of any of @n@ patterns has a best-case complexity
    -- of /O/(@targetLength@ * @lookup n@). The worst-case complexity is
    -- /O/(@targetLength@ * @lookup n@ * @sum patternLengths@), the average is
    -- not much worse than the best case.
    --
    -- The functions in this module store the hashes of the patterns in an
    -- 'Map', so the lookup is /O/(@log n@). Re-hashing is done in constant
    -- time and spurious matches of the hashes /should be/ sufficiently rare.
    -- The maximal length of the prefixes to be hashed is 32.
    -- $caution
    --
    -- Unfortunately, the constant factors are high, so these functions are slow.
    -- Unless the number of patterns to search for is high (larger than 50 at
    -- least), repeated search for single patterns using Boyer-Moore or DFA and
    -- manual merging of the indices is faster. /Much/ faster for less than 40
    -- or so patterns.
    --
    -- In summary, this module is more of an interesting curiosity than anything
    -- else.
    -- | @'indicesOfAny'@ finds all occurrences of any of several non-empty patterns
    -- in a strict target string. If no non-empty patterns are given,
    -- the result is an empty array. Otherwise the result array contains
    -- the pairs of all indices where any of the (non-empty) patterns start
    -- and the array of all patterns starting at that index, the patterns being
    -- represented by their (zero-based) position in the pattern array.
    -- Empty patterns are filtered out before processing begins.
    indicesOfAny :: Array String -- ^ Array of non-empty patterns
    -> String -- ^ String to search
    -> Array (Tuple Int (Array Int)) -- ^ Array of matches
    indicesOfAny pats = if A.null nepats then const []
    else strictMatcher nepats
    where
    nepats = A.filter (not <<< S.null) pats
    ------------------------------------------------------------------------------
    -- Workers --
    ------------------------------------------------------------------------------
    rehash' :: UInt -> UInt -> UInt -> CodePoint -> CodePoint -> UInt
    rehash' shDi out h o n =
    (h `shl` shDi - (fromCodePoint o `shl` out)) + fromCodePoint n
    minimum1 :: forall a f. Ord a => Foldable f => a -> f a -> a
    minimum1 a fa =
    case minimum fa of
    Nothing -> a
    Just b -> min a b
    type GoAcc = Tuple UInt (Array (Maybe (Tuple Int (Array Int))))
    strictMatcher :: Array String -> String -> Array (Tuple Int (Array Int))
    strictMatcher pats = unsafePartial search
    where
    hLen = minimum1 32 (S.length <$> pats)
    hLen' = fromInt hLen
    shDi = case 32 `quot` hLen of
    q | q < 4 -> q
    | otherwise -> 4
    outS = fromInt (shDi * hLen)
    patNum = A.length pats
    rehash :: UInt -> CodePoint -> CodePoint -> UInt
    rehash = case shDi of
    1 -> rehash' (fromInt 1) hLen'
    2 -> rehash' (fromInt 2) outS
    3 -> rehash' (fromInt 3) outS
    _ -> rehash' (fromInt 4) outS
    hash :: String -> UInt
    hash = foldl (\h w -> (h `shl` fromInt shDi) + fromCodePoint w) (fromInt 0)
    <<< S.toCodePointArray
    <<< S.take hLen
    hashMap :: M.Map UInt (Array Int)
    hashMap =
    M.fromFoldableWith (flip (<>))
    (mapWithIndex (\i a -> Tuple (hash a) [i]) pats)
    search :: Partial => String -> Array (Tuple Int (Array Int))
    search str = if strLen < hLen then []
    else A.catMaybes $ snd <$> foldl go' (Tuple shash []) $ A.zip (0 .. maxIdx) (GDA.slidingWindow arr hLen)
    -- else A.fromFoldable (go 0 shash)
    where
    strLen = S.length str
    maxIdx = strLen - hLen
    arr = S.toCodePointArray str
    strAt i = A.unsafeIndex arr i
    shash :: UInt
    shash = hash str
    -- NOTE: A new function, with a map over the range [0..maxIdx]
    go' :: GoAcc -> Tuple Int (Array CodePoint) -> GoAcc
    go' (Tuple h acc) (Tuple idx arr') =
    let rehashed = rehash h (A.unsafeIndex arr' 0) (A.unsafeIndex arr' (-1))
    str' = S.fromCodePointArray arr'
    okay bs = isJust (S.stripPrefix (S.Pattern bs) str')
    mPs = M.lookup h hashMap
    acc' = case mPs of
    Nothing -> Nothing
    Just ps ->
    case A.filter (\x -> okay (A.unsafeIndex pats x)) ps of
    [] -> Nothing
    qs -> Just (Tuple idx qs)
    in
    Tuple rehashed (A.snoc acc acc')
    -- go :: Int -> UInt -> L.List (Tuple Int (Array Int))
    -- go sI h =
    -- let rehashed = rehash h (strAt sI) (strAt (sI + hLen))
    -- in
    -- if sI == maxIdx then
    -- L.Nil
    -- else
    -- case M.lookup h hashMap of
    -- Nothing ->
    -- go (sI + 1) rehashed
    -- Just ps ->
    -- let rst = S.drop sI str
    -- okay bs =
    -- isJust (S.stripPrefix (S.Pattern bs) rst)
    -- in case A.filter (\x -> okay (A.unsafeIndex pats x)) ps of
    -- [] -> go (sI + 1) rehashed
    -- qs -> Tuple sI qs L.: (go (sI + 1) rehashed)
    -- case M.lookup h hashMap of
    -- Nothing ->
    -- if sI == maxIdx
    -- then L.Nil
    -- else go (sI + 1) (rehash h (strAt sI) (strAt (sI + hLen)))
    -- Just ps ->
    -- let rst = S.drop sI str
    -- hd = strAt sI
    -- more = if sI == maxIdx then L.Nil else
    -- go (sI + 1) (rehash h hd (strAt (sI + hLen)))
    -- okay bs =
    -- isJust (S.stripPrefix (S.Pattern bs) rst)
    -- in case A.filter (\x -> okay (A.unsafeIndex pats x)) ps of
    -- [] -> more
    -- qs -> Tuple sI qs L.: more
    test/Gargantext/Components/NgramsTable/Spec.purs
    View file @ baca05ec
    ......@@ -21,7 +21,7 @@ ne :: String -> TermList -> CTabNgramType -> NgramsElement
    ne ngrams list ngramType = NgramsElement { ngrams: normed
    , size: 1 -- TODO
    , list
    , occurrences: 0
    , occurrences: Set.singleton 0
    , parent: Nothing
    , root: Nothing
    , children: Set.empty
    ......
    Markdown is supported
    0% or
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment