mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 09:51:36 +03:00
50 lines
1.6 KiB
Haskell
50 lines
1.6 KiB
Haskell
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)
|