diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.7.9 +Version: 3.7.10 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. @@ -78,6 +78,7 @@ Language.Egison.Parser Language.Egison.Primitives Language.Egison.Util + Language.Egison.MathOutput Other-modules: Paths_egison ghc-options: -O3 diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -20,6 +20,7 @@ import Language.Egison import Language.Egison.Util +import Language.Egison.MathOutput main :: IO () main = do args <- getArgs @@ -28,7 +29,7 @@ case opts of Options {optShowHelp = True} -> printHelp Options {optShowVersion = True} -> printVersionNumber - Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag} -> do + Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag, optMathExpr = mathExprLang} -> do coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv mEnv <- evalEgisonTopExprs coreEnv $ (map Load loadLibs) ++ (map LoadFile loadFiles) case mEnv of @@ -60,7 +61,7 @@ Nothing -> case nonOpts of [] -> do - when bannerFlag showBanner >> repl noIOFlag env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess + when bannerFlag showBanner >> repl noIOFlag mathExprLang env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess (file:args) -> do case opts of Options {optTestOnly = True} -> do @@ -86,7 +87,8 @@ optNoIO :: Bool, optShowBanner :: Bool, optTestOnly :: Bool, - optPrompt :: String + optPrompt :: String, + optMathExpr :: Maybe String } defaultOptions :: Options @@ -103,7 +105,8 @@ optNoIO = False, optShowBanner = True, optTestOnly = False, - optPrompt = "> " + optPrompt = "> ", + optMathExpr = Nothing } options :: [OptDescr (Options -> Options)] @@ -161,7 +164,11 @@ Option ['F'] ["--field"] (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [(readFieldOption d)]}) "String") - "field information" + "field information", + Option ['M'] ["math"] + (ReqArg (\lang opts -> opts {optMathExpr = Just lang}) + "String") + "output in LaTeX format" ] readFieldOption :: String -> (String, String) @@ -227,8 +234,8 @@ showByebyeMessage :: IO () showByebyeMessage = putStrLn $ "Leaving Egison Interpreter." -repl :: Bool -> Env -> String -> IO () -repl noIOFlag env prompt = do +repl :: Bool -> (Maybe String) -> Env -> String -> IO () +repl noIOFlag mathExprLang env prompt = do loop env where settings :: MonadIO m => FilePath -> Settings m @@ -247,12 +254,19 @@ putStrLn "error: No IO support" loop env (_, Just (topExpr, _)) -> do - result <- liftIO $ runEgisonTopExpr env topExpr + result <- liftIO $ runEgisonTopExpr' env topExpr case result of Left err -> do liftIO $ putStrLn $ show err loop env - Right env' -> loop env') + Right (Nothing, env') -> loop env' + Right (Just output, env') -> + case mathExprLang of + Nothing -> putStrLn output >> loop env' + (Just "haskell") -> putStrLn (mathExprToHaskell output) >> loop env' + (Just "asciimath") -> putStrLn (mathExprToAsciiMath output) >> loop env' + (Just "latex") -> putStrLn (mathExprToLatex output) >> loop env' + ) `catch` (\e -> case e of UserInterrupt -> putStrLn "" >> loop env 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 @@ -17,6 +17,7 @@ , evalEgisonTopExprsTestOnly , runEgisonExpr , runEgisonTopExpr + , runEgisonTopExpr' , runEgisonTopExprs , runEgisonTopExprsNoIO -- * Load Egison files @@ -64,6 +65,10 @@ -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr :: Env -> String -> IO (Either EgisonError Env) runEgisonTopExpr env input = fromEgisonM $ readTopExpr input >>= evalTopExpr env + +-- |eval an Egison top expression. Input is a Haskell string. +runEgisonTopExpr' :: Env -> String -> IO (Either EgisonError (Maybe String, Env)) +runEgisonTopExpr' env input = fromEgisonM $ readTopExpr input >>= evalTopExpr' env -- |eval Egison top expressions. Input is a Haskell string. runEgisonTopExprs :: Env -> String -> IO (Either EgisonError Env) 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 @@ -15,6 +15,7 @@ , evalTopExprsTestOnly , evalTopExprsNoIO , evalTopExpr + , evalTopExpr' , evalExpr , evalExprDeep , evalRef @@ -416,6 +417,17 @@ return (Intermediate (ITensor t')) (Value (TensorData t)) -> do t' <- tTranspose' syms t + return (Value (TensorData t')) + _ -> return whnf + +evalExpr env (FlipIndicesExpr expr) = do + whnf <- evalExpr env expr + case whnf of + (Intermediate (ITensor t)) -> do + t' <- tFlipIndices t + return (Intermediate (ITensor t')) + (Value (TensorData t)) -> do + t' <- tFlipIndices t return (Value (TensorData t')) _ -> return whnf 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 @@ -187,10 +187,14 @@ desugar (LambdaExpr names expr) = do let (rtnames, rhnames) = span (\name -> case name of TensorArg _ -> True + InvertedScalarArg _ -> False ScalarArg _ -> False) (reverse names) case rhnames of [] -> do expr' <- desugar expr return $ LambdaExpr names expr' + (InvertedScalarArg rhname:rhnames') -> do + desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames) + (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (VarExpr rhname))) (ScalarArg rhname:rhnames') -> do let (rtnames2, rhnames2) = span (\name -> case name of TensorArg _ -> True @@ -313,6 +317,10 @@ vars' <- desugar vars expr' <- desugar expr return $ TransposeExpr vars' expr' + +desugar (FlipIndicesExpr expr) = do + expr' <- desugar expr + return $ FlipIndicesExpr expr' desugar (ParExpr expr1 expr2) = do expr1' <- desugar expr1 diff --git a/hs-src/Language/Egison/MathOutput.hs b/hs-src/Language/Egison/MathOutput.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/MathOutput.hs @@ -0,0 +1,278 @@ +{- | +Module : Language.Egison.MathOutput +Copyright : Satoshi Egi +Licence : MIT + +This module provides utility functions. +-} + +module Language.Egison.MathOutput (mathExprToHaskell, mathExprToAsciiMath, mathExprToLatex) where + +import Control.Monad +import System.Environment +import Text.ParserCombinators.Parsec hiding (spaces) + +mathExprToHaskell :: String -> String +mathExprToHaskell input = case parse parseExpr "math-expr" input of + Left err -> input + Right val -> "#haskell\"" ++ show val ++ "\"" + +mathExprToAsciiMath :: String -> String +mathExprToAsciiMath input = case parse parseExpr "math-expr" input of + Left err -> input + Right val -> "#asciimath\"" ++ showMathExprAsciiMath val ++ "\"" + +mathExprToLatex :: String -> String +mathExprToLatex input = case parse parseExpr "math-expr" input of + Left err -> input + Right val -> "#latex|" ++ showMathExprLatex val ++ "|#" + +data MathExpr = Atom String + | NegativeAtom String + | Plus [MathExpr] + | Multiply [MathExpr] + | Power MathExpr MathExpr + | Func MathExpr [MathExpr] + | Tensor [MathExpr] [MathIndex] + | Tuple [MathExpr] + | Collection [MathExpr] + | Exp MathExpr + | Quote MathExpr + | Partial String [String] + deriving (Eq, Show) + +data MathIndex = Super MathExpr + | Sub MathExpr + deriving (Eq, Show) + +-- +-- Show (AsciiMath) +-- + +showMathIndexAsciiMath :: MathIndex -> String +showMathIndexAsciiMath (Super a) = showMathExprAsciiMath a +showMathIndexAsciiMath (Sub a) = showMathExprAsciiMath a + +showMathExprAsciiMath :: MathExpr -> String +showMathExprAsciiMath (Atom func) = func +showMathExprAsciiMath (NegativeAtom func) = "-" ++ func +showMathExprAsciiMath (Plus []) = "" +showMathExprAsciiMath (Plus (x:xs)) = showMathExprAsciiMath x ++ showMathExprAsciiMathForPlus xs + where + showMathExprAsciiMathForPlus :: [MathExpr] -> String + showMathExprAsciiMathForPlus [] = "" + showMathExprAsciiMathForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprAsciiMathForPlus xs + showMathExprAsciiMathForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprAsciiMath (Multiply ((Atom a):ys)) ++ " " ++ showMathExprAsciiMathForPlus xs + showMathExprAsciiMathForPlus (x:xs) = showMathExprAsciiMath x ++ " + " ++ showMathExprAsciiMathForPlus xs +showMathExprAsciiMath (Multiply []) = "" +showMathExprAsciiMath (Multiply [a]) = showMathExprAsciiMath a +showMathExprAsciiMath (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExprAsciiMath (Multiply lvs) +showMathExprAsciiMath (Multiply lvs) = showMathExprAsciiMath' (head lvs) ++ " " ++ showMathExprAsciiMath (Multiply (tail lvs)) +showMathExprAsciiMath (Power lv1 lv2) = showMathExprAsciiMath lv1 ++ "^" ++ showMathExprAsciiMath lv2 +showMathExprAsciiMath (Func f lvs) = case f of + Atom "/" -> if length lvs == 2 then "frac{" ++ showMathExprAsciiMath (head lvs) ++ "}{" ++ showMathExprAsciiMath (lvs !! 1) ++ "}" + else showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" + _ -> showMathExprAsciiMath f ++ "(" ++ showMathExprAsciiMathArg lvs ++ ")" +showMathExprAsciiMath (Tensor lvs mis) + | null mis = "(" ++ showMathExprAsciiMathArg lvs ++ ")" + | not (any isSub mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")^(" ++ showMathExprAsciiMathIndices mis ++ ")" + | not (any (not . isSub) mis) = "(" ++ showMathExprAsciiMathArg lvs ++ ")_(" ++ showMathExprAsciiMathIndices mis ++ ")" + | otherwise = "(" ++ showMathExprAsciiMathArg lvs ++ ")_(" ++ showMathExprAsciiMathIndices (filter isSub mis) ++ ")^(" ++ showMathExprAsciiMathIndices (filter (not . isSub) mis) ++ ")" +showMathExprAsciiMath (Tuple lvs) = "(" ++ showMathExprAsciiMathArg lvs ++ ")" +showMathExprAsciiMath (Collection lvs) = "{" ++ showMathExprAsciiMathArg lvs ++ "}" +showMathExprAsciiMath (Exp x) = "e^(" ++ showMathExprAsciiMath x ++ ")" + +isSub :: MathIndex -> Bool +isSub x = case x of + Sub _ -> True + _ -> False + +showMathExprAsciiMath' :: MathExpr -> String +showMathExprAsciiMath' (Plus lvs) = "(" ++ showMathExprAsciiMath (Plus lvs) ++ ")" +showMathExprAsciiMath' val = showMathExprAsciiMath val + +showMathExprAsciiMathArg :: [MathExpr] -> String +showMathExprAsciiMathArg [] = "" +showMathExprAsciiMathArg [a] = showMathExprAsciiMath a +showMathExprAsciiMathArg lvs = showMathExprAsciiMath (head lvs) ++ ", " ++ (showMathExprAsciiMathArg (tail lvs)) + +showMathExprAsciiMathIndices :: [MathIndex] -> String +showMathExprAsciiMathIndices [a] = showMathIndexAsciiMath a +showMathExprAsciiMathIndices lvs = showMathIndexAsciiMath (head lvs) ++ showMathExprAsciiMathIndices (tail lvs) + +-- +-- Show (Latex) +-- + +showMathExprLatex :: MathExpr -> String +showMathExprLatex (Atom a) = a +showMathExprLatex (Partial a is) = a ++ "_{" ++ concat is ++ "}" +showMathExprLatex (NegativeAtom a) = "-" ++ a +showMathExprLatex (Plus []) = "" +showMathExprLatex (Plus (x:xs)) = showMathExprLatex x ++ showMathExprLatexForPlus xs + where + showMathExprLatexForPlus :: [MathExpr] -> String + showMathExprLatexForPlus [] = "" + showMathExprLatexForPlus ((NegativeAtom a):xs) = " - " ++ a ++ showMathExprLatexForPlus xs + showMathExprLatexForPlus ((Multiply (NegativeAtom a:ys)):xs) = " - " ++ showMathExprLatex (Multiply ((Atom a):ys)) ++ showMathExprLatexForPlus xs + showMathExprLatexForPlus (x:xs) = " + " ++ showMathExprLatex x ++ showMathExprLatexForPlus xs +showMathExprLatex (Multiply []) = "" +showMathExprLatex (Multiply [x]) = showMathExprLatex x +showMathExprLatex (Multiply (Atom "1":xs)) = showMathExprLatex (Multiply xs) +showMathExprLatex (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExprLatex (Multiply xs) +showMathExprLatex (Multiply (x:xs)) = showMathExprLatex' x ++ " " ++ showMathExprLatex (Multiply xs) +showMathExprLatex (Power lv1 lv2) = showMathExprLatex lv1 ++ "^" ++ showMathExprLatex lv2 +showMathExprLatex (Func (Atom "sqrt") [x]) = "\\sqrt{" ++ showMathExprLatex x ++ "}" +showMathExprLatex (Func (Atom "rt") [x, y]) = "\\sqrt[" ++ showMathExprLatex x ++ "]{" ++ showMathExprLatex y ++ "}" +showMathExprLatex (Func (Atom "/") [x, y]) = "\\frac{" ++ showMathExprLatex x ++ "}{" ++ showMathExprLatex y ++ "}" +showMathExprLatex (Func f xs) = showMathExprLatex f ++ "(" ++ showMathExprLatexArg xs ", " ++ ")" +showMathExprLatex (Tensor xs mis) = case head xs of + Tensor _ _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis + _ -> "\\begin{pmatrix} " ++ showMathExprLatexVectors xs ++ "\\end{pmatrix}" ++ showMathExprLatexScript mis +showMathExprLatex (Tuple xs) = "(" ++ showMathExprLatexArg xs ", " ++ ")" +showMathExprLatex (Collection xs) = "\\{" ++ showMathExprLatexArg xs ", " ++ "\\}" +showMathExprLatex (Exp x) = "e^{" ++ showMathExprLatex x ++ "}" +showMathExprLatex (Quote x) = "(" ++ showMathExprLatex x ++ ")" + +showMathExprLatex' :: MathExpr -> String +showMathExprLatex' (Plus xs) = "(" ++ showMathExprLatex (Plus xs) ++ ")" +showMathExprLatex' x = showMathExprLatex x + +showMathExprLatexArg :: [MathExpr] -> String -> String +showMathExprLatexArg [] _ = "" +showMathExprLatexArg [a] _ = showMathExprLatex a +showMathExprLatexArg lvs s = showMathExprLatex (head lvs) ++ s ++ showMathExprLatexArg (tail lvs) s + +showMathExprLatexSuper :: MathIndex -> String +showMathExprLatexSuper (Super (Atom "#")) = "\\#" +showMathExprLatexSuper (Super x) = showMathExprLatex x +showMathExprLatexSuper (Sub x) = "\\;" + +showMathExprLatexSub :: MathIndex -> String +showMathExprLatexSub (Sub (Atom "#")) = "\\#" +showMathExprLatexSub (Sub x) = showMathExprLatex x +showMathExprLatexSub (Super x) = "\\;" + +showMathExprLatexScript :: [MathIndex] -> String +showMathExprLatexScript [] = "" +showMathExprLatexScript is = "_{" ++ concat (map showMathExprLatexSub is) ++ "}^{" ++ concat (map showMathExprLatexSuper is) ++ "}" + +showMathExprLatexVectors :: [MathExpr] -> String +showMathExprLatexVectors [] = "" +showMathExprLatexVectors (Tensor lvs []:r) = showMathExprLatexArg lvs " & " ++ " \\\\ " ++ showMathExprLatexVectors r +showMathExprLatexVectors lvs = showMathExprLatexArg lvs " \\\\ " ++ "\\\\ " + +-- +-- Parser +-- + +spaces :: Parser () +spaces = skipMany1 space + +spaces0 :: Parser () +spaces0 = skipMany space + +symbol :: Parser Char +symbol = oneOf "!$%&*+-/:<=>?@#" + +parseAtom :: Parser MathExpr +parseAtom = do + first <- letter <|> symbol <|> digit + rest <- many (letter <|> digit <|> symbol) + let atom = first : rest + option (Atom atom) $ do is <- many1 (char '|' >> many digit) + return $ Partial atom is + +parseNegativeAtom :: Parser MathExpr +parseNegativeAtom = do + char '-' + first <- letter <|> symbol <|> digit + rest <- many (letter <|> digit <|> symbol) + let atom = first : rest + return $ NegativeAtom atom + +parseList :: Parser [MathExpr] +parseList = sepEndBy parseExpr spaces + +parseScript :: Parser MathIndex +parseScript = (Sub <$> (char '_' >> parseExpr)) <|> (Super <$> (char '~' >> parseExpr)) + +parsePlus :: Parser MathExpr +parsePlus = do + string "(+" + spaces + xs <- parseList + char ')' + return $ Plus xs + +parseMultiply :: Parser MathExpr +parseMultiply = do + string "(*" + spaces + xs <- parseList + char ')' + return $ Multiply xs + +parseFunction :: Parser MathExpr +parseFunction = do + char '(' + func <- parseAtom + spaces + xs <- parseList + char ')' + return $ Func func xs + +parseTensor :: Parser MathExpr +parseTensor = do + string "[|" + spaces0 + xs <- parseList + spaces0 + string "|]" + ys <- many parseScript + return $ Tensor xs ys + +parseTuple :: Parser MathExpr +parseTuple = do + char '[' + xs <- parseList + char ']' + return $ Tuple xs + +parseCollection :: Parser MathExpr +parseCollection = do + char '{' + xs <- parseList + char '}' + return $ Collection xs + +parseExp :: Parser MathExpr +parseExp = do + string "(exp" + spaces + x <- parseExpr + char ')' + return $ Exp x + +parseQuote :: Parser MathExpr +parseQuote = do + char '\'' + x <- parseExpr' + return $ Quote x + +parseExpr' :: Parser MathExpr +parseExpr' = parseNegativeAtom + <|> parseAtom + <|> parseQuote + <|> try parseExp + <|> try parsePlus + <|> try parseMultiply + <|> try parseFunction + <|> try parseTensor + <|> try parseTuple + <|> try parseCollection + +parseExpr :: Parser MathExpr +parseExpr = do + x <- parseExpr' + option x $ Power x <$> try (char '^' >> parseExpr') 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 @@ -474,6 +474,7 @@ argName :: Parser Arg argName = try (char '$' >> ident >>= return . ScalarArg) + <|> try (string "*$" >> ident >>= return . InvertedScalarArg) <|> try (char '%' >> ident >>= return . TensorArg) ioExpr :: Parser EgisonExpr diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -427,7 +427,7 @@ numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer) numberUnaryOp' (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term y [])]))) = return $ toEgison (quot x y) numberUnaryOp' (Float x _) = return $ toEgison ((truncate x) :: Integer) - numberUnaryOp' val = throwError $ TypeMismatch "ratinal or float" (Value val) + numberUnaryOp' val = throwError $ TypeMismatch "rational or float" (Value val) realPart :: PrimitiveFunc realPart = oneArg $ realPart' 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 @@ -46,6 +46,7 @@ , enumTensorIndices , tTranspose , tTranspose' + , tFlipIndices , appendDFscripts , removeDFscripts , tMap @@ -273,6 +274,7 @@ | TensorMapExpr EgisonExpr EgisonExpr | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr | TransposeExpr EgisonExpr EgisonExpr + | FlipIndicesExpr EgisonExpr | SomethingExpr | UndefinedExpr @@ -280,6 +282,7 @@ data Arg = ScalarArg String + | InvertedScalarArg String | TensorArg String deriving (Eq) @@ -851,6 +854,14 @@ (Just j') -> do js' <- g is js return $ j':js' +tFlipIndices :: HasTensor a => (Tensor a) -> EgisonM (Tensor a) +tFlipIndices (Tensor ns xs js) = do + return $ Tensor ns xs (map flipIndex js) + where + flipIndex (Subscript i) = Superscript i + flipIndex (Superscript i) = Subscript i + flipIndex x = x + appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do let k = fromIntegral ((length s) - (length is)) @@ -1186,6 +1197,7 @@ instance Show Arg where show (ScalarArg name) = "$" ++ name + show (InvertedScalarArg name) = "*$" ++ name show (TensorArg name) = "%" ++ name instance Show ScalarData where diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -38,7 +38,7 @@ (lambda $x (foldl 2#(%2 %1) x fs)))) -(define $flip (lambda [$fn] (lambda [$x $y] (fn y x)))) +(define $flip (lambda [$fn] (lambda [%x %y] (fn y x)))) (define $ref (lambda [%xa $is] diff --git a/lib/math/analysis/derivative.egi b/lib/math/analysis/derivative.egi --- a/lib/math/analysis/derivative.egi +++ b/lib/math/analysis/derivative.egi @@ -5,7 +5,7 @@ ;;;;; (define $∂/∂ - (lambda [$f $x] + (lambda [$f *$x] (match f math-expr {; symbol [,x 1] diff --git a/lib/math/normalize.egi b/lib/math/normalize.egi --- a/lib/math/normalize.egi +++ b/lib/math/normalize.egi @@ -17,6 +17,8 @@ [rewrite-rule-for-i 1#(contain-symbol? i %1)] [rewrite-rule-for-w-term 1#(contain-symbol? w %1)] [rewrite-rule-for-rtu-term 1#(contain-function? rtu %1)] + [rewrite-rule-for-exp-term 1#(contain-function? exp %1)] + [rewrite-rule-for-**-term 1#(contain-function? ** %1)] [rewrite-rule-for-w-poly 1#(contain-symbol? w %1)] [rewrite-rule-for-rtu-poly 1#(contain-function? rtu %1)] [rewrite-rule-for-sqrt 1#(contain-function? sqrt %1)] @@ -135,6 +137,36 @@ (match term math-expr {[(* $a (,rt $n $x)^(& ?(gte? $ n) $k) $r) (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) r)] + [_ term]}))) + +;; +;; exp +;; + +(define $rewrite-rule-for-exp (map-terms rewrite-rule-for-exp-term $)) + +(define $rewrite-rule-for-exp-term + (lambda [$term] + (match term math-expr + {[(* $a (,exp $x)^(& ?(gte? $ 2) $n) $r) + (rewrite-rule-for-exp (*' a (exp (* x n)) r))] + [(* $a (,exp $x) (,exp $y) $r) + (rewrite-rule-for-exp (*' a (exp (+ x y)) r))] + [_ term]}))) + +;; +;; exp +;; + +(define $rewrite-rule-for-** (map-terms rewrite-rule-for-**-term $)) + +(define $rewrite-rule-for-**-term + (lambda [$term] + (match term math-expr + {[(* $a (,** $x $y)^(& ?(gte? $ 2) $n) $r) + (rewrite-rule-for-** (*' a (** x (* y n)) r))] + [(* $a (,** $x $y) (,** ,x $z) $r) + (rewrite-rule-for-** (*' a (** x (+ y z)) r))] [_ term]}))) ;; diff --git a/sample/math/geometry/chern-form-of-CP1.egi b/sample/math/geometry/chern-form-of-CP1.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/chern-form-of-CP1.egi @@ -0,0 +1,22 @@ +(define $params [| r θ |]) + +(define $u (* r (** e (* 2 π i θ)))) +(define $ū (* r (** e (* -2 π i θ)))) + +(define $d + (lambda [%X] + !((flip ∂/∂) params X))) + +(define $ω (/ (* ū (d u)) + (+ 1 (* u ū)))) +ω;[| (/ r (+ 1 r^2)) (/ (* 2 r^2 π i) (+ 1 r^2)) |] + +(define $Ω (df-normalize (d ω))) +Ω;[| [| 0 (/ (* 2 r π i) (+ 1 (* 2 r^2) r^4)) |] [| (/ (* -2 r π i) (+ 1 (* 2 r^2) r^4)) 0 |] |] + +(define $c1 (/ Ω (* -2 π i))) +c1;[| [| 0 (/ r (+ -1 (* -2 r^2) (* -1 r^4))) |] [| (/ (* -1 r) (+ -1 (* -2 r^2) (* -1 r^4))) 0 |] |] + +; ∫ dθ dr (/ (* -2 r) (+ 1 (* 2 r^2) r^4)) = ∫ dθ dr (/ (* -2 r) (+ 1 r^2)^2) +; = ∫ dr (/ (* -2 r) (+ 1 r^2)^2) = [ (/ 1 (+ 1 r^2)) ] 0-∞ = (- 0 1) +; = -1 diff --git a/sample/math/geometry/chern-form-of-CP2.egi b/sample/math/geometry/chern-form-of-CP2.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/chern-form-of-CP2.egi @@ -0,0 +1,33 @@ +(define $params [| z1 z2 z1' z2' |]) +(define $params' [| z1 z2 # # |]) +(define $params'' [| # # z1' z2' |]) + +(define $d + (lambda [%X] + !((flip ∂/∂) params X))) + +(define $d' + (lambda [%X] + !((flip ∂/∂) params' X))) + +(define $d'' + (lambda [%X] + !((flip ∂/∂) params'' X))) + +(define $h (+ 1 (* z1 z1') (* z2 z2'))) + +(define $ω (d' (log h))) +ω;[| (/ z1' (+ 1 (* z1 z1') (* z2 z2'))) (/ z2' (+ 1 (* z1 z1') (* z2 z2'))) 0 0 |] + +(define $Ω (d'' ω)) +Ω +;[|[| 0 0 0 0 |] +; [| 0 0 0 0 |] +; [| (/ (+ 1 (* z2 z2')) (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) (/ (* -1 z1 z2') (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) 0 0 |] +; [| (/ (* -1 z2 z1') (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) (/ (+ 1 (* z1 z1')) (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) 0 0 |]|] + +;(define $c1 (/ Ω (* -2 π i))) +;c1;[| [| 0 (/ r (+ -1 (* -2 r^2) (* -1 r^4))) |] [| (/ (* -1 r) (+ -1 (* -2 r^2) (* -1 r^4))) 0 |] |] + + + diff --git a/sample/math/geometry/k143.egi b/sample/math/geometry/k143.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/k143.egi @@ -0,0 +1,27 @@ +(define $params [| r θ |]) + +(define $d + (lambda [%X] + !((flip ∂/∂) params X))) + +(define $wedge + (lambda [%X %Y] + !(. X Y))) + +(define $u + (lambda [$r $θ] + (* r (** e (* 2 π i θ))))) + +(define $ū + (lambda [$r $θ] + (* r (** e (* -2 π i θ))))) + +(d (u r θ)) +;[| (exp (* 2 π θ i)) (* 2 r (exp (* 2 π θ i)) π i) |] + +(d (ū r θ)) +;;[| (exp (* -2 π θ i)) (* -2 r (exp (* -2 π θ i)) π i) |] + +(df-normalize (wedge (d (u r θ)) + (d (ū r θ)))) +;[| [| 0 (* -2 r π i) |] [| (* 2 r π i) 0 |] |] diff --git a/sample/math/geometry/riemann-curvature-tensor-of-S2.egi b/sample/math/geometry/riemann-curvature-tensor-of-S2.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-S2.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-S2.egi @@ -13,17 +13,17 @@ ;; Local basis ;; -(define $e ((flip ∂/∂) x~# X_#)) -e +(define $e_i_j (∂/∂ X_j x_i)) +e_i_j ;[|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |] ; [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |] -; |]_#~# +; |]_#_# ;; ;; Metric tensor ;; -(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2})) +(define $g__ (generate-tensor 2#(V.* e_%1_# e_%2_#) {2 2})) (define $g~~ (M.inverse g_#_#)) g_#_#;[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_# @@ -35,9 +35,9 @@ (define $Γ_j_k_l (* (/ 1 2) - (+ (∂/∂ g_j_l x_k) - (∂/∂ g_j_k x_l) - (* -1 (∂/∂ g_k_l x_j))))) + (+ (∂/∂ g_j_l x~k) + (∂/∂ g_j_k x~l) + (* -1 (∂/∂ g_k_l x~j))))) Γ_#_#_#;(tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_# Γ_1_#_#;[| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_# @@ -58,7 +58,7 @@ ;; (define $∇g___ (with-symbols {i j m n} - (- (∂/∂ g_i_j x_m) + (- (∂/∂ g_i_j x~m) (. Γ~n_m_i g_n_j) (. Γ~n_m_j g_i_n)))) @@ -70,7 +70,7 @@ (define $R~i_j_k_l (with-symbols {m} - (+ (- (∂/∂ Γ~i_j_l x_k) (∂/∂ Γ~i_j_k x_l)) + (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l)) (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l))))) R~#_#_#_#;(tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_# @@ -109,7 +109,7 @@ (define $∇R_____ (with-symbols {i j k l m n} - (- (∂/∂ R_i_j_k_l x_m) + (- (∂/∂ R_i_j_k_l x~m) (. Γ~n_m_i R_n_j_k_l) (. Γ~n_m_j R_i_n_k_l) (. Γ~n_m_k R_i_j_n_l)