shrub/pkg/hs/king/lib/Noun/Rip.hs

50 lines
1.6 KiB
Haskell
Raw Normal View History

2019-12-10 06:21:36 +03:00
module Noun.Rip where
import ClassyPrelude
import Noun.Atom
import Data.Bits
import Control.Lens (view, (&), from)
import qualified Data.Vector.Primitive as VP
--------------------------------------------------------------------------------
takeBits Word Word Word
takeBits 64 w = w
takeBits 0 w = 0
takeBits n w = w .&. (shiftL 1 (fromIntegral n) - 1)
divCeil Word Word Word
divCeil 0 y = 0
divCeil x y = 1 + ((x-1) `div` y)
--------------------------------------------------------------------------------
repn :: Word -> [Word] -> Atom
repn bits blox =
(bits > 64) & \case
True error "repn only works with block sizes <= 64"
False view (from atomWords)
$ VP.fromList
$ finish
$ foldl' f ([], 0, 0)
$ zip (repeat bits) blox
where
finish (acc, wor, n) = reverse
$ dropWhile (==0)
$ case n of { 0 -> acc; _ -> wor:acc }
slice size off wor = shiftL (takeBits size wor)
$ fromIntegral off
f (acc, wor, off) (remBlok, blok) =
let rem = 64 - off in
compare remBlok rem & \case
LT -> (acc, res, off+bits)
where res = wor .|. slice bits off blok
EQ -> (res:acc, 0, 0)
where res = (wor .|. slice bits off blok)
GT -> f (res:acc, 0, 0) (remBlok', blok')
where res = wor .|. slice rem off blok
remBlok' = remBlok-rem
blok' = shiftR blok (fromIntegral bits)