{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
-- | Implementation of proquints according to https://arxiv.org/html/0901.4016
module Proquint
( word16ToProquint
, proquintToWord16
) where

import Control.Applicative (liftA2)
import Data.Bits ((.&.), (.|.), unsafeShiftR, (!<<.))
import Data.Word (Word16)
import Data.Ix (inRange)

import Data.Array.Unboxed (UArray, listArray, accumArray, (!), bounds)

-- Bitmasks
-----------

-- Consonants define 4 bits
cMask :: Word16
cMask :: Word16
cMask = Word16
0b0000000000001111
-- Vowels define 2 bits
vMask :: Word16
vMask :: Word16
vMask = Word16
0b0000000000000011

-- Lookup tables
----------------

-- Maps from right-shifted portions of 'Word16' to their 'Char' representations
consonants :: UArray Word16 Char
consonants :: UArray Word16 Char
consonants = (Word16, Word16) -> [Char] -> UArray Word16 Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Word16
0,Word16
15) [Char]
"bdfghjklmnprstvz"
vowels :: UArray Word16 Char
vowels :: UArray Word16 Char
vowels = (Word16, Word16) -> [Char] -> UArray Word16 Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Word16
0,Word16
3) [Char]
"aiou"

-- Inverse maps, using Nil for unused letters in the range, such as 'c' and 'e'
pattern Nil :: Word16
pattern $mNil :: forall {r}. Word16 -> ((# #) -> r) -> ((# #) -> r) -> r
$bNil :: Word16
Nil = 0b1111111111111111
consonants' :: UArray Char Word16
consonants' :: UArray Char Word16
consonants' = (Word16 -> Word16 -> Word16)
-> Word16 -> (Char, Char) -> [(Char, Word16)] -> UArray Char Word16
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray (\Word16
_ Word16
e -> Word16
e) Word16
Nil (Char
'b', Char
'z') ([(Char, Word16)] -> UArray Char Word16)
-> [(Char, Word16)] -> UArray Char Word16
forall a b. (a -> b) -> a -> b
$ (\Word16
i -> (UArray Word16 Char
consonants UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16
i, Word16
i)) (Word16 -> (Char, Word16)) -> [Word16] -> [(Char, Word16)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word16
0..Word16
15]
vowels' :: UArray Char Word16
vowels' :: UArray Char Word16
vowels' = (Word16 -> Word16 -> Word16)
-> Word16 -> (Char, Char) -> [(Char, Word16)] -> UArray Char Word16
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray (\Word16
_ Word16
e -> Word16
e) Word16
Nil (Char
'a', Char
'u') ([(Char, Word16)] -> UArray Char Word16)
-> [(Char, Word16)] -> UArray Char Word16
forall a b. (a -> b) -> a -> b
$ (\Word16
i -> (UArray Word16 Char
vowels UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16
i, Word16
i)) (Word16 -> (Char, Word16)) -> [Word16] -> [(Char, Word16)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word16
0..Word16
3]

-- Reverse lookup, from character to the bits it represents
revLookup :: UArray Char Word16 -> Char -> Maybe Word16
revLookup :: UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
a Char
i | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (UArray Char Word16 -> (Char, Char)
forall i. Ix i => UArray i Word16 -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Char Word16
a) Char
i = case UArray Char Word16
a UArray Char Word16 -> Char -> Word16
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Char
i of
                                         Word16
Nil -> Maybe Word16
forall a. Maybe a
Nothing
                                         Word16
w -> Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
w
              | Bool
otherwise = Maybe Word16
forall a. Maybe a
Nothing

-- Conversion
-------------

-- | Convert a 16-bit number to its proquint representation
--
-- >>> word16ToProquint 42659
-- "pipog"
word16ToProquint :: Word16 -> String
word16ToProquint :: Word16 -> [Char]
word16ToProquint Word16
word = [Char
c1,Char
v1,Char
c2,Char
v2,Char
c3]
  where
    c1 :: Char
c1 = UArray Word16 Char
consonants UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
cMask Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
unsafeShiftR Word16
word Int
12)
    v1 :: Char
v1 = UArray Word16 Char
vowels     UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
vMask Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
unsafeShiftR Word16
word Int
10)
    c2 :: Char
c2 = UArray Word16 Char
consonants UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
cMask Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
unsafeShiftR Word16
word Int
6 )
    v2 :: Char
v2 = UArray Word16 Char
vowels     UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
vMask Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
unsafeShiftR Word16
word Int
4 )
    c3 :: Char
c3 = UArray Word16 Char
consonants UArray Word16 Char -> Word16 -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
cMask Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&.              Word16
word   )

-- | Convert a proquint representation back into a 16-bit number, if possible
--
-- >>> proquintToWord16 "pipog"
-- Just 42659
-- >>> proquintToWord16 ""
-- Nothing
-- >>> proquintToWord16 "bababab"
-- Nothing
-- >>> proquintToWord16 "cecec"
-- Nothing
proquintToWord16 :: String -> Maybe Word16
proquintToWord16 :: [Char] -> Maybe Word16
proquintToWord16 [Char
c1,Char
v1,Char
c2,Char
v2,Char
c3] = (Maybe Word16 -> Maybe Word16 -> Maybe Word16)
-> Maybe Word16 -> [Maybe Word16] -> Maybe Word16
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Word16 -> Word16 -> Word16)
-> Maybe Word16 -> Maybe Word16 -> Maybe Word16
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
(.|.))
  (UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
consonants' Char
c3)
  [ (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
!<<. Int
12) (Word16 -> Word16) -> Maybe Word16 -> Maybe Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
consonants' Char
c1
  , (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
!<<. Int
10) (Word16 -> Word16) -> Maybe Word16 -> Maybe Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
vowels' Char
v1
  , (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
!<<. Int
6 ) (Word16 -> Word16) -> Maybe Word16 -> Maybe Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
consonants' Char
c2
  , (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
!<<. Int
4 ) (Word16 -> Word16) -> Maybe Word16 -> Maybe Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UArray Char Word16 -> Char -> Maybe Word16
revLookup UArray Char Word16
vowels' Char
v2
  ]
proquintToWord16 [Char]
_ = Maybe Word16
forall a. Maybe a
Nothing