diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,11 +1,11 @@ Name: egison -Version: 3.3.5 +Version: 3.3.6 Synopsis: Programming language with non-linear pattern-matching against unfree data Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching against unfree data types. With Egison, we can directly represent pattern-matching against a wide range of data types such as lists, multisets, sets, trees and graphs. We can find Egison programs in @lib@ and @sample@ directories. - This package also include Emacs Lisp file @egison-mode.el@ in @elisp@ directory. + This package also include Emacs Lisp file @elisp/egison-mode.el@. . The following code is the program that determines poker-hands written in Egison. All hands are expressed in a single pattern. @@ -31,7 +31,7 @@ Extra-Source-Files: benchmark/Benchmark.hs -Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/string.egi lib/core/database.egi lib/core/io.egi +Data-files: lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/natural-number.egi lib/core/math.egi lib/core/string.egi lib/core/database.egi lib/core/io.egi lib/tree/xml.egi lib/math/prime.egi sample/*.egi sample/io/*.egi sample/io/*.egi elisp/egison-mode.el diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -18,6 +18,7 @@ "\\" "\\" + "\\" "\\" "\\" "\\" @@ -131,6 +132,7 @@ ((equal "load-file" name) 2) ((equal "execute" name) 2) ((equal "lambda" name) 2) + ((equal "memoized-lambda" name) 2) ((equal "let" name) 2) ((equal "letrec" name) 2) ((equal "if" name) 2) diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -105,6 +105,7 @@ , "lib/core/order.egi" , "lib/core/number.egi" , "lib/core/natural-number.egi" + , "lib/core/math.egi" , "lib/core/string.egi" , "lib/core/database.egi" , "lib/core/io.egi" 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 @@ -186,42 +186,9 @@ array <- evalExpr env expr indices <- mapM (evalExprDeep env) indices refArray array indices - where - refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData - refArray val [] = return val - refArray (Value (Array array)) (index:indices) = do - i <- (liftM fromInteger . fromEgison) index - case IntMap.lookup (i + 1) array of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined - refArray (Intermediate (IArray array)) (index:indices) = do - i <- (liftM fromInteger . fromEgison) index - case IntMap.lookup (i + 1) array of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined - refArray (Value (IntHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined - refArray (Intermediate (IIntHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined - refArray (Value (StrHash hash)) (index:indices) = do - key <- evalStringWHNF $ Value index - case HL.lookup (B.pack key) hash of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined - refArray (Intermediate (IStrHash hash)) (index:indices) = do - key <- evalStringWHNF $ Value index - case HL.lookup (B.pack key) hash of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined - refArray val _ = throwError $ TypeMismatch "array or hash" val -evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr +evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr + evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern evalExpr env (IfExpr test expr expr') = do @@ -301,7 +268,22 @@ evalExpr env (ApplyExpr func arg) = do func <- evalExpr env func arg <- evalExpr env arg - applyFunc func arg + case func of + Value (MemoizedFunc ref hashRef env names body) -> do + indices <- evalWHNF arg + indices' <- mapM fromEgison $ fromTupleValue indices + hash <- liftIO $ readIORef hashRef + case HL.lookup indices' hash of + Just objRef -> do + evalRef objRef + Nothing -> do + whnf <- applyFunc (Value (Func env names body)) arg + retRef <- newEvalutedObjectRef whnf + hash <- liftIO $ readIORef hashRef + liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) + writeObjectRef ref (Value (MemoizedFunc ref hashRef env names body)) + return whnf + _ -> applyFunc func arg evalExpr env (MatcherBFSExpr info) = return $ Value $ UserMatcher env BFSMode info evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info @@ -401,6 +383,40 @@ ref <- newEvalutedObjectRef (Value . Integer $ i) return $ extendEnv env [(name, ref)] +refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData +refArray val [] = return val +refArray (Value (Array array)) (index:indices) = do + i <- (liftM fromInteger . fromEgison) index + case IntMap.lookup (i + 1) array of + Just val -> refArray (Value val) indices + Nothing -> return $ Value Undefined +refArray (Intermediate (IArray array)) (index:indices) = do + i <- (liftM fromInteger . fromEgison) index + case IntMap.lookup (i + 1) array of + Just ref -> evalRef ref >>= flip refArray indices + Nothing -> return $ Value Undefined +refArray (Value (IntHash hash)) (index:indices) = do + key <- fromEgison index + case HL.lookup key hash of + Just val -> refArray (Value val) indices + Nothing -> return $ Value Undefined +refArray (Intermediate (IIntHash hash)) (index:indices) = do + key <- fromEgison index + case HL.lookup key hash of + Just ref -> evalRef ref >>= flip refArray indices + Nothing -> return $ Value Undefined +refArray (Value (StrHash hash)) (index:indices) = do + key <- evalStringWHNF $ Value index + case HL.lookup (B.pack key) hash of + Just val -> refArray (Value val) indices + Nothing -> return $ Value Undefined +refArray (Intermediate (IStrHash hash)) (index:indices) = do + key <- evalStringWHNF $ Value index + case HL.lookup (B.pack key) hash of + Just ref -> evalRef ref >>= flip refArray indices + Nothing -> return $ Value Undefined +refArray val _ = throwError $ TypeMismatch "array or hash" val + newThunk :: Env -> EgisonExpr -> Object newThunk env expr = Thunk $ evalExpr env expr @@ -421,7 +437,13 @@ let (names, exprs) = unzip bindings refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr let env' = extendEnv env $ makeBindings names refs - zipWithM_ (\ref expr -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs exprs + zipWithM_ (\ref expr -> + case expr of + MemoizedLambdaExpr names body -> do + hashRef <- liftIO $ newIORef HL.empty + liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc ref hashRef env' names body + _ -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) + refs exprs return env' -- 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 @@ -157,6 +157,7 @@ <|> collectionExpr <|> parens (ifExpr <|> lambdaExpr + <|> memoizedLambdaExpr <|> patternFunctionExpr <|> letRecExpr <|> letExpr @@ -296,6 +297,9 @@ lambdaExpr :: Parser EgisonExpr lambdaExpr = keywordLambda >> LambdaExpr <$> varNames <*> expr +memoizedLambdaExpr :: Parser EgisonExpr +memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr + patternFunctionExpr :: Parser EgisonExpr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern @@ -519,6 +523,7 @@ , "if" , "apply" , "lambda" + , "memoized-lambda" , "pattern-function" , "letrec" , "let" @@ -567,6 +572,7 @@ keywordElse = reserved "else" keywordApply = reserved "apply" keywordLambda = reserved "lambda" +keywordMemoizedLambda = reserved "memoized-lambda" 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 @@ -136,6 +136,7 @@ | HashExpr [(EgisonExpr, EgisonExpr)] | LambdaExpr [String] EgisonExpr + | MemoizedLambdaExpr [String] EgisonExpr | PatternFunctionExpr [String] EgisonPattern | IfExpr EgisonExpr EgisonExpr EgisonExpr @@ -235,6 +236,7 @@ | StrHash (HashMap ByteString EgisonValue) | UserMatcher Env PMMode MatcherInfo | Func Env [String] EgisonExpr + | MemoizedFunc ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr | PatternFunc Env [String] EgisonPattern | PrimitiveFunc PrimitiveFunc | IOFunc (EgisonM WHNFData) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -114,6 +114,13 @@ [ (let {[$y (fn init x)]} (foldl fn y xs))]}))) +(define $scanl + (lambda [$fn $init $ls] + {init @(match ls (list something) + {[ {}] + [ (let {[$y (fn init x)]} + (scanl fn y xs))]})})) + (define $map2 (lambda [$fn $xs $ys] (match [xs ys] [(list something) (list something)] @@ -194,6 +201,16 @@ (lambda [$a $x $xs] (length (match-all xs (list a) [> x])))) + +(define $frequency + (lambda [$xs] + (let {[$us (unique xs)]} + (map (lambda [$u] [u (count u xs)]) us)))) + +(define $frequency/m + (lambda [$a $xs] + (let {[$us (unique/m a xs)]} + (map (lambda [$u] [u (count/m a u xs)]) us)))) ;; ;; Simple accessors diff --git a/lib/core/math.egi b/lib/core/math.egi new file mode 100644 --- /dev/null +++ b/lib/core/math.egi @@ -0,0 +1,8 @@ +(define $permutation-count + (lambda [$n $r] + (foldl * 1 (between (- n (- r 1)) n)))) + +(define $combination-count + (lambda [$n $r] + (/ (permutation-count n r) + (fact r))))