Initial commit
This commit is contained in:
La Ancapo
commit
c101616e62
309 changed files with 53937 additions and 0 deletions
20
bundled/Basement/Alg/Class.hs
Normal file
20
bundled/Basement/Alg/Class.hs
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Basement.Alg.Class
|
||||
( Indexable, index
|
||||
, RandomAccess, read, write
|
||||
) where
|
||||
|
||||
import Basement.Types.OffsetSize
|
||||
|
||||
class Indexable container ty where
|
||||
index :: container -> (Offset ty) -> ty
|
||||
|
||||
class RandomAccess container prim ty where
|
||||
read :: container -> (Offset ty) -> prim ty
|
||||
write :: container -> (Offset ty) -> ty -> prim ()
|
||||
75
bundled/Basement/Alg/Mutable.hs
Normal file
75
bundled/Basement/Alg/Mutable.hs
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Basement.Alg.Mutable
|
||||
( inplaceSortBy
|
||||
) where
|
||||
|
||||
import GHC.Types
|
||||
import GHC.Prim
|
||||
import Basement.Compat.Base
|
||||
import Basement.Numerical.Additive
|
||||
import Basement.Numerical.Multiplicative
|
||||
import Basement.Types.OffsetSize
|
||||
import Basement.PrimType
|
||||
import Basement.Monad
|
||||
import Basement.Alg.Class
|
||||
|
||||
inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty)
|
||||
=> (ty -> ty -> Ordering)
|
||||
-- ^ Function defining the ordering relationship
|
||||
-> (Offset ty) -- ^ Offset to first element to sort
|
||||
-> (CountOf ty) -- ^ Number of elements to sort
|
||||
-> container -- ^ Data to be sorted
|
||||
-> prim ()
|
||||
inplaceSortBy ford start len mvec
|
||||
= qsort start (start `offsetPlusE` len `offsetSub` 1)
|
||||
where
|
||||
qsort lo hi
|
||||
| lo >= hi = pure ()
|
||||
| otherwise = do
|
||||
p <- partition lo hi
|
||||
qsort lo (pred p)
|
||||
qsort (p+1) hi
|
||||
pivotStrategy (Offset low) hi@(Offset high) = do
|
||||
let mid = Offset $ (low + high) `div` 2
|
||||
pivot <- read mvec mid
|
||||
read mvec hi >>= write mvec mid
|
||||
write mvec hi pivot -- move pivot @ pivotpos := hi
|
||||
pure pivot
|
||||
partition lo hi = do
|
||||
pivot <- pivotStrategy lo hi
|
||||
-- RETURN: index of pivot with [<pivot | pivot | >=pivot]
|
||||
-- INVARIANT: i & j are valid array indices; pivotpos==hi
|
||||
let go i j = do
|
||||
-- INVARIANT: k <= pivotpos
|
||||
let fw k = do ak <- read mvec k
|
||||
if ford ak pivot == LT
|
||||
then fw (k+1)
|
||||
else pure (k, ak)
|
||||
(i, ai) <- fw i -- POST: ai >= pivot
|
||||
-- INVARIANT: k >= i
|
||||
let bw k | k==i = pure (i, ai)
|
||||
| otherwise = do ak <- read mvec k
|
||||
if ford ak pivot /= LT
|
||||
then bw (pred k)
|
||||
else pure (k, ak)
|
||||
(j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)
|
||||
-- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))
|
||||
if i < j
|
||||
then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)
|
||||
-- swap two non-pivot elements and proceed
|
||||
write mvec i aj
|
||||
write mvec j ai
|
||||
-- POST: (ai < pivot <= aj)
|
||||
go (i+1) (pred j)
|
||||
else do -- ai >= pivot
|
||||
-- complete partitioning by swapping pivot to the center
|
||||
write mvec hi ai
|
||||
write mvec i pivot
|
||||
pure i
|
||||
go lo hi
|
||||
{-# INLINE inplaceSortBy #-}
|
||||
123
bundled/Basement/Alg/PrimArray.hs
Normal file
123
bundled/Basement/Alg/PrimArray.hs
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
module Basement.Alg.PrimArray
|
||||
( Indexable, index
|
||||
, findIndexElem
|
||||
, revFindIndexElem
|
||||
, findIndexPredicate
|
||||
, revFindIndexPredicate
|
||||
, foldl
|
||||
, foldr
|
||||
, foldl1
|
||||
, all
|
||||
, any
|
||||
, filter
|
||||
) where
|
||||
|
||||
import GHC.Types
|
||||
import GHC.Prim
|
||||
import Basement.Alg.Class
|
||||
import Basement.Compat.Base
|
||||
import Basement.Numerical.Additive
|
||||
import Basement.Numerical.Multiplicative
|
||||
import Basement.Types.OffsetSize
|
||||
import Basement.PrimType
|
||||
import Basement.Monad
|
||||
|
||||
findIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty
|
||||
findIndexElem ty ba startIndex endIndex = loop startIndex
|
||||
where
|
||||
loop !i
|
||||
| i >= endIndex = sentinel
|
||||
| index ba i == ty = i
|
||||
| otherwise = loop (i+1)
|
||||
{-# INLINE findIndexElem #-}
|
||||
|
||||
revFindIndexElem :: (Indexable container ty, Eq ty) => ty -> container -> Offset ty -> Offset ty -> Offset ty
|
||||
revFindIndexElem ty ba startIndex endIndex = loop endIndex
|
||||
where
|
||||
loop !iplus1
|
||||
| iplus1 <= startIndex = sentinel
|
||||
| index ba i == ty = i
|
||||
| otherwise = loop i
|
||||
where !i = iplus1 `offsetMinusE` 1
|
||||
{-# INLINE revFindIndexElem #-}
|
||||
|
||||
findIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty
|
||||
findIndexPredicate predicate ba startIndex endIndex = loop startIndex
|
||||
where
|
||||
loop !i
|
||||
| i >= endIndex = sentinel
|
||||
| predicate (index ba i) = i
|
||||
| otherwise = loop (i+1)
|
||||
{-# INLINE findIndexPredicate #-}
|
||||
|
||||
revFindIndexPredicate :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Offset ty
|
||||
revFindIndexPredicate predicate ba startIndex endIndex = loop endIndex
|
||||
where
|
||||
loop !iplus1
|
||||
| iplus1 <= startIndex = sentinel
|
||||
| predicate (index ba i) = i
|
||||
| otherwise = loop i
|
||||
where !i = iplus1 `offsetMinusE` 1
|
||||
{-# INLINE revFindIndexPredicate #-}
|
||||
|
||||
foldl :: Indexable container ty => (a -> ty -> a) -> a -> container -> Offset ty -> Offset ty -> a
|
||||
foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc
|
||||
where
|
||||
loop !i !acc
|
||||
| i == endIndex = acc
|
||||
| otherwise = loop (i+1) (f acc (index ba i))
|
||||
{-# INLINE foldl #-}
|
||||
|
||||
foldr :: Indexable container ty => (ty -> a -> a) -> a -> container -> Offset ty -> Offset ty -> a
|
||||
foldr f !initialAcc ba startIndex endIndex = loop startIndex
|
||||
where
|
||||
loop !i
|
||||
| i == endIndex = initialAcc
|
||||
| otherwise = index ba i `f` loop (i+1)
|
||||
{-# INLINE foldr #-}
|
||||
|
||||
foldl1 :: Indexable container ty => (ty -> ty -> ty) -> container -> Offset ty -> Offset ty -> ty
|
||||
foldl1 f ba startIndex endIndex = loop (startIndex+1) (index ba startIndex)
|
||||
where
|
||||
loop !i !acc
|
||||
| i == endIndex = acc
|
||||
| otherwise = loop (i+1) (f acc (index ba i))
|
||||
{-# INLINE foldl1 #-}
|
||||
|
||||
filter :: (PrimMonad prim, PrimType ty, Indexable container ty)
|
||||
=> (ty -> Bool) -> MutableByteArray# (PrimState prim)
|
||||
-> container -> Offset ty -> Offset ty -> prim (CountOf ty)
|
||||
filter predicate dst src start end = loop azero start
|
||||
where
|
||||
loop !d !s
|
||||
| s == end = pure (offsetAsSize d)
|
||||
| predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)
|
||||
| otherwise = loop d (s+Offset 1)
|
||||
where
|
||||
v = index src s
|
||||
{-# INLINE filter #-}
|
||||
|
||||
all :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool
|
||||
all predicate ba start end = loop start
|
||||
where
|
||||
loop !i
|
||||
| i == end = True
|
||||
| predicate (index ba i) = loop (i+1)
|
||||
| otherwise = False
|
||||
{-# INLINE all #-}
|
||||
|
||||
any :: Indexable container ty => (ty -> Bool) -> container -> Offset ty -> Offset ty -> Bool
|
||||
any predicate ba start end = loop start
|
||||
where
|
||||
loop !i
|
||||
| i == end = False
|
||||
| predicate (index ba i) = True
|
||||
| otherwise = loop (i+1)
|
||||
{-# INLINE any #-}
|
||||
140
bundled/Basement/Alg/String.hs
Normal file
140
bundled/Basement/Alg/String.hs
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Basement.Alg.String
|
||||
( copyFilter
|
||||
, validate
|
||||
, findIndexPredicate
|
||||
, revFindIndexPredicate
|
||||
) where
|
||||
|
||||
import GHC.Prim
|
||||
import GHC.ST
|
||||
import Basement.Alg.Class
|
||||
import Basement.Alg.UTF8
|
||||
import Basement.Compat.Base
|
||||
import Basement.Numerical.Additive
|
||||
import Basement.Types.OffsetSize
|
||||
import Basement.PrimType
|
||||
import Basement.Block (MutableBlock(..))
|
||||
|
||||
import Basement.UTF8.Helper
|
||||
import Basement.UTF8.Table
|
||||
import Basement.UTF8.Types
|
||||
|
||||
copyFilter :: forall s container . Indexable container Word8
|
||||
=> (Char -> Bool)
|
||||
-> CountOf Word8
|
||||
-> MutableByteArray# s
|
||||
-> container
|
||||
-> Offset Word8
|
||||
-> ST s (CountOf Word8)
|
||||
copyFilter predicate !sz dst src start = loop (Offset 0) start
|
||||
where
|
||||
!end = start `offsetPlusE` sz
|
||||
loop !d !s
|
||||
| s == end = pure (offsetAsSize d)
|
||||
| otherwise =
|
||||
let !h = nextAscii src s
|
||||
in case headerIsAscii h of
|
||||
True | predicate (toChar1 h) -> primMbaWrite dst d (stepAsciiRawValue h) >> loop (d + Offset 1) (s + Offset 1)
|
||||
| otherwise -> loop d (s + Offset 1)
|
||||
False ->
|
||||
case next src s of
|
||||
Step c s' | predicate c -> writeUTF8 (MutableBlock dst :: MutableBlock Word8 s) d c >>= \d' -> loop d' s'
|
||||
| otherwise -> loop d s'
|
||||
{-# INLINE copyFilter #-}
|
||||
|
||||
validate :: Indexable container Word8
|
||||
=> Offset Word8
|
||||
-> container
|
||||
-> Offset Word8
|
||||
-> (Offset Word8, Maybe ValidationFailure)
|
||||
validate end ba ofsStart = loop4 ofsStart
|
||||
where
|
||||
loop4 !ofs
|
||||
| ofs4 < end =
|
||||
let h1 = nextAscii ba ofs
|
||||
h2 = nextAscii ba (ofs+1)
|
||||
h3 = nextAscii ba (ofs+2)
|
||||
h4 = nextAscii ba (ofs+3)
|
||||
in if headerIsAscii h1 && headerIsAscii h2 && headerIsAscii h3 && headerIsAscii h4
|
||||
then loop4 ofs4
|
||||
else loop ofs
|
||||
| otherwise = loop ofs
|
||||
where
|
||||
!ofs4 = ofs+4
|
||||
loop !ofs
|
||||
| ofs == end = (end, Nothing)
|
||||
| headerIsAscii h = loop (ofs + Offset 1)
|
||||
| otherwise = multi (CountOf $ getNbBytes h) ofs
|
||||
where
|
||||
h = nextAscii ba ofs
|
||||
|
||||
multi (CountOf 0xff) pos = (pos, Just InvalidHeader)
|
||||
multi nbConts pos
|
||||
| (posNext `offsetPlusE` nbConts) > end = (pos, Just MissingByte)
|
||||
| otherwise =
|
||||
case nbConts of
|
||||
CountOf 1 ->
|
||||
let c1 = index ba posNext
|
||||
in if isContinuation c1
|
||||
then loop (pos + Offset 2)
|
||||
else (pos, Just InvalidContinuation)
|
||||
CountOf 2 ->
|
||||
let c1 = index ba posNext
|
||||
c2 = index ba (pos + Offset 2)
|
||||
in if isContinuation2 c1 c2
|
||||
then loop (pos + Offset 3)
|
||||
else (pos, Just InvalidContinuation)
|
||||
CountOf _ ->
|
||||
let c1 = index ba posNext
|
||||
c2 = index ba (pos + Offset 2)
|
||||
c3 = index ba (pos + Offset 3)
|
||||
in if isContinuation3 c1 c2 c3
|
||||
then loop (pos + Offset 4)
|
||||
else (pos, Just InvalidContinuation)
|
||||
where posNext = pos + Offset 1
|
||||
{-# INLINE validate #-}
|
||||
|
||||
findIndexPredicate :: Indexable container Word8
|
||||
=> (Char -> Bool)
|
||||
-> container
|
||||
-> Offset Word8
|
||||
-> Offset Word8
|
||||
-> Offset Word8
|
||||
findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex
|
||||
where
|
||||
loop !i
|
||||
| i < endIndex && not (predicate c) = loop (i')
|
||||
| otherwise = i
|
||||
where
|
||||
Step c i' = next ba i
|
||||
{-# INLINE findIndexPredicate #-}
|
||||
|
||||
revFindIndexPredicate :: Indexable container Word8
|
||||
=> (Char -> Bool)
|
||||
-> container
|
||||
-> Offset Word8
|
||||
-> Offset Word8
|
||||
-> Offset Word8
|
||||
revFindIndexPredicate predicate ba startIndex endIndex
|
||||
| endIndex > startIndex = loop endIndex
|
||||
| otherwise = endIndex
|
||||
where
|
||||
loop !i
|
||||
| predicate c = i'
|
||||
| i' > startIndex = loop i'
|
||||
| otherwise = endIndex
|
||||
where
|
||||
StepBack c i' = prev ba i
|
||||
{-# INLINE revFindIndexPredicate #-}
|
||||
298
bundled/Basement/Alg/UTF8.hs
Normal file
298
bundled/Basement/Alg/UTF8.hs
Normal file
|
|
@ -0,0 +1,298 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Basement.Alg.UTF8
|
||||
( nextAscii
|
||||
, nextAsciiDigit
|
||||
, expectAscii
|
||||
, next
|
||||
, nextSkip
|
||||
, nextWith
|
||||
, prev
|
||||
, prevSkip
|
||||
, writeASCII
|
||||
, writeUTF8
|
||||
, toList
|
||||
, all
|
||||
, any
|
||||
, foldr
|
||||
, length
|
||||
, reverse
|
||||
) where
|
||||
|
||||
import GHC.Types
|
||||
import GHC.Word
|
||||
import GHC.Prim
|
||||
import Data.Bits
|
||||
import Data.Proxy
|
||||
import Basement.Alg.Class
|
||||
import Basement.Compat.Base hiding (toList)
|
||||
import Basement.Compat.Primitive
|
||||
import Basement.Monad
|
||||
import Basement.Numerical.Additive
|
||||
import Basement.Numerical.Subtractive
|
||||
import Basement.Types.OffsetSize
|
||||
import Basement.Types.Char7 (Char7(..))
|
||||
import Basement.IntegralConv
|
||||
import Basement.PrimType
|
||||
import Basement.UTF8.Helper
|
||||
import Basement.UTF8.Table
|
||||
import Basement.UTF8.Types
|
||||
|
||||
nextAscii :: Indexable container Word8 => container -> Offset Word8 -> StepASCII
|
||||
nextAscii ba n = StepASCII w
|
||||
where
|
||||
!w = index ba n
|
||||
{-# INLINE nextAscii #-}
|
||||
|
||||
-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)
|
||||
nextAsciiDigit :: Indexable container Word8 => container -> Offset Word8 -> StepDigit
|
||||
nextAsciiDigit ba n = StepDigit (index ba n - 0x30)
|
||||
{-# INLINE nextAsciiDigit #-}
|
||||
|
||||
expectAscii :: Indexable container Word8 => container -> Offset Word8 -> Word8 -> Bool
|
||||
expectAscii ba n v = index ba n == v
|
||||
{-# INLINE expectAscii #-}
|
||||
|
||||
next :: Indexable container Word8 => container -> Offset8 -> Step
|
||||
next ba n =
|
||||
case getNbBytes h of
|
||||
0 -> Step (toChar1 h) (n + Offset 1)
|
||||
1 -> Step (toChar2 h (index ba (n + Offset 1))) (n + Offset 2)
|
||||
2 -> Step (toChar3 h (index ba (n + Offset 1))
|
||||
(index ba (n + Offset 2))) (n + Offset 3)
|
||||
3 -> Step (toChar4 h (index ba (n + Offset 1))
|
||||
(index ba (n + Offset 2))
|
||||
(index ba (n + Offset 3))) (n + Offset 4)
|
||||
r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h))
|
||||
where
|
||||
!h = nextAscii ba n
|
||||
{-# INLINE next #-}
|
||||
|
||||
nextSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8
|
||||
nextSkip ba n = n + 1 + Offset (getNbBytes (nextAscii ba n))
|
||||
{-# INLINE nextSkip #-}
|
||||
|
||||
-- | special case for only non ascii next'er function
|
||||
nextWith :: Indexable container Word8
|
||||
=> StepASCII
|
||||
-> container
|
||||
-> Offset8
|
||||
-> Step
|
||||
nextWith h ba n =
|
||||
case getNbBytes h of
|
||||
1 -> Step (toChar2 h (index ba n)) (n + Offset 1)
|
||||
2 -> Step (toChar3 h (index ba n) (index ba (n + Offset 1))) (n + Offset 2)
|
||||
3 -> Step (toChar4 h (index ba n)
|
||||
(index ba (n + Offset 1))
|
||||
(index ba (n + Offset 2))) (n + Offset 3)
|
||||
r -> error ("nextWith: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show (stepAsciiRawValue h))
|
||||
{-# INLINE nextWith #-}
|
||||
|
||||
-- Given a non null offset, give the previous character and the offset of this character
|
||||
-- will fail bad if apply at the beginning of string or an empty string.
|
||||
prev :: Indexable container Word8 => container -> Offset Word8 -> StepBack
|
||||
prev ba offset =
|
||||
case integralUpsize $ index ba prevOfs1 of
|
||||
(W# v1) | isContinuationW# v1 -> atLeast2 (maskContinuation# v1)
|
||||
| otherwise -> StepBack (toChar# v1) prevOfs1
|
||||
where
|
||||
sz1 = CountOf 1
|
||||
!prevOfs1 = offset `offsetMinusE` sz1
|
||||
prevOfs2 = prevOfs1 `offsetMinusE` sz1
|
||||
prevOfs3 = prevOfs2 `offsetMinusE` sz1
|
||||
prevOfs4 = prevOfs3 `offsetMinusE` sz1
|
||||
atLeast2 !v =
|
||||
case integralUpsize $ index ba prevOfs2 of
|
||||
(W# v2) | isContinuationW# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)
|
||||
| otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2
|
||||
atLeast3 !v =
|
||||
case integralUpsize $ index ba prevOfs3 of
|
||||
(W# v3) | isContinuationW# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)
|
||||
| otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3
|
||||
atLeast4 !v =
|
||||
case integralUpsize $ index ba prevOfs4 of
|
||||
(W# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4
|
||||
|
||||
prevSkip :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8
|
||||
prevSkip ba offset = loop (offset `offsetMinusE` sz1)
|
||||
where
|
||||
sz1 = CountOf 1
|
||||
loop o
|
||||
| isContinuation (index ba o) = loop (o `offsetMinusE` sz1)
|
||||
| otherwise = o
|
||||
|
||||
writeASCII :: (PrimMonad prim, RandomAccess container prim Word8)
|
||||
=> container -> Offset8 -> Char7 -> prim ()
|
||||
writeASCII mba !i (Char7 c) = write mba i c
|
||||
{-# INLINE writeASCII #-}
|
||||
|
||||
writeUTF8 :: (PrimMonad prim, RandomAccess container prim Word8)
|
||||
=> container -> Offset8 -> Char -> prim Offset8
|
||||
writeUTF8 mba !i !c
|
||||
| bool# (ltWord# x 0x80## ) = encode1
|
||||
| bool# (ltWord# x 0x800## ) = encode2
|
||||
| bool# (ltWord# x 0x10000##) = encode3
|
||||
| otherwise = encode4
|
||||
where
|
||||
!(I# xi) = fromEnum c
|
||||
!x = int2Word# xi
|
||||
|
||||
encode1 = write mba i (W8# (wordToWord8# x)) >> pure (i + Offset 1)
|
||||
encode2 = do
|
||||
let x1 = or# (uncheckedShiftRL# x 6#) 0xc0##
|
||||
x2 = toContinuation x
|
||||
write mba i (W8# (wordToWord8# x1))
|
||||
write mba (i+1) (W8# (wordToWord8# x2))
|
||||
pure (i + Offset 2)
|
||||
|
||||
encode3 = do
|
||||
let x1 = or# (uncheckedShiftRL# x 12#) 0xe0##
|
||||
x2 = toContinuation (uncheckedShiftRL# x 6#)
|
||||
x3 = toContinuation x
|
||||
write mba i (W8# (wordToWord8# x1))
|
||||
write mba (i+Offset 1) (W8# (wordToWord8# x2))
|
||||
write mba (i+Offset 2) (W8# (wordToWord8# x3))
|
||||
pure (i + Offset 3)
|
||||
|
||||
encode4 = do
|
||||
let x1 = or# (uncheckedShiftRL# x 18#) 0xf0##
|
||||
x2 = toContinuation (uncheckedShiftRL# x 12#)
|
||||
x3 = toContinuation (uncheckedShiftRL# x 6#)
|
||||
x4 = toContinuation x
|
||||
write mba i (W8# (wordToWord8# x1))
|
||||
write mba (i+Offset 1) (W8# (wordToWord8# x2))
|
||||
write mba (i+Offset 2) (W8# (wordToWord8# x3))
|
||||
write mba (i+Offset 3) (W8# (wordToWord8# x4))
|
||||
pure (i + Offset 4)
|
||||
|
||||
toContinuation :: Word# -> Word#
|
||||
toContinuation w = or# (and# w 0x3f##) 0x80##
|
||||
{-# INLINE writeUTF8 #-}
|
||||
|
||||
toList :: Indexable container Word8 => container -> Offset Word8 -> Offset Word8 -> [Char]
|
||||
toList ba !start !end = loop start
|
||||
where
|
||||
loop !idx
|
||||
| idx == end = []
|
||||
| otherwise = c : loop idx'
|
||||
where (Step c idx') = next ba idx
|
||||
|
||||
all :: Indexable container Word8
|
||||
=> (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool
|
||||
all predicate ba start end = loop start
|
||||
where
|
||||
loop !idx
|
||||
| idx == end = True
|
||||
| predicate c = loop idx'
|
||||
| otherwise = False
|
||||
where (Step c idx') = next ba idx
|
||||
{-# INLINE all #-}
|
||||
|
||||
any :: Indexable container Word8
|
||||
=> (Char -> Bool) -> container -> Offset Word8 -> Offset Word8 -> Bool
|
||||
any predicate ba start end = loop start
|
||||
where
|
||||
loop !idx
|
||||
| idx == end = False
|
||||
| predicate c = True
|
||||
| otherwise = loop idx'
|
||||
where (Step c idx') = next ba idx
|
||||
{-# INLINE any #-}
|
||||
|
||||
foldr :: Indexable container Word8
|
||||
=> container -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a
|
||||
foldr dat start end f acc = loop start
|
||||
where
|
||||
loop !i
|
||||
| i == end = acc
|
||||
| otherwise =
|
||||
let (Step c i') = next dat i
|
||||
in c `f` loop i'
|
||||
{-# INLINE foldr #-}
|
||||
|
||||
length :: (Indexable container Word8, Indexable container Word64)
|
||||
=> container -> Offset Word8 -> Offset Word8 -> CountOf Char
|
||||
length dat start end
|
||||
| start == end = 0
|
||||
| otherwise = processStart 0 start
|
||||
where
|
||||
end64 :: Offset Word64
|
||||
end64 = offsetInElements end
|
||||
|
||||
prx64 :: Proxy Word64
|
||||
prx64 = Proxy
|
||||
|
||||
mask64_80 :: Word64
|
||||
mask64_80 = 0x8080808080808080
|
||||
|
||||
processStart :: CountOf Char -> Offset Word8 -> CountOf Char
|
||||
processStart !c !i
|
||||
| i == end = c
|
||||
| offsetIsAligned prx64 i = processAligned c (offsetInElements i)
|
||||
| otherwise =
|
||||
let h = index dat i
|
||||
cont = (h .&. 0xc0) == 0x80
|
||||
c' = if cont then c else c+1
|
||||
in processStart c' (i+1)
|
||||
processAligned :: CountOf Char -> Offset Word64 -> CountOf Char
|
||||
processAligned !c !i
|
||||
| i >= end64 = processEnd c (offsetInBytes i)
|
||||
| otherwise =
|
||||
let !h = index dat i -- Word64
|
||||
!h80 = h .&. mask64_80
|
||||
in if h80 == 0
|
||||
then processAligned (c+8) (i+1)
|
||||
else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)
|
||||
!nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))
|
||||
in processAligned (c + nbAscii + nbHigh) (i+1)
|
||||
processEnd !c !i
|
||||
| i == end = c
|
||||
| otherwise =
|
||||
let h = index dat i
|
||||
cont = (h .&. 0xc0) == 0x80
|
||||
c' = if cont then c else c+1
|
||||
in processStart c' (i+1)
|
||||
{-# INLINE length #-}
|
||||
|
||||
reverse :: (PrimMonad prim, Indexable container Word8)
|
||||
=> MutableByteArray# (PrimState prim) -- ^ Destination buffer
|
||||
-> Offset Word8 -- ^ Destination start
|
||||
-> container -- ^ Source buffer
|
||||
-> Offset Word8 -- ^ Source start
|
||||
-> Offset Word8 -- ^ Source end
|
||||
-> prim ()
|
||||
reverse dst dstOfs src start end
|
||||
| start == end = pure ()
|
||||
| otherwise = loop (dstOfs `offsetPlusE` (offsetAsSize (end `offsetSub` start)) `offsetSub` 1) start
|
||||
where
|
||||
loop !d !s
|
||||
| s == end = pure ()
|
||||
| headerIsAscii h = primMbaWrite dst d (stepAsciiRawValue h) >> loop (d `offsetSub` 1) (s + 1)
|
||||
| otherwise = do
|
||||
case getNbBytes h of
|
||||
1 -> do
|
||||
primMbaWrite dst (d `offsetSub` 1) (stepAsciiRawValue h)
|
||||
primMbaWrite dst d (index src (s + 1))
|
||||
loop (d `offsetSub` 2) (s + 2)
|
||||
2 -> do
|
||||
primMbaWrite dst (d `offsetSub` 2) (stepAsciiRawValue h)
|
||||
primMbaWrite dst (d `offsetSub` 1) (index src (s + 1))
|
||||
primMbaWrite dst d (index src (s + 2))
|
||||
loop (d `offsetSub` 3) (s + 3)
|
||||
3 -> do
|
||||
primMbaWrite dst (d `offsetSub` 3) (stepAsciiRawValue h)
|
||||
primMbaWrite dst (d `offsetSub` 2) (index src (s + 1))
|
||||
primMbaWrite dst (d `offsetSub` 1) (index src (s + 2))
|
||||
primMbaWrite dst d (index src (s + 3))
|
||||
loop (d `offsetSub` 4) (s + 4)
|
||||
_ -> error "impossible"
|
||||
where h = nextAscii src s
|
||||
{-# INLINE reverse #-}
|
||||
69
bundled/Basement/Alg/XorShift.hs
Normal file
69
bundled/Basement/Alg/XorShift.hs
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
-- |
|
||||
-- Module : Foundation.Random.XorShift
|
||||
-- License : BSD-style
|
||||
--
|
||||
-- XorShift variant: Xoroshiro128+
|
||||
-- <https://en.wikipedia.org/wiki/Xoroshiro128%2B>
|
||||
--
|
||||
-- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation.
|
||||
-- This is lar
|
||||
--
|
||||
-- C implementation at:
|
||||
-- <http://xoroshiro.di.unimi.it/xoroshiro128plus.c>
|
||||
--
|
||||
module Basement.Alg.XorShift
|
||||
( State(..)
|
||||
, next
|
||||
, nextDouble
|
||||
, jump
|
||||
) where
|
||||
|
||||
import Data.Word
|
||||
import Data.Bits
|
||||
import Basement.Compat.Base
|
||||
import Basement.Floating (wordToDouble)
|
||||
import Basement.Numerical.Additive
|
||||
import Basement.Numerical.Subtractive
|
||||
|
||||
-- | State of Xoroshiro128 plus
|
||||
data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
|
||||
|
||||
-- | Given a state, call the function 'f' with the generated Word64 and the next State
|
||||
next :: State -> (Word64 -> State -> a) -> a
|
||||
next (State s0 s1prev) f = f ran stNext
|
||||
where
|
||||
!stNext = State s0' s1'
|
||||
!ran = s0 + s1prev
|
||||
!s1 = s0 `xor` s1prev
|
||||
s0' = (s0 `rotateL` 55) `xor` s1 `xor` (s1 `unsafeShiftL` 14)
|
||||
s1' = (s1 `rotateL` 36)
|
||||
|
||||
-- | Same as 'next' but give a random value of type Double in the range of [0.0 .. 1.0]
|
||||
nextDouble :: State -> (Double -> State -> a) -> a
|
||||
nextDouble st f = next st $ \w -> f (toDouble w)
|
||||
where
|
||||
-- generate a number in the interval [1..2[ by bit manipulation.
|
||||
-- this generate double with a ~2^52
|
||||
toDouble w = wordToDouble (upperMask .|. (w .&. lowerMask)) - 1.0
|
||||
where
|
||||
upperMask = 0x3FF0000000000000
|
||||
lowerMask = 0x000FFFFFFFFFFFFF
|
||||
|
||||
-- | Jump the state by 2^64 calls of next
|
||||
jump :: State -> State
|
||||
jump (State s0 s1) = withK 0xd86b048b86aa9922
|
||||
$ withK 0xbeac0467eba5facb
|
||||
$ (State 0 0)
|
||||
where
|
||||
withK :: Word64 -> State -> State
|
||||
withK !k = loop 0
|
||||
where
|
||||
loop !i st@(State c0 c1)
|
||||
| i == 64 = st
|
||||
| testBit k i = loop (i+1) (State (c0 `xor` s0) (c1 `xor` s1))
|
||||
| otherwise = st
|
||||
Loading…
Add table
Add a link
Reference in a new issue