Decode.hs

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
{-
tree they help

2854 8531 8422 2955

t= r= e= h= y= l= p=
-}
module Decode where
{-
ghci:

-}
import Control.Unification
import Control.Unification.IntVar
import Control.Monad.Logic
import Data.Foldable
import Data.Functor.Fixedpoint
import Data.List
import Data.Traversable

-- let's revise type fixing:
data IntListF r = Nil | Cons Int r
type IntList = Fix IntListF

-- now:

data TermF r = C Char
             | L [r]
             | P r r
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

type Term = Fix TermF

instance Unifiable TermF where
  zipMatch (C a) (C b) | a == b    = Just (C a)
  zipMatch (L as) (L bs) | length as == length bs = Just $ L $ zip as bs
  zipMatch (P a1 a2) (P b1 b2) = Just $ P (a1, b1) (a2, b2)
  zipMatch _ _ = Nothing

-- Solver can do unification and backtracking
type Solver a = IntBindingT TermF Logic a

main :: IO ()
main = print $ solve ["tree", "they", "help"] ["2854", "8531", "8422", "2955"]

-- observe tells the logic thing to go and find a solution
solve :: [String] -> [String] -> String
solve ws ds = pretty . observe . evalIntBindingT $ solver (parse ws) (parse ds)

-- runLogic . evalIntBindingT

parse :: [String] -> Term
parse = Fix . L . map parseStr

parseStr :: String -> Term
parseStr = Fix . L . map (Fix . C)

-- here we can use a catamorphism; it takes a data structure and an algebra
-- i.e. a function that goes from bottom (C in our case) to top replacing the type
-- param with result type, "collapsing" (folding) the structure

pretty :: Term -> String
pretty = cata trans

trans :: TermF String -> String
trans (C c)   = [c]
trans (L ss)  = intercalate ", " ss
trans (P a b) = a ++ "= " ++ b

solver :: Term -> Term -> Solver Term
solver = undefined -- TODO!


{-
slowDecode :: [String] -> [String] -> [[(Char, Char)]]
slowDecode decoded encoded =
  filter (encodesCorrectly decoded encoded) allEncodings

encodesCorrectly :: [String] -> [String] -> [(Char, Char)] -> Bool
encodesCorrectly = error

allEncodings :: [[(Char, Char)]]
allEncodings = error
-}