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
Show 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