Привет всем!

Впечатлился накануне вот этим постом

Автор: old_lamer
Дата: 15.11.06

и надумал сделать нечто похожее, только на Хаскеле и со словарем побольше. Короче, результат трехдневного труда перед вами

module Main where

import List hiding (insert)
import Data.Array.Unboxed
import Random
import Char
import Maybe
import IO

newtype Trie = Trie [(String, Trie)]

instance Show Trie where
    showsPrec _ (Trie ts) = intern ts
        where
        intern ((inf,Trie tts):ts) =
            showString inf .
            paren tts .
            commaTail tts ts
        paren [] = id
        paren tts = showParen True $ intern tts
        commaTail _ [] = id
        commaTail [] ts = (:) ',' . intern ts
        commaTail _ ts = intern ts

instance Read Trie where
    readsPrec _ xs = [(Trie ts, xs')]
        where
        (ts, xs') = intern "" xs
        intern acc "" = case acc of
            "" -> ([], "")
            _ -> ([(reverse acc, Trie [])], "")
        intern acc (x:xs) = case x of
            ',' -> let (ts,xs') = intern "" xs in
                ((reverse acc, Trie []) : ts, xs')
            '(' -> let (tts,xs'') = intern "" xs; (ts,xs') = intern "" xs'' in
                ((reverse acc, Trie tts) : ts, xs')
            ')' -> case acc of
                "" -> ([], xs)
                _ -> ([(reverse acc, Trie [])], xs)
            _ -> intern (x:acc) xs

flatten :: Trie -> [String]
flatten (Trie ts) = intern [] ts
    where
    intern xs [] = []
    intern xs ((inf,Trie []):ts) = (xs++inf):intern xs ts
    intern xs ((inf,Trie tts):ts) =
        intern (xs++inf) tts ++
        intern xs ts

pieces :: Trie -> [String]
pieces (Trie ts) = intern ts
    where
    intern [] = []
    intern ((inf,Trie tts):ts) = inf : intern tts ++ intern ts

prefMatch str pat = intern str pat []
    where
    intern [] ys ms = return ms [] ys
    intern xs [] ms = return ms xs []
    intern xxs@(x:xs) yys@(y:ys) ms
        | x==y = intern xs ys (x:ms)
        | otherwise = return ms xxs yys
    return ms xs ys = (reverse ms, xs, ys)

insert :: Trie -> String -> Trie
insert (Trie ts) xs = Trie $ intern ts xs
    where
    intern :: [(String, Trie)] -> String -> [(String, Trie)]
    intern [] xs = [(xs, Trie [])]
    intern tts@(([],_):_) [] = tts
    intern tts@(yys@(ys,Trie yts):ts) xs = case prefMatch xs ys of
        ([],_,_)
            | xs>ys -> yys : intern ts xs
            | otherwise -> (xs, Trie []) : tts
        (pref,[],[]) -> case yts of
            [] -> tts
            _ -> (ys, Trie $ intern yts []) : ts
        (pref,xs',[]) -> case yts of
            [] -> (ys, Trie [([], Trie []), (xs', Trie [])]) : ts
            _ -> (ys, Trie $ intern yts xs') : ts
        (pref,xs',ys')
            | xs'<ys' -> (pref, Trie $ (xs', Trie []) : [(ys', Trie yts)]) : ts
            | otherwise -> (pref, Trie $ (ys', Trie yts) : [(xs', Trie [])]) : ts

dropPrefixes :: Trie -> Trie
dropPrefixes (Trie ts) = Trie $ intern ts
    where
    intern [] = []
    intern (([],Trie []):ts) = intern ts
    intern ((pref,Trie tts):ts) = (case intern tts of
        [(suf,yts)] -> (pref ++ suf, yts)
        itts -> (pref, Trie itts)) : intern ts

maskMatch mask str = intern mask str []
    where
    intern [] ys ms = return ms [] ys
    intern xs [] ms = return ms xs []
    intern ('?':xs) (y:ys) ms = intern xs ys (y:ms)
    intern xxs@(x:xs) yys@(y:ys) ms
        | x==y = intern xs ys (x:ms)
        | otherwise = return ms xxs yys
    return ms xs ys = (reverse ms, xs, ys)

maskMatches :: Trie -> Int -> String -> [String]
maskMatches (Trie ts) i ms = intern ts i ms ""
    where
    intern [] _ _ _ = []
    intern (("",_):ts) i ms acc
        | i<=0 = acc : intern ts i ms acc
        | otherwise = intern ts i ms acc
    intern ((ys,Trie tts):ts) i ms acc = (case maskMatch ms ys of
        (pref,ms',"") -> let prefLen = length pref in case tts of
            []
                | i<=prefLen -> (:) (acc++pref)
                | otherwise -> id
            _ -> (++) (intern tts (i-prefLen) ms' (acc++pref))
        _ -> id) (intern ts i ms acc)

test1 = foldl insert (Trie []) $ words "balka balet bulat bulka bal"

educeNoun xs
    | isNoun && not (any (=='-') word) = filter (\x -> all (x/=) "<>:12345,/") word
    | otherwise = ""
    where
    (word:index1:inds) = words xs
    isNoun =
        index1 `elem` (pat++map (++",") pat++[a++'/':'/':b++"," | a<-pat, b<- pat]) ||
        index1=="мн." && head inds/="от"
        where pat = words "м мо ж жо с со мо-жо"

grammar = do
    g <- readFile "grammar.txt"
    writeFile "nouns.txt" $ unlines $ map head $ group $
        sort $ filter more1 $ map educeNoun $
        filter (any (==' ')) $ lines g
    where
    more1 [] = False
    more1 [_] = False
    more1 _ = True

great = do
    ns <- readFile "nouns.txt"
    let trie = foldl insert (Trie []) (lines ns)
    writeFile "nouns'.txt" $ show trie

piec = do
    ns <- readFile "nouns.txt"
    let trie = foldl insert (Trie []) (lines ns)
    writeFile "pieces.txt" $ unlines $ sort $ flatten $
        foldl insert (Trie []) $ pieces trie

qazol = do
    ns <- readFile "nouns'.txt"
    let trie = read ns
    writeFile "nouns''.txt" $ unlines $ flatten trie

nouns = do
    ns <- readFile "nouns.suf"
    return (read ns :: Trie)

matc = do
    ns <- nouns
    writeFile "match.txt" $ unlines $ maskMatches ns 11 "????????ние"

shuffle :: RandomGen g => g -> [a] -> Int -> [a]
shuffle _ [] 0 = []
shuffle g xs len = (:) y $ shuffle g2 ys $ len-1
    where
    (r,g2) = randomR (0,len-1) g
    (y,ys) = extract xs r
    extract (x:xs) 0 = (x,xs)
    extract (x:xs) i = let (y,ys) = extract xs $ i-1 in (y,x:ys)

type Position = (Int, Int)
type FieldArray = UArray Position Char
--newtype Gamefield = Gamefield FieldArray

showField a = showInFrameDigs $ make $ map (winToDos.notQuest) $ elems a
    where
    d = dimens a
    make "" = []
    make xs = a : make b where (a,b) = splitAt d xs
    notQuest '?' = ' '
    notQuest a = a

showInFrame :: [String] -> String
showInFrame xs =
    '\n':'\xDA':replicate width '\xC4' ++
    '\xBF':'\n':concatMap (\x -> '\xB3':x ++ "\xB3\n") xs ++
    '\xC0':replicate width '\xC4' ++ "\xD9"
    where
    height = length xs
    width = maximum $ map length xs
    xsPad = map (\x -> take width $ x ++ repeat ' ') xs

showInFrameDigs :: [String] -> String
showInFrameDigs xs = concatMap ('\n':) $
    (' ':' ':take width digs) : zipWith (:) vertDigs fs
    where
    (_:fs) = lines $ showInFrame xs
    width = length (head fs) - 2
    digs = ['1'..'9'] ++ ['a'..'z']
    vertDigs = ' ' : take width digs ++ repeat ' '

tableConvert :: [String] -> Char -> Char
tableConvert xs = (!) (listArray ('\x00', '\xff') $
    ['\x00'..'\x7f'] ++ concat xs :: UArray Char Char)

winToDos,dosToWin :: Char -> Char
winToDos = tableConvert
    [ "\x5F\x5F\x27\x5F\x22\x3A\xC5\xD8\x5F\x25\x5F\x3C\x5F\x5F\x5F\x5F"
    , "\x5F\x27\x27\x22\x22\x07\x2D\x2D\x5F\x54\x5F\x3E\x5F\x5F\x5F\x5F"
    , "\xFF\xF6\xF7\x5F\xFD\x5F\xB3\x15\xF0\x63\xF2\x3C\xBF\x2D\x52\xF4"
    , "\xF8\x2B\x5F\x5F\x5F\xE7\x14\xFA\xF1\xFC\xF3\x3E\x5F\x5F\x5F\xF5"
    , "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F"
    , "\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F"
    , "\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF"
    , "\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF"
    ]
dosToWin = tableConvert
    [ "\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF"
    , "\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF"
    , "\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF"
    , "\x2D\x2D\x2D\xA6\x2B\xA6\xA6\xAC\xAC\xA6\xA6\xAC\x2D\x2D\x2D\xAC"
    , "\x4C\x2B\x54\x2B\x2D\x2B\xA6\xA6\x4C\xE3\xA6\x54\xA6\x3D\x2B\xA6"
    , "\xA6\x54\x54\x4C\x4C\x2D\xE3\x2B\x2B\x2D\x2D\x2D\x2D\xA6\xA6\x2D"
    , "\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF"
    , "\xA8\xB8\xAA\xBA\xAF\xBF\xA1\xA2\xB0\x95\xB7\x76\xB9\xA4\xA6\xA0"
    ]

newField :: Int -> String -> FieldArray
newField d word = listArray ((1,1),(d,d)) (repeat '?') //
    (zip (zip (repeat mid) [1..d]) word)
    where mid = d `div` 2 + 1

newFieldR :: RandomGen g => Int -> Trie -> g -> (FieldArray, String)
newFieldR d ns g = (newField d $ w, w)
    where
    w = ws !! (fst $ randomR (0, length ws-1) g)
    ws = maskMatches ns d $ replicate d '?'

dimens a = d where ((1,1),(d,_)) = bounds a

adjacents (y,x) table = let ((h1,w1),(h2,w2)) = bounds table in
    [ ((j, i), table ! (j, i))
    | (j,i) <- [(y-1,x),(y,x-1),(y+1,x),(y,x+1)]
    , (h1, h2) `inRange` j
    , (w1, w2) `inRange` i
    ]

adjLetrs yx a =
    [ (ji, e)
    | (ji,e) <- adjacents yx a
    , e /= '?'
    ]

emptyAdjLetrs :: FieldArray -> [Position]
emptyAdjLetrs a =
    [ yx
    | (yx,e) <- assocs a
    , e == '?'
    , any ((/='?').snd) $ adjacents yx a
    ]

itselfLetrs :: FieldArray -> [Position]
itselfLetrs a =
    [ yx
    | (yx,e) <- assocs a
    , e /= '?'
    ]

beforeQuestion :: FieldArray -> Position -> [(Int, [Position])]
beforeQuestion a yx = intern [yx]
    where
    intern acc@(yx:yxs)
        | a!yx=='?' = afterQuestion a acc >>= \p -> [(length acc, reverse p)]
        | otherwise = case [p | (p,_) <- adjacents yx a, not $ p `elem` yxs] of
            [] -> []
            ads -> concat [intern (p:acc) | p <- ads] -- ads >>= \p -> intern $ p:acc

afterQuestion :: FieldArray -> [Position] -> [[Position]]
afterQuestion a = intern
    where intern acc@(yx:yxs) =
        case [p | (p,_) <- adjLetrs yx a, not $ p `elem` yxs] of
            [] -> [acc]
            ads -> concat [intern (p:acc) | p <- ads]

existWords :: FieldArray -> [[Position]]
existWords a = map reverse $
    concat [afterQuestion a [p] | p <- itselfLetrs a]

posToStrings :: FieldArray -> [[Position]] -> [String]
posToStrings a ps = flatten $ dropPrefixes $ foldl insert (Trie []) strs
    where strs = map (map (a!)) ps

searchPlaces :: FieldArray -> [(Int, [Position])]
searchPlaces a = emptyAdjLetrs a ++ itselfLetrs a >>= beforeQuestion a

searchMatches :: FieldArray -> Trie -> [(String, [Position])]
searchMatches a ns = searchPlaces a >>= \(l,ps) ->
    zip (maskMatches ns l (map (a!) ps)) $ repeat ps

w2d = map winToDos
d2w = map dosToWin

compTurn :: FieldArray -> Trie -> [String] -> IO ()
compTurn a ns ws = do
    printLn $ "слово компьютера: `"++w++"', "++
        show (max scU scC)++':':show (min scU scC) ++ ' ':benefit
    if null $ emptyAdjLetrs a'
        then return ()
        else userTurn a' ns ws'
    where
    print a = do
        putStr $ w2d a
        hFlush stdout
    printLn a = do
        putStrLn $ w2d a
        hFlush stdout
    ws' = w:ws
    score comp = sum $ map (length.fst) $ filter snd $ zip ws' $
        cycle [comp, not comp]
    scU = score False
    scC = score True - length (last ws)
    benefit = case compare scU scC of
        LT -> "в пользу компьютера"
        EQ -> "ничья"
        GT -> "в Вашу пользу"
    a' = a // [(p,l) | (p,l) <- zip ps w, a!p == '?']
    (w,ps) = maximumBy (\(a,_) (b,_) -> compare (length a) (length b))
        [ (w, p)
        | (w,p) <- searchMatches a ns
        , not $ w `elem` ws
        ]

userTurn :: FieldArray -> Trie -> [String] -> IO ()
userTurn a ns ws = do
    putStrLn $ showField a
    (yx,l,w) <- userInput
    ver <- verifyInput yx l w
    return ()
    where
    print a = do
        putStr $ w2d a
        hFlush stdout
    printLn a = do
        putStrLn $ w2d a
        hFlush stdout
    userInput = do
        print "Введите номер строки, столбца, букву и слово (разделять пробелами): "
        user <- getLine
        case user of
            (':':cs) -> userInput
            _ -> case words $ d2w user of
                (sY:sX:(l:_):w:_) -> return ((read sY, read sX), l, w)
                _ -> userInput
    verifyInput yx l w
        | any fst errs = do
            print "\nОшибка: "
            printLn $ snd $ fromJust $ find fst errs
            userTurn a ns ws
        | otherwise = do
            putStrLn $ showField a'
            compTurn a' ns $ w:ws
        where
        errs =
            [ (not $ bounds a `inRange` yx, "клетка "++show yx++" за границами поля")
            , (l == '?', "недопустимая буква")
            , (a!yx /= '?', "клетка "++show yx++" уже занята")
            , (any (=='?') w, "недопустимое слово `"++w++"'")
            , (null $ maskMatches ns (length w) w, "в словаре нет слова `"++w++"'")
            , (w `elem` ws, "слово `"++w++"' уже было")
            , (not wordExist, "слово `"++w++"' не образуется")
            ]
        a' = a // [(yx, l)]
        wordExist = not $ null
            [ p
            | p <- existWords a'
            , let (p1,p2) = span (/=yx) p
            , not $ null p2
            , length p1 < length w
            , and $ zipWith (==) w $ map (a'!) p
            ]

main = do
    g <- newStdGen
    ns <- nouns
    let d = 5
    let (f,w) = newFieldR d ns g
    userTurn f ns [w]

Выглядит не везде красиво, но писалось экспрессом, может быть позже причешу
Словарь (79 Кб) с почти 44000 существительных был образован из "Грамматического словаря русского языка" А.А. Зализняка. Скомпилированный код и исходник лежат здесь (134 Кб).

Как говорится: "Кто обыграет комп дайте знать ))"