Привет всем!
Впечатлился накануне вот этим
постомАвтор: 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 Кб).
Как говорится: "Кто обыграет комп дайте знать ))"
Здравствуйте, R.K., Вы писали:
[]
RK>только на Хаскеле
За пост спасибо. У меня только один вопрос: как вообще на Хаскеле писать можно? Этож набор буковок
Сорри, но правда интересно — меня как будто поленом по голове двинули после просмотра исходника
Еще интересней — что чувствует девелопер на Хаскеле после трудового дня?
... << RSDN@Home 1.1.4 beta 7 rev. 452>>
Здравствуйте, Flamer, Вы писали:
F>Здравствуйте, R.K., Вы писали:
F>[]
RK>>только на Хаскеле
F>За пост спасибо. У меня только один вопрос: как вообще на Хаскеле писать можно? Этож набор буковок
На самом деле все не так страшно. Там по крайней мере два места с действительно набором буковок
F>Сорри, но правда интересно — меня как будто поленом по голове двинули после просмотра исходника Еще интересней — что чувствует девелопер на Хаскеле после трудового дня?
Ну а во-вторых, у меня совсем мало опыта с Хаскелем — когда быстро пишу может не так компактно получаться. Но Хаскель рулит!
Единственный вид ошибок, выживающих после компиляции — логические.
RK>>только на Хаскеле
F>За пост спасибо. У меня только один вопрос: как вообще на Хаскеле писать можно? Этож набор буковок
F>Сорри, но правда интересно — меня как будто поленом по голове двинули после просмотра исходника Еще интересней — что чувствует девелопер на Хаскеле после трудового дня?
Не, мозги взрываются после J (см, например
здесь или
в этюдахАвтор: Mikl Kurkov
Дата: 06.03.06
)
На самом деле там все понятно
Ну, если практиковаться, конечно (мне там не все понятно, я с хаскелем поигрался и бросил
). Частично срабатывает привычка называть некоторые вещи так, а не иначе (это я о xs, ts, tts). Ну и паттерн матчинг конечно. Но так, да, ужас
... << RSDN@Home 1.2.0 alpha rev. 668>>