diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.9.0 +Version: 3.9.1 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. @@ -85,7 +85,7 @@ Language.Egison.Util Language.Egison.MathOutput Other-modules: Paths_egison - build-tools: happy, alex + build-tools: happy >= 1.17.1, alex ghc-options: -O3 Test-Suite test 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 @@ -107,12 +107,13 @@ evalTopExpr' _ st (Test expr) = do pushFuncName "" val <- evalStateT st [] >>= flip evalExprDeep expr + popFuncName return (Just (show val), st) evalTopExpr' _ st (Execute expr) = do pushFuncName "" io <- evalStateT st [] >>= flip evalExpr expr case io of - Value (IOFunc m) -> m >> return (Nothing, st) + Value (IOFunc m) -> m >> popFuncName >> return (Nothing, st) _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack evalTopExpr' opts st (Load file) = do exprs <- if optSExpr opts then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file diff --git a/hs-src/Language/Egison/Lexer.x b/hs-src/Language/Egison/Lexer.x --- a/hs-src/Language/Egison/Lexer.x +++ b/hs-src/Language/Egison/Lexer.x @@ -1,63 +1,159 @@ { -{-# OPTIONS -w #-} +{-# OPTIONS -w #-} + +{- | +Module : Language.Egison.Lexer +Copyright : Satoshi Egi +Licence : MIT + +This module provides new Egison lexer. +-} + module Language.Egison.Lexer - ( Token(..) - , AlexPosn(..) - , TokenClass(..) - , Alex(..) - , runAlex' - , alexMonadScan' - , alexError' - ) where -import Prelude hiding (lex) -import Control.Monad (liftM) + ( Token(..) + , AlexPosn(..) + , TokenClass(..) + , Alex(..) + , runAlex' + , alexMonadScan' + , alexError + , alexError' + ) where + +import Prelude hiding (lex) +import Control.Monad (liftM) + +import Language.Egison.Types + } + %wrapper "monadUserState" $digit = 0-9 $alpha = [A-Za-z] tokens :- $white+ ; - $digit+ { lex (TokenInt . read) } - $alpha [$alpha $digit \_ \']* { lex TokenVar } - \= { lex' TokenEq } - \< { lex' TokenLT } - \> { lex' TokenGT } - \<\= { lex' TokenLE } - \>\= { lex' TokenGE } - \+ { lex' TokenPlus } - \- { lex' TokenMinus } - \* { lex' TokenAsterisk } - \/ { lex' TokenDiv } - \( { lex' TokenLParen } - \) { lex' TokenRParen } - \[ { lex' TokenLBracket } - \] { lex' TokenRBracket } + -- Keywords + True { lex' TokenTrue } + False { lex' TokenFalse } + test { lex' TokenTest } + match { lex' TokenMatch } + matchDFS { lex' TokenMatchDFS } + matchAll { lex' TokenMatchAll } + matchAllDFS { lex' TokenMatchAllDFS } + matchLambda { lex' TokenMatchLambda } + matchAllLambda { lex' TokenMatchAllLambda } + as { lex' TokenAs } + with { lex' TokenWith } + something { lex' TokenSomething } + if { lex' TokenIf } + then { lex' TokenThen } + else { lex' TokenElse } + + -- Data + $digit+ { lex (TokenInt . read) } + $alpha [$alpha $digit \']* { lex TokenVar } + + -- Operators + \=\= { lex' TokenEqEq } + \< { lex' TokenLT } + \> { lex' TokenGT } + \<\= { lex' TokenLE } + \>\= { lex' TokenGE } + \+ { lex' TokenPlus } + \- { lex' TokenMinus } + \% { lex' TokenPercent } + \* { lex' TokenAsterisk } + \/ { lex' TokenDiv } + \^ { lex' TokenCaret } + \&\& { lex' TokenAndAnd } + \|\| { lex' TokenBarBar } + \: { lex' TokenColon } + \.\. { lex' TokenDotDot } + \+\+ { lex' TokenPlusPlus } + + \| { lex' TokenBar } + \-\> { lex' TokenArrow } + \$ { lex' TokenDollar } + \_ { lex' TokenUnderscore } + \# { lex' TokenSharp } + \, { lex' TokenComma } + \\ { lex' TokenBackSlash } + \*\$ { lex' TokenAstDollar } + \= { lex' TokenEq } + + \( { lex' TokenLParen } + \) { lex' TokenRParen } + \[ { lex' TokenLBracket } + \] { lex' TokenRBracket } + { -- To improve error messages, We keep the path of the file we are -- lexing in our own state. data AlexUserState = AlexUserState { filePath :: FilePath } + alexInitUserState :: AlexUserState alexInitUserState = AlexUserState "" + getFilePath :: Alex FilePath getFilePath = liftM filePath alexGetUserState + setFilePath :: FilePath -> Alex () setFilePath = alexSetUserState . AlexUserState + -- The token type, consisting of the source code position and a token class. data Token = Token AlexPosn TokenClass deriving ( Show ) + data TokenClass - = TokenInt Integer + -- Keywords + = TokenTrue + | TokenFalse + | TokenTest + | TokenMatch + | TokenMatchDFS + | TokenMatchAll + | TokenMatchAllDFS + | TokenMatchLambda + | TokenMatchAllLambda + | TokenAs + | TokenWith + | TokenSomething + | TokenIf + | TokenThen + | TokenElse + + -- Data and Variables + | TokenInt Integer | TokenVar String - | TokenEq + + | TokenEqEq | TokenLT | TokenGT | TokenLE | TokenGE | TokenPlus | TokenMinus + | TokenPercent | TokenAsterisk | TokenDiv + | TokenCaret + | TokenAndAnd + | TokenBarBar + | TokenColon + | TokenDotDot + | TokenPlusPlus + + | TokenBar + | TokenArrow + | TokenDollar + | TokenUnderscore + | TokenSharp + | TokenComma + | TokenBackSlash + | TokenAstDollar + | TokenEq + | TokenLParen | TokenRParen | TokenLBracket @@ -66,17 +162,52 @@ -- For nice parser error messages. instance Show TokenClass where + show TokenTrue = "True" + show TokenFalse = "False" + show TokenTest = "test" + show TokenMatch = "match" + show TokenMatchDFS = "matchDFS" + show TokenMatchAll = "matchAll" + show TokenMatchAllDFS = "matchAllDFS" + show TokenMatchLambda = "matchLambda" + show TokenMatchAllLambda = "matchAllLambda" + show TokenAs = "as" + show TokenWith = "with" + show TokenSomething = "something" + show TokenIf = "if" + show TokenThen = "then" + show TokenElse = "else" + show (TokenInt i) = show i show (TokenVar s) = show s - show TokenEq = "=" + + show TokenEqEq = "==" show TokenLT = "<" show TokenGT = ">" show TokenLE = "<=" show TokenGE = ">=" show TokenPlus = "+" show TokenMinus = "-" + show TokenPercent = "%" show TokenAsterisk = "*" show TokenDiv = "/" + show TokenCaret = "^" + show TokenAndAnd = "&&" + show TokenBarBar = "||" + show TokenColon = ":" + show TokenDotDot = ".." + show TokenPlusPlus = "++" + + show TokenBar = "|" + show TokenArrow = "->" + show TokenDollar = "$" + show TokenUnderscore = "_" + show TokenSharp = "#" + show TokenComma = "," + show TokenBackSlash = "\\" + show TokenAstDollar = "*$" + show TokenEq = "=" + show TokenLParen = "(" show TokenRParen = ")" show TokenLBracket = "[" @@ -87,14 +218,17 @@ alexEOF = do (p,_,_,_) <- alexGetInput return $ Token p TokenEOF + -- Unfortunately, we have to extract the matching bit of string -- ourselves... lex :: (String -> TokenClass) -> AlexAction Token lex f = \(p,_,_,s) i -> return $ Token p (f (take i s)) + -- For constructing tokens that do not depend on -- the input lex' :: TokenClass -> AlexAction Token lex' = lex . const + -- We rewrite alexMonadScan' to delegate to alexError' when lexing fails -- (the default implementation just returns an error message). alexMonadScan' :: Alex Token @@ -111,12 +245,17 @@ AlexToken inp' len action -> do alexSetInput inp' action (ignorePendingBytes inp) len + -- Signal an error, including a commonly accepted source code position. alexError' :: AlexPosn -> String -> Alex a alexError' (AlexPn _ l c) msg = do fp <- getFilePath alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) + -- A variant of runAlex, keeping track of the path of the file we are lexing. -runAlex' :: Alex a -> String -> Either String a -runAlex' a input = runAlex input (setFilePath "" >> a) +runAlex' :: Alex a -> String -> Either EgisonError a +runAlex' a input = + case runAlex input (setFilePath "" >> a) of + Left msg -> Left $ Parser msg + Right r -> Right r } diff --git a/hs-src/Language/Egison/ParserNonS2.y b/hs-src/Language/Egison/ParserNonS2.y --- a/hs-src/Language/Egison/ParserNonS2.y +++ b/hs-src/Language/Egison/ParserNonS2.y @@ -1,5 +1,14 @@ { {-# OPTIONS -w #-} + +{- | +Module : Language.Egison.ParserNonS2 +Copyright : Satoshi Egi +Licence : MIT + +This module provides new Egison parser. +-} + module Language.Egison.ParserNonS2 ( -- * Parse a string @@ -12,85 +21,284 @@ , parseExprs , parseExpr -- * Parse a file - , loadFile , loadLibraryFile + , loadFile ) where -import Language.Egison.Lexer -import Language.Egison.Types +import Control.Monad.Except hiding (mapM) +import Data.Either +import qualified Data.Set as Set + +import System.Directory (doesFileExist, getHomeDirectory) + +import Language.Egison.Desugar +import Language.Egison.Lexer +import Language.Egison.Types +import Paths_egison (getDataFileName) + } -%name parse +-- %name parseTopExprs_ TopExprs +%name parseTopExpr_ TopExpr +%name parseExpr_ Expr %tokentype { Token } %monad { Alex } %lexer { lexwrap } { Token _ TokenEOF } -- Without this we get a type error %error { happyError } -%right let in -%left '<' '>' '=' "<=" ">=" -%left '+' '-' +%right '|' +%right "++" +%right "||" +%right "&&" +%right ':' +%left '<' '>' "==" "<=" ">=" +%left '+' '-' '%' %left '*' '/' +%left '^' +%right TENSOR %token - int { Token _ (TokenInt $$) } - var { Token _ (TokenVar $$) } - '=' { Token _ TokenEq } - '<' { Token _ TokenLT } - '>' { Token _ TokenGT } - "<=" { Token _ TokenLE } - ">=" { Token _ TokenGE } - '+' { Token _ TokenPlus } - '-' { Token _ TokenMinus } - '*' { Token _ TokenAsterisk } - '/' { Token _ TokenDiv } - '(' { Token _ TokenLParen } - ')' { Token _ TokenRParen } - '[' { Token _ TokenLBracket } - ']' { Token _ TokenRBracket } + True { Token _ TokenTrue } + False { Token _ TokenFalse } + test { Token _ TokenTest } + match { Token _ TokenMatch } + matchDFS { Token _ TokenMatchDFS } + matchAll { Token _ TokenMatchAll } + matchAllDFS { Token _ TokenMatchAllDFS } + matchLambda { Token _ TokenMatchLambda } + matchAllLambda { Token _ TokenMatchAllLambda } + as { Token _ TokenAs } + with { Token _ TokenWith } + something { Token _ TokenSomething } + if { Token _ TokenIf } + then { Token _ TokenThen } + else { Token _ TokenElse } + int { Token _ (TokenInt $$) } + var { Token _ (TokenVar $$) } + + "==" { Token _ TokenEqEq } + '<' { Token _ TokenLT } + '>' { Token _ TokenGT } + "<=" { Token _ TokenLE } + ">=" { Token _ TokenGE } + '+' { Token _ TokenPlus } + '-' { Token _ TokenMinus } + '%' { Token _ TokenPercent } + '*' { Token _ TokenAsterisk } + '/' { Token _ TokenDiv } + '^' { Token _ TokenCaret } + "&&" { Token _ TokenAndAnd } + "||" { Token _ TokenBarBar } + ':' { Token _ TokenColon } + ".." { Token _ TokenDotDot } + "++" { Token _ TokenPlusPlus } + + '|' { Token _ TokenBar } + "->" { Token _ TokenArrow } + '$' { Token _ TokenDollar } + '_' { Token _ TokenUnderscore } + '#' { Token _ TokenSharp } + ',' { Token _ TokenComma } + '\\' { Token _ TokenBackSlash } + "*$" { Token _ TokenAstDollar } + '=' { Token _ TokenEq } + + '(' { Token _ TokenLParen } + ')' { Token _ TokenRParen } + '[' { Token _ TokenLBracket } + ']' { Token _ TokenRBracket } + %% -EgisonExpr : - int { IntegerExpr $1 } +-- TopExprs : +-- TopExpr { [$1] } +-- | TopExpr TopExprs { $1 : $2 } +TopExpr :: { EgisonTopExpr } + : var '=' Expr { Define (stringToVar $1) $3 } + | var list1(Arg) '=' Expr { Define (stringToVar $1) (LambdaExpr $2 $4) } + | Expr { Test $1 } + | test '(' Expr ')' { Test $3 } + +Expr :: { EgisonExpr } + : Expr1 { $1 } + | MatchExpr { $1 } + | '\\' list1(Arg) "->" Expr { LambdaExpr $2 $4 } + | if Expr then Expr else Expr { IfExpr $2 $4 $6 } + +Expr1 :: { EgisonExpr } + : Atoms { $1 } + | '-' Atom { makeApply (VarExpr $ stringToVar "*") [IntegerExpr(-1), $2] } + | BinOpExpr { $1 } + +BinOpExpr :: { EgisonExpr } + : Expr1 "==" Expr1 { makeApply (VarExpr $ stringToVar "eq?") [$1, $3] } + | Expr1 "<=" Expr1 { makeApply (VarExpr $ stringToVar "lte?") [$1, $3] } + | Expr1 '<' Expr1 { makeApply (VarExpr $ stringToVar "lt?") [$1, $3] } + | Expr1 ">=" Expr1 { makeApply (VarExpr $ stringToVar "gte?") [$1, $3] } + | Expr1 '>' Expr1 { makeApply (VarExpr $ stringToVar "gt?") [$1, $3] } + | Expr1 '+' Expr1 { makeApply (VarExpr $ stringToVar "+") [$1, $3] } + | Expr1 '-' Expr1 { makeApply (VarExpr $ stringToVar "-") [$1, $3] } + | Expr1 '%' Expr1 { makeApply (VarExpr $ stringToVar "remainder") [$1, $3] } + | Expr1 '*' Expr1 { makeApply (VarExpr $ stringToVar "*") [$1, $3] } + | Expr1 '/' Expr1 { makeApply (VarExpr $ stringToVar "/") [$1, $3] } + | Expr1 '^' Expr1 { makeApply (VarExpr $ stringToVar "**") [$1, $3] } + | Expr1 "&&" Expr1 { makeApply (VarExpr $ stringToVar "and") [$1, $3] } + | Expr1 "||" Expr1 { makeApply (VarExpr $ stringToVar "or") [$1, $3] } + | Expr1 ':' Expr1 { makeApply (VarExpr $ stringToVar "cons") [$1, $3] } + | Expr1 "++" Expr1 { makeApply (VarExpr $ stringToVar "append") [$1, $3] } + +Atoms :: { EgisonExpr } + : Atom { $1 } + | Atom list1(Atom) { makeApply $1 $2 } + +MatchExpr :: { EgisonExpr } + : match Expr as Expr with '|' MatchClauses { MatchExpr $2 $4 $7 } + | matchDFS Expr as Expr with '|' MatchClauses { MatchDFSExpr $2 $4 $7 } + | matchAll Expr as Expr with '|' MatchClauses { MatchAllExpr $2 $4 $7 } + | matchAllDFS Expr as Expr with '|' MatchClauses { MatchAllDFSExpr $2 $4 $7 } + | matchLambda as Expr with '|' MatchClauses { MatchLambdaExpr $3 $6 } + | matchAllLambda as Expr with '|' MatchClauses { MatchAllLambdaExpr $3 $6 } + +MatchClauses :: { [MatchClause] } + : Pattern "->" Expr { [($1, $3)] } + | MatchClauses '|' Pattern "->" Expr { $1 ++ [($3, $5)] } + +-- FIXME : +-- Uncommenting these 2 rules will yield shift/reduce conflict at +-- TopExpr -> var . '=' Expr +-- TopExpr -> var . list1__Arg__ '=' Expr +-- Atom -> var . +Arg :: { Arg } + : '$' var { ScalarArg $2 } + -- | var { ScalarArg $1 } + | "*$" var { InvertedScalarArg $2 } + -- | '%' var %prec TENSOR { TensorArg $2 } + +Atom :: { EgisonExpr } + : int { IntegerExpr $1 } + | var { VarExpr $ stringToVar $1 } + | True { BoolExpr True } + | False { BoolExpr False } + | something { SomethingExpr } + | '(' sep2(Expr, ',') ')' { TupleExpr $2 } + | '[' sep(Expr, ',') ']' { CollectionExpr (map ElementExpr $2) } + | '(' Expr ')' { $2 } + | '[' Expr ".." Expr ']' { makeApply (VarExpr $ stringToVar "between") [$2, $4] } + +-- +-- Patterns +-- + +Pattern :: { EgisonPattern } + : '_' { WildCard } + | '$' var { PatVar (stringToVar $2) } + | '#' Atom { ValuePat $2 } + | '(' sep2(Pattern, ',') ')' { TuplePat $2 } + | Pattern ':' Pattern { InductivePat "cons" [$1, $3] } + | Pattern "++" Pattern { InductivePat "join" [$1, $3] } + +-- +-- Helpers (Parameterized Products) +-- + +sep2(p, q) : p q sep1(p, q) { $1 : $3 } +sep1(p, q) : p list(snd(q, p)) { $1 : $2 } +sep(p, q) : sep1(p, q) { $1 } + | { [] } + +snd(p, q) : p q { $2 } + +list1(p) : rev_list1(p) { reverse $1 } +list(p) : list1(p) { $1 } + | { [] } + +rev_list1(p) : p { [$1] } + | rev_list1(p) p { $2 : $1 } + { +makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr +makeApply func xs = do + let args = map (\x -> case x of + LambdaArgExpr s -> Left s + _ -> Right x) xs + let vars = lefts args + case vars of + [] -> ApplyExpr func . TupleExpr $ rights args + _ | all null vars -> + let args' = rights args + args'' = zipWith (curry f) args (annonVars 1 (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' + in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' + | all (not . null) vars -> + let n = Set.size $ Set.fromList vars + args' = rights args + args'' = zipWith (curry g) args (annonVars (n + 1) (length args)) + args''' = map (VarExpr . stringToVar . either id id) args'' + in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args' + where + annonVars m n = take n $ map ((':':) . show) [m..] + f (Left _, var) = Left var + f (Right _, var) = Right var + g (Left arg, _) = Left (':':arg) + g (Right _, var) = Right var + lexwrap :: (Token -> Alex a) -> Alex a lexwrap = (alexMonadScan' >>=) happyError :: Token -> Alex a -happyError (Token p t) = - alexError' p ("parse error at token '" ++ show t ++ "'") +happyError (Token _ TokenEOF) = alexError "unexpected end of input" +happyError (Token p t) = alexError' p ("parse error at token '" ++ show t ++ "'") readTopExprs :: String -> EgisonM [EgisonTopExpr] -readTopExprs = undefined +readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs readTopExpr :: String -> EgisonM EgisonTopExpr -readTopExpr = undefined +readTopExpr = either throwError desugarTopExpr . parseTopExpr readExprs :: String -> EgisonM [EgisonExpr] -readExprs = undefined +readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs readExpr :: String -> EgisonM EgisonExpr -readExpr = undefined +readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] -parseTopExprs = undefined +parseTopExprs = undefined -- runAlex' parseTopExprs_ parseTopExpr :: String -> Either EgisonError EgisonTopExpr -parseTopExpr = undefined +parseTopExpr = runAlex' parseTopExpr_ parseExprs :: String -> Either EgisonError [EgisonExpr] parseExprs = undefined parseExpr :: String -> Either EgisonError EgisonExpr -parseExpr = undefined --- parseExpr = runAlex' parse - -loadFile :: FilePath -> EgisonM [EgisonTopExpr] -loadFile = undefined +parseExpr = runAlex' parseExpr_ +-- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] -loadLibraryFile = undefined +loadLibraryFile file = do + homeDir <- liftIO getHomeDirectory + doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file + if doesExist + then loadFile $ homeDir ++ "/.egison/" ++ file + else liftIO (getDataFileName file) >>= loadFile + +-- |Load a file +loadFile :: FilePath -> EgisonM [EgisonTopExpr] +loadFile file = do + doesExist <- liftIO $ doesFileExist file + unless doesExist $ throwError $ Default ("file does not exist: " ++ file) + input <- liftIO $ readUTF8File file + exprs <- readTopExprs $ shebang input + concat <$> mapM recursiveLoad exprs + where + recursiveLoad (Load file) = loadLibraryFile file + recursiveLoad (LoadFile file) = loadFile file + recursiveLoad expr = return [expr] + shebang :: String -> String + shebang ('#':'!':cs) = ';':'#':'!':cs + shebang cs = cs } 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 @@ -659,6 +659,7 @@ , ("read-file", readFile') , ("rand", randRange) + , ("f.rand", randRangeDouble) -- , ("sqlite", sqlite) ] @@ -749,6 +750,13 @@ randRange = twoArgs' $ \val val' -> do i <- fromEgison val :: EgisonM Integer i' <- fromEgison val' :: EgisonM Integer + n <- liftIO $ getStdRandom $ randomR (i, i') + return $ makeIO $ return $ toEgison n + +randRangeDouble :: PrimitiveFunc +randRangeDouble = twoArgs' $ \val val' -> do + i <- fromEgison val :: EgisonM Double + i' <- fromEgison val' :: EgisonM Double n <- liftIO $ getStdRandom $ randomR (i, i') return $ makeIO $ return $ toEgison n diff --git a/lib/core/random.egi b/lib/core/random.egi --- a/lib/core/random.egi +++ b/lib/core/random.egi @@ -73,3 +73,11 @@ [$ [something] {[$tgt {tgt}]}] }))) + +(define $f.rands + (lambda [$s $e] + {(f.pure-rand s e) @(f.rands s e)})) + +(define $f.pure-rand + (lambda [$s $e] + (io (f.rand s e)))) diff --git a/sample/five-color.egi b/sample/five-color.egi new file mode 100644 --- /dev/null +++ b/sample/five-color.egi @@ -0,0 +1,42 @@ +;;; +;;; 5-color +;;; + + +(define $node [integer (maybe integer)]) +(define $graph (set [node (multiset node)])) + +(define $colors (between 1 5)) + +(define $graph-data + {[[1 Nothing] {[2 Nothing]}] + [[2 Nothing] {[1 Nothing]}]}) + +(define $main + (lambda [$graph-data] + (match [colors graph-data] [(set integer) graph] + {; 周りのノードでまだ5色全部使われていない場合． + [[ ] _>] + (main (assign-color id c graph-data))] + ; 次数が5で周りで5色全部使われているノードしか残っていない場合． + [[_ >>>>>] _>] + undefined] + ; すべてのノードに色付け完了． + [_ graph-data] + }))) + +(define $assign-color + (lambda [$id $c $graph-data] + (map (lambda [$n] + [(rewrite-node id c (2#%1 n)) (map (lambda [$n] (rewrite-node id c n)) (2#%2 n))]) + graph-data))) + +(define $rewrite-node + (lambda [$id $c $n] + (match n node + {[[,id (nothing)] [id (Just c)]] + [_ n]}))) + +(rewrite-node 1 5 [1 Nothing]) ; [1 {5}] +(assign-color 1 5 graph-data) ; {[[1 {5}] {[2 {}]}] [[2 {}] {[1 {5}]}]} +(main graph-data) ; {[[1 {1}] {[2 {2}]}] [[2 {2}] {[1 {1}]}]}