egison 3.3.12 → 3.3.13

raw patch · 12 files changed

+181/−31 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +2/−2
• hs-src/Language/Egison/Core.hs +16/−8
• hs-src/Language/Egison/Desugar.hs +2/−2
• hs-src/Language/Egison/Parser.hs +6/−4
• hs-src/Language/Egison/Types.hs +1/−1
• lib/string/japanese.egi +71/−0
• lib/string/string.egi +60/−0
• sample/demo1-ja.egi +9/−0
• sample/io/cut.egi +3/−3
• sample/io/dice.egi +2/−2
• sample/mahjong.egi +8/−8
• sample/poker-hands.egi +1/−1

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.3.12+Version:             3.3.13 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.@@ -32,7 +32,7 @@  Extra-Source-Files:  benchmark/Benchmark.hs -Data-files:          lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/math.egi lib/core/database.egi lib/core/io.egi lib/string/string.egi +Data-files:          lib/core/base.egi lib/core/collection.egi lib/core/order.egi lib/core/number.egi lib/core/math.egi lib/core/database.egi lib/core/io.egi lib/string/string.egi lib/string/japanese.egi                      lib/tree/xml.egi lib/math/prime.egi lib/math/euler.egi                      sample/*.egi sample/io/*.egi sample/io/*.egi                      elisp/egison-mode.el

@@ -1,4 +1,4 @@-{-# Language TupleSections #-}+{-# Language TupleSections, ViewPatterns #-}  {- | Module      : Language.Egison.Core@@ -314,13 +314,13 @@ evalExpr env (GenerateArrayExpr names size expr) =    evalExpr env (GenerateArrayExpr names (TupleExpr [size]) expr) -evalExpr env (ArrayBoundsExpr expr) = -  evalExpr env expr >>= arrayBounds+evalExpr env (ArraySizeExpr expr) = +  evalExpr env expr >>= arraySize   where-    arrayBounds :: WHNFData -> EgisonM WHNFData-    arrayBounds (Intermediate (IArray arr)) = return . Value . toEgison $ Array.bounds arr-    arrayBounds (Value (Array arr))         = return . Value . toEgison $ Array.bounds arr-    arrayBounds val                          = throwError $ TypeMismatch "array" val+    arraySize :: WHNFData -> EgisonM WHNFData+    arraySize (Intermediate (IArray arr)) = return . Value . toEgison $ snd $ Array.bounds arr+    arraySize (Value (Array arr))         = return . Value . toEgison $ snd $ Array.bounds arr+    arraySize val                          = throwError $ TypeMismatch "array" val  evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined@@ -488,12 +488,20 @@     DFSMode -> processMStatesDFS stream     BFSMode -> processMStatesBFS stream +gatherBindings :: MatchingState -> Maybe [Binding]+gatherBindings (MState _ _ bindings []) = return bindings+gatherBindings (MState _ _ bindings trees) = isResolved trees >> return bindings+  where isResolved :: [MatchingTree] -> Maybe ()+        isResolved [] = return ()+        isResolved (MAtom _ _ _ : _) = Nothing+        isResolved (MNode _ state : rest) = gatherBindings state >> isResolved rest+ extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) extractMatches = extractMatches' ([], [])  where   extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])   extractMatches' (xs, ys) [] = return (xs, ys)-  extractMatches' (xs, ys) ((MCons (MState _ _ bindings []) states):rest) = do+  extractMatches' (xs, ys) ((MCons (gatherBindings -> Just bindings) states):rest) = do     states' <- states     extractMatches' (xs ++ [bindings], ys ++ [states']) rest   extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest

@@ -137,9 +137,9 @@ desugar (IndexedExpr expr indices) =    IndexedExpr <$> desugar expr <*> (mapM desugar indices) -desugar (ArrayBoundsExpr expr) = do+desugar (ArraySizeExpr expr) = do   expr' <- desugar expr-  return $ ArrayBoundsExpr expr'+  return $ ArraySizeExpr expr'  desugar (InductiveDataExpr name exprs) = do    exprs' <- mapM desugar exprs

@@ -323,7 +323,9 @@ statements = braces $ sepEndBy statement whiteSpace  statement :: Parser BindingExpr-statement = try binding <|> brackets (([],) <$> expr)+statement = try binding+        <|> try (brackets (([],) <$> expr))+        <|> (([],) <$> expr)  bindings :: Parser [BindingExpr] bindings = braces $ sepEndBy binding whiteSpace@@ -386,7 +388,7 @@ generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> varNames <*> expr <*> expr  arraySizeExpr :: Parser EgisonExpr-arraySizeExpr = keywordArrayBounds >> ArrayBoundsExpr <$> expr+arraySizeExpr = keywordArraySize >> ArraySizeExpr <$> expr  arrayRefExpr :: Parser EgisonExpr arrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> expr <*> expr@@ -551,7 +553,7 @@   , "io"   , "algebraic-data-matcher"   , "generate-array"-  , "array-bounds"+  , "array-size"   , "array-ref"   , "something"   , "undefined"]@@ -608,7 +610,7 @@ keywordUndefined            = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher" keywordGenerateArray        = reserved "generate-array"-keywordArrayBounds          = reserved "array-bounds"+keywordArraySize            = reserved "array-size" keywordArrayRef             = reserved "array-ref"  sign :: Num a => Parser (a -> a)

@@ -163,7 +163,7 @@    | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]   | GenerateArrayExpr [String] EgisonExpr EgisonExpr-  | ArrayBoundsExpr EgisonExpr+  | ArraySizeExpr EgisonExpr   | ArrayRefExpr EgisonExpr EgisonExpr    | SomethingExpr

@@ -0,0 +1,71 @@+(define $katakana-to-yomi+  (lambda [$s]+    (match s string+      {[<cons $c <cons ,'ャ' $rs>>+        (append (katakana-to-yomi1 {c 'ャ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ュ' $rs>>+        (append (katakana-to-yomi1 {c 'ュ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ョ' $rs>>+        (append (katakana-to-yomi1 {c 'ョ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ァ' $rs>>+        (append (katakana-to-yomi1 {c 'ァ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ィ' $rs>>+        (append (katakana-to-yomi1 {c 'ィ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ゥ' $rs>>+        (append (katakana-to-yomi1 {c 'ゥ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ェ' $rs>>+        (append (katakana-to-yomi1 {c 'ェ'}) (katakana-to-yomi rs))]+       [<cons $c <cons ,'ォ' $rs>>+        (append (katakana-to-yomi1 {c 'ォ'}) (katakana-to-yomi rs))]+       [<cons ,'ー' $rs>+        (katakana-to-yomi rs)]+       [<cons ,'ッ' $rs>+        (katakana-to-yomi rs)]+       [<cons $c $rs>+        (append (katakana-to-yomi1 {c}) (katakana-to-yomi rs))]+       [<nil> {}]+       })))++(define $katakana-to-yomi1+  (lambda [$cs]+    (match cs (list char)+      {[,{'ア'} {"A"}] [,{'イ'} {"I"}] [,{'ウ'} {"U"}] [,{'エ'} {"E"}] [,{'オ'} {"O"}]+       [,{'カ'} {"K" "A"}] [,{'キ'} {"K" "I"}] [,{'ク'} {"K" "U"}] [,{'ケ'} {"K" "E"}] [,{'コ'} {"K" "O"}]+       [,{'サ'} {"S" "A"}] [,{'シ'} {"SH" "I"}] [,{'ス'} {"S" "U"}] [,{'セ'} {"S" "E"}] [,{'ソ'} {"S" "O"}]+       [,{'タ'} {"T" "A"}] [,{'チ'} {"CH" "I"}] [,{'ツ'} {"T" "U"}] [,{'テ'} {"T" "E"}] [,{'ト'} {"T" "O"}]+       [,{'ナ'} {"N" "A"}] [,{'ニ'} {"N" "I"}] [,{'ヌ'} {"N" "U"}] [,{'ネ'} {"N" "E"}] [,{'ノ'} {"N" "O"}]+       [,{'ハ'} {"H" "A"}] [,{'ヒ'} {"H" "I"}] [,{'フ'} {"F" "U"}] [,{'ヘ'} {"H" "E"}] [,{'ホ'} {"H" "O"}]+       [,{'マ'} {"M" "A"}] [,{'ミ'} {"M" "I"}] [,{'ム'} {"M" "U"}] [,{'メ'} {"M" "E"}] [,{'モ'} {"M" "O"}]+       [,{'ヤ'} {"Y" "A"}] [,{'ユ'} {"Y" "U"}] [,{'ヨ'} {"Y" "O"}]+       [,{'ラ'} {"R" "A"}] [,{'リ'} {"R" "I"}] [,{'ル'} {"R" "U"}] [,{'レ'} {"R" "E"}] [,{'ロ'} {"R" "O"}]+       [,{'ワ'} {"W" "A"}] [,{'ヲ'} {"O"}] [,{'ン'} {"N"}]+       [,{'ガ'} {"G" "A"}] [,{'ギ'} {"G" "I"}] [,{'グ'} {"G" "U"}] [,{'ゲ'} {"G" "E"}] [,{'ゴ'} {"G" "O"}]+       [,{'ザ'} {"Z" "A"}] [,{'ジ'} {"J" "I"}] [,{'ズ'} {"Z" "U"}] [,{'ゼ'} {"Z" "E"}] [,{'ゾ'} {"Z" "O"}]+       [,{'ダ'} {"D" "A"}] [,{'ヂ'} {"D" "I"}] [,{'ヅ'} {"D" "U"}] [,{'デ'} {"D" "E"}] [,{'ド'} {"D" "O"}]+       [,{'バ'} {"B" "A"}] [,{'ビ'} {"B" "I"}] [,{'ブ'} {"B" "U"}] [,{'ベ'} {"B" "E"}] [,{'ボ'} {"B" "O"}]+       [,{'パ'} {"P" "A"}] [,{'ピ'} {"P" "I"}] [,{'プ'} {"P" "U"}] [,{'ペ'} {"P" "E"}] [,{'ポ'} {"P" "O"}]+       [,{'キ' 'ャ'} {"K" "AE"}] [,{'キ' 'ュ'} {"K" "YU"}] [,{'キ' 'ョ'} {"K" "YO"}]+       [,{'ギ' 'ャ'} {"G" "AE"}] [,{'ギ' 'ュ'} {"G" "YU"}] [,{'ギ' 'ョ'} {"G" "YO"}]+       [,{'シ' 'ャ'} {"SH" "AE"}] [,{'シ' 'ュ'} {"SH" "U"}] [,{'シ' 'ョ'} {"SH" "O"}]+       [,{'ジ' 'ャ'} {"J" "A"}] [,{'ジ' 'ュ'} {"J" "U"}] [,{'ジ' 'ョ'} {"J" "O"}]+       [,{'チ' 'ャ'} {"CH" "AE"}] [,{'チ' 'ュ'} {"CH" "U"}] [,{'チ' 'ョ'} {"CH" "O"}]+       [,{'ニ' 'ャ'} {"N" "AE"}] [,{'ニ' 'ュ'} {"N" "U"}] [,{'ニ' 'ョ'} {"N" "O"}]+       [,{'ヒ' 'ャ'} {"H" "AE"}] [,{'ヒ' 'ュ'} {"H" "YU"}] [,{'ヒ' 'ョ'} {"H" "YO"}]+       [,{'ビ' 'ャ'} {"B" "AE"}] [,{'ビ' 'ュ'} {"B" "YU"}] [,{'ビ' 'ョ'} {"B" "YO"}]+       [,{'ピ' 'ャ'} {"P" "AE"}] [,{'ピ' 'ュ'} {"P" "YU"}] [,{'ピ' 'ョ'} {"P" "YO"}]+       [,{'ミ' 'ャ'} {"M" "AE"}] [,{'ミ' 'ュ'} {"M" "YU"}] [,{'ミ' 'ョ'} {"M" "YO"}]+       [,{'リ' 'ャ'} {"R" "AE"}] [,{'リ' 'ュ'} {"R" "YU"}] [,{'リ' 'ョ'} {"R" "YO"}]+       [,{'ウ' 'ィ'} {"WI"}] [,{'ウ' 'ェ'} {"WE"}] [,{'ウ' 'ォ'} {"WO"}]+       [,{'キ' 'ィ'} {"K" "I"}]+       [,{'ク' 'ィ'} {"K" "WI"}] [,{'ク' 'ェ'} {"K" "WE"}] [,{'ク' 'ォ'} {"K" "WO"}]+       [,{'シ' 'ィ'} {"S" "I"}] [,{'シ' 'ェ'} {"SH" "E"}]+       [,{'ジ' 'ェ'} {"J" "E"}]+       [,{'チ' 'ェ'} {"CH" "E"}]+       [,{'フ' 'ァ'} {"F" "A"}] [,{'フ' 'ィ'} {"F" "I"}] [,{'フ' 'ェ'} {"F" "E"}] [,{'フ' 'ォ'} {"F" "O"}]+       [,{'ヴ' 'ァ'} {"V" "A"}] [,{'ヴ' 'ィ'} {"V" "I"}] [,{'ヴ' 'ェ'} {"V" "E"}] [,{'ヴ' 'ォ'} {"V" "O"}]+       [,{'シ' 'ィ'} {"S" "I"}] [,{'ス' 'ィ'} {"S" "I"}] [,{'ズ' 'ィ'} {"Z" "I"}]+       [,{'テ' 'ィ'} {"T" "I"}] [,{'デ' 'ィ'} {"D" "I"}] [,{'デ' 'ュ'} {"D" "YU"}]+       [,{'ツ' 'ゥ'} {"T" "U"}] [,{'ト' 'ゥ'} {"T" "U"}] [,{'ヅ' 'ゥ'} {"D" "U"}] [,{'ド' 'ゥ'} {"D" "U"}] [,{'フ' 'ュ'} {"F" "YU"}]+       [,{'ァ'} {"A"}] [,{'ィ'} {"I"}] [,{'ゥ'} {"U"}] [,{'ェ'} {"E"}] [,{'ォ'} {"O"}]+       [<cons $c <cons _>> (katakana-to-yomi1 {c})]+       })))

@@ -45,6 +45,10 @@ ;;; String as Collection ;;; +(define $S.map+  (lambda [$f $xs]+    (pack (map f (unpack xs)))))+ (define $S.length   (lambda [$xs]     (length-string xs)))@@ -64,3 +68,59 @@            xss)))  (define $S.intercalate (compose intersperse S.concat))++(define $katakana?+  (match-lambda char+    {[,'ア' #t] [,'イ' #t] [,'ウ' #t] [,'エ' #t] [,'オ' #t]+     [,'カ' #t] [,'キ' #t] [,'ク' #t] [,'ケ' #t] [,'コ' #t]+     [,'サ' #t] [,'シ' #t] [,'ス' #t] [,'セ' #t] [,'ソ' #t]+     [,'タ' #t] [,'チ' #t] [,'ツ' #t] [,'テ' #t] [,'ト' #t]+     [,'ナ' #t] [,'ニ' #t] [,'ヌ' #t] [,'ネ' #t] [,'ノ' #t]+     [,'ハ' #t] [,'ヒ' #t] [,'フ' #t] [,'ヘ' #t] [,'ホ' #t]+     [,'マ' #t] [,'ミ' #t] [,'ム' #t] [,'メ' #t] [,'モ' #t]+     [,'ヤ' #t] [,'ユ' #t] [,'ヨ' #t]+     [,'ラ' #t] [,'リ' #t] [,'ル' #t] [,'レ' #t] [,'ロ' #t]+     [,'ワ' #t] [,'ヲ' #t] [,'ン' #t]+     [,'ガ' #t] [,'ギ' #t] [,'グ' #t] [,'ゲ' #t] [,'ゴ' #t]+     [,'ザ' #t] [,'ジ' #t] [,'ズ' #t] [,'ゼ' #t] [,'ゾ' #t]+     [,'ダ' #t] [,'ヂ' #t] [,'ヅ' #t] [,'デ' #t] [,'ド' #t]+     [,'バ' #t] [,'ビ' #t] [,'ブ' #t] [,'ベ' #t] [,'ボ' #t]+     [,'パ' #t] [,'ピ' #t] [,'プ' #t] [,'ペ' #t] [,'ポ' #t]+     [,'ァ' #t] [,'ィ' #t] [,'ゥ' #t] [,'ェ' #t] [,'ォ' #t]+     [,'ャ' #t] [,'ュ' #t] [,'ョ' #t]+     [,'ッ' #t] [,'ー' #t]+     [_ #f]}))++(define $katakanas?+  (lambda [$s]+    (all katakana? (unpack s))))++(define $alphabet?+  (match-lambda char+    {[,'a' #t] [,'b' #t] [,'c' #t] [,'d' #t] [,'e' #t]+     [,'f' #t] [,'g' #t] [,'h' #t] [,'i' #t] [,'j' #t]+     [,'k' #t] [,'l' #t] [,'m' #t] [,'n' #t] [,'o' #t]+     [,'p' #t] [,'q' #t] [,'r' #t] [,'s' #t] [,'t' #t]+     [,'u' #t] [,'v' #t] [,'w' #t] [,'x' #t] [,'y' #t]+     [,'z' #t]+     [,'A' #t] [,'B' #t] [,'C' #t] [,'D' #t] [,'E' #t]+     [,'F' #t] [,'G' #t] [,'H' #t] [,'I' #t] [,'J' #t]+     [,'K' #t] [,'L' #t] [,'M' #t] [,'N' #t] [,'O' #t]+     [,'P' #t] [,'Q' #t] [,'R' #t] [,'S' #t] [,'T' #t]+     [,'U' #t] [,'V' #t] [,'W' #t] [,'X' #t] [,'Y' #t]+     [,'Z' #t]+     [_ #f]}))++(define $alphabets?+  (lambda [$s]+    (all alphabet? (unpack s))))++(define $upper-case+  (match-lambda char+    {[,'a' 'A'] [,'b' 'B'] [,'c' 'C'] [,'d' 'D'] [,'e' 'E']+     [,'f' 'F'] [,'g' 'G'] [,'h' 'H'] [,'i' 'I'] [,'j' 'J']+     [,'k' 'K'] [,'l' 'L'] [,'m' 'M'] [,'n' 'N'] [,'o' 'O']+     [,'p' 'P'] [,'q' 'Q'] [,'r' 'R'] [,'s' 'S'] [,'t' 'T']+     [,'u' 'U'] [,'v' 'V'] [,'w' 'W'] [,'x' 'X'] [,'y' 'Y']+     [,'z' 'Z']+     [$c c]}))

@@ -0,0 +1,9 @@+;; 素数の無限リストから全ての双子素数をパターンマッチにより抽出+(define $twin-primes+  (match-all primes (list integer)+    [<join _ <cons $p <cons ,(+ p 2) _>>>+     [p (+ p 2)]]))++;; 最初の10個の双子素数を列挙+(take 10 twin-primes)+;=>{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]}

@@ -6,6 +6,6 @@ (define $cut   (lambda [$file $nums]     (do {[$port (open-input-file file)]-         [(each-line-from-port port (lambda [$line] (let {[$fs (S.split "," line)]}-                                                      (print (S.intercalate "," (map (nth $ fs) nums))))))]-         [(close-input-port port)]})))+         (each-line-from-port port (lambda [$line] (let {[$fs (S.split "," line)]}+                                                     (print (S.intercalate "," (map (nth $ fs) nums))))))+         (close-input-port port)})))

@@ -1,5 +1,5 @@ (define $main   (lambda [$argv]     (do {[$v (rand 1 6)]-         [(write (show v))]-         [(write-char '\n')]})))+         (write (show v))+         (write-char '\n')})))

@@ -15,12 +15,12 @@   (algebraic-data-matcher     {<ton> <nan> <sha> <pe> <haku> <hatsu> <chun>})) -(define $hai+(define $tile   (algebraic-data-matcher-    {<num suit integer> <ji honor>}))+    {<num suit integer> <hnr honor>}))  ;;-;; Pattern modularizations+;; Pattern modularization ;; (define $twin   (pattern-function [$pat1 $pat2]@@ -43,10 +43,10 @@        pat2>>>))  ;;-;; A function that determins whether the hand is finished or not.+;; A function that determines whether the hand is completed or not. ;;-(define $agari?-  (match-lambda (multiset hai)+(define $complete?+  (match-lambda (multiset tile)     {[(twin $th_1        (| (shuntsu $sh_1 (| (shuntsu $sh_2 (| (shuntsu $sh_3 (| (shuntsu $sh_4 <nil>)                                                                 (kohtsu $kh_1 <nil>)))@@ -60,13 +60,13 @@ ;; ;; Demonstration code ;;-(test (agari? {<Ji <Haku>> <Ji <Haku>>+(test (complete? {<Hnr <Haku>> <Hnr <Haku>>                <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>                <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>                <Num <Pin> 2> <Num <Pin> 3> <Num <Pin> 4>                <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>})) -(test (agari? {<Ji <Haku>> <Ji <Haku>>+(test (complete? {<Hnr <Haku>> <Hnr <Haku>>                <Num <Pin> 1> <Num <Pin> 3> <Num <Pin> 4>                <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>                <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>

@@ -16,7 +16,7 @@     {<card suit (mod 13)>}))  ;;-;; A function that determins poker-hands+;; A function that determines poker-hands ;; (define $poker-hands   (lambda [$cs]