repn in Haskell.

pkg/king/lib/Noun/Rip.hs

@@ -0,0 +1,49 @@
+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)