egison 3.9.0 → 3.9.1
raw patch · 7 files changed
+478/−72 lines, 7 files
Files
- egison.cabal +2/−2
- hs-src/Language/Egison/Core.hs +2/−1
- hs-src/Language/Egison/Lexer.x +170/−31
- hs-src/Language/Egison/ParserNonS2.y +246/−38
- hs-src/Language/Egison/Primitives.hs +8/−0
- lib/core/random.egi +8/−0
- sample/five-color.egi +42/−0
egison.cabal view
@@ -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
hs-src/Language/Egison/Core.hs view
@@ -107,12 +107,13 @@ evalTopExpr' _ st (Test expr) = do pushFuncName "<stdin>" val <- evalStateT st [] >>= flip evalExprDeep expr+ popFuncName return (Just (show val), st) evalTopExpr' _ st (Execute expr) = do pushFuncName "<stdin>" 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
hs-src/Language/Egison/Lexer.x view
@@ -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 "<unknown>"+ 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 "<stdin>" >> a)+runAlex' :: Alex a -> String -> Either EgisonError a+runAlex' a input =+ case runAlex input (setFilePath "<stdin>" >> a) of+ Left msg -> Left $ Parser msg+ Right r -> Right r }
hs-src/Language/Egison/ParserNonS2.y view
@@ -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 }
hs-src/Language/Egison/Primitives.hs view
@@ -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
lib/core/random.egi view
@@ -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))))
+ sample/five-color.egi view
@@ -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色全部使われていない場合．+ [[<cons $c _> <cons [[$id (nothing)] !<cons [_ (just ,c)] _>] _>]+ (main (assign-color id c graph-data))]+ ; 次数が5で周りで5色全部使われているノードしか残っていない場合．+ [[_ <cons [[$id (nothing)] <cons [$nid_1 (just $c_1)] <cons [$nid_2 (just $c_2)] <cons [$nid_3 (just $c_3)] <cons [$nid_4 (just $c_4)] <cons [$nid_5 (just $c_5)] <nil>>>>>>] _>]+ 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}]}]}