egison 3.4.0 → 3.5.0

raw patch · 15 files changed

+378/−102 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• hs-src/Interpreter/egison.hs +109/−36
• hs-src/Language/Egison/Core.hs +46/−7
• hs-src/Language/Egison/Desugar.hs +3/−0
• hs-src/Language/Egison/Parser.hs +8/−0
• hs-src/Language/Egison/Primitives.hs +15/−2
• hs-src/Language/Egison/Types.hs +26/−8
• lib/core/base.egi +3/−1
• lib/core/collection.egi +22/−23
• lib/core/io.egi +1/−0
• lib/core/math.egi +1/−5
• lib/core/number.egi +45/−1
• lib/core/shell.egi +58/−0
• sample/pi.egi +23/−0
• sample/salesman.egi +17/−18

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.4.0+Version:             3.5.0 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.

@@ -1,10 +1,12 @@ module Main where -import Prelude hiding ( catch )+import Prelude hiding (catch) import Control.Exception ( AsyncException(..), catch ) import Control.Monad.Error  import qualified Data.Text as T+import Data.Char+import Data.List (intercalate)  import Data.Version @@ -14,6 +16,7 @@ import System.Console.Haskeline hiding (handle, catch, throwTo) import System.Console.GetOpt import System.Exit (ExitCode (..), exitWith, exitFailure)+import System.IO  import Language.Egison import Language.Egison.Util@@ -25,43 +28,61 @@           case opts of             Options {optShowHelp = True} -> printHelp             Options {optShowVersion = True} -> printVersionNumber-            Options {optEvalString = mExpr, optExecuteString = mCmd, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optNoIO = noIOFlag} -> do-              env <- if noIOFlag then initialEnvNoIO else initialEnv-              result <- evalEgisonTopExprs env (map LoadFile loadFiles)-              case result of+            Options {optEvalString = mExpr, optExecuteString = mCmd, optSubstituteString = mSub, optFieldInfo = fieldInfo, optLoadLibs = loadLibs, optLoadFiles = loadFiles, optPrompt = prompt, optShowBanner = bannerFlag, optTsvOutput = tsvFlag, optNoIO = noIOFlag} -> do+              coreEnv <- if noIOFlag then initialEnvNoIO else initialEnv+              mEnv <- evalEgisonTopExprs coreEnv $ (map Load loadLibs) ++ (map LoadFile loadFiles)+              case mEnv of                 Left err -> putStrLn $ show err                 Right env -> do                   case mExpr of-                    Just expr -> do-                      ret <- runEgisonExpr env expr-                      case ret of-                        Left err -> putStrLn $ show err-                        Right val -> putStrLn $ show val+                    Just expr ->+                      if tsvFlag+                        then do ret <- runEgisonTopExprs env ("(execute (each (compose show-tsv print) " ++ expr ++ "))")+                                case ret of+                                  Left err -> hPutStrLn stderr $ show err+                                  Right _ -> return ()+                        else do ret <- runEgisonExpr env expr+                                case ret of+                                  Left err -> hPutStrLn stderr (show err) >> exitFailure+                                  Right val -> putStrLn (show val) >> exitWith ExitSuccess                     Nothing ->                       case mCmd of-                        Just cmd -> runEgisonTopExpr env ("(execute " ++ cmd ++ ")") >> return ()+                        Just cmd -> do cmdRet <- runEgisonTopExpr env ("(execute " ++ cmd ++ ")")+                                       case cmdRet of+                                         Left err -> putStrLn (show err) >> exitFailure+                                         _ -> exitWith ExitSuccess                         Nothing ->-                          case nonOpts of-                            [] -> do-                              when bannerFlag showBanner >> repl noIOFlag env prompt >> when bannerFlag showByebyeMessage-                            (file:args) -> do-                              case opts of-                                Options {optTestOnly = True} -> do-                                  result <- if noIOFlag-                                              then do input <- readFile file-                                                      runEgisonTopExprsNoIO env input-                                              else evalEgisonTopExprsTestOnly env [LoadFile file]-                                  either print (const $ return ()) result-                                Options {optTestOnly = False} -> do-                                  result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (map (ElementExpr . StringExpr) (map T.pack args))))]-                                  either print (const $ return ()) result+                          case mSub of+                            Just sub -> do cmdRet <- runEgisonTopExprs env ("(load \"lib/core/shell.egi\") (execute (each (compose " ++ (if tsvFlag then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ intercalate " " (map fst fieldInfo) ++  "} {" ++ intercalate " " (map snd fieldInfo) ++  "})]} (" ++ sub ++ " SH.input))))")+                                           case cmdRet of+                                             Left err -> putStrLn (show err) >> exitFailure+                                             _ -> exitWith ExitSuccess+                            Nothing ->+                              case nonOpts of+                                [] -> do+                                  when bannerFlag showBanner >> repl noIOFlag env prompt >> when bannerFlag showByebyeMessage >> exitWith ExitSuccess+                                (file:args) -> do+                                  case opts of+                                    Options {optTestOnly = True} -> do+                                      result <- if noIOFlag+                                                  then do input <- readFile file+                                                          runEgisonTopExprsNoIO env input+                                                  else evalEgisonTopExprsTestOnly env [LoadFile file]+                                      either print (const $ return ()) result+                                    Options {optTestOnly = False} -> do+                                      result <- evalEgisonTopExprs env [LoadFile file, Execute (ApplyExpr (VarExpr "main") (CollectionExpr (map (ElementExpr . StringExpr) (map T.pack args))))]+                                      either print (const $ return ()) result  data Options = Options {     optShowVersion :: Bool,     optShowHelp :: Bool,     optEvalString :: Maybe String,     optExecuteString :: Maybe String,+    optSubstituteString :: Maybe String,+    optFieldInfo :: [(String, String)],+    optLoadLibs :: [String],     optLoadFiles :: [String],+    optTsvOutput :: Bool,     optNoIO :: Bool,     optShowBanner :: Bool,     optTestOnly :: Bool,@@ -74,7 +95,11 @@     optShowHelp = False,     optEvalString = Nothing,     optExecuteString = Nothing,+    optSubstituteString = Nothing,+    optFieldInfo = [],+    optLoadLibs = [],     optLoadFiles = [],+    optTsvOutput = False,     optNoIO = False,     optShowBanner = True,     optTestOnly = False,@@ -89,6 +114,9 @@   Option ['h', '?'] ["help"]     (NoArg (\opts -> opts {optShowHelp = True}))     "show usage information",+  Option ['T'] ["tsv"]+    (NoArg (\opts -> opts {optTsvOutput = True}))+    "output in tsv format",   Option ['e'] ["eval"]     (ReqArg (\expr opts -> opts {optEvalString = Just expr})             "String")@@ -97,10 +125,14 @@     (ReqArg (\expr opts -> opts {optExecuteString = Just expr})             "String")     "execute the argument string",+  Option ['L'] ["load-library"]+    (ReqArg (\d opts -> opts {optLoadLibs = optLoadLibs opts ++ [d]})+            "[String]")+    "load library",   Option ['l'] ["load-file"]     (ReqArg (\d opts -> opts {optLoadFiles = optLoadFiles opts ++ [d]})             "[String]")-    "load files",+    "load file",   Option [] ["no-io"]     (NoArg (\opts -> opts {optNoIO = True}))     "prohibit all io primitives",@@ -113,25 +145,68 @@   Option ['p'] ["prompt"]     (ReqArg (\prompt opts -> opts {optPrompt = prompt})             "String")-    "set prompt string"+    "set prompt string",+  Option ['s'] ["substitute"]+    (ReqArg (\expr opts -> opts {optSubstituteString = Just expr})+            "String")+    "substitute strings",+  Option ['m'] ["map"]+    (ReqArg (\expr opts -> opts {optSubstituteString = Just ("(map " ++ expr ++ " $)")})+            "String")+    "filter strings",+  Option ['f'] ["filter"]+    (ReqArg (\expr opts -> opts {optSubstituteString = Just ("(filter " ++ expr ++ " $)")})+            "String")+    "filter strings",+  Option ['F'] ["--field"]+    (ReqArg (\d opts -> opts {optFieldInfo = optFieldInfo opts ++ [(readFieldOption d)]})+            "String")+    "field information"   ] +readFieldOption :: String -> (String, String)+readFieldOption str =+   let (s, rs) = span isDigit str in+   case rs of+     ',':rs' -> let (e, opts) = span isDigit rs' in+                case opts of+                  ['s'] -> ("{" ++ s ++ " " ++ e ++ "}", "")+                  ['c'] -> ("{}", "{" ++ s ++ " " ++ e ++ "}")+                  ['s', 'c'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")+                  ['c', 's'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}")+     ['s'] -> ("{" ++ s ++ "}", "")+     ['c'] -> ("", "{" ++ s ++ "}")+     ['s', 'c'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")+     ['c', 's'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}")+ printHelp :: IO () printHelp = do   putStrLn "Usage: egison [options]"   putStrLn "       egison [options] file"+  putStrLn "       egison [options] expr"   putStrLn ""-  putStrLn "Options:"+  putStrLn "Global Options:"   putStrLn "  --help, -h                 Display this information"   putStrLn "  --version, -v              Display egison version information"-  putStrLn "  --eval, -e string          Evaluate the argument string"-  putStrLn "  --command, -c string       Execute the argument string"-  putStrLn "  --load-file, -l string     Load the argument file"-  putStrLn "  --test, -t                 Run only test expressions"+  putStrLn ""+  putStrLn "  --load-library, -L file    Load the argument library"+  putStrLn "  --load-file, -l file       Load the argument file"+  putStrLn "  --no-io                    Prohibit all IO primitives"+  putStrLn ""+  putStrLn "Options as an interactive interpreter:"   putStrLn "  --prompt string            Set prompt of the interpreter"   putStrLn "  --no-banner                Don't show banner"-  putStrLn "  --no-io                    Prohibit all IO primitives"   putStrLn ""+  putStrLn "Options to handle Egison program file:"+  putStrLn "  --test, -t file            Run only test expressions"+  putStrLn ""+  putStrLn "Options as a shell command:"+  putStrLn "  --eval, -e expr            Evaluate the argument expression"+  putStrLn "  --command, -c expr         Execute the argument expression"+  putStrLn ""+  putStrLn "  --substitute, -s expr      Substitute input using the argument expression"+  putStrLn "  --map, -m expr             Substitute each line of input using the argument expression"+  putStrLn "  --filter, -f expr          Filter each line of input using the argument predicate"   exitWith ExitSuccess  printVersionNumber :: IO ()@@ -150,9 +225,7 @@ --  putStrLn $ "*****************"  showByebyeMessage :: IO ()-showByebyeMessage = do-  putStrLn $ "Leaving Egison Interpreter."-  exitWith ExitSuccess+showByebyeMessage = putStrLn $ "Leaving Egison Interpreter."  repl :: Bool -> Env -> String -> IO () repl noIOFlag env prompt = do

@@ -185,6 +185,9 @@        IntKey _ -> do          let keys' = map (\key -> case key of IntKey i -> i) keys          return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs+       CharKey _ -> do+         let keys' = map (\key -> case key of CharKey c -> c) keys+         return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs        StrKey _ -> do           let keys' = map (\key -> case key of StrKey s -> s) keys           return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs@@ -193,6 +196,7 @@   makeHashKey (Value val) =     case val of       Integer i -> return (IntKey i)+      Char c -> return (CharKey c)       String str -> return (StrKey str)       _ -> throwError $ TypeMismatch "integer or string" $ Value val   makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf@@ -284,6 +288,27 @@   evalExprDeep env expr1   evalExpr env expr2 +evalExpr env@(loopCxts, frames) (LoopExpr name (LoopRange start end WildCard) expr1 expr2) = do+  startNum <- evalExpr env start >>= fromWHNF+  startNumRef <- newEvalutedObjectRef $ Value $ Integer startNum+  end' <- evalExpr env end+  endRef <- newEvalutedObjectRef end'+  endNum <- evalRef endRef >>= fromWHNF+  if startNum > endNum+    then evalExpr (loopCxts, frames) expr2+    else evalExpr (((LoopExprContext (name, startNumRef) endRef expr1 expr2):loopCxts), frames) expr1++evalExpr env@(loopCxts, frames) ContExpr = do+  case loopCxts of+    [] -> throwError $ strMsg "cannot use cont expr except in loop expr"+    ((LoopExprContext (name, startNumRef) endRef expr1 expr2):loopCxts') -> do+      startNum <- evalRef startNumRef >>= fromWHNF+      nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1)+      endNum <- evalRef endRef >>= fromWHNF+      if startNum >= endNum+       then evalExpr (loopCxts', frames) expr2+       else evalExpr (((LoopExprContext (name, nextNumRef) endRef expr1 expr2):loopCxts'), frames) expr1+ evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func   arg <- evalExpr env arg@@ -363,6 +388,9 @@ evalWHNF (Intermediate (IIntHash refs)) = do   refs' <- mapM evalRefDeep refs   return $ IntHash refs'+evalWHNF (Intermediate (ICharHash refs)) = do+  refs' <- mapM evalRefDeep refs+  return $ CharHash refs' evalWHNF (Intermediate (IStrHash refs)) = do   refs' <- mapM evalRefDeep refs   return $ StrHash refs'@@ -424,6 +452,16 @@   case HL.lookup key hash of     Just ref -> evalRef ref >>= flip refArray indices     Nothing -> return $ Value Undefined+refArray (Value (CharHash 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 (ICharHash 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 <- fromEgison index   case HL.lookup key hash of@@ -614,14 +652,14 @@           endsRef <- newEvalutedObjectRef ends'           inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef]           endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners)))-          return $ msingleton $ MState env ((LoopContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)         else do           endsRef <- newEvalutedObjectRef ends'-          return $ msingleton $ MState env ((LoopContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)+          return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)     ContPat ->       case loops of         [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"-        LoopContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do+        LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do           startNum <- evalRef startNumRef >>= fromWHNF           nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1)           ends <- evalRef endsRef@@ -633,8 +671,8 @@               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 ((LoopContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]-                else return $ fromList [MState env ((LoopContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((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'@@ -832,8 +870,8 @@       unsnocCollection coll unsnocCollection _ = matchFail -extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopContext] -> Env-extendEnvForNonLinearPatterns env bindings loops =  extendEnv env $ bindings ++ map (\(LoopContext binding _ _ _ _) -> binding) loops+extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env+extendEnvForNonLinearPatterns env bindings loops =  extendEnv env $ bindings ++ map (\(LoopPatContext binding _ _ _ _) -> binding) loops  evalMatcherWHNF :: WHNFData -> EgisonM Matcher evalMatcherWHNF (Value matcher@Something) = return matcher@@ -890,6 +928,7 @@ -- data EgisonHashKey =     IntKey Integer+  | CharKey Char   | StrKey Text  extractPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue

@@ -43,6 +43,9 @@ desugarTopExpr (Test expr) = do   expr' <- liftEgisonM $ runDesugarM $ desugar expr   return (Test expr')+desugarTopExpr (Execute expr) = do+  expr' <- liftEgisonM $ runDesugarM $ desugar expr+  return (Execute expr') desugarTopExpr expr = return expr  desugarExpr :: EgisonExpr -> EgisonM EgisonExpr

@@ -156,6 +156,7 @@  expr' :: Parser EgisonExpr expr' = (try constantExpr+             <|> contExpr              <|> try varExpr              <|> inductiveDataExpr              <|> try arrayExpr@@ -183,6 +184,7 @@                          <|> matcherBFSExpr                          <|> matcherDFSExpr                          <|> seqExpr+                         <|> loopExpr                          <|> applyExpr                          <|> algebraicDataMatcherExpr                          <|> generateArrayExpr@@ -350,6 +352,12 @@  seqExpr :: Parser EgisonExpr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr++loopExpr :: Parser EgisonExpr+loopExpr = keywordLoop >> LoopExpr <$> varName <*> loopRange <*> expr <*> expr++contExpr :: Parser EgisonExpr+contExpr = reservedOp "..." >> pure ContExpr  applyExpr :: Parser EgisonExpr applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr) 

@@ -150,7 +150,9 @@              , ("split-string", splitString)                              , ("read", read')+             , ("read-tsv", readTSV)              , ("show", show')+             , ("show-tsv", showTSV')               , ("empty?", isEmpty')              , ("uncons", uncons')@@ -190,8 +192,10 @@  floatUnaryOp :: (Double -> Double) -> PrimitiveFunc floatUnaryOp op = oneArg $ \val -> do-  f <- fromEgison val-  return $ Float $ op f+  case val of+    (Float f) -> return $ Float $ op f+    (Integer i) -> return $ Float $ op (fromIntegral i)+    (Rational r) -> return $ Float $ op (fromRational r)  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> do@@ -425,8 +429,17 @@ read' :: PrimitiveFunc read'= oneArg $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv +readTSV :: PrimitiveFunc+readTSV= oneArg $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv)+                             case rets of+                               [ret] -> return ret+                               _ -> return (Tuple rets)+ show' :: PrimitiveFunc show'= oneArg $ \val -> return $ toEgison $ T.pack $ show val++showTSV' :: PrimitiveFunc+showTSV'= oneArg $ \val -> return $ toEgison $ T.pack $ showTSV val  -- -- Collection

@@ -1,6 +1,6 @@ {-# Language TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving,              MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable,-             TypeFamilies #-}+             TypeFamilies, TupleSections #-} {- | Module      : Language.Egison.Types Copyright   : Satoshi Egi@@ -27,6 +27,7 @@     , Matcher (..)     , PrimitiveFunc (..)     , EgisonData (..)+    , showTSV     -- * Internal data     , Object (..)     , ObjectRef (..)@@ -41,6 +42,7 @@     , nullEnv     , extendEnv     , refVar+    , LoopExprContext (..)     -- * Pattern matching     , Match     , PMMode (..)@@ -48,7 +50,7 @@     , MatchingState (..)     , MatchingTree (..)     , PatternBinding (..)-    , LoopContext (..)+    , LoopPatContext (..)     -- * Errors     , EgisonError (..)     , liftError@@ -97,6 +99,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List (intercalate) import Data.Text (Text) import qualified Data.Text as T @@ -159,6 +162,8 @@   | IoExpr EgisonExpr        | SeqExpr EgisonExpr EgisonExpr+  | LoopExpr String LoopRange EgisonExpr EgisonExpr+  | ContExpr   | ApplyExpr EgisonExpr EgisonExpr    | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]@@ -234,6 +239,7 @@   | Collection (Seq EgisonValue)   | Array (Array.Array Integer EgisonValue)   | IntHash (HashMap Integer EgisonValue)+  | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)   | UserMatcher Env PMMode MatcherInfo   | Func Env [String] EgisonExpr@@ -266,6 +272,7 @@                              else "{" ++ unwords (map show (toList vals)) ++ "}"   show (Array vals) = "[|" ++ unwords (map show $ Array.elems vals) ++ "|]"   show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"+  show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (UserMatcher _ BFSMode _) = "#<matcher-bfs>"   show (UserMatcher _ DFSMode _) = "#<matcher-dfs>"@@ -280,6 +287,11 @@   show World = "#<world>"   show EOF = "#<eof>" +showTSV :: EgisonValue -> String+showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals)+showTSV (Collection vals) = intercalate "\t" (map showTSV (toList vals))+showTSV val = show val+ instance Eq EgisonValue where  (Char c) == (Char c') = c == c'  (String str) == (String str') = str == str'@@ -291,6 +303,7 @@  (Collection vals) == (Collection vals') = vals == vals'  (Array vals) == (Array vals') = vals == vals'  (IntHash vals) == (IntHash vals') = vals == vals'+ (CharHash vals) == (CharHash vals') = vals == vals'  (StrHash vals) == (StrHash vals') = vals == vals'  _ == _ = False @@ -412,6 +425,7 @@   | ICollection (IORef (Seq Inner))   | IArray (Array.Array Integer ObjectRef)   | IIntHash (HashMap Integer ObjectRef)+  | ICharHash (HashMap Char ObjectRef)   | IStrHash (HashMap Text ObjectRef)  data Inner =@@ -425,6 +439,7 @@   show (Intermediate (ICollection _)) = "{...}"   show (Intermediate (IArray _)) = "[|...|]"    show (Intermediate (IIntHash _)) = "{|...|}" +  show (Intermediate (ICharHash _)) = "{|...|}"    show (Intermediate (IStrHash _)) = "{|...|}"   instance Show Object where@@ -499,20 +514,23 @@ -- Environment -- -type Env = [HashMap Var ObjectRef]+type Env = ([LoopExprContext], [HashMap Var ObjectRef]) type Var = String type Binding = (Var, ObjectRef)  nullEnv :: Env-nullEnv = []+nullEnv = ([], [])  extendEnv :: Env -> [Binding] -> Env-extendEnv env = (: env) . HashMap.fromList+extendEnv env = ([],) . (: (snd env)) . HashMap.fromList  refVar :: Env -> Var -> EgisonM ObjectRef refVar env var = maybe (throwError $ UnboundVariable var) return-                       (msum $ map (HashMap.lookup var) env)+                       (msum $ map (HashMap.lookup var) (snd (extendEnv env (map (\(LoopExprContext binding _ _ _) -> binding) (fst env))))) +data LoopExprContext = LoopExprContext Binding ObjectRef EgisonExpr EgisonExpr+ deriving (Show)+ -- -- Pattern Match --@@ -527,7 +545,7 @@ pmMode (Tuple _) = DFSMode pmMode Something = DFSMode -data MatchingState = MState Env [LoopContext] [Binding] [MatchingTree]+data MatchingState = MState Env [LoopPatContext] [Binding] [MatchingTree]  deriving (Show)  data MatchingTree =@@ -537,7 +555,7 @@  type PatternBinding = (Var, EgisonPattern) -data LoopContext = LoopContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern+data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern  deriving (Show)  --

@@ -16,7 +16,9 @@    (define $id (lambda [$x] x)) -(define $bool builtin-data-matcher)+(define $fst (lambda [$x $y] x))++(define $snd (lambda [$x $y] y))(define $bool builtin-data-matcher)  (define $or   (lambda [$b1 $b2]

@@ -26,10 +26,10 @@          [_ {}]}]        [<join $ $> [(list a) (list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]+                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(loop $i [1 n] {xa_i @...} {}) rs]])]}]        [<nioj $ $> [(list a) (list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]+                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(loop $i [1 n] {xa_i @...} {}) rs]])]}]        [$ [something]         {[$tgt {tgt}]}]        })))@@ -48,10 +48,10 @@        [<join $ <cons ,$px $>> [(ordered-list a) (ordered-list a)]         {[{} {}]          [$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]+                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>) [(loop $i [1 n] {xa_i @...} {}) rs]])]}]        [<join $ $> [(ordered-list a) (ordered-list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]+                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(loop $i [1 n] {xa_i @...} {}) rs]])]}]        [<cons ,$px $> [(ordered-list a)]         {[{$x @$xs} (if (gt? x px)                       {}@@ -62,7 +62,7 @@          [_ {}]}]        [<nioj $ $> [(ordered-list a) (ordered-list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]+                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(loop $i [1 n] {xa_i @...} {}) rs]])]}]        [<snoc ,$px $> [a (ordered-list a)]         {[{@$xs $x} (if (lt? x px)                       {}@@ -86,12 +86,11 @@  (define $between   (lambda [$s $e]-    (if (gt? (+ s 10) e)-      (if (gt? s e)-        {}-        {s @(between (+ s 1) e)})-      {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(between (+ s 11) e)})-    ))+    (if (eq? s e)+      {s}+      (if (lt? s e)+        {s @(between (+ s 1) e)}+        {s @(between (- s 1) e)}))))  (define $from   (lambda [$s]@@ -124,12 +123,6 @@         (let {[$z (fn init x)]}           (seq z (foldl' fn z xs)))]}))) -(define $foldl-naive-  (lambda [$fn $init $ls]-    (match ls (list something)-      {[<nil> init]-       [<cons $x $xs> (foldl fn (fn init x) xs)]})))- (define $filter   (lambda [$pred $xs]     (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys))@@ -237,17 +230,23 @@ ;; (define $length   (lambda [$xs]-    (foldl' (lambda [$x $y] (+ x 1)) 0 xs)))+    (foldl (lambda [$r $x] (+ r 1)) 0 xs)))  (define $count   (lambda [$x $xs]-    (length (match-all xs (list something)-              [<join _ <cons ,x _>> x]))))+    (foldl (match-lambda [something something]+             {[[$r ,x] (+ r 1)]+              [[$r $y] r]})+           0+           xs)))  (define $count/m   (lambda [$a $x $xs]-    (length (match-all xs (list a)-              [<join _ <cons ,x _>> x]))))+    (foldl (match-lambda [a a]+             {[[$r ,x] (+ r 1)]+              [[$r $y] r]})+           0+           xs)))  (define $frequency   (lambda [$xs]@@ -387,7 +386,7 @@        })))  ;;-;; multiset operation (Don't use multiset matcher)+;; multiset operation ;; (define $add   (lambda [$x $xs]

@@ -11,6 +11,7 @@   (lambda [$x]     (do {[(write x)]          [(write "\n")]+         [(flush)]          })))  (define $print-to-port

@@ -6,11 +6,7 @@  (define $fact   (lambda [$n]-    (letrec {[$fact1 (lambda [$n $ret]-                       (match n integer-                         {[,0 ret]-                          [_ (fact1 (- n 1) (* n ret))]}))]}-      (fact1 n 1))))+    (foldl * 1 (between 1 n))))  (define $perm   (lambda [$n $r]

@@ -48,6 +48,10 @@  (define $nats0 {0 @nats}) +(define $odds {1 @(map (+ $ 2) odds)})++(define $evens {2 @(map (+ $ 2) odds)})+ (define $primes   (letrec {[$next-primes             (lambda [$primes1 $k]@@ -122,9 +126,49 @@  (define $sum   (lambda [$xs]-    (foldl' + 0 xs)))+    (foldl + 0 xs)))  ;;; ;;; Float Numbers ;;; (define $float builtin-data-matcher)++;;;+;;; Decimal Fractions+;;;+(define $decimal (algebraic-data-matcher {<df integer (list integer)>}))+(define $decimal' (algebraic-data-matcher {<df' integer (list integer) (list integer)>}))++(define $rtod-helper+  (lambda [$m $n]+    (let {[$q (quotient (* m 10) n)]+          [$r (remainder (* m 10) n)]}+      {[q r] @(rtod-helper r n)})))++(define $rtod+  (lambda [$x]+    (let {[$m (numerator x)]+          [$n (denominator x)]}+      (let {[$q (quotient m n)]+            [$r (remainder m n)]}+          <Df q (map (lambda [$x $y] x) (rtod-helper r n))>))))++(define $rtod'+  (lambda [$x]+    (let {[$m (numerator x)]+          [$n (denominator x)]}+      (let {[$q (quotient m n)]+            [$r (remainder m n)]}+        (let {[[$s $c] (match (rtod-helper r n) (list [integer integer])+                         {[<join $s <cons $x <join $c <cons ,x _>>>> [s {x @c}]]})]}+          <Df' q (map (lambda [$x $y] x) s) (map (lambda [$x $y] x) c)>)))))++(define $show-decimal+  (lambda [$n $x]+    (match (rtod x) decimal+      {[<df $q $sc> (foldl S.append (S.append (show q) ".") (map show (take n sc)))]})))++(define $show-decimal'+  (lambda [$x]+    (match (rtod' x) decimal'+      {[<df' $q $s $c> (foldl S.append "" {(S.append (show q) ".") @(map show s) " " @(map show c) " ..."})]})))

@@ -0,0 +1,58 @@+(define $SH.gen-input+  (lambda [$sopts $copts]+    (if (io (eof?))+      {}+      (let {[$x (io (TSV.read-line sopts copts))]}+        (seq x {x @(SH.gen-input sopts copts)})))))++(define $TSV.read-line+  (lambda [$sopts $copts]+    (do {[$line (read-line)]}+      (let {[$fs (S.split "\t" line)]}+        (letrec {[$fn-s (match-lambda [(list (list integer)) (list string)]+                          {[[<nil> $fs] fs]+                           [[<cons <cons $m <nil>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   $ts>]+                            (fn-s opts' {@hs @(map (lambda [$t] (S.concat {"\"" t "\""})) ts)})]+                           [[<cons <cons $m <cons ,m <nil>>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <cons $mf $ts>>]+                            (fn-s opts' {@hs (S.concat {"\"" mf "\""}) @ts})]+                           [[<cons <cons $m <cons $n <nil>>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <join (& $ms ?(lambda [$ms] (eq? (+ (- n m) 1) (length ms))))+                                         $ts>>]+                            (fn-s opts' {@hs @(map (lambda [$m] (S.concat {"\"" m "\""})) ms) @ts})]+                           [[<cons <cons $m <cons _ <nil>>> $opts'>+                             _]+                            (fn-s {{m} @opts'} fs)]+                           [[_ _] fs]+                           })]+                 [$fn-c (match-lambda [(list (list integer)) (list string)]+                          {[[<nil> $fs] fs]+                           [[<cons <cons $m <nil>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <cons $mf <nil>>>]+                            (fn-c opts' {@hs (S.concat {"{" mf "}"})})]+                           [[<cons <cons $m <nil>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <cons $mf <snoc $tf $ms>>>]+                            (fn-c opts' {@hs (S.append "{" mf) @ms (S.append tf "}")})]+                           [[<cons <cons $m <cons ,m <nil>>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <cons $mf $ts>>]+                            (fn-c opts' {@hs (S.concat {"{" mf "}"}) @ts})]+                           [[<cons <cons $m <cons $n <nil>>> $opts'>+                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))+                                   <cons $mf <join (& $ms ?(lambda [$ms] (eq? (- n m 1) (length ms))))+                                                   <cons $nf $ts>>>>]+                            (fn-c opts' {@hs (S.append "{" mf) @ms (S.append nf "}") @ts})]+                           [[<cons <cons $m <cons _ <nil>>> $opts'>+                             _]+                            (fn-c {{m} @opts'} fs)]+                           [[_ _] fs]+                           })]}+          (return (read-tsv (S.intercalate "\t" (fn-c copts (fn-s sopts fs))))))))))++(define $TSV.show (show-tsv $))

@@ -0,0 +1,23 @@+(define $pi+  (lambda [$n]+    (/ 4+       (+ 1+          (foldr (lambda [$x $r]+                   (/ (power x 2)+                      (+ (+ (* x 2) 1)+                         r)))+                 0+                 (take n nats))))))++(test (pi 5))+(test (rtod' (pi 5)))+(test (show-decimal' (pi 5)))+(test (pi 6))+(test (rtod' (pi 6)))+(test (show-decimal' (pi 6)))+(test (pi 7))+(test (show-decimal 10 (pi 7)))+(test (pi 100))+(test (rtof (pi 100)))+(test (show-decimal 100 (pi 100)))+

@@ -2,35 +2,34 @@ ;;; Travelling Salesman Problem ;;; -(define $station string)  ; 駅は文字列として表現-(define $price   integer) ; 運賃は整数値として表現-(define $graph   (multiset [station (multiset [station price])])) ; 運賃グラフのマッチャー+(define $station string)+(define $price   integer)+(define $graph   (multiset [station (multiset [station price])])) -(define $graph-data ; 運賃データ+(define $graph-data   {-   ["東京"   {             ["新宿" 200] ["渋谷" 200] ["三鷹" 390] ["錦糸町" 160] ["北千住" 220]}]-   ["新宿"   {["東京" 200]              ["渋谷" 160] ["三鷹" 220] ["錦糸町" 220] ["北千住" 310]}]-   ["渋谷"   {["東京" 200] ["新宿" 160]              ["三鷹" 310] ["錦糸町" 220] ["北千住" 310]}]-   ["三鷹"   {["東京" 390] ["新宿" 220] ["渋谷" 310]              ["錦糸町" 470] ["北千住" 550]}]-   ["錦糸町" {["東京" 160] ["新宿" 220] ["渋谷" 220] ["三鷹" 470]                ["北千住" 220]}]-   ["北千住" {["東京" 220] ["新宿" 310] ["渋谷" 310] ["三鷹" 550] ["錦糸町" 220]               }]+   ["Tokyo"     {              ["Shinjuku" 200] ["Shibuya" 200] ["Mitaka" 390] ["Kinshicho" 160] ["Kitasenju" 220]}]+   ["Shinjuku"  {["Tokyo" 200]                  ["Shibuya" 160] ["Mitaka" 220] ["Kinshicho" 220] ["Kitasenju" 310]}]+   ["Shibuya"   {["Tokyo" 200] ["Shinjuku" 160]                 ["Mitaka" 310] ["Kinshicho" 220] ["Kitasenju" 310]}]+   ["Mitaka"    {["Tokyo" 390] ["Shinjuku" 220] ["Shibuya" 310]                ["Kinshicho" 470] ["Kitasenju" 550]}]+   ["Kinshicho" {["Tokyo" 160] ["Shinjuku" 220] ["Shibuya" 220] ["Mitaka" 470]                   ["Kitasenju" 220]}]+   ["Kitasenju" {["Tokyo" 220] ["Shinjuku" 310] ["Shibuya" 310] ["Mitaka" 550] ["Kinshicho" 220]                  }]    }) -(define $trips ; 全ての経路をパターンマッチを用いて列挙+(define $trips ; List up all routes that visit each city exactly once and return to Tokyo   (match-all graph-data graph-    [<cons [,"東京" <cons [$s_1 $p_1] _>]+    [<cons [,"Tokyo" <cons [$s_1 $p_1] _>]            (loop $i [2 5]              <cons [,s_(- i 1) <cons [$s_i $p_i] _>]                    ...>-             <cons [,s_5 <cons [(& ,"東京" $s_6) $p_6] _>]+             <cons [,s_5 <cons [(& ,"Tokyo" $s_6) $p_6] _>]                    _>)>      [(sum (map (lambda [$i] p_i) (between 1 6)))       s]]))  (define $main   (lambda [$args]-    (do {[(print "経路一覧:")]-         [(each (compose show print) trips)]                       ; 全ての経路を出力-         [(write "最安値:")]-         [(print (show (min (map (lambda [$x $y] x) trips))))]}))) ; 最安値を出力-+    (do {[(print "Route list:")]+         [(each (compose show print) trips)]+         [(write "Lowest price:")]+         [(print (show (min (map (lambda [$x $y] x) trips))))]})))