enable to use function symbol in tensor

Author: kotapiku

hs-src/Language/Egison/Core.hs

@@ -223,10 +223,21 @@ evalExpr env (VectorExpr exprs) = do
   whnfs <- mapM (evalExpr env) exprs
   case whnfs of
     ((Intermediate (ITensor (Tensor _ _ _))):_) -> do
-      ret <- mapM toTensor whnfs >>= tConcat' >>= fromTensor
+      ret <- mapM toTensor (map f $ zip whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor
       return ret
-    _ -> do
-      fromTensor (Tensor [fromIntegral (length whnfs)] (V.fromList whnfs) [])
+    _ -> fromTensor (Tensor [fromIntegral $ length whnfs] (V.fromList whnfs) [])
+ where
+  f ((Intermediate (ITensor (Tensor ns xs indices))), i) =
+    Intermediate $ ITensor $ Tensor ns (V.fromList $ map g $ zip (V.toList xs) $ map (\ms -> map toEgison $ (toInteger i):ms) $ enumTensorIndices ns) indices
+  f (x, _) = x
+  g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) =
+    let Env _ maybe_vwi = env in
+    let fn' = case maybe_vwi of
+                Nothing -> fn
+                Just (VarWithIndices nameString indexList) ->
+                   Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms in
+    Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p
+  g (x, _) = x
 
 evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do
   nsWhnf <- evalExpr env nsExpr
@@ -690,11 +701,6 @@ evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do
     applyFunc env fn (Value (makeTuple ms)))
                 (map (\ms -> map toEgison ms) (enumTensorIndices ns))
   fromTensor (Tensor ns (V.fromList xs) [])
- where
-   changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]
-   changeIndexList idxlist ms = map (\(i, m) -> case i of
-                                                  Superscript s -> Superscript (s ++ m)
-                                                  Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)
 
 evalExpr env (TensorContractExpr fnExpr tExpr) = do
   fn <- evalExpr env fnExpr
@@ -1007,6 +1013,7 @@ recursiveBind env bindings = do
   let (names, exprs) = unzip bindings
   refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr
   let env' = extendEnv env $ makeBindings names refs
+  let Env frame _ = env'
   zipWithM_ (\ref (name,expr) -> do
                case expr of
                  MemoizedLambdaExpr names body -> do
@@ -1021,14 +1028,14 @@ recursiveBind env bindings = do
                    case whnf of
                      (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body))
                  FunctionExpr args -> do
-                   let Env frame _ = env'
                    liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args
-                 GenerateTensorExpr _ _ -> do
-                   let Env frame _ = env'
-                   liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ expr
-                 _ -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)
+                 _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr
+                   | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)
             refs bindings
   return env'
+ where
+  isVarWithIndices :: Var -> Bool
+  isVarWithIndices (Var _ xs) = not $ null xs
 
 recursiveRebind :: Env -> (Var, EgisonExpr) -> EgisonM Env
 recursiveRebind env (name, expr) = do

hs-src/Language/Egison/ParserNonS.hs

@@ -230,6 +230,7 @@ term' :: Parser EgisonExpr
 term' = matchExpr
         <|> matchAllExpr
         <|> matchLambdaExpr
+        <|> matchAllLambdaExpr
         <|> matcherExpr
         <|> matcherDFSExpr
         <|> functionWithArgExpr
@@ -318,19 +319,22 @@ quoteSymbolExpr :: Parser EgisonExpr
 quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr
 
 matchAllExpr :: Parser EgisonExpr
-matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* (inSpaces $ string "as") <*> expr <*> matchClauses
+matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <* keywordAs <*> expr <*> matchClauses
 
 matchExpr :: Parser EgisonExpr
-matchExpr = keywordMatch >> MatchExpr <$> expr <* (inSpaces $ string "as") <*> expr <*> matchClauses
+matchExpr = keywordMatch >> MatchExpr <$> expr <* keywordAs <*> expr <*> matchClauses
 
 matchLambdaExpr :: Parser EgisonExpr
-matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$ (inSpaces $ string "as") <*> expr <*> matchClauses
+matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$ keywordAs <*> expr <*> matchClauses
+
+matchAllLambdaExpr :: Parser EgisonExpr
+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$ keywordAs <*> expr <*> matchClauses
 
 matchClauses :: Parser [MatchClause]
 matchClauses = many1 matchClause
 
 matchClause :: Parser MatchClause
-matchClause = inSpaces (string "|") >> (,) <$> pattern <* (reservedOp "->") <*> expr
+matchClause = try $ inSpaces (string "|") >> (,) <$> pattern <* (reservedOp "->") <*> expr
 
 matcherExpr :: Parser EgisonExpr
 matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses

hs-src/Language/Egison/Types.hs

@@ -43,6 +43,7 @@ module Language.Egison.Types
     , tIndex
     , tref
     , enumTensorIndices
+    , changeIndexList
     , tTranspose
     , tTranspose'
     , tFlipIndices
@@ -879,6 +880,11 @@ enumTensorIndices :: [Integer] -> [[Integer]]
 enumTensorIndices [] = [[]]
 enumTensorIndices (n:ns) = concatMap (\i -> (map (\is -> i:is) (enumTensorIndices ns))) [1..n]
 
+changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]
+changeIndexList idxlist ms = map (\(i, m) -> case i of
+                                              Superscript s -> Superscript (s ++ m)
+                                              Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)
+
 transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer]
 transIndex [] [] is = return is
 transIndex (j1:js1) js2 is = do

nons-test/test/lib/math/tensor.egi

@@ -65,3 +65,8 @@ assertEqual("generate_tensor by using function expr",
                     [3, 3]) in
    show(withSymbols {i, j} d/d(g_i_j, x)),
   "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]")
+
+assertEqual("define tensor having value of function expr",
+  letrec g__ = [| [| function(x, y, z), 0, 0 |], [| 0, function(x, y, z), 0 |], [| 0, 0, function(x, y, z) |] |] in
+    show(withSymbols {i, j} d/d(g_i_j, x)),
+  "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]")

nons-test/test/syntax.egi

@@ -104,19 +104,31 @@ assertEqual("match-all",
   | $x<:>$xs -> [x, xs],
   [[1, [2, 3]]])
 
+assertEqual("match-all-multi",
+  matchAll [1, 2, 3] as multiset(integer)
+  | $x <:> (x + 1) <:> _ -> [x, x + 1]
+  | $x <:> (x + 2) <:> _ -> [x, x + 2],
+  [[1, 2], [2, 3], [1, 3]])
+
 assertEqual("match-lambda",
-  letrec count = $l ->
-    match l as list(something)
+  letrec count =
+    matchLambda as list(something)
     | <nil> -> 0
     | _<:>$xs -> count(xs)+1 in
   count([1, 2, 3]),
   3)
 
 assertEqual("match-all-lambda",
-  ($l -> matchAll l as list(something)
-         | _ <++> $x <:> _ -> x)([1, 2, 3]),
+  (matchAllLambda as list(something)
+   | _ <++> $x <:> _ -> x)([1, 2, 3]),
   [1, 2, 3])
 
+assertEqual("match-all-lambda-multi",
+  (matchAllLambda as multiset(something)
+   | $x <:> (x + 1) <:> _ -> [x, x + 1]
+   | $x <:> (x + 2) <:> _ -> [x, x + 2])([1, 2, 3]),
+  [[1, 2], [2, 3], [1, 3]])
+
 assertEqual("pattern variable",
   match 1 as something
   | $x -> x,

test/lib/math/tensor.egi

@@ -78,3 +78,8 @@
                     {3 3})]}
      (show (with-symbols {i j} (d/d g_i_j x))))
   "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]")
+
+(assert-equal "define tensor having value of function expr"
+  (letrec {[$g__ [| [| (function [x y z]) 0 0 |] [| 0 (function [x y z]) 0 |] [| 0 0 (function [x y z]) |] |]]}
+     (show (with-symbols {i j} (d/d g_i_j x))))
+  "[| [| g_1_1|x 0 0 |] [| 0 g_2_2|x 0 |] [| 0 0 g_3_3|x |] |]")