45
\$\begingroup\$

I find sometimes it is useful to capture the notion of invertible functions.

The idea is that if two functions f :: a -> b and g :: b -> a are the inverse function of each other, and if there is another function h :: b -> b, then h can also work on values of type a.

Moreover, if there f' and g' are another pair of functions that are the inverse function of each other, (f,g) and (f',g') can actually be composed to (f' . f, g . g') and the invertibility still holds.

The following is my attempt to implement this in Haskell, and I'm wondering if an existing library can do the same thing (or even more general thing) for me. Also advice and comments about my code are appreciated.

Implementation

First I use records to store two functions:

data Invertible a b = Invertible
    { into :: a -> b
    , back :: b -> a
    }

into means "convert a into b" while back means "convert b back to a".

And then few helper functions:

selfInv :: (a -> a) -> Invertible a a
selfInv f = Invertible f f

flipInv :: Invertible a b -> Invertible b a
flipInv (Invertible f g) = Invertible g f

borrow :: Invertible a b -> (b -> b) -> a -> a
borrow (Invertible fIn fOut) g = fOut . g . fIn

liftInv :: (Functor f) => Invertible a b -> Invertible (f a) (f b)
liftInv (Invertible a b) = Invertible (fmap a) (fmap b)

In the above code borrow will use the pair of functions to make its last argument g available to values of type a. And changing borrow f to borrow (flipInv f) will make g available to values of type b. Therefore borrow captures my initial idea of making a function of type b -> b available for values of a if a and b can be converted to each other.

In addition, Invertible forms a monoid-like structure, I use rappend and rempty to suggest a similiarity between it and Monoid:

rempty :: Invertible a a
rempty = selfInv id

rappend :: Invertible a b
         -> Invertible b c
         -> Invertible a c
(Invertible f1 g1) `rappend` (Invertible f2 g2) =
    Invertible (f2 . f1) (g1 . g2)

Examples

Here I have two examples to demonstrate that Invertible might be useful.

Data Encryption

It is natural that Invertible can be used under scenario of symmetric encryption. Invertible (encrypt key) (decrypt key) might be one instance if:

encrypt :: Key -> PlainText -> CipherText
decrypt :: Key -> CipherText -> PlainText

To simplify a little, I make an example of Caesar cipher and assume that plain text contains only uppercase letters:

-- constructor should be invisible from outside
newtype OnlyUpper a = OnlyUpper
    { getOU :: [a]
    } deriving (Eq, Ord, Show, Functor)

ouAsList :: Invertible (OnlyUpper a) [a]
ouAsList = Invertible getOU OnlyUpper

onlyUpper :: String -> OnlyUpper Char
onlyUpper = OnlyUpper . filter isAsciiUpper

upperAsOrd :: Invertible Char Int
upperAsOrd = Invertible ord' chr'
    where
        ord' x = ord x - ord 'A'
        chr' x = chr (x + ord 'A')

And Caesar Cipher is basically doing some modular arithmetic:

modShift :: Int -> Int -> Invertible Int Int
modShift base offset = Invertible f g
    where
        f x = (x + offset) `mod` base
        g y = (y + (base - offset)) `mod` base

caesarShift :: Invertible Int Int
caesarShift = modShift 26 4

caesarCipher :: Invertible (OnlyUpper Char) (OnlyUpper Char)
caesarCipher = liftInv (upperAsOrd
                        -- Char <-> Int
                        `rappend` caesarShift
                        -- Int <-> Int
                        `rappend` flipInv upperAsOrd)
                        -- Int <-> Char

One way to use Invertible is just using its into and back as encrypt and decrypt, and Invertible also gives you the power of manipulating encrypyed data as if it was plain text:

exampleCaesar :: IO ()
exampleCaesar = do
    let encF = into caesarCipher
        decF = back caesarCipher
        encrypted = encF (onlyUpper "THEQUICKBROWNFOX")
        decrypted = decF encrypted
        encrypted' = borrow (flipInv caesarCipher
                             `rappend` ouAsList) (++ "JUMPSOVERTHELAZYDOG") encrypted
        decrypted' = decF encrypted'

    print encrypted
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSB"}
    print decrypted
    -- OnlyUpper {getOU = "THEQUICKBROWNFOX"}

    print encrypted'
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSBNYQTWSZIVXLIPEDCHSK"}
    print decrypted'
    -- OnlyUpper {getOU = "THEQUICKBROWNFOXJUMPSOVERTHELAZYDOG"}

Matrix manipulation

Sometimes it's convenient to write some code that manipulates matrices using Invertible.

Say there is a list of type [Int] in which 0 stands for an empty cell, and we want every non-zero element move to their leftmost possible position while preserving the order:

compactLeft :: [Int] -> [Int]
compactLeft xs = nonZeros ++ replicate (((-) `on` length) xs nonZeros) 0
    where nonZeros = filter (/= 0) xs

Now consider 2D matrices, we want to "gravitize" the matrix so that every non-zero element in it falls to {left,right,up,down}-most possible position while preserving the order.

data Dir = DU | DD | DL | DR deriving (Eq, Ord, Enum, Show, Bounded)
gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = borrow invertible (map compactLeft)
    where mirrorI = selfInv (map reverse)
          diagonalI = selfInv transpose
          invertible = case dir of
            DL -> rempty
            DR -> mirrorI
            DU -> diagonalI
            DD -> diagonalI `rappend` mirrorI

here Invertible comes into play by the observation that transpose and map reverse are all invertible (moreover, they are inverse functions of themselves). So that we can transform matrices and pretend the problem is only "gravitize to the left".

Here is one example:

print2DMat :: (Show a) => [[a]] -> IO ()
print2DMat mat = do
    putStrLn "Matrix: ["
    mapM_ print mat
    putStrLn "]"

exampleMatGravitize :: IO ()
exampleMatGravitize = do
    let mat = [ [1,0,2,0]
              , [0,3,4,0]
              , [0,0,0,5]
              ]
    print2DMat mat

    let showExample d = do
            putStrLn $ "Direction: " ++ show d
            print2DMat $ gravitizeMat d mat

    mapM_ showExample [minBound .. maxBound]

And the result will be:

Matrix: [
[1,0,2,0]
[0,3,4,0]
[0,0,0,5]
]
Direction: DU
Matrix: [
[1,3,2,5]
[0,0,4,0]
[0,0,0,0]
]
Direction: DD
Matrix: [
[0,0,0,0]
[0,0,2,0]
[1,3,4,5]
]
Direction: DL
Matrix: [
[1,2,0,0]
[3,4,0,0]
[5,0,0,0]
]
Direction: DR
Matrix: [
[0,0,1,2]
[0,0,3,4]
[0,0,0,5]
]

Complete code

Since code review's policy requires complete code (you can also find it from my gist):

{-# LANGUAGE DeriveFunctor #-}
import Data.Char
import Data.Function
import Data.List

data Invertible a b = Invertible
    { into :: a -> b
    , back :: b -> a
    }

selfInv :: (a -> a) -> Invertible a a
selfInv f = Invertible f f

rempty :: Invertible a a
rempty = selfInv id

rappend :: Invertible a b
         -> Invertible b c
         -> Invertible a c
(Invertible f1 g1) `rappend` (Invertible f2 g2) =
    Invertible (f2 . f1) (g1 . g2)

flipInv :: Invertible a b -> Invertible b a
flipInv (Invertible f g) = Invertible g f

borrow :: Invertible a b -> (b -> b) -> a -> a
borrow (Invertible fIn fOut) g = fOut . g . fIn

liftInv :: (Functor f) => Invertible a b -> Invertible (f a) (f b)
liftInv (Invertible a b) = Invertible (fmap a) (fmap b)

-- examples
-- constructor should be invisible from outside
newtype OnlyUpper a = OnlyUpper
    { getOU :: [a]
    } deriving (Eq, Ord, Show, Functor)

ouAsList :: Invertible (OnlyUpper a) [a]
ouAsList = Invertible getOU OnlyUpper

onlyUpper :: String -> OnlyUpper Char
onlyUpper = OnlyUpper . filter isAsciiUpper

upperAsOrd :: Invertible Char Int
upperAsOrd = Invertible ord' chr'
    where
        ord' x = ord x - ord 'A'
        chr' x = chr (x + ord 'A')

modShift :: Int -> Int -> Invertible Int Int
modShift base offset = Invertible f g
    where
        f x = (x + offset) `mod` base
        g y = (y + (base - offset)) `mod` base

caesarShift :: Invertible Int Int
caesarShift = modShift 26 4

caesarCipher :: Invertible (OnlyUpper Char) (OnlyUpper Char)
caesarCipher = liftInv (upperAsOrd
                        -- Char <-> Int
                        `rappend` caesarShift
                        -- Int <-> Int
                        `rappend` flipInv upperAsOrd)
                        -- Int <-> Char

exampleCaesar :: IO ()
exampleCaesar = do
    let encF = into caesarCipher
        decF = back caesarCipher
        encrypted = encF (onlyUpper "THEQUICKBROWNFOX")
        decrypted = decF encrypted
        encrypted' = borrow (flipInv caesarCipher
                             `rappend` ouAsList) (++ "JUMPSOVERTHELAZYDOG") encrypted
        decrypted' = decF encrypted'

    print encrypted
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSB"}
    print decrypted
    -- OnlyUpper {getOU = "THEQUICKBROWNFOX"}

    print encrypted'
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSBNYQTWSZIVXLIPEDCHSK"}
    print decrypted'
    -- OnlyUpper {getOU = "THEQUICKBROWNFOXJUMPSOVERTHELAZYDOG"}


-- gravitize
compactLeft :: [Int] -> [Int]
compactLeft xs = nonZeros ++ replicate (((-) `on` length) xs nonZeros) 0
    where nonZeros = filter (/= 0) xs

data Dir = DU | DD | DL | DR deriving (Eq, Ord, Enum, Show, Bounded)

gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = borrow invertible (map compactLeft)
    where mirrorI = selfInv (map reverse)
          diagonalI = selfInv transpose
          invertible = case dir of
            DL -> rempty
            DR -> mirrorI
            DU -> diagonalI
            DD -> diagonalI `rappend` mirrorI

print2DMat :: (Show a) => [[a]] -> IO ()
print2DMat mat = do
    putStrLn "Matrix: ["
    mapM_ print mat
    putStrLn "]"

exampleMatGravitize :: IO ()
exampleMatGravitize = do
    let mat = [ [1,0,2,0]
              , [0,3,4,0]
              , [0,0,0,5]
              ]
    print2DMat mat

    let showExample d = do
            putStrLn $ "Direction: " ++ show d
            print2DMat $ gravitizeMat d mat

    mapM_ showExample [minBound .. maxBound]

main :: IO ()
main = do
    exampleCaesar
    exampleMatGravitize
\$\endgroup\$
  • 11
    \$\begingroup\$ By no means I claim that they theoretically fit here, but somehow, I suspect that by using lens isomorphisms, you may be able to abstract much of what you are trying to do here. \$\endgroup\$ – Danny Navarro Mar 17 '14 at 8:49
  • 2
    \$\begingroup\$ rempty and rappend form a Category instance. \$\endgroup\$ – David Mar 20 '14 at 1:55
  • 3
    \$\begingroup\$ hackage.haskell.org/package/TypeCompose-0.6.4/docs/… \$\endgroup\$ – Zeta Mar 24 '14 at 14:31
  • \$\begingroup\$ The 4th revision of your gist illustrates using lens isomorphisms as per the suggestion from @DannyNavarro. I'd suggest posting that as the answer. In combination with your original code, both show a good way of working with a pair of invertible functions. Your original code is nice because it is self contained, and then after that, the lens code is easier to understand. \$\endgroup\$ – figmentum Oct 5 '14 at 23:10
  • 1
    \$\begingroup\$ Not sufficient for an answer, but in modShift, g can be simplified to g y = (y - offset) `mod` base. \$\endgroup\$ – mjolka Oct 17 '14 at 2:25
10
+100
\$\begingroup\$

Naming:

There are a lot of names I'd change. Some of them matter more than others (local names in a let are not that big a deal even if they're terrible, but a name for a widely used function should be suggestive, if possible). Some of them I'm more sure of than others.

I'd change borrow to within. The old name isn't bad, but I think the new one is suggestive in the right way. I'd change Invertible to Transform, since an invertible function is just the one function, and we're talking about a pair of related functions. Bijection is the mathematical name for it, and it would make a good name too, but it seems (to me at least) to suggest that the domain and range are the entire input and output types, and not every function we'd want to use with this fits that.

I'd change the local invertible to transform to match, so borrow invertible (map compactLeft) becomes within transform (map compactLeft).

I'd change mirrorI -> mirror and diagonalI -> diagonal; the I doesn't add anything, it just looks as if you're using roman numerals at first. I'd also change DD, DL, DR, DU -> DOWN, LEFT, RIGHT, UP, as it's just clearer.

The Inv suffix doesn't help. Not all of the functions have it, and it isn't spelled out enough to be suggestive. Also, if we change it from Invertible, it no longer makes sense. So, selfInv -> involution, liftInv -> lift, flipInv -> backwards. An involution is the mathematical name for a function that is its own inverse (and if you didn't know that, don't feel bad, I was only guessing there might be a name for it until I googled it). flip is already taken, and I think backwards is more suggestive (reverse would have been nice too, but it's also taken). lift isn't taken as far as I know, but it's the sort of thing that seems like it might be. If so, liftT or liftTr might work (or liftB if we're using Bijection).

I'd change fIn, fOut -> f, f'. Using f' doesn't quite say "I'm an inverse", but it suggests it somewhat if we know how Transform is defined/meant to be used.

I can see why you named rempty and rappend as you did, but the names made me (and would probably make other people) want to try to make it a Monoid instance, and that doesn't work. I'd change rempty -> idT, rappend -> >>>. >>> matches the Category class, and is nicely intuitive (and doesn't need backquotes). I'm not really sure about idT, and it could probably be improved, but it still seems a bit nicer than rempty to me.

I'd also change into, back -> fwd, rev, but I don't have much justification here. It seems a little more suggestive of a thing that can go both ways, instead of a box that you can go into and come out of, but can't be flipped inside out. The original names here are good.

All Namechanges in One Spot:

DD, DL, DR, DU -> DOWN, LEFT, RIGHT, UP

Invertible -> Transform

invertible -> transform

mirrorI -> mirror

diagonalI -> diagonal

selfInv -> involution

liftInv -> lift

flipInv -> backwards

into, back -> fwd, rev

fIn, fOut -> f, f'

rempty -> idT

rappend -> >>>

Instances that don't work:

Monad, Applicative, and Functor don't work because fmap :: (a -> b) -> f a -> f b and that doesn't fit.

Monoid doesn't work because mappend :: a -> a -> a, and our composition takes 2 different types and returns yet another different type.

Arrow seems like it should work at first, but arr :: (b -> c) -> a b c. The types match nicely, but we'd need a way that makes sense to take an arbitrary function and find its inverse. Functions and Arrows go one way, but we want to go both ways.

Category fits perfectly, but when I tried to get it to work, the compiler complained about all the uses of . in the program being ambiguous. There may be a way to make it work, but looking at Control.Category, the gains were almost nonexistent, so I abandoned the attempt. The interface (>>> and <<< for forward and backward composition), was nice, though, so I kept it.

Instances that do work:

None?

Non-Naming Changes:

The suggestion in the comments by mjolka is correct, and the resulting code:

modShift base offset = Transform f g
    where
        f x = (x + offset) `mod` base
        g y = (y - offset) `mod` base

looks nicer and is clearer.

This:

compactLeft xs = nonZeros ++ replicate (((-) `on` length) xs nonZeros) 0
    where nonZeros = filter (/= 0) xs

is a bit ugly, and can be simplified to this:

compactLeft xs = take (length xs) $ nonZeros ++ repeat 0
    where nonZeros = filter (/= 0) xs

I'd introduce a new function that abstracts the pattern in the parentheses in

caesarCipher = liftInv (upperAsOrd
                        -- Char <-> Int
                        `rappend` caesarShift
                        -- Int <-> Int
                        `rappend` flipInv upperAsOrd)
                        -- Int <-> Char

making my suggested namechanges, it becomes:

caesarCipher = lift (upperAsOrd >>> caesarShift >>> backwards upperAsOrd)

and the new function I'd suggest is:

nest :: Transform a b -> Transform b b -> Transform a a
nest ab bb = backwards ab <<< bb <<< ab

The reason I'm using <<< is that it composes in the same order as ., and this way, the nest function looks very similar to within (the function formerly known as borrow), which its type signature strongly resembles.

Here they (both) are, with type signatures:

within :: Transform a b -> (b -> b) -> a -> a
within (Transform f f') g = f' . g . f

nest :: Transform a b -> Transform b b -> Transform a a
nest ab bb = backwards ab <<< bb <<< ab

I can't be sure, based on only one example, that this will end up commonly used, but it would make some sense if it did, based on the fact that it showed up once in a small set of examples and on the type signature resemblance. Also, nest may not be the best possible name, but it seems reasonable to me, and I haven't been able to think of a better one.

Using nest, we can rewrite caesarCipher to be even shorter:

caesarCipher = lift $ nest upperAsOrd caesarShift

We also used $ to avoid having to wrap parentheses around the nest.

gravitizeMat doesn't change, except for namechanges, but it is more readable.

Before:

data Dir = DU | DD | DL | DR deriving (Eq, Ord, Enum, Show, Bounded)
gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = borrow invertible (map compactLeft)
    where mirrorI = selfInv (map reverse)
          diagonalI = selfInv transpose
          invertible = case dir of
            DL -> rempty
            DR -> mirrorI
            DU -> diagonalI
            DD -> diagonalI `rappend` mirrorI

After:

data Dir = UP | DOWN | LEFT | RIGHT deriving (Eq, Ord, Enum, Show, Bounded)
gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = within transform (map compactLeft)
    where mirror = involution (map reverse)
          diagonal = involution transpose
          transform = case dir of
            LEFT  -> idT
            RIGHT -> mirror
            UP    -> diagonal
            DOWN  -> diagonal >>> mirror

exampleCaesar doesn't change much, but this part looks nicer.

Before:

    encrypted' = borrow (flipInv caesarCipher
                         `rappend` ouAsList) (++ "JUMPSOVERTHELAZYDOG") encrypted

After:

    encrypted' = within (backwards caesarCipher >>> ouAsList)
                        (++ "JUMPSOVERTHELAZYDOG") encrypted

Here I think the suggestion for backwards really shines, since the forward direction of caesarCipher is encryption and the reverse direction is decryption, but here, we're trying to mess with the plaintext of an encryptedtext, which is using it backwards.

Overall:

It was nice code. There were several names that could be made more suggestive, and a couple of places where complex expressions could be simplified, but overall, it was pleasant to read, and an interesting idea as well.

Complete Modified Code:

{-# LANGUAGE DeriveFunctor #-}
import Data.Char
import Data.Function
import Data.List

data Transform a b = Transform
    { fwd :: a -> b
    , rev :: b -> a
    }

involution :: (a -> a) -> Transform a a
involution f = Transform f f

idT :: Transform a a
idT = involution id

(>>>) :: Transform a b -> Transform b c -> Transform a c
(Transform f1 g1) >>> (Transform f2 g2) =
    Transform (f2 . f1) (g1 . g2)

(<<<) :: Transform b c -> Transform a b -> Transform a c
f <<< g = g >>> f

backwards :: Transform a b -> Transform b a
backwards (Transform f g) = Transform g f

within :: Transform a b -> (b -> b) -> a -> a
within (Transform f f') g = f' . g . f

nest :: Transform a b -> Transform b b -> Transform a a
nest ab bb = backwards ab <<< bb <<< ab

lift :: (Functor f) => Transform a b -> Transform (f a) (f b)
lift (Transform f g) = Transform (fmap f) (fmap g)

-- examples
-- constructor should be invisible from outside
newtype OnlyUpper a = OnlyUpper
    { getOU :: [a]
    } deriving (Eq, Ord, Show, Functor)

ouAsList :: Transform (OnlyUpper a) [a]
ouAsList = Transform getOU OnlyUpper

onlyUpper :: String -> OnlyUpper Char
onlyUpper = OnlyUpper . filter isAsciiUpper

upperAsOrd :: Transform Char Int
upperAsOrd = Transform ord' chr'
    where
        ord' x = ord x - ord 'A'
        chr' x = chr (x + ord 'A')

modShift :: Int -> Int -> Transform Int Int
modShift base offset = Transform f g
    where
        f x = (x + offset) `mod` base
        g y = (y - offset) `mod` base

caesarShift :: Transform Int Int
caesarShift = modShift 26 4

caesarCipher :: Transform (OnlyUpper Char) (OnlyUpper Char)
caesarCipher = lift $ nest upperAsOrd caesarShift

exampleCaesar :: IO ()
exampleCaesar = do
    let encF = fwd caesarCipher
        decF = rev caesarCipher
        encrypted = encF (onlyUpper "THEQUICKBROWNFOX")
        decrypted = decF encrypted
        encrypted' = within (backwards caesarCipher >>> ouAsList)
                            (++ "JUMPSOVERTHELAZYDOG") encrypted
        decrypted' = decF encrypted'

    print encrypted
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSB"}
    print decrypted
    -- OnlyUpper {getOU = "THEQUICKBROWNFOX"}

    print encrypted'
    -- OnlyUpper {getOU = "XLIUYMGOFVSARJSBNYQTWSZIVXLIPEDCHSK"}
    print decrypted'
    -- OnlyUpper {getOU = "THEQUICKBROWNFOXJUMPSOVERTHELAZYDOG"}


-- gravitize
compactLeft :: [Int] -> [Int]
compactLeft xs = take (length xs) $ nonZeros ++ repeat 0
    where nonZeros = filter (/= 0) xs

data Dir = UP | DOWN | LEFT | RIGHT deriving (Eq, Ord, Enum, Show, Bounded)

gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = within transform (map compactLeft)
    where mirror = involution (map reverse)
          diagonal = involution transpose
          transform = case dir of
            LEFT  -> idT
            RIGHT -> mirror
            UP    -> diagonal
            DOWN  -> diagonal >>> mirror

print2DMat :: (Show a) => [[a]] -> IO ()
print2DMat mat = do
    putStrLn "Matrix: ["
    mapM_ print mat
    putStrLn "]"

exampleMatGravitize :: IO ()
exampleMatGravitize = do
    let mat = [ [1,0,2,0]
              , [0,3,4,0]
              , [0,0,0,5]
              ]
    print2DMat mat

    let showExample d = do
            putStrLn $ "Direction: " ++ show d
            print2DMat $ gravitizeMat d mat

    mapM_ showExample [minBound .. maxBound]

main :: IO ()
main = do
    exampleCaesar
    exampleMatGravitize
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.