diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.5.7 +Version: 3.5.8 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -170,6 +170,7 @@ ((equal "execute" name) 2) ((equal "lambda" name) 2) ((equal "memoized-lambda" name) 2) + ((equal "memoize" name) 2) ((equal "letrec" name) 2) ((equal "let" name) 2) ((equal "let*" name) 2) diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -308,6 +308,21 @@ return whnf _ -> applyFunc func arg +evalExpr env (MemoizeExpr memoizeFrame expr) = do + mapM (\(x, y, z) -> do x' <- evalExprDeep env x + case x' of + (MemoizedFunc ref hashRef env' names body) -> do + indices <- evalExprDeep env y + indices' <- mapM fromEgison $ fromTupleValue indices + hash <- liftIO $ readIORef hashRef + ret <- evalExprDeep env z + retRef <- newEvalutedObjectRef (Value ret) + liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) + writeObjectRef ref (Value (MemoizedFunc ref hashRef env' names body)) + _ -> throwError $ TypeMismatch "memoized-function" (Value x')) + memoizeFrame + evalExpr env expr + evalExpr env (MatcherBFSExpr info) = return $ Value $ UserMatcher env BFSMode info evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info @@ -478,9 +493,6 @@ MemoizedLambdaExpr names body -> do hashRef <- liftIO $ newIORef HL.empty liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc ref hashRef env' names body - MemoizeExpr fnExpr -> do - hashRef <- liftIO $ newIORef HL.empty - liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc ref hashRef env' ["arg"] (ApplyExpr fnExpr (VarExpr "arg")) _ -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs exprs return env' @@ -648,10 +660,12 @@ else do (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) carEndsNum <- evalRef carEndsRef >>= fromWHNF - if startNum == carEndsNum - then return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), - MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] - else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] + if startNum > carEndsNum + then return MNil + else if startNum == carEndsNum + then return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), + MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] + else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] AndPat patterns -> let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees in return $ msingleton $ MState env loops bindings trees' diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -172,9 +172,14 @@ expr' <- desugar expr return $ MemoizedLambdaExpr names expr' -desugar (MemoizeExpr expr) = do +desugar (MemoizeExpr memoizeBindings expr) = do + memoizeBindings' <- mapM (\(x,y,z) -> do x' <- desugar x + y' <- desugar y + z' <- desugar z + return (x',y',z')) + memoizeBindings expr' <- desugar expr - return $ MemoizeExpr expr' + return $ MemoizeExpr memoizeBindings' expr' desugar (PatternFunctionExpr names pattern) = do pattern' <- desugarPattern pattern diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -315,8 +315,14 @@ memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr memoizeExpr :: Parser EgisonExpr -memoizeExpr = keywordMemoize >> MemoizeExpr <$> expr +memoizeExpr = keywordMemoize >> MemoizeExpr <$> memoizeFrame <*> expr +memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)] +memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace + +memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr) +memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr + patternFunctionExpr :: Parser EgisonExpr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern @@ -646,7 +652,7 @@ keywordApply = reserved "apply" keywordLambda = reserved "lambda" keywordMemoizedLambda = reserved "memoized-lambda" -keywordMemoize = reserved "memoize" +keywordMemoize = reserved "memoize" keywordPatternFunction = reserved "pattern-function" keywordLetRec = reserved "letrec" keywordLet = reserved "let" diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -143,7 +143,7 @@ | LambdaExpr [String] EgisonExpr | MemoizedLambdaExpr [String] EgisonExpr - | MemoizeExpr EgisonExpr + | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr | PatternFunctionExpr [String] EgisonPattern | IfExpr EgisonExpr EgisonExpr EgisonExpr diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -4,7 +4,7 @@ ;;;;; ;;;;; -(define $builtin-data-matcher +(define $eq (matcher-dfs {[,$val [] {[$tgt (if (eq? val tgt) @@ -14,10 +14,10 @@ {[$tgt {tgt}]}] })) -(define $bool builtin-data-matcher) -(define $char builtin-data-matcher) -(define $integer builtin-data-matcher) -(define $float builtin-data-matcher) +(define $bool eq) +(define $char eq) +(define $integer eq) +(define $float eq) ;; ;; Utility diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -263,14 +263,6 @@ (lambda [$x] {x @(repeat1 x)})) -(define $merge - (lambda [$xs $ys] - (match [xs ys] [(list something) (list something)] - {[[ _] ys] - [[_ ] xs] - [[ ] {x @(merge txs ys)}] - [[_ ] {y @(merge xs tys)}]}))) - ;; ;; Others ;; diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -34,8 +34,7 @@ (define $prime? (lambda [$n] - (not (any 1#(eq? (remainder n %1) 0) - (while (lte? $ (floor (sqrt (itof n)))) primes))))) + (eq? n (find-factor n)))) (define $primes {2 @(filter prime? (drop 2 nats))}) @@ -44,9 +43,10 @@ (eq? 0 (remainder n d)))) (define $find-factor - (lambda [$n] - (match primes (list integer) - {[> x]}))) + (memoized-lambda [$n] + (match (while (lte? $ (floor (sqrt (itof n)))) primes) (list integer) + {[> x] + [_ n]}))) (define $prime-factorization (match-lambda integer diff --git a/lib/core/order.egi b/lib/core/order.egi --- a/lib/core/order.egi +++ b/lib/core/order.egi @@ -87,3 +87,24 @@ [$p (nth (quotient n 2) xs)] [[$ys1 $ys2 $ys3] (split-by-ordering/fn f p xs)]} {@(sort/fn f ys1) @ys2 @(sort/fn f ys3)})]}))) + +(define $sort-strings + (lambda [$xs] + (sort/fn 2#(compare-c (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs))) + +(define $merge + (lambda [$xs $ys] + (match [xs ys] [(list something) (list something)] + {[[ _] ys] + [[_ ] xs] + [[ ] {x @(merge txs ys)}] + [[_ ] {y @(merge xs tys)}]}))) + +(define $merge/fn + (lambda [$f $xs $ys] + (match [xs ys] [(list something) (list something)] + {[[ _] ys] + [[_ ] xs] + [[ ) _>] {x @(merge txs ys)}] + [[_ ] {y @(merge xs tys)}]}))) +