Skip to content

Commit

Permalink
remove dfs pat and bfs pat
Browse files Browse the repository at this point in the history
  • Loading branch information
@egisatoshi
egisatoshi committed Apr 29, 2019
1 parent d36c3a7 commit 69104d1
Show file tree
Hide file tree
Showing 9 changed files with 178 additions and 285 deletions.
209 changes: 75 additions & 134 deletions hs-src/Language/Egison/Core.hs
View file

Large diffs are not rendered by default.

29 changes: 6 additions & 23 deletions hs-src/Language/Egison/Desugar.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -312,6 +312,12 @@ desugar (MatchAllExpr expr0 expr1 clauses) = do
clauses' <- desugarMatchClauses clauses
return $ MatchAllExpr expr0' expr1' clauses'

desugar (MatchAllDFSExpr expr0 expr1 clauses) = do
expr0' <- desugar expr0
expr1' <- desugar expr1
clauses' <- desugarMatchClauses clauses
return $ MatchAllDFSExpr expr0' expr1' clauses'

desugar (DoExpr binds expr) = do
binds' <- desugarBindings binds
expr' <- desugar expr
Expand Down Expand Up @@ -398,10 +404,6 @@ desugar (MatcherExpr matcherInfo) = do
matcherInfo' <- desugarMatcherInfo matcherInfo
return $ MatcherExpr matcherInfo'

desugar (MatcherDFSExpr matcherInfo) = do
matcherInfo' <- desugarMatcherInfo matcherInfo
return $ MatcherDFSExpr matcherInfo'

desugar (PartialVarExpr n) = return $ PartialVarExpr n

desugar (PartialExpr n expr) = do
Expand Down Expand Up @@ -451,8 +453,6 @@ desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern
collectName (PlusPat patterns) = collectNames patterns
collectName (MultPat patterns) = collectNames patterns
collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2
collectName (DFSPat _ pattern) = collectName pattern
collectName (BFSPat pattern) = collectName pattern
collectName _ = S.empty

makeBinding :: String -> BindingExpr
Expand Down Expand Up @@ -505,25 +505,8 @@ desugarPattern' (MultPat (intPat:patterns)) = do
f (MultPat xs) = concatMap f xs
f pat = [pat]
desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2
desugarPattern' (DFSPat' pattern) = desugarPattern' pattern >>= dfs
desugarPattern' (BFSPat pattern) = BFSPat <$> desugarPattern' pattern
desugarPattern' pattern = return pattern

dfs :: EgisonPattern -> DesugarM EgisonPattern
dfs (NotPat pattern) = NotPat <$> dfs pattern
dfs (AndPat patterns) = DFSPat <$> fresh <*> (AndPat <$> mapM dfs patterns)
dfs (OrPat patterns) = DFSPat <$> fresh <*> (OrPat <$> mapM dfs patterns)
dfs (OrderedOrPat id pat1 pat2) = OrderedOrPat id <$> dfs pat1 <*> dfs pat2
dfs (TuplePat patterns) = DFSPat <$> fresh <*> (TuplePat <$> mapM dfs patterns)
dfs (InductivePat name patterns) = DFSPat <$> fresh <*> (InductivePat name <$> mapM dfs patterns)
dfs (IndexedPat pattern exprs) = DFSPat <$> fresh <*> (flip IndexedPat exprs <$> dfs pattern)
dfs (PApplyPat expr patterns) = DFSPat <$> fresh <*> (PApplyPat expr <$> mapM dfs patterns)
dfs (DApplyPat pattern patterns) = DFSPat <$> fresh <*> (DApplyPat <$> dfs pattern <*> mapM dfs patterns)
dfs (LoopPat name range pattern1 pattern2) = DFSPat <$> fresh <*> (LoopPat name range <$> dfs pattern1 <*> dfs pattern2)
dfs (LetPat binds pattern) = DFSPat <$> fresh <*> (LetPat binds <$> dfs pattern)
dfs (PowerPat pattern1 pattern2) = DFSPat <$> fresh <*> (PowerPat <$> dfs pattern1 <*> dfs pattern2)
dfs pattern = return pattern

desugarLoopRange :: LoopRange -> DesugarM LoopRange
desugarLoopRange (LoopRange sExpr eExpr pattern) = do
sExpr' <- desugar sExpr
Expand Down
20 changes: 5 additions & 15 deletions hs-src/Language/Egison/Parser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -227,11 +227,11 @@ expr' = try partialExpr
<|> doExpr
<|> ioExpr
<|> matchAllExpr
<|> matchAllDFSExpr
<|> matchExpr
<|> matchAllLambdaExpr
<|> matchLambdaExpr
<|> matcherExpr
<|> matcherDFSExpr
<|> seqExpr
<|> applyExpr
<|> cApplyExpr
Expand Down Expand Up @@ -316,6 +316,9 @@ quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr
matchAllExpr :: Parser EgisonExpr
matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)

matchAllDFSExpr :: Parser EgisonExpr
matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <*> expr <*> ((flip (:) [] <$> matchClause) <|> matchClauses)

matchExpr :: Parser EgisonExpr
matchExpr = keywordMatch >> MatchExpr <$> expr <*> expr <*> matchClauses

Expand All @@ -334,9 +337,6 @@ matchClause = brackets $ (,) <$> pattern <*> expr
matcherExpr :: Parser EgisonExpr
matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses

matcherDFSExpr :: Parser EgisonExpr
matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses

ppMatchClauses :: Parser MatcherInfo
ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace

Expand Down Expand Up @@ -594,8 +594,6 @@ pattern' = wildCard
<|> loopPat
<|> letPat
<|> laterPat
<|> bfsPat
<|> dfsPat
<|> try divPat
<|> try plusPat
<|> try multPat
Expand Down Expand Up @@ -681,12 +679,6 @@ powerPat :: Parser EgisonPattern
powerPat = try (PowerPat <$> pattern <* char '^' <*> pattern)
<|> pattern

dfsPat :: Parser EgisonPattern
dfsPat = keywordDFS >> DFSPat' <$> pattern

bfsPat :: Parser EgisonPattern
bfsPat = keywordBFS >> BFSPat <$> pattern

-- Constants

constantExpr :: Parser EgisonExpr
Expand Down Expand Up @@ -872,11 +864,11 @@ keywordWithSymbols = reserved "with-symbols"
keywordLoop = reserved "loop"
keywordCont = reserved "..."
keywordMatchAll = reserved "match-all"
keywordMatchAllDFS = reserved "match-all-dfs"
keywordMatchAllLambda = reserved "match-all-lambda"
keywordMatch = reserved "match"
keywordMatchLambda = reserved "match-lambda"
keywordMatcher = reserved "matcher"
keywordMatcherDFS = reserved "matcher-dfs"
keywordDo = reserved "do"
keywordIo = reserved "io"
keywordSomething = reserved "something"
Expand All @@ -902,8 +894,6 @@ keywordUserrefs = reserved "user-refs"
keywordUserrefsNew = reserved "user-refs!"
keywordFunction = reserved "function"
keywordSymbolicTensor = reserved "symbolic-tensor"
keywordDFS = reserved "dfs"
keywordBFS = reserved "bfs"

sign :: Num a => Parser (a -> a)
sign = (char '-' >> return negate)
Expand Down
26 changes: 7 additions & 19 deletions hs-src/Language/Egison/ParserNonS.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -231,10 +231,10 @@ term = P.lexeme lexer
term' :: Parser EgisonExpr
term' = matchExpr
<|> matchAllExpr
<|> matchAllDFSExpr
<|> matchLambdaExpr
<|> matchAllLambdaExpr
<|> matcherExpr
<|> matcherDFSExpr
<|> functionWithArgExpr
<|> userrefsExpr
<|> algebraicDataMatcherExpr
Expand Down Expand Up @@ -323,6 +323,9 @@ quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr
matchAllExpr :: Parser EgisonExpr
matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses

matchAllDFSExpr :: Parser EgisonExpr
matchAllDFSExpr = keywordMatchAllDFS >> MatchAllDFSExpr <$> expr <* keywordAs <*> expr <*> matchClauses

matchExpr :: Parser EgisonExpr
matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses

Expand All @@ -341,9 +344,6 @@ matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* reservedOp "->"
matcherExpr :: Parser EgisonExpr
matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses

matcherDFSExpr :: Parser EgisonExpr
matcherDFSExpr = keywordMatcherDFS >> MatcherDFSExpr <$> ppMatchClauses

ppMatchClauses :: Parser MatcherInfo
ppMatchClauses = many1 ppMatchClause

Expand Down Expand Up @@ -597,8 +597,6 @@ pattern' = wildCard
<|> contPat
<|> try indexedPat
<|> patVar
<|> try dfsPat
<|> try bfsPat
<|> try loopPat
<|> try pApplyPat
<|> try dApplyPat
Expand Down Expand Up @@ -661,12 +659,6 @@ loopRange = parens (try (LoopRange <$> expr <* comma <*> expr <*> option WildCar
ep <- option WildCard pattern
return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, IntegerExpr 1]))) ep)))

dfsPat :: Parser EgisonPattern
dfsPat = keywordDFS >> DFSPat' <$> parens pattern

bfsPat :: Parser EgisonPattern
bfsPat = keywordBFS >> BFSPat <$> parens pattern

-- Constants

constantExpr :: Parser EgisonExpr
Expand Down Expand Up @@ -769,11 +761,11 @@ reservedKeywords =
, "withSymbols"
, "loop"
, "matchAll"
, "matchAllDFS"
, "matchAllLambda"
, "match"
, "matchLambda"
, "matcher"
, "matcherDFS"
, "do"
, "io"
, "something"
Expand All @@ -788,9 +780,7 @@ reservedKeywords =
, "suprefs!"
, "userRefs"
, "userRefs!"
, "function"
, "dfs"
, "bfs"]
, "function"]

reservedOperators :: [String]
reservedOperators =
Expand Down Expand Up @@ -844,11 +834,11 @@ keywordWithSymbols = reserved "withSymbols"
keywordLoop = reserved "loop"
keywordCont = reserved "..."
keywordMatchAll = reserved "matchAll"
keywordMatchAllDFS = reserved "matchAllDFS"
keywordMatchAllLambda = reserved "matchAllLambda"
keywordMatch = reserved "match"
keywordMatchLambda = reserved "matchLambda"
keywordMatcher = reserved "matcher"
keywordMatcherDFS = reserved "matcherDFS"
keywordDo = reserved "do"
keywordIo = reserved "io"
keywordSomething = reserved "something"
Expand All @@ -864,8 +854,6 @@ keywordSuprefsNew = reserved "suprefs!"
keywordUserrefs = reserved "userRefs"
keywordUserrefsNew = reserved "userRefs!"
keywordFunction = reserved "function"
keywordDFS = reserved "dfs"
keywordBFS = reserved "bfs"

sign :: Num a => Parser (a -> a)
sign = (char '-' >> return negate)
Expand Down
60 changes: 6 additions & 54 deletions hs-src/Language/Egison/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -104,19 +104,10 @@ module Language.Egison.Types
-- * Pattern matching
, Match
, PMMode (..)
, pmMode
, MatchingTree (..)
, MatchingState (..)
, MatchingStates (..)
, PatternBinding (..)
, LoopPatContext (..)
, topDFS
, containBFS
-- * makeLenses
, normalTree
, orderedOrTrees
, ids
, bool
-- * Errors
, EgisonError (..)
, liftError
Expand Down Expand Up @@ -264,11 +255,11 @@ data EgisonExpr =

| MatchExpr EgisonExpr EgisonExpr [MatchClause]
| MatchAllExpr EgisonExpr EgisonExpr [MatchClause]
| MatchAllDFSExpr EgisonExpr EgisonExpr [MatchClause]
| MatchLambdaExpr EgisonExpr [MatchClause]
| MatchAllLambdaExpr EgisonExpr [MatchClause]

| MatcherExpr MatcherInfo
| MatcherDFSExpr MatcherInfo
| AlgebraicDataMatcherExpr [(String, [EgisonExpr])]

| QuoteExpr EgisonExpr
Expand Down Expand Up @@ -362,9 +353,6 @@ data EgisonPattern =
| PlusPat [EgisonPattern]
| MultPat [EgisonPattern]
| PowerPat EgisonPattern EgisonPattern
| DFSPat' EgisonPattern
| DFSPat Id EgisonPattern
| BFSPat EgisonPattern
deriving (Show, Eq)

data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern
Expand Down Expand Up @@ -407,7 +395,7 @@ data EgisonValue =
| IntHash (HashMap Integer EgisonValue)
| CharHash (HashMap Char EgisonValue)
| StrHash (HashMap Text EgisonValue)
| UserMatcher Env MatcherInfo PMMode
| UserMatcher Env MatcherInfo
| Func (Maybe Var) Env [String] EgisonExpr
| PartialFunc Env Integer EgisonExpr
| CFunc (Maybe Var) Env String EgisonExpr
Expand Down Expand Up @@ -1628,59 +1616,25 @@ refVar (Env env _) var = msum $ map (HashMap.lookup var) env

type Match = [Binding]

data PMMode = BFSMode | DFSMode Id
data PMMode = BFSMode | DFSMode
deriving (Show)

data MatchingState = MState PMMode Env [LoopPatContext] [Binding] [MatchingTree]
data MatchingState = MState Env [LoopPatContext] [Binding] [MatchingTree] -- [MatchingTree]

instance Show MatchingState where
show (MState mode _ _ bindings mtrees) = "(MState " ++ unwords [show mode, "_", "_", show bindings, show mtrees] ++ ")"

pmMode :: MatchingState -> PMMode
pmMode (MState mode _ _ _ _) = mode
show (MState _ _ bindings mtrees) = "(MState " ++ unwords ["_", "_", show bindings, show mtrees] ++ ")"
-- show (MState _ _ bindings mtrees nextmtrees) = "(MState " ++ unwords ["_", "_", show bindings, show mtrees, show nextmtrees] ++ ")"

data MatchingTree =
MAtom EgisonPattern WHNFData Matcher
| MNode [PatternBinding] MatchingState
deriving (Show)

data MatchingStates = MatchingStates { _normalTree :: [[MList EgisonM MatchingState]],
_orderedOrTrees :: Map Id (Map Int [MList EgisonM MatchingState]),
_ids :: [Id],
_bool :: Bool
} deriving (Show)

type PatternBinding = (String, EgisonPattern)

data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern
deriving (Show)

topDFS :: EgisonPattern -> Bool
topDFS (DFSPat _ _) = True
topDFS (InductivePat _ (pattern:_)) = topDFS pattern
topDFS (LetPat _ pattern) = topDFS pattern
topDFS _ = False

containBFS :: EgisonPattern -> Bool
containBFS (BFSPat _) = True
containBFS (IndexedPat pattern _) = containBFS pattern
containBFS (NotPat pattern) = containBFS pattern
containBFS (AndPat patterns) = any containBFS patterns
containBFS (OrPat patterns) = any containBFS patterns
containBFS (OrderedOrPat _ pat1 pat2) = containBFS pat1 || containBFS pat2
containBFS (TuplePat patterns) = any containBFS patterns
containBFS (InductivePat _ patterns) = any containBFS patterns
containBFS (LoopPat _ _ pat1 pat2) = containBFS pat1 || containBFS pat2
containBFS (PApplyPat _ patterns) = any containBFS patterns
containBFS (DApplyPat pat patterns) = any containBFS (pat:patterns)
containBFS (DivPat pat1 pat2) = containBFS pat1 || containBFS pat2
containBFS (PlusPat patterns) = any containBFS patterns
containBFS (MultPat patterns) = any containBFS patterns
containBFS (PowerPat pat1 pat2) = containBFS pat1 || containBFS pat2
containBFS (DFSPat _ pattern) = containBFS pattern
containBFS (LetPat _ pattern) = containBFS pattern
containBFS _ = False

--
-- Errors
--
Expand Down Expand Up @@ -1978,5 +1932,3 @@ varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is
f (Superscript ()) = Superscript ""
f (Subscript ()) = Subscript ""
f (SupSubscript ()) = SupSubscript ""

makeLenses ''MatchingStates
34 changes: 34 additions & 0 deletions sample/salesman2.egi
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,34 @@
;;;
;;; Travelling Salesman Problem
;;;

(define $station string)
(define $price integer)
(define $graph (multiset [station (multiset [station price])]))

(define $graph-data
{["Berlin" { ["St. Louis" 14] ["Oxford" 2] ["Nara" 14] ["Vancouver" 13]}]
["St. Louis" {["Berlin" 14] ["Oxford" 12] ["Nara" 18] ["Vancouver" 6]}]
["Oxford" {["Berlin" 2] ["St. Louis" 12] ["Nara" 15] ["Vancouver" 10]}]
["Nara" {["Berlin" 14] ["St. Louis" 18] ["Oxford" 15] ["Vancouver" 12]}]
["Vancouver" {["Berlin" 13] ["St. Louis" 6] ["Oxford" 10] ["Nara" 12] }]})


(define $trips ; List up all routes that visit each city exactly once and return to Tokyo
(match-all graph-data graph
[<cons [,"Berlin" <cons [$s_1 $p_1] _>]
(loop $i [2 4]
<cons [,s_(- i 1) <cons [$s_i $p_i] _>]
...>
<cons [,s_4 <cons [(& ,"Berlin" $s_5) $p_5] _>]
_>)>
[(sum (map (lambda [$i] p_i) (between 1 5)))
s]]))

(define $main
(lambda [$args]
(do {[(print "Route list:")]
[(each (compose show print) trips)]
[(write "Lowest price:")]
[(print (show (min (map (lambda [$x $y] x) trips))))]})))

1 change: 1 addition & 0 deletions small-benchmark/fact-bench.egi
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
(fact 10000)
Loading

0 comments on commit 69104d1

Please sign in to comment.