Lehmer.hs

Lehmer.hs

module Main where

import Data.Array (Array, elems, listArray, (!))
import Data.List (elemIndex, uncons, unfoldr)
import Data.Maybe (mapMaybe)

encodeLehmer :: forall a. (Eq a) => Array Int a -> [a] -> [Int]
encodeLehmer set =
  unfoldr
    ( fmap
        ( \(x, xs) ->
            ( x,
              map
                ( \y ->
                    if y > x
                      then pred y
                      else y
                )
                xs
            )
        )
        . uncons
    )
    . mapMaybe (`elemIndex` ordered)
  where
    ordered = elems set

decodeLehmer :: forall a. Array Int a -> [Int] -> [a]
decodeLehmer set =
  map (set !)
    . foldl (\acc n -> n : map (\m -> if m >= n then m + 1 else m) acc) []
    . reverse

main :: IO ()
main = do
  let set = listArray (0, 6) ['A' .. 'G']
  let permutation = ['B', 'F', 'A', 'G', 'D', 'E', 'C']
  let encoded = encodeLehmer set permutation
  print encoded
  print (decodeLehmer set encoded)