egison 3.5.9 → 3.5.10
raw patch · 8 files changed
+119/−61 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- egison.cabal +1/−1
- elisp/egison-mode.el +1/−0
- hs-src/Language/Egison/Parser.hs +22/−3
- hs-src/Language/Egison/Primitives.hs +21/−16
- hs-src/Language/Egison/Types.hs +8/−1
- lib/core/collection.egi +19/−19
- lib/core/number.egi +42/−16
- lib/core/string.egi +5/−5
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 3.5.9+Version: 3.5.10 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.
elisp/egison-mode.el view
@@ -69,6 +69,7 @@ "\\<next-match-all-lambda\\>" "\\<next-matcher\\>" "\\<matcher\\>"+ "\\<self\\>" "\\<matcher-bfs\\>" "\\<matcher-dfs\\>" "\\<algebraic-data-matcher\\>"
hs-src/Language/Egison/Parser.hs view
@@ -530,8 +530,15 @@ floatExpr :: Parser EgisonExpr floatExpr = do- x <- floatLiteral- y <- return 0+ (x,y) <- P.lexeme lexer $ try (do x <- floatLiteral'+ y <- sign' <*> positiveFloatLiteral+ char 'i'+ return (x,y))+ <|> try (do y <- floatLiteral'+ char 'i'+ return (0,y))+ <|> try (do x <- floatLiteral'+ return (x,0)) return $ FloatExpr x y numberExpr :: Parser EgisonExpr@@ -561,7 +568,19 @@ integerLiteral' = sign <*> positiveIntegerLiteral positiveIntegerLiteral :: Parser Integer-positiveIntegerLiteral = read <$> many1 digit +positiveIntegerLiteral = read <$> many1 digit++positiveFloatLiteral :: Parser Double+positiveFloatLiteral = do+ n <- positiveIntegerLiteral+ char '.'+ mStr <- many1 digit+ let m = read mStr+ let l = m % (10 ^ (fromIntegral (length mStr)))+ return (fromRational ((fromIntegral n) + l) :: Double)++floatLiteral' :: Parser Double+floatLiteral' = sign <*> positiveFloatLiteral -- -- Tokens
hs-src/Language/Egison/Primitives.hs view
@@ -245,35 +245,39 @@ where numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (addInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y') numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x + x') (y + y')- numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val)- numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)+ numberBinaryOp' val (Float x' y') = numberBinaryOp' (numberToFloat' val) (Float x' y')+ numberBinaryOp' (Float x y) val' = numberBinaryOp' (Float x y) (numberToFloat' val')+ numberBinaryOp' (Number _ _) val' = throwError $ TypeMismatch "number" (Value val')+ numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) minus :: PrimitiveFunc minus = twoArgs $ \val val' -> numberBinaryOp' val val' where numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (subInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y') numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x - x') (y - y')- numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val)- numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)+ numberBinaryOp' val (Float x' y') = numberBinaryOp' (numberToFloat' val) (Float x' y')+ numberBinaryOp' (Float x y) val' = numberBinaryOp' (Float x y) (numberToFloat' val')+ numberBinaryOp' (Number _ _) val' = throwError $ TypeMismatch "number" (Value val')+ numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) multiply :: PrimitiveFunc multiply = twoArgs $ \val val' -> numberBinaryOp' val val' where numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x x') (mulInteger' y y')- numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x * x' - y * y') (x * y' + x' * y)- numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val)- numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)- numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)+ numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x * x' - y * y') (x * y' + x' * y) + numberBinaryOp' val (Float x' y') = numberBinaryOp' (numberToFloat' val) (Float x' y')+ numberBinaryOp' (Float x y) val' = numberBinaryOp' (Float x y) (numberToFloat' val')+ numberBinaryOp' (Number _ _) val' = throwError $ TypeMismatch "number" (Value val')+ numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) divide :: PrimitiveFunc divide = twoArgs $ \val val' -> numberBinaryOp' val val' where numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x y') (mulInteger' y x') numberBinaryOp' (Float f 0) (Float f' 0) = return $ Float (f / f') 0- numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val)- numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val)+ numberBinaryOp' val (Float x' y') = numberBinaryOp' (numberToFloat' val) (Float x' y')+ numberBinaryOp' (Float x y) val' = numberBinaryOp' (Float x y) (numberToFloat' val')+ numberBinaryOp' (Number _ _) val' = throwError $ TypeMismatch "number" (Value val') numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) numerator' :: PrimitiveFunc@@ -367,15 +371,16 @@ -- -- Transform --+numberToFloat' :: EgisonValue -> EgisonValue+numberToFloat' (Number (x,y) (d,0)) = Float (fromRational (x % d)) (fromRational (y % d))+ integerToFloat :: PrimitiveFunc integerToFloat = rationalToFloat rationalToFloat :: PrimitiveFunc-rationalToFloat = oneArg $ \val -> do+rationalToFloat = oneArg $ \val -> case val of- n@(Number (_,0) (_,0)) -> do- r <- fromEgison n- return $ Float (fromRational r) 0+ Number (x,y) (d,0) -> return $ numberToFloat' val _ -> throwError $ TypeMismatch "integer of rational number" (Value val) charToInteger :: PrimitiveFunc
hs-src/Language/Egison/Types.hs view
@@ -111,6 +111,7 @@ import System.IO import Data.Ratio+import Numeric import System.IO.Unsafe (unsafePerformIO) @@ -272,7 +273,7 @@ show (Bool False) = "#f" show (Number (x,y) (1,0)) = showComplex x y show (Number (x,y) (x',y')) = showComplex x y ++ "/" ++ showComplex x' y'- show (Float x y) = showComplex x y+ show (Float x y) = showComplexFloat x y show (InductiveData name []) = "<" ++ name ++ ">" show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">" show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]"@@ -319,6 +320,11 @@ showComplex 0 y = show y ++ "i" showComplex x y = show x ++ (if y > 0 then "+" else "") ++ show y ++ "i" +showComplexFloat :: Double -> Double -> String+showComplexFloat x 0.0 = showFFloat Nothing x ""+showComplexFloat 0.0 y = showFFloat Nothing y "i"+showComplexFloat x y = (showFFloat Nothing x "") ++ (if y > 0 then "+" else "") ++ (showFFloat Nothing y "i")+ reduceFraction :: EgisonValue -> EgisonValue reduceFraction (Number (x,y) (x',y')) | x' < 0 = let m = negate (foldl gcd x [y, x', y']) in@@ -329,6 +335,7 @@ Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m) | x' == 0 && y' > 0 = let m = foldl gcd x [y, x', y'] in Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m)+ | x' == 0 && y' == 0 = Number (1,0) (0,0) showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals)
lib/core/collection.egi view
@@ -10,9 +10,7 @@ (define $list (lambda [$a] (matcher- {[,$val []- {[$tgt (if (eq? val tgt) {[]} {})]}]- [<nil> []+ {[<nil> [] {[{} {[]}] [_ {}]}] [<cons $ $> [a (list a)]@@ -29,6 +27,8 @@ {[$tgt (match-all tgt (list a) [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [$i $r] {@r xa_i}) {} (between 1 n)) rs]])]}]+ [,$val []+ {[$tgt (if (eq? val tgt) {[]} {})]}] [$ [something] {[$tgt {tgt}]}] })))@@ -36,9 +36,7 @@ (define $sorted-list (lambda [$a] (matcher- {[,$val []- {[$tgt (if (eq? val tgt) {[]} {})]}]- [<nil> []+ {[<nil> [] {[{} {[]}] [_ {}]}] [<join $ <cons ,$px $>> [(sorted-list a) (sorted-list a)]@@ -54,6 +52,8 @@ [<cons $ $> [a (sorted-list a)] {[{$x @$xs} {[x xs]}] [_ {}]}]+ [,$val []+ {[$tgt (if (eq? val tgt) {[]} {})]}] [$ [something] {[$tgt {tgt}]}] })))@@ -312,12 +312,7 @@ (define $multiset (lambda [$a] (matcher- {[,$val []- {[$tgt (match [val tgt] [(list a) (multiset a)]- {[[<nil> <nil>] {[]}]- [[<cons $x $xs> <cons ,x ,xs>] {[]}]- [[_ _] {}]})]}]- [<nil> []+ {[<nil> [] {[{} {[]}] [_ {}]}] [<cons $ $> [a (multiset a)]@@ -334,6 +329,11 @@ [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $ts) [(map (lambda [$i] x_i) (between 1 n)) (concat {@(map (lambda [$i] rs_i) (between 1 n)) ts})]])]}]+ [,$val []+ {[$tgt (match [val tgt] [(list a) (multiset a)]+ {[[<nil> <nil>] {[]}]+ [[<cons $x $xs> <cons ,x ,xs>] {[]}]+ [[_ _] {}]})]}] [$ [something] {[$tgt {tgt}]}] })))@@ -485,12 +485,7 @@ (define $set (lambda [$a] (matcher- {[,$val []- {[$tgt (match [val tgt] [(list a) (multiset a)]- {[[<nil> <nil>] {[]}]- [[<cons $x $xs> <cons ,x ,xs>] {[]}]- [[_ _] {}]})]}]- [<nil> []+ {[<nil> [] {[{} {[]}] [_ {}]}] [<cons $ $> [a (set a)]@@ -507,7 +502,12 @@ [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $ts) [(map (lambda [$i] x_i) (between 1 n)) tgt]])]}]- [$ [something]+ [,$val []+ {[$tgt (match [val tgt] [(list a) (multiset a)]+ {[[<nil> <nil>] {[]}]+ [[<cons $x $xs> <cons ,x ,xs>] {[]}]+ [[_ _] {}]})]}]+ [$ [something] {[$tgt {tgt}]}] })))
lib/core/number.egi view
@@ -9,15 +9,15 @@ ;;; (define $nat (matcher- {[,$n []- {[$tgt (if (eq? tgt n) {[]} {})]}]- [<o> []+ {[<o> [] {[0 {[]}] [_ {}]}] [<s $> nat {[$tgt (match (compare tgt 0) ordering {[<greater> {(- tgt 1)}] [_ {}]})]}]+ [,$n []+ {[$tgt (if (eq? tgt n) {[]} {})]}] [$ [something] {[$tgt {tgt}]}] }))@@ -133,12 +133,12 @@ {[q r] @(rtod-helper r n)}))) (define $rtod- (lambda [$c $x]+ (lambda [$x] (let* {[$m (numerator x)] [$n (denominator x)] [$q (quotient m n)] [$r (remainder m n)]}- [q (take c (map fst (rtod-helper r n)))])))+ [q (map fst (rtod-helper r n))]))) (define $rtod' (lambda [$x]@@ -151,7 +151,7 @@ (define $show-decimal (lambda [$c $x]- (match (rtod c x) [integer (list integer)]+ (match (2#[%1 (take c %2)] (rtod x)) [integer (list integer)] {[[$q $sc] (foldl S.append (S.append (show q) ".") (map show sc))]}))) (define $show-decimal'@@ -163,19 +163,45 @@ ;;; Continued Fraction ;;; (define $regular-continued-fraction- (lambda [$as]- (+ (car as)+ (lambda [$n $as]+ (+ n (foldr (lambda [$a $r] (/ 1 (+ a r))) 0- (cdr as)))))-+ as)))) (define $continued-fraction- (match-lambda [(list integer) (list integer)]- {[[<cons $a $as> <cons $b $bs>]- (+ a (/ b (continued-fraction as bs)))]- [[<cons $a <nil>> <nil>] a]}))+ (lambda [$n $as $bs]+ (match [as bs] [(list integer) (list integer)]+ {[[<cons $a $as> <cons $b $bs>]+ (+ n (/ b (continued-fraction a as bs)))]+ [[<nil> <nil>] n]}))) +(define $regular-continued-fraction-of-sqrt-helper+ (lambda [$m $a $b] ; a+b*rt(m)+ (let* {[$n (floor (+ (rtof a) (* (rtof b) (sqrt m))))]+ [$x (- m (power n 2))]}+ (if (eq? x 0)+ {[a b n]}+ (let {[$y (- (power (- n a) 2) (* b b m))]}+ {[a b n] @(regular-continued-fraction-of-sqrt-helper m (/ (- a n) y) (neg (/ b y)))})))))+ (define $regular-continued-fraction-of-sqrt- (lambda [$n]- undefined))+ (lambda [$m]+ (let* {[$n (floor (sqrt m))]+ [$x (- m (power n 2))]}+ ; n+rt(m)-n+ ; n+(rt(m)-n)*(rt(m)+n)/(rt(m)+n)+ ; n+x/(rt(m)+n)+ (if (eq? x 0)+ [n {} {}]+ [n (map 3#%3 (regular-continued-fraction-of-sqrt-helper m (/ n x) (/ 1 x)))]))))++(define $regular-continued-fraction-of-sqrt'+ (lambda [$m]+ (let* {[$n (floor (sqrt m))]+ [$x (- m (power n 2))]}+ (if (eq? x 0)+ [n {} {}]+ (let {[[$s $c] (find-cycle (regular-continued-fraction-of-sqrt-helper m (/ n x) (/ 1 x)))]}+ [n (map 3#%3 s) (map 3#%3 c)])))))+
lib/core/string.egi view
@@ -6,11 +6,7 @@ (define $string (matcher- {[,$val []- {[$tgt (if (eq? val tgt)- {[]}- {})]}]- [<regex-cg ,$regexpr $ $ $> [string (list string) string]+ {[<regex-cg ,$regexpr $ $ $> [string (list string) string] {[$tgt (regex-cg regexpr tgt)]}] [<regex ,$regexpr $ $ $> [string string string] {[$tgt (regex regexpr tgt)]}]@@ -35,6 +31,10 @@ [<join $ $> [string string] {[$tgt (match-all tgt string [(loop $i [1 $n] <cons $xa_i ...> $rs) [(pack (map (lambda [$i] xa_i) (between 1 n))) rs]])]}]+ [,$val []+ {[$tgt (if (eq? val tgt)+ {[]}+ {})]}] [$ [something] {[$tgt {tgt}]}] }))