diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -69,6 +69,7 @@ "\\" "\\" "\\" + "\\" "\\" "\\" "\\" diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -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 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 @@ -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 diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -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) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -10,9 +10,7 @@ (define $list (lambda [$a] (matcher - {[,$val [] - {[$tgt (if (eq? val tgt) {[]} {})]}] - [ [] + {[ [] {[{} {[]}] [_ {}]}] [ [a (list a)] @@ -29,6 +27,8 @@ {[$tgt (match-all tgt (list a) [(loop $i [1 $n] $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) {[]} {})]}] - [ [] + {[ [] {[{} {[]}] [_ {}]}] [> [(sorted-list a) (sorted-list a)] @@ -54,6 +52,8 @@ [ [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)] - {[[ ] {[]}] - [[ ] {[]}] - [[_ _] {}]})]}] - [ [] + {[ [] {[{} {[]}] [_ {}]}] [ [a (multiset a)] @@ -334,6 +329,11 @@ [(loop $i [1 $n] > $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)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] [$ [something] {[$tgt {tgt}]}] }))) @@ -485,12 +485,7 @@ (define $set (lambda [$a] (matcher - {[,$val [] - {[$tgt (match [val tgt] [(list a) (multiset a)] - {[[ ] {[]}] - [[ ] {[]}] - [[_ _] {}]})]}] - [ [] + {[ [] {[{} {[]}] [_ {}]}] [ [a (set a)] @@ -507,7 +502,12 @@ [(loop $i [1 $n] > $ts) [(map (lambda [$i] x_i) (between 1 n)) tgt]])]}] - [$ [something] + [,$val [] + {[$tgt (match [val tgt] [(list a) (multiset a)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] + [$ [something] {[$tgt {tgt}]}] }))) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -9,15 +9,15 @@ ;;; (define $nat (matcher - {[,$n [] - {[$tgt (if (eq? tgt n) {[]} {})]}] - [ [] + {[ [] {[0 {[]}] [_ {}]}] [ nat {[$tgt (match (compare tgt 0) ordering {[ {(- 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)] - {[[ ] - (+ a (/ b (continued-fraction as bs)))] - [[> ] a]})) + (lambda [$n $as $bs] + (match [as bs] [(list integer) (list integer)] + {[[ ] + (+ n (/ b (continued-fraction a as bs)))] + [[ ] 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)]))))) + diff --git a/lib/core/string.egi b/lib/core/string.egi --- a/lib/core/string.egi +++ b/lib/core/string.egi @@ -6,11 +6,7 @@ (define $string (matcher - {[,$val [] - {[$tgt (if (eq? val tgt) - {[]} - {})]}] - [ [string (list string) string] + {[ [string (list string) string] {[$tgt (regex-cg regexpr tgt)]}] [ [string string string] {[$tgt (regex regexpr tgt)]}] @@ -35,6 +31,10 @@ [ [string string] {[$tgt (match-all tgt string [(loop $i [1 $n] $rs) [(pack (map (lambda [$i] xa_i) (between 1 n))) rs]])]}] + [,$val [] + {[$tgt (if (eq? val tgt) + {[]} + {})]}] [$ [something] {[$tgt {tgt}]}] }))