Калькулятор множеств

@Leshkin · Регистрация: 22.10.2012

Студворк — интернет-сервис помощи студентам

Есть список множеств, хранятся множества так [("1",["1","2","3"]),("2",["4","5","77"])].
+ - объединение
* - пересечение
Пользователь вводит выражение, к примеру 1+2, вводит имя нового множества.В итоге получается [("1",["1","2","3"]),("2",["4","5","77"]),("3",["1","2","3","4","5","77"])].
Собственно для подобных примеров мой код работает, но для примеров посложнее уже нет. Например: 3*(1+2).
Подскажите пожалуйста как реализовать калькулятор, подобный этому:

Haskell
1
2
3
4
5
6
7
8
calc :: String -> [Float]
calc = foldl f [] . words
  where 
    f (x:y:zs) "+" = (y + x):zs
    f (x:y:zs) "-" = (y - x):zs
    f (x:y:zs) "*" = (y * x):zs
    f (x:y:zs) "/" = (y / x):zs
    f xs y         = read y : xs

либо помогите с моим,пожалуйста:

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
--sets - список с множествами
--new_set- имя конечного множества
--третий аргумент, это выражение отпарсенное в ОПЗ ["1","2","+'] и т.д.
calc sets new_set [] result=
        if has_set sets "tmp" then 
                sets++[(new_set,(sort result))]++(delete (get_set_by_name sets "tmp") sets)
        else
                sets++[(new_set,(sort result))]  
calc sets new_set (x:y:z:[]) result=
        if z=="+" then
                calc sets new_set [] (result++(union (snd (get_set_by_name sets x)) (snd (get_set_by_name sets y))))
        else
                calc sets new_set [] (result++(intersect (snd (get_set_by_name sets x)) (snd (get_set_by_name sets y))))
                        
calc sets new_set (x:y:z:o:os) result=
        if o=="+"&&elem y numbers&&elem z numbers then
                calc (sets++[("tmp",(union (snd (get_set_by_name sets y)) (snd (get_set_by_name sets z))))]) new_set (["tmp"]++os) result-- ++union (snd (get_set_by_name sets x)) (snd (get_set_by_name sets y)))
        else
                calc (sets++[("tmp",(union (snd (get_set_by_name sets y)) (snd (get_set_by_name sets z))))]) new_set (["tmp"]++os) result-- ++intersect (snd (get_set_by_name sets x)) (snd (get_set_by_name sets y)))
 
        
has_set::[(String,[String])] -> String -> Bool
has_set [] _=False
has_set (item:sets) setName
        |(fst item) == setName=True
        |otherwise=has_set sets setName
        
--получает список с множествами и имя множества
--возвращает кортеж с нужным множеством 
get_set_by_name::[(String,[String])] -> String -> (String,[String])
get_set_by_name (item:sets) setName
        |(fst item) == setName=item
        |otherwise=get_set_by_name sets setName

@Catstail · 13.08.2013, 21:10

Ну почему используешь строки вместо целых? Чем это вызвано???
Вот здесь [("1",["1","2","3"]),("2",["4","5","77"])] какой смысл в первых элементах кортежей (выделены красным)? И зачем кортежи? "От веку" множества прекрасно моделируются списками:

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
-- Объединение
 
unionSets :: (Eq a) => [a] -> [a] -> [a]
unionSets [] y = y
unionSets x [] = x
unionSets (x:xs) y | (x `elem` y) = unionSets xs y
                   | otherwise = x:(unionSets xs y)
                   
-- Пересечение
 
interSets :: (Eq a) => [a] -> [a] -> [a]
interSets [] _ = []
interSets _ [] = []
interSets (x:xs) y | (x `elem` y) = x : (interSets xs y)
                   | otherwise = (interSets xs y)
 
-- Проверка
 
Main> unionSets [1,2,3] [2,3,4]
[1,2,3,4]
Main> unionSets "abcd" "cdefg"
"abcdefg"
 
Main> interSets "abcd" "cdefg"
"cd"
Main> interSets "abcdzxv" "wercdfg"
"cd"

@Leshkin · 13.08.2013, 21:30 **[ТС]**

Catstail, пользователь может создать сколько угодно множеств, поэтому для удобства работы каждому множеству дается какое-то имя.
Спасибо за код,но само объединение и пересечение у меня реализовано.
Проблема именно в том как считать сложные выражение вроде 1*(2+3)+(4*(5+6)), где 1,2,3,4,5,6 это имена множеств.

@Catstail · 13.08.2013, 21:47

А, тогда понятно. Что означает (x - y) и (x / y)? (x - y) - разность (входящие в x и не входящие в y)? А (x / y) что? А может, (x - y) - симметрическая разность?

@Leshkin · 13.08.2013, 21:51 **[ТС]**

Catstail, пока что достаточно операций объединения и пересечения.

@Catstail · 13.08.2013, 22:52

Начнем с предварительного разбора строки на лексемы (имена множеств, знаки операций и скобки):

Haskell
1
2
3
4
5
6
7
8
9
10
11
12
parse :: String -> String -> [String] -> [String]
parse [] lex r = r ++ [lex]
parse (x:xs) lex r | ((x == '*') || (x == '+') || (x == '-') || (x == '(') || (x == ')')) = 
                       if (length lex) > 0 then parse xs [] (r ++ [lex] ++ [[x]]) else parse xs [] (r ++ [[x]])
                   | otherwise = (parse xs (lex ++ [x]) r)
 
-- Проверка
 
Main> parse "a+(b-c)*d" [] []
["a","+","(","b","-","c",")","*","d"]
Main> parse "aa+(xb-dc)*d1" [] []
["aa","+","(","xb","-","dc",")","*","d1"]

Остальное - завтра.

@Leshkin · 13.08.2013, 22:59 **[ТС]**

Catstail, забыл написать,но это я реализовал. Выражение парсится в ОПЗ, то есть получается что-то вроде ["1","2","+"].

@Catstail · 14.08.2013, 10:25

А парсить в ОПЗ и считать потом результат - нерационально. Лучше парсить последовательно и сразу вычислять.

@Leshkin · 14.08.2013, 11:16 **[ТС]**

Catstail, может оно и лучше,но не хотелось бы переписывать что уже написано..

@Mysterious Light · 14.08.2013, 11:20

Предлагаю свой вариант, который может использоваться для интерактивного общения.

Здесь используются 4 монады, список как монада не используется. Потому нужно быть аккуратным при чтении, следя за тем, в какой монаде работаем.

Пусть мы распарсили выражение и представили результат в виде дерева

Haskell
1
2
3
data SetExpr n = SetUnion (SetExpr n) (SetExpr n) |
    SetIntersection (SetExpr n) (SetExpr n) | SetName n
type SetDataBase n v = [(n,[v])]

Здесь n — тип имени, а v — тип элементов множеств. Точнее говоря, это не множества, а некий их урезанный вариант, разупорядоченный список [v].
Напишем функцию, которая из базы данных (по сути ассоциативный массив с ключом n и значением [v] получает значения множеств, заданных буквами, и возвращает оценённое выражение:

Haskell
1
2
3
4
5
6
7
eval :: (Eq n, Eq v) => SetExpr n -> State (SetDataBase n v) (Maybe [v])
eval (SetName name) = getSetByName name
eval (SetUnion se1 se2) = do
    s1 <- eval se1
    s2 <- eval se2
    return $ liftM2 union s1 s2
eval (SetIntersection se1 se2) = liftM2 (liftM2 intersect) (eval se1) (eval se2)

State монада нужна для хранения базы данных, которая играет роль состояния. Maybe монада нужна на случай неизвестного имени.
Мы можем желать добавлять множество в базу:

Haskell
1
2
3
4
5
6
addToDataBase :: (Eq n, Eq v) => n -> (SetExpr n) -> State (SetDataBase n v) (Maybe [v])
addToDataBase name expr = do
    set <- eval expr
    database <- get
    if isNothing set then return Nothing
        else put ((name,fromJust set):database) >> return set

Несложно набрасать тело цикла интерактивного общения. Как видно, loop :: DataBase n v -> IO DataBase n v является петлёй в категории Клейсли монады IO, то есть её выход имеет тип входа, обёрнутый в монаду. Такие петли можно компоновать в произвольном числе: условно говоря, можно делать loop . loop . loop . loop и т.д., потому это и может мыслиться как тело некоторого цикла.

Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
loop database = do
    pe <- fmap parseExpr getLine
    case pe of
        Nothing -> loop database
        Just e  -> getCommand e
    where
        getCommand expr = do 
            (c:r) <- fmap trim getLine
            -- с — имя команды
            -- r — параметр команды
            let
                printValue  = printMaybe $ fst $ runState (eval expr) database
                setVariable = let
                    (v,db) = runState (addToDataBase r expr) database
                    in printMaybe v >> return db
                in case c of
                    '>' -> printValue >> loop database
                    '=' -> setVariable >>= loop
                    'q' -> return database
                    _   -> getCommand expr
printMaybe = print . fromMaybe [] -- вывод множества на экран

Теперь самое сложное (для меня), парсинг. Выше я рассуждал, как будто дерево уже отстроено. Сейчас мы его строим.

Парсинг

Haskell
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
psSet = digit >>= return . SetName . return
psExpr :: Parser (SetExpr String)
psExpr = psSet <|> psUnion <|> psIntersect <|> complexExpr
    where 
        complexExpr = do
            char '('
            e <- psExpr
            char ')'
            return e
psUnion = do
    e1 <- psExpr 
    char '+'
    e2 <- psExpr
    return (SetUnion e1 e2)
psIntersect = do
    e1 <- psExpr
    char '*'
    e2 <- psExpr
    return (SetIntersection e1 e2)
 
parseExpr = either (const Nothing) Just . parse psExpr "expr"

Полный текст:

Кликните здесь для просмотра всего текста

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
import Control.Monad.State
import Data.List(union, intersect, find, dropWhile)
import Data.Maybe(fromMaybe, fromJust, isNothing)
import Data.Char(isSpace)
import Text.ParserCombinators.Parsec hiding(State)
 
type SetDataBase n v = [(n,[v])]
 
getSetByName :: Eq n => n -> State (SetDataBase n v) (Maybe [v])
getSetByName name = fmap (fmap snd . find (\x -> fst x == name)) get
 
data SetExpr n = SetUnion (SetExpr n) (SetExpr n) | 
    SetIntersection (SetExpr n) (SetExpr n) | SetName n
 
eval :: (Eq n, Eq v) => SetExpr n -> State (SetDataBase n v) (Maybe [v])
eval (SetName name) = getSetByName name
eval (SetUnion se1 se2) = do
    s1 <- eval se1
    s2 <- eval se2
    return $ liftM2 union s1 s2
eval (SetIntersection se1 se2) = liftM2 (liftM2 intersect) (eval se1) (eval se2)
 
addToDataBase :: (Eq n, Eq v) => n -> (SetExpr n) -> State (SetDataBase n v) (Maybe [v])
addToDataBase name expr = do
    set <- eval expr
    database <- get
    if isNothing set then return Nothing
        else put ((name,fromJust set):database) >> return set
 
trim = f . f where f = reverse . dropWhile isSpace
 
loop database = do
    pe <- fmap parseExpr getLine
    case pe of
        Nothing -> loop database
        Just e  -> getCommand e
    where
        getCommand expr = do 
            (c:r) <- fmap trim getLine
            let
                printValue  = printMaybe $ fst $ runState (eval expr) database
                setVariable = let (v,db) = runState (addToDataBase r expr) database in printMaybe v >> return db
                in case c of
                    '>' -> printValue >> loop database
                    '=' -> setVariable >>= loop
                    'q' -> return database
                    _   -> getCommand expr
printMaybe = print . fromMaybe []
 
main = loop [("1",['1','2','3']),("2",['3','4','5'])]
 
psSet = digit >>= return . SetName . return
psExpr :: Parser (SetExpr String)
psExpr = psSet <|> psUnion <|> psIntersect <|> complexExpr
    where 
        complexExpr = do
            char '('
            e <- psExpr
            char ')'
            return e
psUnion = do
    e1 <- psExpr 
    char '+'
    e2 <- psExpr
    return (SetUnion e1 e2)
psIntersect = do
    e1 <- psExpr
    char '*'
    e2 <- psExpr
    return (SetIntersection e1 e2)
 
parseExpr = either (const Nothing) Just . parse psExpr "expr"

Что я недоделал:
1. Нормальный вывод множеств, по всем канонам, абстрагированно от типа v.
2. Добавление нового множества, вводимого пользователем, в базу. Лень парсить множество.

@Nameless One · 14.08.2013, 11:34

Набросал простенький интерпретатор.

Программа интерпретатора состоит из последовательности инструкций (statements). Типов инструкций две: присваивание переменной значения выражения и печать значения выражения. Каждая инструкция должна заканчиваться точкой с запятой.

Выражением может быть бинарная операция (объединение |, пересечение &, разность \ и симметричная разность - двух множеств), имя переменной (которое вычисляется в значение переменной) и множество-литерал. Бинарные операции левоассоциативные с одинаковым приоритетом, скобки могут использоваться для изменения приоритета операций.

Пример скрипта для интерпретатора:

Code
1
2
3
4
5
6
7
s1 = {1, 2, 3};
s2 = {3, 4, 5};
print s1;
print s2;
print s1 - s2;
print s1 \ s2 | s2 \ s1;
print (s1 \ s2) | (s2 \ s1);

Код интерпретатора (Main.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
module Main where
 
import Lexer
import Parser
 
import qualified Data.Set as S
import qualified Data.Map as M
 
import Data.List
import Data.Maybe
 
type Set = S.Set Int
type Env = M.Map String Set
 
getVal :: String -> Env -> Set
getVal var = fromMaybe (error $ "Undefined variable " ++ var) . M.lookup var
 
putVal :: String -> Set -> Env -> Env
putVal = M.insert
 
eval :: Expr -> Env -> Set
eval (Intersection e1 e2) env = S.intersection (eval e1 env) (eval e2 env)
eval (Union e1 e2) env        = S.union (eval e1 env) (eval e2 env)
eval (Difference e1 e2) env   = S.difference (eval e1 env) (eval e2 env)
eval (SymDiff e1 e2) env      = symmetricDiff (eval e1 env) (eval e2 env)
eval (Var var) env            = getVal var env
eval (SetLit s) _             = S.fromList s
 
symmetricDiff :: Ord k => S.Set k -> S.Set k -> S.Set k
symmetricDiff s1 s2 = S.union (S.difference s1 s2) (S.difference s2 s1)
 
exec :: Program -> IO ()
exec (Program stmts) = execStmts M.empty stmts
 
execStmts :: Env -> [Stmt] -> IO ()
execStmts _   []     = return ()
execStmts env (s:ss) = case s of
                         Assign str expr -> execStmts (putVal str (eval expr env) env) ss
                         Print expr      -> printSet (eval expr env) >> execStmts env ss
 
printSet :: Set -> IO ()
printSet s = putStrLn $ "{" ++ intercalate ", " (map show (S.toAscList s)) ++ "}"
 
main = getContents >>= exec . parse . scanTokens

Лексический и синтаксические анализаторы генерируются из следующих файлов с помощью генераторов Alex и Happy.

Lexer.y:

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
{
module Lexer ( Token (..)
             , scanTokens
             , AlexPosn (..)
             , tokenPos
             ) where
}
 
%wrapper "posn"
 
$digit = 0-9
$alpha = [a-zA-Z]
 
tokens :-
       $white+                                  ;
       $digit+                                  { \p s -> TokenInt p (read s) }
       print                                    { \p s -> TokenPrint p }
       \=                                       { \p s -> TokenEq p }
       \;                                       { \p s -> TokenSemicolon p }
       $alpha [$alpha $digit _]*                { \p s -> TokenIdent p s }
       \&                                       { \p s -> TokenIntersection p }
       \|                                       { \p s -> TokenUnion p }
       \\                                       { \p s -> TokenDifference p }
       \-                                       { \p s -> TokenSymDiff p }
       \(                                       { \p s -> TokenLeftParen p }
       \)                                       { \p s -> TokenRightParen p }
       \{                                       { \p s -> TokenLeftBrace p }
       \}                                       { \p s -> TokenRightBrace p }
       \,                                       { \p s -> TokenComma p }
 
{
data Token = TokenEq AlexPosn
           | TokenSemicolon AlexPosn
           | TokenInt AlexPosn Int
           | TokenIdent AlexPosn String
           | TokenLeftParen AlexPosn
           | TokenRightParen AlexPosn
           | TokenLeftBrace AlexPosn
           | TokenRightBrace AlexPosn
           | TokenComma AlexPosn
           | TokenUnion AlexPosn
           | TokenIntersection AlexPosn
           | TokenDifference AlexPosn
           | TokenSymDiff AlexPosn
           | TokenPrint AlexPosn
             deriving (Eq)
 
scanTokens = alexScanTokens
 
tokenPos (TokenEq p)           = p
tokenPos (TokenSemicolon p)    = p
tokenPos (TokenInt p _)        = p
tokenPos (TokenIdent p _)      = p
tokenPos (TokenLeftParen p)    = p
tokenPos (TokenRightParen p)   = p
tokenPos (TokenLeftBrace p)    = p
tokenPos (TokenRightBrace p)   = p
tokenPos (TokenComma p)        = p
tokenPos (TokenUnion p)        = p
tokenPos (TokenIntersection p) = p
tokenPos (TokenDifference p)   = p
tokenPos (TokenSymDiff p)      = p
tokenPos (TokenPrint p)        = p
 
instance Show Token where
  show (TokenEq _)           = "Eq"
  show (TokenSemicolon _)    = "Semicolon"
  show (TokenInt _ i)        = "Int" ++ show i
  show (TokenIdent _ i)      = "Ident" ++ show i
  show (TokenLeftParen _)    = "LeftParen"
  show (TokenRightParen _)   = "RightParen"
  show (TokenLeftBrace _)    = "LeftBrace"
  show (TokenRightBrace _)   = "RightBrace"
  show (TokenComma _)        = "Comma"
  show (TokenUnion _)        = "Union"
  show (TokenIntersection _) = "Intersection"
  show (TokenDifference _)   = "Difference"
  show (TokenSymDiff _)      = "SymDifference"
  show (TokenPrint _)        = "Print"
}

Parser.y:

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
{
module Parser where
 
import Lexer
}
 
%name parse
%tokentype { Token }
 
%token
        int                     { TokenInt _ $$ }
        '='                     { TokenEq _ }
        ';'                     { TokenSemicolon _ }
        ident                   { TokenIdent _ $$ }
        'print'                 { TokenPrint _ }
        '('                     { TokenLeftParen _ }
        ')'                     { TokenRightParen _ }
        '{'                     { TokenLeftBrace _ }
        '}'                     { TokenRightBrace _ }
        ','                     { TokenComma _ }
        '&'                     { TokenIntersection _ }
        '|'                     { TokenUnion _ }
        '\\'                    { TokenDifference _ }
        '-'                     { TokenSymDiff _ }
 
%left '&' '|' '\\' '-'
 
%%
 
Program : Stmts                            { Program $1 }
 
Stmts : {- empty -}                        { [] }
      | Stmt Stmts                         { $1 : $2 }
 
Stmt : ident '=' Expr ';'                  { Assign $1 $3 }
     | 'print' Expr ';'                    { Print $2 }
 
Expr : Expr '&' Expr                       { Intersection $1 $3 }
     | Expr '|' Expr                       { Union $1 $3 }
     | Expr '\\' Expr                      { Difference $1 $3 }
     | Expr '-' Expr                       { SymDiff $1 $3 }
     | '(' Expr ')'                        { $2 }
     | ident                               { Var $1 }
     | SetLit                              { SetLit $1 }
 
SetLit : '{' SetItems '}'                  { $2 }
 
SetItems : {- empty -}                     { [] }
         | int                             { [$1] }
         | int ',' SetItems                { $1 : $3 }
 
{
data Program = Program [Stmt]
               deriving (Eq, Show)
 
data Stmt = Assign String Expr
          | Print Expr
            deriving (Eq, Show)
 
data Expr = Intersection Expr Expr
          | Union Expr Expr
          | Difference Expr Expr
          | SymDiff Expr Expr
          | Var String
          | SetLit [Int]
            deriving (Eq, Show)
 
happyError :: [Token] -> a
happyError tokens = error $ "Parse error at " ++ loc
       where loc = case tokens of
                     []    -> "end of file"
                     tok:_ -> "line " ++ show l ++ ", column " ++ show c ++
                                    " (near token " ++ show tok ++ ")"
                         where AlexPn _ l c = tokenPos tok
}

Makefile:

Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
TARGET=set-calc
ALEX_FLAGS=-g
HAPPY_FLAGS=-g
 
all: $(TARGET)
 
$(TARGET): Main.hs Lexer.hs Parser.hs
    ghc --make $< -o $@
 
%.hs: %.x
    alex $(ALEX_FLAGS) $< -o $@
 
%.hs: %.y
    happy $(HAPPY_FLAGS) $< -o $@
 
clean:
    $(RM) Lexer.hs Parser.hs *.o *.hi
 
.PHONY: all clean

@Catstail · 14.08.2013, 13:24

Nameless One, класс!

Добавлено через 1 час 39 минут
Ну, и детское решение (без сохранения состояния):

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
86
87
88
89
-- Объединение множеств
 
unionSets :: (Eq a) => [a] -> [a] -> [a]
unionSets [] y = y
unionSets x [] = x
unionSets (x:xs) y | (x `elem` y) = unionSets xs y
                   | otherwise = x:(unionSets xs y)
                   
-- Пересечение множеств
 
interSets :: (Eq a) => [a] -> [a] -> [a]
interSets [] _ = []
interSets _ [] = []
interSets (x:xs) y | (x `elem` y) = x : (interSets xs y)
                   | otherwise = (interSets xs y)
          
-- Дать "мясо" множества по имени
 
getSet :: [(String,[String])] -> String -> [String]
getSet [] _ = []
getSet (u:us) n | (n == (fst u)) = snd u
                | otherwise = getSet us n 
                             
-- Разобрать управляющую строку на лексемы
 
parse :: String -> String -> [String] -> [String]
parse [] lex r = r ++ [lex]
parse (x:xs) lex r | ((x == '*') || (x == '+') || (x == '-') || (x == '(') || (x == ')')) = 
                       if (length lex) > 0 then parse xs [] (r ++ [lex] ++ [[x]]) else parse xs [] (r ++ [[x]])
                   | otherwise = (parse xs (lex ++ [x]) r)
                   
-- Дать приоритет операции
 
prty :: String -> Int
prty "(" = 0
prty "+" = 1
prty "-" = 2
prty "*" = 3
prty "/" = 3
prty _   = -1
 
-- Тип лексемы (1-разделитель; 0-операнд)
 
lexType :: String -> Int
lexType x | (x `elem` ["(",")","+","-","*","/"]) = 1
          | otherwise = 0
     
-- Опустошить стек операций до открывающей скобки
 
emptyP :: [String] -> [[String]] -> ([String],[[String]])
emptyP (o:os) inin@(n:ns) | (o == "(") = (os,inin)
                          | otherwise = emptyP os ((exec (head ns) n o) : (tail ns))
 
-- Опустошить стек операций 
 
empty :: [String] -> [[String]] -> [String]
empty [] n = (head n)
empty (o:os) (n:ns) = empty os ((exec (head ns) n o) : (tail ns))                          
     
-- Выполнить операцию
 
exec :: [String] -> [String] -> String -> [String]
exec a1 a2 "+" = unionSets a1 a2 
exec a1 a2 "*" = interSets a1 a2           
          
-- Вычислить выражение 
--            универсум       список лексем   стек операций  стек операндов   
calcF :: [(String,[String])]   -> [String]   ->   [[String]]   ->    [String] -> [String]
calcF u [] s1 [] = head s1
calcF u [] s1 s2 = empty s2 s1
calcF u (l:ls) s1 s2 | (lexType l) == 0 = calcF u ls ( (getSet u l) :s1) s2
                     | (l == "(")       = calcF u ls s1 ("(" : s2)
                     | (l == ")")       = calcF u ls q1 q2
                     | (s2 == [])       = calcF u ls s1 [l]
                     | (prty l) == (prty (head s2)) = calcF u ls ((exec (s1 !! 1) (s1 !! 0) (head s2)):(tail s1)) (l : (tail s2))
                     | otherwise = calcF u ls s1 (l:s2)
                       where tmp=(emptyP s2 s1); q1=(snd tmp); q2=(fst tmp);
 
-- Парадная программа калькулятора (без лишних параметров)                   
 
calc :: [(String,[String])] -> String -> [String]
calc u x = calcF u (parse x "" []) [] []
 
-- Проверка
 
Main> calc [("a",["1","2","3"]),("b",["11","22","33"]),("c",["3","4","5"])] "a+b*c"
["1","2","3"]
Main> calc [("a",["1","2","3"]),("b",["11","22","33"]),("c",["3","4","5"])] "(a+b)*c"
["3"]

@Leshkin · 15.08.2013, 09:33 **[ТС]**

Catstail, спасибо большое

Добавлено через 1 минуту
Catstail, нашел небольшую ошибочку в вашем коде:

| (prty l) == (prty (head s2)) = calcF u ls ((exec (s1 !! 1) (s1 !! 0) (head s2))

tail s1)) (l : (tail s2))

вместо == должен быть <,иначе он операцию объединения считает по приоритету выше, чем операцию пересечения.

Так же выражение вроде 1*(2+3) считаются некорректно. Почему-пока не разобрался.Не подскажете?
Например:
есть множество [("1",["1","2","3","4"]),("2",["5","6","7","8"]),("4",["0","2"]),("3",["0","234","23432","4342"])]
выражение 4*(1+3) должно давать результат ["0","2"], но кидает пустой список.
Однако если ввести (1+3)*4 все прекрасно работает..

Добавлено через 14 часов 27 минут
так же не считает выражения вроде (1+2), именно в скобках

@Catstail · 15.08.2013, 11:16

Сейчас посмотрю.

Добавлено через 1 час 36 минут
Проблема оказалась в функции parse (добавлялись лишние пустые лексемы):

Haskell
1
2
3
4
5
6
7
8
parse :: String -> String -> [String] -> [String]
parse [] lex r = if lex /= "" then r ++ [lex] else r
parse (x:xs) lex r | ((x == '*') || (x == '+') || (x == '-') || (x == '(') || (x == ')')) = 
                       if (length lex) > 0 then parse xs [] (r ++ [lex] ++ [[x]]) else parse xs [] (r ++ [[x]])
                   | otherwise = (parse xs (lex ++ [x]) r)
 
*Main> calc [("1",["1","2","3","4"]),("2",["5","6","7","8"]),("4",["0","2"]),("3",["0","234","23432","4342"])] "4*(1+3)"
["0","2"]

Новые блоги и статьи Все статьи Все блоги /
Почему дизайн решает? Neotwalker 09.01.2026 В современном мире, где конкуренция за внимание потребителя достигла пика, дизайн становится мощным инструментом для успеха бренда. Это не просто красивый внешний вид продукта или сайта — это. . .	Модель микоризы: классовый агентный подход 3 anaschu 06.01.2026 aa0a7f55b50dd51c5ec569d2d10c54f6/ O1rJuneU_ls https:/ / vkvideo. ru/ video-115721503_456239114	Owen Logic: О недопустимости использования связки «аналоговый ПИД» + RegKZR ФедосеевПавел 06.01.2026 Owen Logic: О недопустимости использования связки «аналоговый ПИД» + RegKZR ВВЕДЕНИЕ Введу сокращения: аналоговый ПИД — ПИД регулятор с управляющим выходом в виде числа в диапазоне от 0% до. . .	Модель микоризы: классовый агентный подход 2 anaschu 06.01.2026 репозиторий https:/ / github. com/ shumilovas/ fungi ветка по-частям. коммит Create переделка под биомассу. txt вход sc, но sm считается внутри мицелия. кстати, обьем тоже должен там считаться. . . .
Расчёт токов в цепи постоянного тока igorrr37 05.01.2026 / * Дана цепь постоянного тока с сопротивлениями и напряжениями. Надо найти токи в ветвях. Программа составляет систему уравнений по 1 и 2 законам Кирхгофа и решает её. Последовательность действий:. . .	Новый CodeBlocs. Версия 25.03 palva 04.01.2026 Оказывается, недавно вышла новая версия CodeBlocks за номером 25. 03. Когда-то давно я возился с только что вышедшей тогда версией 20. 03. С тех пор я давно снёс всё с компьютера и забыл. Теперь. . .	Модель микоризы: классовый агентный подход anaschu 02.01.2026 Раньше это было два гриба и бактерия. Теперь три гриба, растение. И на уровне агентов добавится между грибами или бактериями взаимодействий. До того я пробовал подход через многомерные массивы,. . .	Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Programma_Boinc 28.12.2025 Советы по крайней бережливости. Внимание, это ОЧЕНЬ длинный пост. Налог на собак: https:/ / ********/ gallery/ V06K53e Финансовый отчет в Excel: https:/ / ********/ gallery/ bKBkQFf Пост отсюда. . .

@Leshkin 6 / 6 / 1 Регистрация: 22.10.2012 Сообщений: 36
	13.08.2013, 21:30 [ТС]
	Catstail, пользователь может создать сколько угодно множеств, поэтому для удобства работы каждому множеству дается какое-то имя. Спасибо за код,но само объединение и пересечение у меня реализовано. Проблема именно в том как считать сложные выражение вроде 1(2+3)+(4(5+6)), где 1,2,3,4,5,6 это имена множеств. 0

@Catstail Супер-модератор 38167 / 21102 / 4307 Регистрация: 12.02.2012 Сообщений: 34,690 Записей в блоге: 14
	13.08.2013, 21:47
	А, тогда понятно. Что означает (x - y) и (x / y)? (x - y) - разность (входящие в x и не входящие в y)? А (x / y) что? А может, (x - y) - симметрическая разность? 0

@Leshkin 6 / 6 / 1 Регистрация: 22.10.2012 Сообщений: 36
	13.08.2013, 21:51 [ТС]
	Catstail, пока что достаточно операций объединения и пересечения. 0

@Leshkin 6 / 6 / 1 Регистрация: 22.10.2012 Сообщений: 36
	13.08.2013, 22:59 [ТС]
	Catstail, забыл написать,но это я реализовал. Выражение парсится в ОПЗ, то есть получается что-то вроде ["1","2","+"]. 0

@Catstail Супер-модератор 38167 / 21102 / 4307 Регистрация: 12.02.2012 Сообщений: 34,690 Записей в блоге: 14
	14.08.2013, 10:25
	А парсить в ОПЗ и считать потом результат - нерационально. Лучше парсить последовательно и сразу вычислять. 0

@Leshkin 6 / 6 / 1 Регистрация: 22.10.2012 Сообщений: 36
	14.08.2013, 11:16 [ТС]
	Catstail, может оно и лучше,но не хотелось бы переписывать что уже написано.. 0