{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Locator.English16 (
    Locator (..),
    English16 (..),
    fromEnglish16,
    toEnglish16,
    toEnglish16a,
    hashStringToEnglish16a,
    -- Deprecated
    fromLocator16,
    toLocator16,
    toLocator16a,
    hashStringToLocator16a,
) where

import Prelude hiding (toInteger)

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.List (mapAccumL)
import Data.Set (Set)
import qualified Data.Set as Set
import Numeric (showIntAtBase)

import Data.Locator.Common

--

{- |
A symbol set with sixteen uniquely pronounceable digits.

The fact there are sixteen symbols is more an indication of a certain degree
of bullheaded-ness on the part of the author, and less of any kind of actual
requirement. We might have a slighly better readback score if we dropped to
15 or 14 unique characters. It does mean you can match up with hexidecimal,
which is not entirely without merit.

The grouping of letters and numbers was the hard part; having come up with
the set and deconflicted the choices, the ordering is then entirely
arbitrary. Since there are some numbers, might as well have them at the same
place they correspond to in base 10; the letters were then allocated in alpha
order in the remaining slots.
-}

{-
        -- 0 Conflicts with @\'O\'@ obviously, and @\'Q\'@ often enough
        --
        -- 2 @\'U\'@, @\'W\'@, and @\'2\'@. @\'W\'@ is disqualifed because of
        -- the way Australians butcher double-this and triple-that. \"Double
        -- @\'U\'@\" or \"@\'W\'@\"?
        --
        -- C @\'B\'@, @\'C\'@, @\'D\'@, @\'E\'@, @\'G\'@, @\'P\'@, @\'T\'@,
        -- @\'V\'@, and @\'3\'@ plus @\'Z\'@ because Americans can't pronounce
        -- Zed properly.
        --
        -- 4 @\'4\'@ and @\'5\'@ are often confused, and @\'5\'@, definitely
        -- out due to its collision with @\'I\'@ when spoken and @\'S\'@ in
        -- writing.
        --
        -- F @\'F\'@ and @\'S\'@ are notoriously confused, making the choice of
        -- @\'F\'@ borderline, but @\'S\'@ is already disqualified for looking
        -- like @\'5\'@.
        --
        -- K group of @\'A\'@, @\'J\'@, @\'K\'@.
        --
        -- L @\'L\'@ has good phonetics, and as long as it's upper case (which
        -- the whole 'English16' symbol set is) there's no conflict with
        -- @\'1\'@.
        --
        -- M choice from @\'M\'@ and @\'N\'@; the latter is a little too close
        -- to @\'7\'@.
        --
        -- X choice from @\'X\'@ and @\'6\'@.
        --
        -- Y choice from @\'I\'@, @\'Y\'@, @\'5\'@. @\'I\'@ is out for the
        -- usual reason of being similar to @\'1\'@.
-}
data English16
    = -- | @\'0\'@ /0th/
      Zero
    | -- | @\'1\'@ /1st/
      One
    | -- | @\'2\'@ /2nd/
      Two
    | -- | @\'C\'@ /3rd/
      Charlie
    | -- | @\'4\'@ /4th/
      Four
    | -- | @\'F\'@ /5th/
      Foxtrot
    | -- | @\'H\'@ /6th/
      Hotel
    | -- | @\'7\'@ /7th/
      Seven
    | -- | @\'8\'@ /8th/
      Eight
    | -- | @\'9\'@ /9th/
      Nine
    | -- | @\'K\'@ /10th/
      Kilo
    | -- | @\'L\'@ /11th/
      Lima
    | -- | @\'M\'@ /12th/
      Mike
    | -- | @\'R\'@ /13th/
      Romeo
    | -- | @\'X\'@ /14th/
      XRay
    | -- | @\'Y\'@ /15th/
      Yankee
    deriving (English16 -> English16 -> Bool
(English16 -> English16 -> Bool)
-> (English16 -> English16 -> Bool) -> Eq English16
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: English16 -> English16 -> Bool
== :: English16 -> English16 -> Bool
$c/= :: English16 -> English16 -> Bool
/= :: English16 -> English16 -> Bool
Eq, Eq English16
Eq English16 =>
(English16 -> English16 -> Ordering)
-> (English16 -> English16 -> Bool)
-> (English16 -> English16 -> Bool)
-> (English16 -> English16 -> Bool)
-> (English16 -> English16 -> Bool)
-> (English16 -> English16 -> English16)
-> (English16 -> English16 -> English16)
-> Ord English16
English16 -> English16 -> Bool
English16 -> English16 -> Ordering
English16 -> English16 -> English16
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: English16 -> English16 -> Ordering
compare :: English16 -> English16 -> Ordering
$c< :: English16 -> English16 -> Bool
< :: English16 -> English16 -> Bool
$c<= :: English16 -> English16 -> Bool
<= :: English16 -> English16 -> Bool
$c> :: English16 -> English16 -> Bool
> :: English16 -> English16 -> Bool
$c>= :: English16 -> English16 -> Bool
>= :: English16 -> English16 -> Bool
$cmax :: English16 -> English16 -> English16
max :: English16 -> English16 -> English16
$cmin :: English16 -> English16 -> English16
min :: English16 -> English16 -> English16
Ord, Int -> English16
English16 -> Int
English16 -> [English16]
English16 -> English16
English16 -> English16 -> [English16]
English16 -> English16 -> English16 -> [English16]
(English16 -> English16)
-> (English16 -> English16)
-> (Int -> English16)
-> (English16 -> Int)
-> (English16 -> [English16])
-> (English16 -> English16 -> [English16])
-> (English16 -> English16 -> [English16])
-> (English16 -> English16 -> English16 -> [English16])
-> Enum English16
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: English16 -> English16
succ :: English16 -> English16
$cpred :: English16 -> English16
pred :: English16 -> English16
$ctoEnum :: Int -> English16
toEnum :: Int -> English16
$cfromEnum :: English16 -> Int
fromEnum :: English16 -> Int
$cenumFrom :: English16 -> [English16]
enumFrom :: English16 -> [English16]
$cenumFromThen :: English16 -> English16 -> [English16]
enumFromThen :: English16 -> English16 -> [English16]
$cenumFromTo :: English16 -> English16 -> [English16]
enumFromTo :: English16 -> English16 -> [English16]
$cenumFromThenTo :: English16 -> English16 -> English16 -> [English16]
enumFromThenTo :: English16 -> English16 -> English16 -> [English16]
Enum, English16
English16 -> English16 -> Bounded English16
forall a. a -> a -> Bounded a
$cminBound :: English16
minBound :: English16
$cmaxBound :: English16
maxBound :: English16
Bounded)

instance Locator English16 where
    locatorToDigit :: English16 -> Char
    locatorToDigit :: English16 -> Char
locatorToDigit English16
x =
        case English16
x of
            English16
Zero -> Char
'0'
            English16
One -> Char
'1'
            English16
Two -> Char
'2'
            English16
Charlie -> Char
'C'
            English16
Four -> Char
'4'
            English16
Foxtrot -> Char
'F'
            English16
Hotel -> Char
'H'
            English16
Seven -> Char
'7'
            English16
Eight -> Char
'8'
            English16
Nine -> Char
'9'
            English16
Kilo -> Char
'K'
            English16
Lima -> Char
'L'
            English16
Mike -> Char
'M'
            English16
Romeo -> Char
'R'
            English16
XRay -> Char
'X'
            English16
Yankee -> Char
'Y'

    digitToLocator :: Char -> English16
    digitToLocator :: Char -> English16
digitToLocator Char
c =
        case Char
c of
            Char
'0' -> English16
Zero
            Char
'1' -> English16
One
            Char
'2' -> English16
Two
            Char
'C' -> English16
Charlie
            Char
'4' -> English16
Four
            Char
'F' -> English16
Foxtrot
            Char
'H' -> English16
Hotel
            Char
'7' -> English16
Seven
            Char
'8' -> English16
Eight
            Char
'9' -> English16
Nine
            Char
'K' -> English16
Kilo
            Char
'L' -> English16
Lima
            Char
'M' -> English16
Mike
            Char
'R' -> English16
Romeo
            Char
'X' -> English16
XRay
            Char
'Y' -> English16
Yankee
            Char
_ -> [Char] -> English16
forall a. HasCallStack => [Char] -> a
error [Char]
"Illegal digit"

instance Show English16 where
    show :: English16 -> [Char]
show English16
x = [Char
c]
      where
        c :: Char
c = English16 -> Char
forall α. Locator α => α -> Char
locatorToDigit English16
x

--

{- |
Given a number, convert it to a string in the English16 base 16 symbol
alphabet. You can use this as a replacement for the standard \'0\'-\'9\'
\'A\'-\'F\' symbols traditionally used to express hexidemimal, though really
the fact that we came up with 16 total unique symbols was a nice
co-incidence, not a requirement.
-}
toEnglish16 :: Int -> String
toEnglish16 :: Int -> [Char]
toEnglish16 Int
x =
    Int -> (Int -> Char) -> Int -> ShowS
forall a. Integral a => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
16 (English16 -> Int -> Char
forall α. Locator α => α -> Int -> Char
represent English16
Yankee) Int
x [Char]
""

--

{- |
Represent a number in English16a format. This uses the Locator16 symbol
set, and additionally specifies that no symbol can be repeated. The /a/ in
Locator16a represents that this transformation is done on the cheap; when
converting if we end up with \'9\' \'9\' we simply pick the subsequent digit
in the enum, in this case getting you \'9\' \'K\'.

Note that the transformation is /not/ reversible. A number like @4369@
(which is @0x1111@, incidentally) encodes as @12C4@. So do @4370@, @4371@,
and @4372@. The point is not uniqueness, but readibility in adverse
conditions. So while you can count locators, they don't map continuously to
base10 integers.

The first argument is the number of digits you'd like in the locator; if the
number passed in is less than 16^limit, then the result will be padded.

>>> toEnglish16a 6 4369
12C40F
-}
toEnglish16a :: Int -> Int -> String
toEnglish16a :: Int -> Int -> [Char]
toEnglish16a Int
limit Int
n
    | Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16 = ShowS
forall a. HasCallStack => [Char] -> a
error [Char]
"Can only request a maximum of 16 English16a characters, not " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
limit)
    | Bool
otherwise =
        let n' :: Int
n' = Int -> Int
forall a. Num a => a -> a
abs Int
n
            ls :: [English16]
ls = Int -> [English16] -> [English16]
forall α. Locator α => Int -> [α] -> [α]
convert Int
n' (Int -> English16 -> [English16]
forall a. Int -> a -> [a]
replicate Int
limit English16
forall a. Bounded a => a
minBound) :: [English16]
            (Set English16
_, [English16]
us) = (Set English16 -> English16 -> (Set English16, English16))
-> Set English16 -> [English16] -> (Set English16, [English16])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set English16 -> English16 -> (Set English16, English16)
forall α. Locator α => Set α -> α -> (Set α, α)
uniq Set English16
forall a. Set a
Set.empty [English16]
ls
         in (English16 -> Char) -> [English16] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map English16 -> Char
forall α. Locator α => α -> Char
locatorToDigit (Int -> [English16] -> [English16]
forall a. Int -> [a] -> [a]
take Int
limit [English16]
us)
  where
    convert :: Locator α => Int -> [α] -> [α]
    convert :: forall α. Locator α => Int -> [α] -> [α]
convert Int
0 [α]
xs = [α]
xs
    convert Int
i [α]
xs =
        let (Int
d, Int
r) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
i Int
16
            x :: α
x = Int -> α
forall a. Enum a => Int -> a
toEnum Int
r
         in Int -> [α] -> [α]
forall α. Locator α => Int -> [α] -> [α]
convert Int
d (α
x α -> [α] -> [α]
forall a. a -> [a] -> [a]
: [α]
xs)

    uniq :: Locator α => Set α -> α -> (Set α, α)
    uniq :: forall α. Locator α => Set α -> α -> (Set α, α)
uniq Set α
s α
x =
        if α -> Set α -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member α
x Set α
s
            then Set α -> α -> (Set α, α)
forall α. Locator α => Set α -> α -> (Set α, α)
uniq Set α
s (α -> α
forall α. Locator α => α -> α
subsequent α
x)
            else (α -> Set α -> Set α
forall a. Ord a => a -> Set a -> Set a
Set.insert α
x Set α
s, α
x)

    subsequent :: Locator α => α -> α
    subsequent :: forall α. Locator α => α -> α
subsequent α
x =
        if α
x α -> α -> Bool
forall a. Eq a => a -> a -> Bool
== α
forall a. Bounded a => a
maxBound
            then α
forall a. Bounded a => a
minBound
            else α -> α
forall a. Enum a => a -> a
succ α
x

--

-- | Given a number encoded in Locator16, convert it back to an integer.
fromEnglish16 :: [Char] -> Int
fromEnglish16 :: [Char] -> Int
fromEnglish16 [Char]
ss =
    (Int -> Char -> Int) -> Int -> [Char] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (English16 -> Int -> Char -> Int
forall α. Locator α => α -> Int -> Char -> Int
multiply English16
Yankee) Int
0 [Char]
ss

--

{- |
Take an arbitrary sequence of bytes, hash it with SHA1, then format as a
short @digits@-long Locator16 string.

>>> hashStringToLocator16a 6 "Hello World"
M48HR0
-}
hashStringToEnglish16a :: Int -> ByteString -> ByteString
hashStringToEnglish16a :: Int -> ByteString -> ByteString
hashStringToEnglish16a Int
limit ByteString
s' =
    let s :: [Char]
s = ByteString -> [Char]
S.unpack ByteString
s'
        n :: Int
n = [Char] -> Int
digest [Char]
s -- SHA1 hash
        r :: Int
r = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
n Int
upperBound -- trim to specified number of base 16 chars
        x :: [Char]
x = Int -> Int -> [Char]
toLocator16a Int
limit Int
r -- express in locator16
        b' :: ByteString
b' = [Char] -> ByteString
S.pack [Char]
x
     in ByteString
b'
  where
    upperBound :: Int
upperBound = Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
limit

toLocator16 :: Int -> String
toLocator16 :: Int -> [Char]
toLocator16 = Int -> [Char]
toEnglish16
{-# DEPRECATED toLocator16 "Use toEnglish16 instead" #-}

toLocator16a :: Int -> Int -> String
toLocator16a :: Int -> Int -> [Char]
toLocator16a = Int -> Int -> [Char]
toEnglish16a
{-# DEPRECATED toLocator16a "Use toEnglish16a instead" #-}

fromLocator16 :: [Char] -> Int
fromLocator16 :: [Char] -> Int
fromLocator16 = [Char] -> Int
fromEnglish16
{-# DEPRECATED fromLocator16 "Use fromEnglish16 instead" #-}

hashStringToLocator16a :: Int -> ByteString -> ByteString
hashStringToLocator16a :: Int -> ByteString -> ByteString
hashStringToLocator16a = Int -> ByteString -> ByteString
hashStringToEnglish16a
{-# DEPRECATED hashStringToLocator16a "Use hashStringToEnglish16a instead" #-}