packages feed

urbit-hob (empty) → 0.1.0

raw patch · 8 files changed

+484/−0 lines, 8 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, murmur3, text, urbit-hob

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2019 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/Urbit/Ob.hs view
@@ -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
+ lib/Urbit/Ob/Co.hs view
@@ -0,0 +1,134 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Urbit.Ob.Co (+    Patp+  , render++  , patp+  , fromPatp+  ) where++import qualified Data.ByteString as BS+import qualified Data.IntMap.Strict as IMS+import Data.Maybe (fromMaybe)+import qualified Data.Serialize as C+import qualified Data.Text as T+import Data.Word (Word8, Word16, Word)+import Urbit.Ob.Ob (fein, fynd)++newtype Patp = Patp BS.ByteString+  deriving (Eq, Show)++-- | 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+    sxz  = fein n+    sxz8 = fromIntegral sxz :: Word8++    _patp+      | met 3 sxz <= 1 = Patp (BS.cons 0 (BS.singleton sxz8))+      | otherwise      = Patp (C.encode (fromIntegral sxz :: Word))++-- | Convert a Patp value to an Int.+fromPatp :: Patp -> Int+fromPatp (Patp p) = decoded where+  decoded = case BS.length p of+    2 -> case C.decode p :: Either String Word16 of+      Left _  -> internalErr "fromPatp"+      Right x -> fynd (fromIntegral x)+    _ -> case C.decode p :: Either String Word of+      Left _  -> internalErr "fromPatp"+      Right x -> fynd (fromIntegral x)++-- | Render a Patp value as Text.+render :: Patp -> T.Text+render (Patp p) = prefixed where+  grab = fromMaybe (internalErr "render")++  prefixed = case T.uncons encoded of+    Just ('-', pp) -> T.cons '~' pp+    Just _         -> T.cons '~' encoded+    _              -> internalErr "render"++  encoded = foldr alg mempty pruned where+    alg (idx, x) acc+      | odd idx   =        grab (IMS.lookup (fromIntegral x) suffixes) <> acc+      | otherwise = "-" <> grab (IMS.lookup (fromIntegral x) prefixes) <> acc++  pruned =+    let len = BS.length p+        indexed = zip [len, pred len..] (BS.unpack p)+        padding (idx, val) = idx /= 1 && val == 0+    in  dropWhile padding indexed++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)++internalErr :: String -> a+internalErr fn = error $+  "urbit-hob (" <> fn <> "): internal error -- please report this as a bug!"+
+ lib/Urbit/Ob/Muk.hs view
@@ -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)+
+ lib/Urbit/Ob/Ob.hs view
@@ -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++
+ test/Small.hs view
@@ -0,0 +1,47 @@+module Main where++import Control.Monad (unless)+import Data.List (nub, foldl')+import Prelude hiding (tail)+import System.Exit (exitSuccess, exitFailure)+import qualified Urbit.Ob.Ob as Ob++a, b, c :: Int+a = 2 ^ 2 - 1+b = 2 ^ 2+c = a * b++eff j m =+  let v0 = [5, 9, 2, 6, 4, 0, 8, 7, 1, 10, 3, 11]+      v1 = [2, 1, 0, 3, 10, 4, 9, 5, 7, 11, 6, 8]+      v2 = [10, 6, 7, 1, 0, 11, 3, 9, 5, 2, 8, 4]+      v3 = [11, 0, 3, 5, 9, 8, 6, 10, 4, 1, 2, 7]++  in  case j of+        0 -> v0 !! m+        1 -> v1 !! m+        2 -> v2 !! m+        _ -> v3 !! m++feis = Ob.capFe 4 a b c eff++tail = Ob.capFen 4 a b c eff++main :: IO ()+main = do+  let emm  = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11]+      perm = fmap feis emm+      inv  = fmap tail perm+      distincts = nub perm++  let distinctElems = length distincts == length perm+  unless distinctElems exitFailure++  let permuteSuccessful = foldl' (\acc x -> x `elem` emm && acc) True perm+  unless permuteSuccessful exitFailure++  let tailInvertsFeis = emm == inv+  unless tailInvertsFeis exitFailure++  exitSuccess+
+ urbit-hob.cabal view
@@ -0,0 +1,77 @@+name:           urbit-hob+version:        0.1.0+synopsis:       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+category:       Urbit+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+description:+  Here you can primarily find functions for dealing with the "patp" phonetic+  base used by Urbit.  The '@p' encoding is used for naming ships; it uniquely+  represents a 32-bit number in a memorable and pronounceable fashion.+  .+  The '@p' encoding is an obfuscated representation of an underlying 32-bit+  number, in particular, hence the 'ob' in the library's name.+  .+  The library exposes two functions, 'patp' and 'fromPatp', for converting+  between representations.  You can render a 'Patp' value via the 'render'+  function.+  .+  Here's a quick example:+  .+  > import qualified Urbit.Ob as Ob+  >+  > let nidsut = Ob.patp 15663360+  > Ob.render nidsut+  "~nidsut-tomdun"+  > Ob.fromPatp nidsut+  15663360++source-repository head+  type: git+  location: https://github.com/urbit/urbit-hob++flag release+  Description:  Build for release+  Default:      False+  Manual:       True++library+  default-language: Haskell2010+  hs-source-dirs:   lib++  if flag(release)+    ghc-options:     -Wall+  else+    ghc-options:     -Wall -Werror++  exposed-modules:+      Urbit.Ob+    , Urbit.Ob.Co+    , Urbit.Ob.Muk+    , Urbit.Ob.Ob+  build-depends:+      base        >= 4.7  && < 6+    , bytestring  >= 0.10 && < 1+    , cereal      >= 0.5  && < 1+    , containers  >= 0.5  && < 1+    , murmur3     >= 1.0  && < 2+    , text        >= 1.2  && < 2++Test-suite small+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Small.hs+  default-language:    Haskell2010+  ghc-options:+    -rtsopts+  build-depends:+      base+    , urbit-hob+