urbit-hob

Haskell utilities for phonetic base wrangling.
Log | Files | Refs | README | LICENSE

commit 79f29fba9542735d30f84b8ea8b2c10ef410d299
parent 6d54de5488de856466e2599bd5323a974c583ac6
Author: Jared Tobin <jared@jtobin.io>
Date:   Fri,  6 Sep 2019 11:11:47 -0230

general large-scale hacking

Diffstat:
MREADME.md | 1+
Dhob.cabal | 32--------------------------------
Alib/Urbit/Ob.hs | 8++++++++
Alib/Urbit/Ob/Co.hs | 144+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/Urbit/Ob/Muk.hs | 19+++++++++++++++++++
Alib/Urbit/Ob/Ob.hs | 178+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dsrc/Co.hs | 113-------------------------------------------------------------------------------
Dsrc/Muk.hs | 18------------------
Dsrc/Ob.hs | 174-------------------------------------------------------------------------------
Aurbit-hob.cabal | 34++++++++++++++++++++++++++++++++++
10 files changed, 384 insertions(+), 337 deletions(-)

diff --git a/README.md b/README.md @@ -1,6 +1,7 @@ # urbit-hob [![Build Status](https://secure.travis-ci.org/urbit/urbit-hob.png)](http://travis-ci.org/urbit/urbit-hob) +[![Hackage Version](https://img.shields.io/hackage/v/urbit-hob.svg)](http://hackage.haskell.org/package/urbit-hob) [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) Utilities for phonetic base wrangling. diff --git a/hob.cabal b/hob.cabal @@ -1,32 +0,0 @@ -name: urbit-hob -version: 0.1.0 -description: Hoon-style atom manipulation and printing functions -homepage: https://github.com/urbit/urbit-hob#readme -bug-reports: https://github.com/urbit/urbit-hob/issues -author: Jared Tobin -maintainer: jared@jtobin.io -copyright: 2019 Jared Tobin -license: MIT -license-file: LICENSE -build-type: Simple -cabal-version: >= 1.10 - -source-repository head - type: git - location: https://github.com/urbit/urbit-hob - -library - default-language: Haskell2010 - hs-source-dirs: src - other-modules: Paths_hob - exposed-modules: - Co, - Muk, - Ob - build-depends: - base >= 4.7 && < 6 - , bytestring >= 0.10 && < 1 - , containers >= 0.5 && < 1 - , murmur3 >= 1.0 && < 2 - , text >= 1.2 && < 2 - diff --git a/lib/Urbit/Ob.hs b/lib/Urbit/Ob.hs @@ -0,0 +1,8 @@ + +module Urbit.Ob ( + module E + ) where + +import Urbit.Ob.Co as E +import Urbit.Ob.Muk as E +import Urbit.Ob.Ob as E diff --git a/lib/Urbit/Ob/Co.hs b/lib/Urbit/Ob/Co.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Urbit.Ob.Co ( + patp + , render + ) where + +import qualified Data.IntMap.Strict as IMS +import Data.Maybe (fromMaybe) +import Urbit.Ob.Ob (fein) +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as VU +import Data.Word (Word8) + +newtype Patp = Patp (VU.Vector (Word8, Word8)) + deriving (Eq, Show) + +-- | Render a Patp value as Text. +render :: Patp -> T.Text +render (Patp p) = rendered where + folded + | VU.length p == 1 = case VU.unsafeHead p of + (0, su) -> fromMaybe (internalErr "render") $ do + suf <- IMS.lookup (fromIntegral su) suffixes + return (T.cons '~' suf) + + _ -> VU.foldl' alg mempty p + + | otherwise = VU.foldl' alg mempty p + + rendered = case T.uncons folded of + Just (_, pp) -> T.cons '~' pp + Nothing -> internalErr "render" + + alg acc x = acc <> "-" <> glue x + + glue (pr, su) = fromMaybe (internalErr "render") $ do + pre <- IMS.lookup (fromIntegral pr) prefixes + suf <- IMS.lookup (fromIntegral su) suffixes + return (pre <> suf) + +internalErr :: String -> a +internalErr fn = error $ + "urbit-hob (" <> fn <> "): internal error -- please report this as a bug!" + +-- | Convert a nonnegative Int to a Patp value. +patp :: Int -> Patp +patp n + | n >= 0 = _patp + | otherwise = error "urbit-hob (patp): input out of range" + where + _patp + | dyx <= 1 = Patp (VU.singleton (0, fromIntegral sxz)) + | otherwise = Patp (loop sxz 0 mempty) + + sxz = fein n + dyx = met 3 sxz + dyy = met 4 sxz + + loop !tsxz !timp !acc = + let lug = end 4 1 tsxz + -- FIXME index + etc = + if timp `mod` 4 /= 0 + then "-" + else if timp == 0 + then "" + else "--" + + pre = rsh 3 1 lug + suf = end 3 1 lug + res = VU.cons (fromIntegral pre, fromIntegral suf) acc + + in if timp == dyy + then acc + else loop (rsh 4 1 tsxz) (succ timp) res + +prefixes :: IMS.IntMap T.Text +prefixes = IMS.fromList $ zip [0..] + ["doz","mar","bin","wan","sam","lit","sig","hid","fid","lis","sog","dir" + ,"wac","sab","wis","sib","rig","sol","dop","mod","fog","lid","hop","dar" + ,"dor","lor","hod","fol","rin","tog","sil","mir","hol","pas","lac","rov" + ,"liv","dal","sat","lib","tab","han","tic","pid","tor","bol","fos","dot" + ,"los","dil","for","pil","ram","tir","win","tad","bic","dif","roc","wid" + ,"bis","das","mid","lop","ril","nar","dap","mol","san","loc","nov","sit" + ,"nid","tip","sic","rop","wit","nat","pan","min","rit","pod","mot","tam" + ,"tol","sav","pos","nap","nop","som","fin","fon","ban","mor","wor","sip" + ,"ron","nor","bot","wic","soc","wat","dol","mag","pic","dav","bid","bal" + ,"tim","tas","mal","lig","siv","tag","pad","sal","div","dac","tan","sid" + ,"fab","tar","mon","ran","nis","wol","mis","pal","las","dis","map","rab" + ,"tob","rol","lat","lon","nod","nav","fig","nom","nib","pag","sop","ral" + ,"bil","had","doc","rid","moc","pac","rav","rip","fal","tod","til","tin" + ,"hap","mic","fan","pat","tac","lab","mog","sim","son","pin","lom","ric" + ,"tap","fir","has","bos","bat","poc","hac","tid","hav","sap","lin","dib" + ,"hos","dab","bit","bar","rac","par","lod","dos","bor","toc","hil","mac" + ,"tom","dig","fil","fas","mit","hob","har","mig","hin","rad","mas","hal" + ,"rag","lag","fad","top","mop","hab","nil","nos","mil","fop","fam","dat" + ,"nol","din","hat","nac","ris","fot","rib","hoc","nim","lar","fit","wal" + ,"rap","sar","nal","mos","lan","don","dan","lad","dov","riv","bac","pol" + ,"lap","tal","pit","nam","bon","ros","ton","fod","pon","sov","noc","sor" + ,"lav","mat","mip","fip"] + +suffixes :: IMS.IntMap T.Text +suffixes = IMS.fromList $ zip [0..] + ["zod","nec","bud","wes","sev","per","sut","let","ful","pen","syt","dur" + ,"wep","ser","wyl","sun","ryp","syx","dyr","nup","heb","peg","lup","dep" + ,"dys","put","lug","hec","ryt","tyv","syd","nex","lun","mep","lut","sep" + ,"pes","del","sul","ped","tem","led","tul","met","wen","byn","hex","feb" + ,"pyl","dul","het","mev","rut","tyl","wyd","tep","bes","dex","sef","wyc" + ,"bur","der","nep","pur","rys","reb","den","nut","sub","pet","rul","syn" + ,"reg","tyd","sup","sem","wyn","rec","meg","net","sec","mul","nym","tev" + ,"web","sum","mut","nyx","rex","teb","fus","hep","ben","mus","wyx","sym" + ,"sel","ruc","dec","wex","syr","wet","dyl","myn","mes","det","bet","bel" + ,"tux","tug","myr","pel","syp","ter","meb","set","dut","deg","tex","sur" + ,"fel","tud","nux","rux","ren","wyt","nub","med","lyt","dus","neb","rum" + ,"tyn","seg","lyx","pun","res","red","fun","rev","ref","mec","ted","rus" + ,"bex","leb","dux","ryn","num","pyx","ryg","ryx","fep","tyr","tus","tyc" + ,"leg","nem","fer","mer","ten","lus","nus","syl","tec","mex","pub","rym" + ,"tuc","fyl","lep","deb","ber","mug","hut","tun","byl","sud","pem","dev" + ,"lur","def","bus","bep","run","mel","pex","dyt","byt","typ","lev","myl" + ,"wed","duc","fur","fex","nul","luc","len","ner","lex","rup","ned","lec" + ,"ryd","lyd","fen","wel","nyd","hus","rel","rud","nes","hes","fet","des" + ,"ret","dun","ler","nyr","seb","hul","ryl","lud","rem","lys","fyn","wer" + ,"ryc","sug","nys","nyl","lyn","dyn","dem","lux","fed","sed","bec","mun" + ,"lyr","tes","mud","nyt","byr","sen","weg","fyr","mur","tel","rep","teg" + ,"pec","nel","nev","fes"] + +bex :: Integral a => a -> a +bex = (^) 2 + +rsh :: Integral a => a -> a -> a -> a +rsh a b c = c `div` bex (bex a * b) + +met :: Integral a => a -> a -> a +met = loop 0 where + loop !acc a !b + | b == 0 = acc + | otherwise = loop (succ acc) a (rsh a 1 b) + +end :: Integral a => a -> a -> a -> a +end a b c = c `mod` bex (bex a * b) + diff --git a/lib/Urbit/Ob/Muk.hs b/lib/Urbit/Ob/Muk.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wall #-} + +module Urbit.Ob.Muk ( + muk + ) where + +import Data.Bits +import qualified Data.ByteString.Char8 as B8 +import Data.Char +import Data.Word (Word32) +import qualified Data.Hash.Murmur as M + +-- | A specific murmur3 variant. +muk :: Word32 -> Word32 -> Word32 +muk syd key = M.murmur3 syd kee where + kee = chr lo `B8.cons` chr hi `B8.cons` mempty + lo = fromIntegral (key .&. 0xFF) + hi = fromIntegral (key .&. 0xFF00 `div` 256) + diff --git a/lib/Urbit/Ob/Ob.hs b/lib/Urbit/Ob/Ob.hs @@ -0,0 +1,178 @@ +{-# OPTIONS_GHC -Wall #-} + +module Urbit.Ob.Ob ( + fein + , fynd + , feis + , tail + , fe + , fen + , capF + , capFe + , capFen + ) where + +import Data.Bits +import Data.Word (Word32) +import Urbit.Ob.Muk (muk) +import Prelude hiding (tail) + +-- | Conceal structure v3. +fein :: (Integral a, Bits a) => a -> a +fein = loop where + loop pyn = + let lo = pyn .&. 0xFFFFFFFF + hi = pyn .&. 0xFFFFFFFF00000000 + p32 = fromIntegral pyn :: Word32 + in if pyn >= 0x10000 && pyn <= 0xFFFFFFFF + then 0x10000 + fromIntegral (feis (p32 - 0x10000)) + else if pyn >= 0x100000000 && pyn <= 0xFFFFFFFFFFFFFFFF + then hi .|. loop lo + else pyn + +-- | Restore structure v3. +fynd :: (Integral a, Bits a) => a -> a +fynd = loop where + loop cry = + let lo = cry .&. 0xFFFFFFFF + hi = cry .&. 0xFFFFFFFF00000000 + c32 = fromIntegral cry :: Word32 + in if cry >= 0x10000 && cry <= 0xFFFFFFFF + then 0x10000 + fromIntegral (tail (c32 - 0x10000)) + else if cry >= 0x100000000 && cry <= 0xFFFFFFFFFFFFFFFF + then hi .|. loop lo + else cry + +-- | Generalised Feistel cipher +-- +-- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." +-- +-- Note that this has been adjusted from the reference paper in order to +-- support some legacy behaviour. +feis :: Word32 -> Word32 +feis = capFe 4 65535 65536 0xFFFFFFFF capF + +-- | Reverse 'feis'. +-- +-- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." +-- +-- Note that this has been adjusted from the reference paper in order to +-- support some legacy behaviour. +tail :: Word32 -> Word32 +tail = capFen 4 65535 65536 0xFFFFFFFF capF + +-- | A PRF for j in [0, .., 3] +capF :: Int -> Word32 -> Word32 +capF j key = fromIntegral (muk seed key) where + seed = raku !! fromIntegral j + raku = [ + 0xb76d5eed + , 0xee281300 + , 0x85bcae01 + , 0x4b387af7 + ] + +-- | 'Fe' in B&R (2002). +capFe + :: Integral a + => Int + -> a + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +capFe r a b k f m + | c < k = c + | otherwise = fe r a b f c + where + c = fe r a b f m + +-- | 'fe' in B&R (2002). +fe + :: Integral a + => Int + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +fe r a b f m = loop 1 capL capR where + capL = m `mod` a + capR = m `div` a + loop j ell arr + | j > r = + if odd r + then a * arr + ell + else if arr == a + then a * arr + ell + else a * ell + arr + | otherwise = + let eff = f (pred j) arr + tmp = if odd j + then (ell + eff) `mod` a + else (ell + eff) `mod` b + in loop (succ j) arr tmp + +-- | 'Fen' in B&R (2002). +capFen + :: Integral a + => Int + -> a + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +capFen r a b k f m + | c <= k = c + | otherwise = fen r a b f c + where + c = fen r a b f m + +-- | 'fen' in B&R (2002). +fen + :: Integral a + => Int + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +fen r a b f m = loop r capL capR where + ahh = + if odd r + then m `div` a + else m `mod` a + + ale = + if odd r + then m `mod` a + else m `div` a + + capL = + if ale == a + then ahh + else ale + + capR = + if ale == a + then ale + else ahh + + loop j ell arr + | j < 1 = a * arr + ell + | otherwise = + let eff = f (pred j) ell + -- NB (jtobin): + -- + -- Slight deviation from B&R (2002) here to prevent negative + -- values. We add 'a' or 'b' to arr as appropriate and reduce + -- 'eff' modulo the same number before performing subtraction. + -- + tmp = if odd j + then (arr + a - (eff `mod` a)) `mod` a + else (arr + b - (eff `mod` b)) `mod` b + in loop (pred j) tmp ell + + diff --git a/src/Co.hs b/src/Co.hs @@ -1,113 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Co ( - patp - ) where - -import qualified Data.IntMap.Strict as IMS -import Ob (fein) -import qualified Data.Text as T - -newtype Patp = Patp T.Text - deriving Eq - -instance Show Patp where - show = T.unpack . render - -render :: Patp -> T.Text -render (Patp p) = T.cons '~' p - -patp :: Int -> Maybe Patp -patp n - | dyx <= 1 = fmap Patp (IMS.lookup sxz suffixes) - | otherwise = fmap Patp (loop sxz 0 mempty) - where - sxz = fein n - dyx = met 3 sxz - dyy = met 4 sxz - - loop !tsxz !timp !trep = do - let lug = end 4 1 tsxz - etc = - if timp `mod` 4 /= 0 - then "-" - else if timp == 0 - then "" - else "--" - - pre <- IMS.lookup (rsh 3 1 lug) prefixes - suf <- IMS.lookup (end 3 1 lug) suffixes - - let res = pre <> suf <> etc <> trep - - if timp == dyy - then return trep - else loop (rsh 4 1 tsxz) (succ timp) res - -prefixes :: IMS.IntMap T.Text -prefixes = IMS.fromList $ zip [0..] - ["doz","mar","bin","wan","sam","lit","sig","hid","fid","lis","sog","dir" - ,"wac","sab","wis","sib","rig","sol","dop","mod","fog","lid","hop","dar" - ,"dor","lor","hod","fol","rin","tog","sil","mir","hol","pas","lac","rov" - ,"liv","dal","sat","lib","tab","han","tic","pid","tor","bol","fos","dot" - ,"los","dil","for","pil","ram","tir","win","tad","bic","dif","roc","wid" - ,"bis","das","mid","lop","ril","nar","dap","mol","san","loc","nov","sit" - ,"nid","tip","sic","rop","wit","nat","pan","min","rit","pod","mot","tam" - ,"tol","sav","pos","nap","nop","som","fin","fon","ban","mor","wor","sip" - ,"ron","nor","bot","wic","soc","wat","dol","mag","pic","dav","bid","bal" - ,"tim","tas","mal","lig","siv","tag","pad","sal","div","dac","tan","sid" - ,"fab","tar","mon","ran","nis","wol","mis","pal","las","dis","map","rab" - ,"tob","rol","lat","lon","nod","nav","fig","nom","nib","pag","sop","ral" - ,"bil","had","doc","rid","moc","pac","rav","rip","fal","tod","til","tin" - ,"hap","mic","fan","pat","tac","lab","mog","sim","son","pin","lom","ric" - ,"tap","fir","has","bos","bat","poc","hac","tid","hav","sap","lin","dib" - ,"hos","dab","bit","bar","rac","par","lod","dos","bor","toc","hil","mac" - ,"tom","dig","fil","fas","mit","hob","har","mig","hin","rad","mas","hal" - ,"rag","lag","fad","top","mop","hab","nil","nos","mil","fop","fam","dat" - ,"nol","din","hat","nac","ris","fot","rib","hoc","nim","lar","fit","wal" - ,"rap","sar","nal","mos","lan","don","dan","lad","dov","riv","bac","pol" - ,"lap","tal","pit","nam","bon","ros","ton","fod","pon","sov","noc","sor" - ,"lav","mat","mip","fip"] - -suffixes :: IMS.IntMap T.Text -suffixes = IMS.fromList $ zip [0..] - ["zod","nec","bud","wes","sev","per","sut","let","ful","pen","syt","dur" - ,"wep","ser","wyl","sun","ryp","syx","dyr","nup","heb","peg","lup","dep" - ,"dys","put","lug","hec","ryt","tyv","syd","nex","lun","mep","lut","sep" - ,"pes","del","sul","ped","tem","led","tul","met","wen","byn","hex","feb" - ,"pyl","dul","het","mev","rut","tyl","wyd","tep","bes","dex","sef","wyc" - ,"bur","der","nep","pur","rys","reb","den","nut","sub","pet","rul","syn" - ,"reg","tyd","sup","sem","wyn","rec","meg","net","sec","mul","nym","tev" - ,"web","sum","mut","nyx","rex","teb","fus","hep","ben","mus","wyx","sym" - ,"sel","ruc","dec","wex","syr","wet","dyl","myn","mes","det","bet","bel" - ,"tux","tug","myr","pel","syp","ter","meb","set","dut","deg","tex","sur" - ,"fel","tud","nux","rux","ren","wyt","nub","med","lyt","dus","neb","rum" - ,"tyn","seg","lyx","pun","res","red","fun","rev","ref","mec","ted","rus" - ,"bex","leb","dux","ryn","num","pyx","ryg","ryx","fep","tyr","tus","tyc" - ,"leg","nem","fer","mer","ten","lus","nus","syl","tec","mex","pub","rym" - ,"tuc","fyl","lep","deb","ber","mug","hut","tun","byl","sud","pem","dev" - ,"lur","def","bus","bep","run","mel","pex","dyt","byt","typ","lev","myl" - ,"wed","duc","fur","fex","nul","luc","len","ner","lex","rup","ned","lec" - ,"ryd","lyd","fen","wel","nyd","hus","rel","rud","nes","hes","fet","des" - ,"ret","dun","ler","nyr","seb","hul","ryl","lud","rem","lys","fyn","wer" - ,"ryc","sug","nys","nyl","lyn","dyn","dem","lux","fed","sed","bec","mun" - ,"lyr","tes","mud","nyt","byr","sen","weg","fyr","mur","tel","rep","teg" - ,"pec","nel","nev","fes"] - -bex :: Integral a => a -> a -bex = (^) 2 - -rsh :: Integral a => a -> a -> a -> a -rsh a b c = c `div` bex (bex a * b) - -met :: Integral a => a -> a -> a -met = loop 0 where - loop !acc a !b - | b == 0 = acc - | otherwise = loop (succ acc) a (rsh a 1 b) - -end :: Integral a => a -> a -> a -> a -end a b c = c `mod` bex (bex a * b) - diff --git a/src/Muk.hs b/src/Muk.hs @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module Muk ( - muk - ) where - -import Data.Bits -import qualified Data.ByteString.Char8 as B8 -import Data.Char -import Data.Word (Word32) -import qualified Data.Hash.Murmur as M - -muk :: Word32 -> Word32 -> Word32 -muk syd key = M.murmur3 syd kee where - kee = chr lo `B8.cons` chr hi `B8.cons` mempty - lo = fromIntegral (key .&. 0xFF) - hi = fromIntegral (key .&. 0xFF00 `div` 256) - diff --git a/src/Ob.hs b/src/Ob.hs @@ -1,174 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module Ob ( - fein - , fynd - , feis - , tail - , fe - , fen - , capF - , capFe - , capFen - ) where - -import Data.Bits -import Data.Word (Word32) -import Muk (muk) -import Prelude hiding (tail) - --- | A PRF for j in [0, .., 3] -capF :: Int -> Word32 -> Word32 -capF j key = fromIntegral (muk seed key) where - seed = raku !! fromIntegral j - raku = [ - 0xb76d5eed - , 0xee281300 - , 0x85bcae01 - , 0x4b387af7 - ] - --- | Conceal structure v3. -fein :: (Integral a, Bits a) => a -> a -fein = loop where - loop pyn = - let lo = pyn .&. 0xFFFFFFFF - hi = pyn .&. 0xFFFFFFFF00000000 - p32 = fromIntegral pyn :: Word32 - in if pyn >= 0x10000 && pyn <= 0xFFFFFFFF - then 0x10000 + fromIntegral (feis (p32 - 0x10000)) - else if pyn >= 0x100000000 && pyn <= 0xFFFFFFFFFFFFFFFF - then hi .|. loop lo - else pyn - --- | Restore structure v3. -fynd :: (Integral a, Bits a) => a -> a -fynd = loop where - loop cry = - let lo = cry .&. 0xFFFFFFFF - hi = cry .&. 0xFFFFFFFF00000000 - c32 = fromIntegral cry :: Word32 - in if cry >= 0x10000 && cry <= 0xFFFFFFFF - then 0x10000 + fromIntegral (tail (c32 - 0x10000)) - else if cry >= 0x100000000 && cry <= 0xFFFFFFFFFFFFFFFF - then hi .|. loop lo - else cry - --- | Generalised Feistel cipher --- --- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." --- --- Note that this has been adjusted from the reference paper in order to --- support some legacy behaviour. -feis :: Word32 -> Word32 -feis = capFe 4 65535 65536 0xFFFFFFFF capF - --- | Reverse 'feis'. --- --- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." --- --- Note that this has been adjusted from the reference paper in order to --- support some legacy behaviour. -tail :: Word32 -> Word32 -tail = capFen 4 65535 65536 0xFFFFFFFF capF - -capFe - :: Integral a - => Int - -> a - -> a - -> a - -> (Int -> a -> a) - -> a - -> a -capFe r a b k f m - | c < k = c - | otherwise = fe r a b f c - where - c = fe r a b f m - -fe - :: Integral a - => Int - -> a - -> a - -> (Int -> a -> a) - -> a - -> a -fe r a b f m = loop 1 capL capR where - capL = m `mod` a - capR = m `div` a - loop j ell arr - | j > r = - if odd r - then a * arr + ell - else if arr == a - then a * arr + ell - else a * ell + arr - | otherwise = - let eff = f (pred j) arr - tmp = if odd j - then (ell + eff) `mod` a - else (ell + eff) `mod` b - in loop (succ j) arr tmp - -capFen - :: Integral a - => Int - -> a - -> a - -> a - -> (Int -> a -> a) - -> a - -> a -capFen r a b k f m - | c <= k = c - | otherwise = fen r a b f c - where - c = fen r a b f m - -fen - :: Integral a - => Int - -> a - -> a - -> (Int -> a -> a) - -> a - -> a -fen r a b f m = loop r capL capR where - ahh = - if odd r - then m `div` a - else m `mod` a - - ale = - if odd r - then m `mod` a - else m `div` a - - capL = - if ale == a - then ahh - else ale - - capR = - if ale == a - then ale - else ahh - - loop j ell arr - | j < 1 = a * arr + ell - | otherwise = - let eff = f (pred j) ell - -- NB (jtobin): - -- - -- Slight deviation from B&R (2002) here to prevent negative - -- values. We add 'a' or 'b' to arr as appropriate and reduce - -- 'eff' modulo the same number before performing subtraction. - -- - tmp = if odd j - then (arr + a - (eff `mod` a)) `mod` a - else (arr + b - (eff `mod` b)) `mod` b - in loop (pred j) tmp ell - - diff --git a/urbit-hob.cabal b/urbit-hob.cabal @@ -0,0 +1,34 @@ +name: urbit-hob +version: 0.1.0 +description: Hoon-style atom manipulation and printing functions +homepage: https://github.com/urbit/urbit-hob#readme +bug-reports: https://github.com/urbit/urbit-hob/issues +author: Jared Tobin +maintainer: jared@jtobin.io +copyright: 2019 Jared Tobin +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/urbit/urbit-hob + +library + default-language: Haskell2010 + hs-source-dirs: lib + other-modules: Paths_hob + exposed-modules: + Urbit.Ob + , Urbit.Ob.Co + , Urbit.Ob.Muk + , Urbit.Ob.Ob + build-depends: + base >= 4.7 && < 6 + , bytestring >= 0.10 && < 1 + , containers >= 0.5 && < 1 + , murmur3 >= 1.0 && < 2 + , text >= 1.2 && < 2 + , vector >= 0.12 && < 1 +