commit f9d887c56b669c27203e5394c9ad05736a5ff2d8
parent de116ba836c50067fda9b25bdbd562e3198fc454
Author: Jared Tobin <jared@jtobin.io>
Date: Thu, 19 Sep 2019 14:13:57 -0230
title: add 'clan' and 'sein' support
These are two common and useful functions that are also exported in
urbit-ob. 'clan' determines a ship's class, while 'sein' determines its
(default) parent.
Diffstat:
6 files changed, 199 insertions(+), 1 deletion(-)
diff --git a/README.md b/README.md
@@ -22,7 +22,10 @@ The library exposes two functions, `patp` and `fromPatp`, for converting
between representations. You can render a `patp` value via the `render`
function, and parse one from Text via `parse`.
-Here's a quick example:
+The `clan` and `sein` functions, for determining a ship's class and (default)
+parent, are also exposed.
+
+Here are some quick examples:
```
> :set -XOverloadedStrings
@@ -34,6 +37,10 @@ Here's a quick example:
15663360
> Ob.parse "~nidsut-tomdun"
Right ~nidsut-tomdun
+> Ob.clan nidsut
+Planet
+> Ob.sein nidsut
+~marzod
```
## See also
diff --git a/lib/Urbit/Ob.hs b/lib/Urbit/Ob.hs
@@ -6,3 +6,4 @@ module Urbit.Ob (
import Urbit.Ob.Co as E
import Urbit.Ob.Muk as E
import Urbit.Ob.Ob as E
+import Urbit.Ob.Title as E
diff --git a/lib/Urbit/Ob/Title.hs b/lib/Urbit/Ob/Title.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- |
+-- Module: Urbit.Ob.Title
+-- Copyright: (c) 2019 Jared Tobin
+-- License: MIT
+--
+-- Maintainer: Jared Tobin <jared@jtobin.io>
+-- Stability: unstable
+-- Portability: ghc
+--
+-- Functions for determining ship class and parentage.
+--
+-- Analogous to the +title arm of zuse.hoon.
+
+module Urbit.Ob.Title (
+ Class(..)
+ , clan
+ , sein
+ ) where
+
+import Urbit.Ob.Co (Patp)
+import qualified Urbit.Ob.Co as Co (patp, fromPatp)
+
+-- | Ship class.
+data Class =
+ -- | 8-bit atom
+ --
+ Galaxy
+ -- | 16-bit atom
+ --
+ | Star
+ -- | 32-bit atom
+ --
+ | Planet
+ -- | 64-bit atom
+ --
+ | Moon
+ -- | 128-bit atom
+ --
+ | Comet
+ deriving (Eq, Show)
+
+-- | Determine ship class.
+--
+-- >>> let fes = patp 255
+-- >>> let fipfes = patp 256
+-- >>> let dostec = patp 0xFFFFFFFF
+-- >>> let risfen = patp 0xFFFFFFFFFFFFFFFF
+-- >>> let fipfesfipfes = patp 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+-- >>> clan fes
+-- Galaxy
+-- >>> clan fipfes
+-- Star
+-- >>> clan dostec
+-- Planet
+-- >>> clan risfen
+-- Moon
+-- >>> clan fipfesfipfes
+-- Comet
+--
+clan :: Patp -> Class
+clan ship
+ | wid <= 1 = Galaxy
+ | wid == 2 = Star
+ | wid <= 4 = Planet
+ | wid <= 8 = Moon
+ | otherwise = Comet
+ where
+ wid = met 3 (Co.fromPatp ship)
+
+-- | Determine parent.
+--
+-- A ship's parent signs for it on the network. 'sein' establishes the
+-- so-called /autoboss/ of a ship (which can escape to another sponsor).
+--
+-- Note that galaxies sign for themselves, and stars sign for comets.
+--
+-- >>> sein fes
+-- ~fes
+-- >>> sein fipfes
+-- ~fes
+-- >>> sein dostec
+-- ~fipfes
+-- >>> sein risfen
+-- ~dostec-risfen
+-- >>> sein fipfesfipfes
+-- ~fipfes
+--
+sein :: Patp -> Patp
+sein ship = Co.patp $ case clan ship of
+ Galaxy -> nat
+ Star -> end 3 1 nat
+ Planet -> end 4 1 nat
+ Moon -> end 5 1 nat
+ Comet -> end 4 1 nat
+ where
+ nat = Co.fromPatp ship
+
+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)
+
+rsh :: Integral a => a -> a -> a -> a
+rsh a b c = c `div` 2 ^ (2 ^ a * b)
+
+end :: Integral a => a -> a -> a -> a
+end a b c = c `mod` 2 ^ (2 ^ a * b)
+
diff --git a/test/Title.hs b/test/Title.hs
@@ -0,0 +1,10 @@
+module Main where
+
+import qualified Title.Tests.Property as P
+import Test.Hspec
+
+main :: IO ()
+main =
+ hspec $
+ context "property tests" P.tests
+
diff --git a/test/Title/Tests/Property.hs b/test/Title/Tests/Property.hs
@@ -0,0 +1,45 @@
+
+module Title.Tests.Property (
+ tests
+ ) where
+
+import Data.Word (Word8, Word16, Word32, Word64)
+import Test.Hspec
+import Test.QuickCheck
+import Urbit.Ob.Co (Patp)
+import qualified Urbit.Ob.Co as Co
+import qualified Urbit.Ob.Title as Title
+
+galaxies :: Gen Patp
+galaxies = fmap (Co.patp . fromIntegral) (arbitrary :: Gen Word8)
+
+stars :: Gen Patp
+stars = do
+ star <- arbitrary `suchThat` (> (0xFF :: Word16))
+ return (Co.patp (fromIntegral star))
+
+planets :: Gen Patp
+planets = do
+ planet <- arbitrary `suchThat` (> (0xFFFF :: Word32))
+ return (Co.patp (fromIntegral planet))
+
+moons :: Gen Patp
+moons = do
+ moon <- arbitrary `suchThat` (> (0xFFFFFFFF :: Word64))
+ return (Co.patp (fromIntegral moon))
+
+tests :: Spec
+tests =
+ describe "clan" $ do
+ it "identifies galaxies correctly" $
+ forAll galaxies $ \x -> Title.clan x == Title.Galaxy
+
+ it "identifies stars correctly" $
+ forAll stars $ \x -> Title.clan x == Title.Star
+
+ it "identifies planets correctly" $
+ forAll planets $ \x -> Title.clan x == Title.Planet
+
+ it "identifies moons correctly" $
+ forAll moons $ \x -> Title.clan x == Title.Moon
+
diff --git a/urbit-hob.cabal b/urbit-hob.cabal
@@ -23,6 +23,10 @@ description:
converting between representations. You can also render a 'Patp' value via
the 'render' function, or parse one via 'parse'.
.
+ Since \@p values represent ships, some utilities for dealing with ships are
+ also exposed. The 'clan' and 'sein' functions are useful for determining a
+ ship's class and (default) parent, respectively.
+ .
Some quick examples:
.
>>> :set -XOverloadedStrings
@@ -35,6 +39,10 @@ description:
15663360
>>> Ob.parse "~nidsut-tomdun"
Right ~nidsut-tomdun
+ >>> Ob.clan nidsut
+ Planet
+ >>> Ob.sein nidsut
+ ~marzod
source-repository head
type: git
@@ -59,6 +67,7 @@ library
, Urbit.Ob.Co
, Urbit.Ob.Muk
, Urbit.Ob.Ob
+ , Urbit.Ob.Title
other-modules:
Data.Serialize.Extended
@@ -107,6 +116,21 @@ Test-suite co
, text
, urbit-hob
+Test-suite title
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Title.hs
+ other-modules:
+ Title.Tests.Property
+ default-language: Haskell2010
+ ghc-options:
+ -rtsopts
+ build-depends:
+ base
+ , hspec
+ , QuickCheck
+ , urbit-hob
+
benchmark ob-bench
type: exitcode-stdio-1.0
hs-source-dirs: bench
