public
Created

  • Download Gist
Decode.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
{-# 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
-}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.