Title.hs (2242B)
1 {-# LANGUAGE BangPatterns #-} 2 3 -- | 4 -- Module: Urbit.Ob.Title 5 -- Copyright: (c) 2019 Jared Tobin 6 -- License: MIT 7 -- 8 -- Maintainer: Jared Tobin <jared@jtobin.io> 9 -- Stability: unstable 10 -- Portability: ghc 11 -- 12 -- Functions for determining ship class and parentage. 13 -- 14 -- Analogous to the +title arm of zuse.hoon. 15 16 module Urbit.Ob.Title ( 17 Class(..) 18 , clan 19 , sein 20 ) where 21 22 import Urbit.Ob.Co (Patp) 23 import qualified Urbit.Ob.Co as Co (patp, fromPatp) 24 25 -- | Ship class. 26 data Class = 27 -- | 8-bit atom 28 -- 29 Galaxy 30 -- | 16-bit atom 31 -- 32 | Star 33 -- | 32-bit atom 34 -- 35 | Planet 36 -- | 64-bit atom 37 -- 38 | Moon 39 -- | 128-bit atom 40 -- 41 | Comet 42 deriving (Eq, Show) 43 44 -- | Determine ship class. 45 -- 46 -- >>> let fes = patp 255 47 -- >>> let fipfes = patp 256 48 -- >>> let dostec = patp 0xFFFFFFFF 49 -- >>> let risfen = patp 0xFFFFFFFFFFFFFFFF 50 -- >>> let fipfesfipfes = patp 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF 51 -- >>> clan fes 52 -- Galaxy 53 -- >>> clan fipfes 54 -- Star 55 -- >>> clan dostec 56 -- Planet 57 -- >>> clan risfen 58 -- Moon 59 -- >>> clan fipfesfipfes 60 -- Comet 61 -- 62 clan :: Patp -> Class 63 clan ship 64 | wid <= 1 = Galaxy 65 | wid == 2 = Star 66 | wid <= 4 = Planet 67 | wid <= 8 = Moon 68 | otherwise = Comet 69 where 70 wid = met 3 (Co.fromPatp ship) 71 72 -- | Determine parent. 73 -- 74 -- A ship's parent signs for it on the network. 'sein' establishes the 75 -- so-called /autoboss/ of a ship (which can escape to another sponsor). 76 -- 77 -- Note that galaxies sign for themselves, and stars sign for comets. 78 -- 79 -- >>> sein fes 80 -- ~fes 81 -- >>> sein fipfes 82 -- ~fes 83 -- >>> sein dostec 84 -- ~fipfes 85 -- >>> sein risfen 86 -- ~dostec-risfen 87 -- >>> sein fipfesfipfes 88 -- ~fipfes 89 -- 90 sein :: Patp -> Patp 91 sein ship = Co.patp $ case clan ship of 92 Galaxy -> nat 93 Star -> end 3 1 nat 94 Planet -> end 4 1 nat 95 Moon -> end 5 1 nat 96 Comet -> end 4 1 nat 97 where 98 nat = Co.fromPatp ship 99 100 met :: Integral a => a -> a -> a 101 met = loop 0 where 102 loop !acc a !b 103 | b == 0 = acc 104 | otherwise = loop (succ acc) a (rsh a 1 b) 105 106 rsh :: Integral a => a -> a -> a -> a 107 rsh a b c = c `div` 2 ^ (2 ^ a * b) 108 109 end :: Integral a => a -> a -> a -> a 110 end a b c = c `mod` 2 ^ (2 ^ a * b) 111