From 74740f0e493a174552d79c3bbd2ab7786f18eb39 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 1 Mar 2016 05:15:23 +0100
Subject: Support for Pow operation (x a y b ^ := x^a * y^b)

---
 rpn.hs | 28 ++++++++++++++++++----------
 1 file changed, 18 insertions(+), 10 deletions(-)

(limited to 'rpn.hs')

diff --git a/rpn.hs b/rpn.hs
index b441db4..d70c909 100755
--- a/rpn.hs
+++ b/rpn.hs
@@ -1,5 +1,7 @@
 #!/usr/bin/env runghc
 
+{-# LANGUAGE ViewPatterns #-}
+
 import Control.Monad (join, sequence, forever)
 import Control.Applicative
 import System.Environment
@@ -10,7 +12,7 @@ import qualified Control.Monad.State as S
 import qualified Data.Map as M
 import System.IO
 
-data Symbol a = Number a a | Err | Add | Sub | Mult | Div | Unc | Exp deriving (Eq, Ord, Show)
+data Symbol a = Number a a | Err | Add | Sub | Mult | Div | Unc | Exp | Pow deriving (Eq, Ord, Show)
 instance Floating a => Num (Symbol a) where
   (Number x del) + (Number y del') = Number (x + y) (abs $ gMean [del, del'])
   _ + _ = Err
@@ -42,7 +44,7 @@ fromSymbol _ = (0, 0)
 
 
 pPrint :: (Show a, Fractional a) => Symbol a -> String
-pPrint (Number x d) = (show x) ++ " ± " ++ (show d) ++ " (relative error: " ++ (show $ d / x) ++ ")"
+pPrint (Number x d) = x `seq` d `seq` (show x) ++ " ± " ++ (show d) ++ " (relative error: " ++ (show $ d / x) ++ ")"
 pPrint s = show s
 
 main :: IO ()
@@ -71,7 +73,7 @@ clarifySymbol s = maybe clarify' (return . words) =<< lookupEnv s
 
 isKnownSymbol :: String -> Bool
 isKnownSymbol s = or [
-  s `elem` ["+", "-", "*", "/", "±", "+-", "e"],
+  s `elem` ["+", "-", "*", "/", "±", "+-", "e", "^"],
   isJust $ (maybeRead s :: Maybe Double)
                      ]
 
@@ -91,17 +93,18 @@ interpreteSymbol "/" = Div
 interpreteSymbol "±" = Unc
 interpreteSymbol "+-" = Unc
 interpreteSymbol "e" = Exp
+interpreteSymbol "^" = Pow
 interpreteSymbol x = Number (read x) 0
 
-evalExpVec :: Floating a => [Symbol a] -> Symbol a
+evalExpVec :: (Floating a, RealFrac a, Eq a) => [Symbol a] -> Symbol a
 evalExpVec is = head . snd $ S.runState (evalExpVec' is) []
 
-evalExpVec' :: Floating a => [Symbol a] -> S.State [Symbol a] ()
+evalExpVec' :: (Floating a, RealFrac a, Eq a) => [Symbol a] -> S.State [Symbol a] ()
 evalExpVec' is = do
   sequence $ map evalExp is
   return ()
 
-evalExp :: Floating a => Symbol a -> S.State [Symbol a] ()
+evalExp :: (Floating a, RealFrac a, Eq a) => Symbol a -> S.State [Symbol a] ()
 evalExp (Number x del) = do
   state <- S.get
   S.put $ ((Number x del):state)
@@ -121,8 +124,13 @@ evalExp Div = do
   state <- S.get
   S.put $ ((foldl1 (/) . reverse $ take 2 state):drop 2 state)
 evalExp Exp = do
-  state <- S.get
+  (e:b:state) <- S.get
+  S.put $ (b * (Number (10 ** (fst $ fromSymbol e)) 0)):state
+evalExp Pow = do
+  ((Number b'@(round -> b) 0):(Number y dY):(Number a'@(round -> a) 0):(Number x dX):state) <- S.get
   let
-    b = state !! 1
-    e = state !! 0
-  S.put $ ((b * (Number (10 ** (fst $ fromSymbol e)) 0)):drop 2 state)
+    prod = (x^^a) * (y^^b)
+    dX' = dX / x
+    dY' = dY / y
+    err = prod * (sqrt $ (a' * dX')^2 + (b' * dY')^2)
+  S.put $ (Number prod err):state
-- 
cgit v1.2.3