thedeemon's June FP(FP) contest entry

gistfile1.hs

import Data.List
import Data.Maybe
import Data.Char
import qualified Data.Map as Map
import qualified Data.Set as Set

type Var = Char

sets :: [[Var]]
sets = [ ['i', 'R', 'T', 'r'],
   ['R', ',', 'p', 'T', ' ', 'O', 's', 't'],
   ['p', '!', 't', 'm'],
   ['r', 'T', ' ', 'O', 'o', '-'],
   ['O', 'o', 's', 't', 'm', 'y'] 
  ]

diff :: (Eq a) => [a] -> [a] -> ([a], [a])
diff xs ys = (xs \\ ys, ys \\ xs) 

swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)

type LP = ([Var],[Var])
equalities :: [LP]
equalities = nubBy (\a b -> a == b || swap a == b) $ filter (/= ([],[])) [diff a b | a <- sets, b <- sets]

varseq :: [Var]
varseq = ['!', 'O', 'o', 'p', 'y', 'R', 'T', 's', 't', ' ', '-', 'i', 'm', ',', 'r' ]

type Range = (Int, Int)
data Env = Env { binds :: Map.Map Var Int, possible :: Range, used :: Set.Set Int }

instance Show Env where
  show e = show (binds e) ++ " " ++ show (possible e)

range :: Env -> Var -> Range
range e v = case Map.lookup v (binds e) of
  Just x  -> (x,x)
  Nothing -> possible e

addRange :: Range -> Range -> Range
addRange (a,b) (c,d) = (a+c, b+d)

evalSum :: Env -> [Var] -> Range
evalSum e vars = foldl (\r v -> addRange r (range e v)) (0,0) vars

addHypo :: Env -> Var -> Int -> Env
addHypo e v x = 
  let bs = Map.insert v x (binds e) in
  let used' = Set.insert x $ used e in
  let (mn, mx) = possible e in
  let searchIn = \pool -> fromMaybe 0 $ find (\a -> Set.notMember a used') pool in
  let low = searchIn [mn..15] in
  let hi  = searchIn [mx, mx-1 .. 1] in 
  Env bs (low, hi) used'

ee :: Env
ee = Env Map.empty (1,15) Set.empty

inters :: Range -> Range -> Bool
inters (a,b) (c,d) = if a > d || b < c then False else True

checkEnv :: Env -> Bool
checkEnv e = loop equalities where
  loop [] = True
  loop ((l,r):es) = if inters (evalSum e l) (evalSum e r) then loop es else False

search :: Env -> [Var] -> Int -> [Env] -> [Env]
search env []             _ rsl = env : rsl
search env (var:leftvars) 0 rsl = rsl
search env (var:leftvars) x rsl =
  if Set.member x (used env) 
    then search env (var:leftvars) (x-1) rsl
    else
     let hyp = addHypo env var x in
     let res = if checkEnv hyp then search hyp leftvars (snd $ possible hyp) rsl else rsl in
     search env (var:leftvars) (x-1) res

showAnswer :: Env -> String
showAnswer e = map snd $ sort $ map swap $ Map.assocs $ binds e

mywords :: [String]
mywords = ["mir", "sport", "ty"]

good :: Env -> Bool
good e = all (\w -> isInfixOf w s) mywords where
  s = map toLower $ showAnswer e

main :: IO ()
main = print $ map (\e -> (showAnswer e, e)) $ filter good ans where
  ans = search ee varseq 15 []

-- outputs:
--[("O spoRT,ty-mir!", fromList [(' ',2),('!',15),(',',8),('-',11),('O',1),('R',6),('T',7),
-- ('i',13),('m',12),('o',5),('p',4),('r',14),('s',3),('t',9),('y',10)] (0,0))]