Isomorphism using Lens

gistfile1.hs

{-# LANGUAGE DeriveFunctor, RankNTypes #-}
import Data.Char
import Data.List

import Control.Lens

type Invertible a b = Simple Iso a  b

{- translation table

into = view

back = view . from

selfInv x = iso x x

rempty = selfInv id

rappend = (.)

flipInv = from

borrow = over

liftInv = mapping

-}

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

ouAsList :: Iso (OnlyUpper a) (OnlyUpper a) [a] [a]
ouAsList = iso getOU OnlyUpper

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

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

modShift :: Int -> Int -> Invertible Int Int
modShift base offset = iso 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 = mapping ( upperAsOrd
                        -- Char <-> Int
                        . caesarShift
                        -- Int <-> Int
                        . from upperAsOrd)
                        -- Int <-> Char

exampleCaesar :: IO ()
exampleCaesar = do
    let encF = view caesarCipher
        decF = view (from caesarCipher)
        encrypted = encF (onlyUpper "THEQUICKBROWNFOX")
        decrypted = decF encrypted
        encrypted' = over (from 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 = DU | DD | DL | DR deriving (Eq, Ord, Enum, Show, Bounded)

gravitizeMat :: Dir -> [[Int]] -> [[Int]]
gravitizeMat dir = over isoX (map compactLeft)
    where mirrorI = iso (map reverse) (map reverse)
          diagonalI = iso transpose transpose
          isoX = case dir of
            DL -> id
            DR -> mirrorI
            DU -> diagonalI
            DD -> diagonalI . 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