-- File created: 2009-07-15 21:15:44

{-# LANGUAGE Rank2Types #-}

module Haschoo.Evaluator.Standard.Numeric
   (procedures, isNumeric, isExact, numEq, asInt) where

import Control.Arrow     ((&&&), (***))
import Control.Monad     (ap, foldM)
import Data.Array.IArray (elems)
import Data.Array.MArray (getElems)
import Data.Char         (intToDigit)
import Data.Complex      ( Complex((:+)), mkPolar
                         , imagPart, realPart, phase, magnitude)
import Data.Ratio        (numerator, denominator, approxRational)
import Data.Function     (on)
import Numeric           (showIntAtBase, showSigned)

import qualified Haschoo.Parser as Parser
import           Haschoo.Types           (ScmValue(..), toScmMString)
import           Haschoo.Utils           (ErrOr, allM, ($<), (.:))
import           Haschoo.Evaluator.Utils (tooFewArgs, tooManyArgs, notInt)

procedures :: [(String, ScmValue)]
procedures = map (\(a,b) -> (a, ScmFunc a (return . b)))
   [ ("number?",   fmap ScmBool . scmIsNumber)
   , ("complex?",  fmap ScmBool . scmIsNumber)
   , ("real?",     fmap ScmBool . scmIsReal)
   , ("rational?", fmap ScmBool . scmIsRational)
   , ("integer?",  fmap ScmBool . scmIsInteger)

   , "exact?"   $< id &&& fmap  ScmBool        .: scmIsExact
   , "inexact?" $< id &&& fmap (ScmBool . not) .: scmIsExact

   , ("=", fmap ScmBool . scmNumEq)
   , "<"  $< id &&& fmap ScmBool .: scmCompare (<)
   , ">"  $< id &&& fmap ScmBool .: scmCompare (>)
   , "<=" $< id &&& fmap ScmBool .: scmCompare (<=)
   , ">=" $< id &&& fmap ScmBool .: scmCompare (>=)

   , ("zero?",     fmap ScmBool . scmIsZero)
   , ("positive?", fmap ScmBool . scmIsPos)
   , ("negative?", fmap ScmBool . scmIsNeg)
   , "even?" $< id &&& fmap  ScmBool        .: scmIsEven
   , "odd?"  $< id &&& fmap (ScmBool . not) .: scmIsEven

   , ("max", scmMax)
   , ("min", scmMin)

   , ("+", scmPlus)
   , ("-", scmMinus)
   , ("*", scmMul)
   , ("/", scmDiv)

   , ("abs", scmAbs)

   , ("quotient",  scmQuot)
   , ("remainder", scmRem)
   , ("modulo",    scmMod)

   , ("gcd", scmGcd)
   , ("lcm", scmLcm)

   , ("numerator",   scmNumerator)
   , ("denominator", scmDenominator)

   , ("floor",    scmFloor)
   , ("ceiling",  scmCeil)
   , ("truncate", scmTrunc)
   , ("round",    scmRound)

   , ("rationalize", scmRationalize)

   , ("exp",  scmExp)
   , ("log",  scmLog)
   , ("sin",  scmSin)
   , ("cos",  scmCos)
   , ("tan",  scmTan)
   , ("asin", scmAsin)
   , ("acos", scmAcos)
   , ("atan", scmAtan)

   , ("sqrt", scmSqrt)
   , ("expt", scmExpt)

   , ("make-rectangular", scmMakeRectangular)
   , ("make-polar",       scmMakePolar)
   , ("real-part",        scmRealPart)
   , ("imag-part",        scmImagPart)
   , ("magnitude",        scmNorm)
   , ("angle",            scmAngle)

   , ("exact->inexact", scmToInexact)
   , ("inexact->exact", scmToExact) ]

   ++ map (\(a,b) -> (a, ScmFunc a b))
   [ ("number->string", scmToString)
   , ("string->number", scmToNumber) ]

---- Predicates

scmIsNumber, scmIsReal, scmIsRational, scmIsInteger :: [ScmValue] -> ErrOr Bool
scmIsNumber [x] = Right $ isNumeric x
scmIsNumber []  = tooFewArgs  "number?"
scmIsNumber _   = tooManyArgs "number?"

scmIsReal [x] = Right $ isReal x
scmIsReal []  = tooFewArgs  "real?"
scmIsReal _   = tooManyArgs "real?"

scmIsRational [ScmRat _] = Right True
scmIsRational [x]        = Right $ isInteger x
scmIsRational []         = tooFewArgs "rational?"
scmIsRational _          = tooManyArgs "rational?"

scmIsInteger [x] = Right $ isInteger x
scmIsInteger []  = tooFewArgs  "integer?"
scmIsInteger _   = tooManyArgs "integer?"

scmIsExact :: String -> [ScmValue] -> ErrOr Bool
scmIsExact _ [x] | isNumeric x = Right $ isExact x
scmIsExact s [_]               = notNum s
scmIsExact s []                = tooFewArgs s
scmIsExact s _                 = tooManyArgs s

isExact :: ScmValue -> Bool
isExact (ScmInt _) = True
isExact (ScmRat _) = True
isExact _          = False

---- Comparison

scmNumEq :: [ScmValue] -> ErrOr Bool
scmNumEq [] = tooFewArgs "="
scmNumEq xs = allM f . (zip`ap`tail) $ xs
 where
   f (a,b) = if isNumeric a && isNumeric b
                then Right $ numEq a b
                else notNum "="

numEq :: ScmValue -> ScmValue -> Bool
numEq x y =
   case pairScmComplex x y of
        Right (ScmInt     a, ScmInt     b) -> a == b
        Right (ScmRat     a, ScmRat     b) -> a == b
        Right (ScmReal    a, ScmReal    b) -> a == b
        Right (ScmComplex a, ScmComplex b) -> a == b
        _ -> error "numEq :: the impossible happened"

scmCompare :: (forall a. Real a => a -> a -> Bool)
           -> String -> [ScmValue] -> ErrOr Bool
scmCompare p s xs@(_:_:_) = allM f . (zip`ap`tail) $ xs
 where
   f (a,b) = case liftScmRealA2 p a b of
                  Left _ -> notReal s
                  x      -> x

scmCompare _ s _ = tooFewArgs s

scmIsZero :: [ScmValue] -> ErrOr Bool
scmIsZero [ScmInt     0]    = Right True
scmIsZero [ScmRat     0]    = Right True
scmIsZero [ScmReal    0]    = Right True
scmIsZero [ScmComplex 0]    = Right True
scmIsZero [x] | isNumeric x = Right False
scmIsZero [_]               = notNum "zero?"
scmIsZero _                 = tooManyArgs "zero?"

scmIsPos, scmIsNeg :: [ScmValue] -> ErrOr Bool
scmIsPos [x] = scmCompare (>) "positive?" [x, ScmInt 0]
scmIsPos _   = tooManyArgs "positive?"

scmIsNeg [x] = scmCompare (<) "negative?" [x, ScmInt 0]
scmIsNeg _   = tooManyArgs "negative?"

scmIsEven :: String -> [ScmValue] -> ErrOr Bool
scmIsEven s [x] = if isInteger x
                     then (scmIsZero.return) =<< scmMod [x, ScmInt 2]
                     else notInt s
scmIsEven s _   = tooManyArgs s

scmMax, scmMin :: [ScmValue] -> ErrOr ScmValue
scmMax = scmMinMax max "max"
scmMin = scmMinMax min "min"

scmMinMax :: (forall a. Real a => a -> a -> a) -> String
          -> [ScmValue] -> ErrOr ScmValue
scmMinMax _ s []     = tooFewArgs s
scmMinMax f s (x:xs) = if isNumeric x then foldM go x xs else notNum s
 where
   go n a = if isNumeric a
               then case liftScmReal2 f n a of
                         Left _ -> notReal s
                         m      -> m
               else notNum s

---- +-*/

scmPlus, scmMinus, scmMul, scmDiv :: [ScmValue] -> ErrOr ScmValue
scmPlus [] = Right $ ScmInt 0
scmPlus xs = foldM go (ScmInt 0) xs
 where
   go n x = if isNumeric x then liftScmNum2 (+) n x else notNum "+"

scmMinus []                        = tooFewArgs "-"
scmMinus (x:_) | not (isNumeric x) = notNum "-"
scmMinus [x]                       = liftScmNum negate x
scmMinus (x:xs)                    = foldM go x xs
 where
   go n a = if isNumeric a then liftScmNum2 (-) n a else notNum "-"

scmMul [] = Right $ ScmInt 1
scmMul xs = foldM go (ScmInt 1) xs
 where
   go n x = if isNumeric x then liftScmNum2 (*) n x else notNum "*"

scmDiv []     = tooFewArgs "/"
scmDiv (x:xs) =
   unint x >>= case xs of
                    []  -> liftScmFrac recip
                    _:_ -> flip (foldM go) xs
 where
   go n a = unint a >>= liftScmFrac2 (/) n

   unint (ScmInt n) = Right $ ScmRat (fromInteger n)
   unint n          = if isNumeric x then Right n else notNum "/"

---- abs

scmAbs :: [ScmValue] -> ErrOr ScmValue
scmAbs [x] =
   if isReal x
      then liftScmNum abs x
      else notReal "abs"
scmAbs [] = tooFewArgs  "abs"
scmAbs _  = tooManyArgs "abs"

---- quot rem mod

scmQuot, scmRem, scmMod :: [ScmValue] -> ErrOr ScmValue
scmQuot = scmQuotRemMod quot "quotient"
scmRem  = scmQuotRemMod rem "remainder"
scmMod  = scmQuotRemMod mod "modulo"

scmQuotRemMod :: (Integer -> Integer -> Integer) -> String
              -> [ScmValue] -> ErrOr ScmValue
scmQuotRemMod f s [x,y] = do
   (e1,a) <- asInt s x
   (e2,b) <- asInt s y
   return . (if e1 && e2 then ScmInt else ScmReal . fromInteger) $ f a b
scmQuotRemMod _ s (_:_:_) = tooManyArgs s
scmQuotRemMod _ s _       = tooFewArgs  s

---- gcd lcm

scmGcd, scmLcm :: [ScmValue] -> ErrOr ScmValue
scmGcd = scmGcdLcm (\a b -> if a == 0 && b == 0 then 0 else gcd a b) 0 "gcd"
scmLcm = scmGcdLcm lcm 1 "lcm"

scmGcdLcm :: (Integer -> Integer -> Integer) -> Integer -> String
          -> [ScmValue] -> ErrOr ScmValue
scmGcdLcm f i s = fmap fin . foldM go (True,i)
 where
   go  (exact, n) = fmap ((exact &&) *** f n) . asInt s
   fin (exact, n) = if exact then ScmInt n else ScmReal (fromInteger n)

---- numerator denominator

scmNumerator, scmDenominator :: [ScmValue] -> ErrOr ScmValue
scmNumerator   = scmNumerDenom numerator   "numerator"
scmDenominator = scmNumerDenom denominator "denominator"

scmNumerDenom :: (Rational -> Integer) -> String
              -> [ScmValue] -> ErrOr ScmValue
scmNumerDenom f s [n] =
   case n of
        ScmInt      x       -> Right . ScmInt  $ f (fromInteger x)
        ScmRat      x       -> Right . ScmInt  $ f x
        ScmReal     x       -> Right . ScmReal . fromInteger $ f (realToFrac x)
        ScmComplex (x :+ 0) -> Right . ScmReal . fromInteger $ f (realToFrac x)
        _                   -> notRat s

scmNumerDenom _ s [] = tooFewArgs s
scmNumerDenom _ s _  = tooManyArgs s

---- floor ceil trunc round

scmFloor, scmCeil, scmTrunc, scmRound :: [ScmValue] -> ErrOr ScmValue
scmFloor = scmGenericRound floor    "floor"
scmCeil  = scmGenericRound ceiling  "ceiling"
scmTrunc = scmGenericRound truncate "truncate"
scmRound = scmGenericRound round    "round"

scmGenericRound :: (forall a. RealFrac a => a -> Integer) -> String
                -> [ScmValue] -> ErrOr ScmValue
scmGenericRound _ _ [   ScmInt     x]  = Right . ScmInt                $ x
scmGenericRound f _ [   ScmRat     x]  = Right . ScmInt                $ f x
scmGenericRound f _ [   ScmReal    x]  = Right . ScmReal . fromInteger $ f x
scmGenericRound _ s [n@(ScmComplex _)] =
   case asInt s n of
        Right (_,x) -> Right . ScmInt $ x
        Left _      -> notReal s
scmGenericRound _ s [_]            = notNum s
scmGenericRound _ s []             = tooFewArgs s
scmGenericRound _ s _              = tooManyArgs s

---- rationalize

scmRationalize :: [ScmValue] -> ErrOr ScmValue
scmRationalize (_:_:_:_) = tooManyArgs "rationalize"
scmRationalize [x,y]     =
   case liftScmRealFracB2 approxRational x y of
        Left _           -> notReal "rationalize"
        Right (True , n) -> Right (ScmRat  n)
        Right (False, n) -> Right (ScmReal (fromRational n))

scmRationalize _         = tooFewArgs "rationalize"

---- exp log sin cos tan asin acos atan sqrt

scmExp, scmLog,
 scmSin,  scmCos,  scmTan,
 scmAsin, scmAcos, scmAtan,
 scmSqrt :: [ScmValue] -> ErrOr ScmValue

scmExp  = scmComplex1 exp  "exp"
scmLog  = scmComplex1 log  "log"
scmSin  = scmComplex1 sin  "sin"
scmCos  = scmComplex1 cos  "cos"
scmTan  = scmComplex1 tan  "tan"
scmAsin = scmComplex1 asin "asin"
scmAcos = scmComplex1 acos "acos"

scmAtan [y,x] =
   case pairScmReal x y of
        Left  _                      -> notReal "atan"
        Right (ScmReal a, ScmReal b) -> Right (ScmReal $ phase $ a :+ b)
        Right (ScmInt a, ScmInt b)   ->
           Right (ScmReal $ phase $ fromInteger a :+ fromInteger b)
        Right (ScmRat a, ScmRat b)   ->
           Right (ScmReal $ phase $ fromRational a :+ fromRational b)
        Right _                      -> error "scmAtan :: internal error"

scmAtan xs    = scmComplex1 atan "atan" xs

scmSqrt = scmComplex1 sqrt "sqrt"

scmComplex1 :: (Complex Double -> Complex Double) -> String
            -> [ScmValue] -> ErrOr ScmValue
scmComplex1 f _ [ScmInt     x] = Right . fromComplex $ f (fromInteger  x :+ 0)
scmComplex1 f _ [ScmRat     x] = Right . fromComplex $ f (fromRational x :+ 0)
scmComplex1 f _ [ScmReal    x] = Right . fromComplex $ f (x :+ 0)
scmComplex1 f _ [ScmComplex x] = Right . fromComplex $ f x
scmComplex1 _ s [_]            = notNum s
scmComplex1 _ s []             = tooFewArgs s
scmComplex1 _ s _              = tooManyArgs s

---- expt

scmExpt :: [ScmValue] -> ErrOr ScmValue
scmExpt [x,y] =
   case pairScmComplex x y of
        Left _                              -> notNum "expt"
        Right (ScmInt     a, ScmInt      b) ->
           if b < 0
              then Right . ScmReal $ fromInteger a ^^ b
              else Right . ScmInt  $ a ^ b
        Right (ScmReal    a, ScmReal     b) -> Right . ScmReal    $ a ** b
        Right (ScmComplex a, ScmComplex  b) -> Right . ScmComplex $ a ** b
        Right (ScmRat     a, ScmRat      b) ->
           Right . ScmReal $ fromRational a ** fromRational b
        Right _                             -> error "expt :: internal error"

scmExpt (_:_:_) = tooManyArgs "expt"
scmExpt _       = tooFewArgs  "expt"

---- make-rectangular make-polar real-part imag-part magnitude angle

scmMakeRectangular, scmMakePolar :: [ScmValue] -> ErrOr ScmValue
scmMakeRectangular = scmMakeComplex (:+)    "make-rectangular"
scmMakePolar       = scmMakeComplex mkPolar "make-polar"

scmMakeComplex :: (Double -> Double -> Complex Double) -> String
               -> [ScmValue] -> ErrOr ScmValue
scmMakeComplex f s [x,y] =
   case pairScmReal x y of
        Left _                       -> notReal s
        Right (ScmReal a, ScmReal b) -> Right . ScmComplex $ f a b
        Right (ScmRat  a, ScmRat  b) ->
           Right . ScmComplex $ (f `on` fromRational) a b
        Right (ScmInt  a, ScmInt  b) ->
           Right . ScmComplex $ (f `on` fromInteger) a b
        Right _                      ->
           error $ s ++ " :: internal error"

scmMakeComplex _ s (_:_:_) = tooManyArgs s
scmMakeComplex _ s _       = tooFewArgs  s

scmRealPart, scmImagPart, scmNorm, scmAngle :: [ScmValue] -> ErrOr ScmValue
scmRealPart = scmComplexPart realPart  Right                  "real-part"
scmImagPart = scmComplexPart imagPart  (liftScmNum $ const 0) "imag-part"
scmNorm     = scmComplexPart magnitude (liftScmNum abs)       "magnitude"
scmAngle    = scmComplexPart phase     (Right . angle)        "angle"
 where
   angle (ScmReal n) = f ScmReal n
   angle (ScmRat  n) = f ScmRat  n
   angle (ScmInt  n) = f ScmInt  n
   angle _           = error "angle :: the impossible happened"

   f c n = if n >= 0 then c 0 else ScmReal pi

scmComplexPart :: (Complex Double -> Double)
               -> (ScmValue -> ErrOr ScmValue)
               -> String
               -> [ScmValue] -> ErrOr ScmValue
scmComplexPart f _ _ [ScmComplex x]    = Right $ ScmReal (f x)
scmComplexPart _ g _ [x] | isNumeric x = g x
scmComplexPart _ _ s [_]               = notNum s
scmComplexPart _ _ s []                = tooFewArgs s
scmComplexPart _ _ s _                 = tooManyArgs s

---- exact->inexact inexact->exact

scmToInexact, scmToExact :: [ScmValue] -> ErrOr ScmValue
scmToInexact [ScmInt x]         = Right $ ScmReal (fromInteger  x)
scmToInexact [ScmRat x]         = Right $ ScmReal (fromRational x)
scmToInexact [x] | isNumeric x  = Right x
scmToInexact [_]                = notNum      "exact->inexact"
scmToInexact []                 = tooFewArgs  "exact->inexact"
scmToInexact _                  = tooManyArgs "exact->inexact"

scmToExact [ScmReal    x]     =
   let r = toRational x
    in Right $ if denominator r == 1
                  then ScmInt (numerator r)
                  else ScmRat r
scmToExact [ScmComplex x]     =
   case imagPart x of
        0 -> Right $ ScmReal (realPart x)
        _ -> fail $ "inexact->exact :: implementation restriction: " ++
                    "can't exactify complex numbers"
scmToExact [x] | isNumeric x  = Right x
scmToExact [_]                = notNum      "exact->inexact"
scmToExact []                 = tooFewArgs  "exact->inexact"
scmToExact _                  = tooManyArgs "exact->inexact"

---- number->string string->number

scmToString, scmToNumber :: [ScmValue] -> IO (ErrOr ScmValue)

-- TODO: scmShow should use this or vice versa
scmToString (x:xs) | isNumeric x =
   case xs of
        []             -> g x 10
        [ScmInt radix] ->
           if radix `elem` [2,8,10,16]
              then g x (fromInteger radix)
              else return. fail $
                      "number->string :: invalid radix " ++ show radix

        [_] -> return$ notInt      "number->string"
        _   -> return$ tooManyArgs "number->string"
 where
   g n radix = case f n radix of
                    Left  err -> return$ fail err
                    Right s   -> fmap Right $ toScmMString s

   f (ScmInt i) radix = Right $ showInt radix i
   f (ScmRat r) radix = Right $
      if denominator r == 1
         then showInt radix (numerator r)
         else concat [ showInt radix (numerator r)
                     , "/"
                     , showInt radix (denominator r) ]

   f (ScmReal r) radix =
      if radix == 10
         then Right $
                 case () of
                      _| isNaN      r -> "+nan.#"
                       | isInfinite r -> (if r < 0 then '-' else '+') : "inf.#"

                       -- R5RS 6.2.6 specifies that "the result contains a
                       -- decimal point" if inexact and a decimal-point
                       -- containing result can make it work
                       | otherwise    -> show r
         else fail "number->string :: nondecimal radix for inexact real"

   f (ScmComplex (a :+ b)) radix =
      -- As in the ScmReal case
      if radix == 10
         then Right . concat $ let bs = either undefined id $ f (ScmReal b) 10
                                in [ either undefined id $ f (ScmReal a) 10
                                   , if head bs `elem` "-+" then [] else "+"
                                   , bs
                                   , "i" ]

         else fail "number->string :: nondecimal radix for inexact complex"

   f _ _ = error "number->string :: the impossible happened"

   showInt radix i = showSigned (showIntAtBase radix intToDigit) 0 i ""

scmToString [] = return$ tooFewArgs "number->string"
scmToString _  = return$ notNum     "number->string"

scmToNumber (ScmString  s : xs) = return$ toNumHelper xs     (elems s)
scmToNumber (ScmMString s : xs) = fmap   (toNumHelper xs) (getElems s)
scmToNumber [] = return$ tooFewArgs "string->number"
scmToNumber _  = return$ fail "Nonstring argument to string->number"

toNumHelper :: [ScmValue] -> String -> ErrOr ScmValue
toNumHelper xs s =
   case xs of
        []             -> Right $ f s 10
        [ScmInt radix] ->
           if radix `elem` [2,8,10,16]
              then Right $ f s (fromInteger radix)
              else fail $ "string->number :: invalid radix " ++ show radix

        [_]            -> notInt       "string->number"
        _              -> tooManyArgs  "string->number"
 where
   f str radix =
       case Parser.runParser (Parser.number radix) "" str of
            Right n | isNumeric n -> n
            _                     -> ScmBool False

-------------

notNum, notReal, notRat :: String -> ErrOr a
notNum  = fail . ("Nonnumeric argument to " ++)
notReal = fail . ("Nonreal argument to " ++)
notRat  = fail . ("Nonrational argument to " ++)

isNumeric, isInteger, isReal :: ScmValue -> Bool
isNumeric (ScmInt     _) = True
isNumeric (ScmRat     _) = True
isNumeric (ScmReal    _) = True
isNumeric (ScmComplex _) = True
isNumeric _              = False

isInteger (ScmInt     _)      = True
isInteger (ScmRat     x)      = denominator x == 1
isInteger (ScmReal    x)      = x == fromInteger (round x)
isInteger (ScmComplex (a:+b)) = b == 0 && a == fromInteger (round a)
isInteger _                   = False

isReal (ScmComplex (_ :+ b)) = b == 0
isReal x                     = isNumeric x

asInt :: String -> ScmValue -> ErrOr (Bool, Integer)
asInt s x | not (isInteger x) = notInt s
asInt _ (ScmInt     x)        = Right (True,  x)
asInt _ (ScmRat     x)        = Right (True,  numerator x)
asInt _ (ScmReal    x)        = Right (False, round x)
asInt _ (ScmComplex (x:+0))   = Right (False, round x)
asInt _ _                     = error "This can't happen"

fromComplex :: Complex Double -> ScmValue
fromComplex (x :+ 0) = ScmReal x
fromComplex x        = ScmComplex x

-- Lift ScmValue's numeric types to a common type
--
-- Versions without 'A' at the end also return results in the correct
-- constructor of the two given. Versions with 'B' just return whether the
-- result should be exact or not.
--
-- Ugly and verbose... too lazy to metaize these {{{

--- Num
liftScmNum :: (forall a. Num a => a -> a) -> ScmValue -> ErrOr ScmValue
liftScmNum f (ScmInt     a) = Right . ScmInt     $ f a
liftScmNum f (ScmRat     a) = Right . ScmRat     $ f a
liftScmNum f (ScmReal    a) = Right . ScmReal    $ f a
liftScmNum f (ScmComplex a) = Right . ScmComplex $ f a
liftScmNum _ _ = fail "liftScmNum :: internal error"

liftScmNum2 :: (forall a. Num a => a -> a -> a)
            -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmNum2 f (ScmInt     a) (ScmInt     b) = Right . ScmInt    $ f a b
liftScmNum2 f (ScmRat     a) (ScmRat     b) = Right . ScmRat    $ f a b
liftScmNum2 f (ScmReal    a) (ScmReal    b) = Right . ScmReal   $ f a b
liftScmNum2 f (ScmComplex a) (ScmComplex b) = Right . ScmComplex$ f a b

-- Int+{Rat,Real,Complex}
liftScmNum2 f (ScmInt     a) (ScmRat     b) = Right . ScmRat    $ f (fInt a) b
liftScmNum2 f (ScmRat     a) (ScmInt     b) = Right . ScmRat    $ f a (fInt b)
liftScmNum2 f (ScmInt     a) (ScmReal    b) = Right . ScmReal   $ f (fInt a) b
liftScmNum2 f (ScmReal    a) (ScmInt     b) = Right . ScmReal   $ f a (fInt b)
liftScmNum2 f (ScmInt     a) (ScmComplex b) = Right . ScmComplex$ f (fInt a) b
liftScmNum2 f (ScmComplex a) (ScmInt     b) = Right . ScmComplex$ f a (fInt b)

-- Rat+{Real,Complex}
liftScmNum2 f (ScmRat     a) (ScmReal    b) = Right . ScmReal   $ f (fRat a) b
liftScmNum2 f (ScmReal    a) (ScmRat     b) = Right . ScmReal   $ f a (fRat b)
liftScmNum2 f (ScmRat     a) (ScmComplex b) = Right . ScmComplex$ f (fRat a) b
liftScmNum2 f (ScmComplex a) (ScmRat     b) = Right . ScmComplex$ f a (fRat b)

-- Real+Complex
liftScmNum2 f (ScmReal    a) (ScmComplex b) = Right . ScmComplex$ f (a :+ 0) b
liftScmNum2 f (ScmComplex a) (ScmReal    b) = Right . ScmComplex$ f a (b :+ 0)

liftScmNum2 _ _ _ = fail "liftScmNum2 :: internal error"

--- Frac
liftScmFrac :: (forall a. Fractional a => a -> a) -> ScmValue -> ErrOr ScmValue
liftScmFrac f (ScmRat     a) = Right . ScmRat     $ f a
liftScmFrac f (ScmReal    a) = Right . ScmReal    $ f a
liftScmFrac f (ScmComplex a) = Right . ScmComplex $ f a
liftScmFrac _ _ = fail "liftScmFrac :: internal error"

liftScmFrac2 :: (forall a. Fractional a => a -> a -> a)
             -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmFrac2 f (ScmRat     a) (ScmRat     b) = Right . ScmRat    $ f a b
liftScmFrac2 f (ScmReal    a) (ScmReal    b) = Right . ScmReal   $ f a b
liftScmFrac2 f (ScmComplex a) (ScmComplex b) = Right . ScmComplex$ f a b

-- Rat+{Real,Complex}
liftScmFrac2 f (ScmRat     a) (ScmReal    b) = Right . ScmReal   $ f (fRat a) b
liftScmFrac2 f (ScmReal    a) (ScmRat     b) = Right . ScmReal   $ f a (fRat b)
liftScmFrac2 f (ScmRat     a) (ScmComplex b) = Right . ScmComplex$ f (fRat a) b
liftScmFrac2 f (ScmComplex a) (ScmRat     b) = Right . ScmComplex$ f a (fRat b)

-- Real+Complex
liftScmFrac2 f (ScmReal    a) (ScmComplex b) = Right . ScmComplex$ f (a :+ 0) b
liftScmFrac2 f (ScmComplex a) (ScmReal    b) = Right . ScmComplex$ f a (b :+ 0)

liftScmFrac2 _ _ _ = fail "liftScmFrac2 :: internal error"

--- Real
liftScmReal2 :: (forall a. Real a => a -> a -> a)
             -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmReal2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right . ScmReal $ f a b
        Right (ScmRat  a, ScmRat  b) -> Right . ScmRat  $ f a b
        Right (ScmInt  a, ScmInt  b) -> Right . ScmInt  $ f a b
        Left s                       -> Left s
        Right _                      -> fail "liftScmReal2 :: internal error"

liftScmRealA2 :: (forall a. Real a => a -> a -> b)
              -> (ScmValue -> ScmValue -> ErrOr b)
liftScmRealA2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right $ f a b
        Right (ScmRat  a, ScmRat  b) -> Right $ f a b
        Right (ScmInt  a, ScmInt  b) -> Right $ f a b
        Left s                       -> Left s
        Right _                      -> fail "liftScmRealA2 :: internal error"

--- RealFrac
liftScmRealFracB2 :: (forall a. RealFrac a => a -> a -> b)
                  -> (ScmValue -> ScmValue -> ErrOr (Bool, b))
liftScmRealFracB2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right (False, f a b)
        Right (ScmRat  a, ScmRat  b) -> Right (True,  f a b)
        Right (ScmInt  a, ScmInt  b) ->
           Right (True,  f (fInt a) (fInt b :: Rational))
        Left s                       -> Left s
        Right _                      ->
           fail "liftScmRealFracB2 :: internal error"

pairScmReal :: ScmValue -> ScmValue -> ErrOr (ScmValue, ScmValue)
pairScmReal (ScmComplex a) _ | imagPart a /= 0 = fail "pairScmReal :: complex"
pairScmReal _ (ScmComplex b) | imagPart b /= 0 = fail "pairScmReal :: complex"

pairScmReal a@(ScmInt     _) b@(ScmInt     _) = Right (a,b)
pairScmReal a@(ScmRat     _) b@(ScmRat     _) = Right (a,b)
pairScmReal a@(ScmReal    _) b@(ScmReal    _) = Right (a,b)
pairScmReal   (ScmComplex a)   (ScmComplex b) =
   Right $ ((,) `on` ScmReal . realPart) a b

-- Int+{Rat,Real,Complex}
pairScmReal (ScmInt     a) (ScmRat     b) = Right $ ((,)`on`ScmRat)  (fInt a) b
pairScmReal (ScmRat     a) (ScmInt     b) = Right $ ((,)`on`ScmRat)  a (fInt b)
pairScmReal (ScmInt     a) (ScmReal    b) = Right $ ((,)`on`ScmReal) (fInt a) b
pairScmReal (ScmReal    a) (ScmInt     b) = Right $ ((,)`on`ScmReal) a (fInt b)
pairScmReal (ScmInt     a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) (fInt a) (realPart b)
pairScmReal (ScmComplex a) (ScmInt     b) =
   Right $ ((,)`on`ScmReal) (realPart a) (fInt b)

-- Rat+{Real,Complex}
pairScmReal (ScmRat     a) (ScmReal    b) = Right $ ((,)`on`ScmReal) (fRat a) b
pairScmReal (ScmReal    a) (ScmRat     b) = Right $ ((,)`on`ScmReal) a (fRat b)
pairScmReal (ScmRat     a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) (fRat a) (realPart b)
pairScmReal (ScmComplex a) (ScmRat     b) =
   Right $ ((,)`on`ScmReal) (realPart a) (fRat b)

-- Real+Complex
pairScmReal (ScmReal    a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) a (realPart b)
pairScmReal (ScmComplex a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (realPart a) b

pairScmReal _ _ = fail "pairScmReal :: internal error"

pairScmComplex :: ScmValue -> ScmValue -> ErrOr (ScmValue, ScmValue)
pairScmComplex a@(ScmInt     _) b@(ScmInt     _) = Right (a,b)
pairScmComplex a@(ScmRat     _) b@(ScmRat     _) = Right (a,b)
pairScmComplex a@(ScmReal    _) b@(ScmReal    _) = Right (a,b)
pairScmComplex a@(ScmComplex _) b@(ScmComplex _) = Right (a,b)

-- Int+{Rat,Real,Complex}
pairScmComplex (ScmInt     a) (ScmRat     b) = Right$((,)`on`ScmRat) (fInt a) b
pairScmComplex (ScmRat     a) (ScmInt     b) = Right$((,)`on`ScmRat) a (fInt b)
pairScmComplex (ScmInt     a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (fInt a) b
pairScmComplex (ScmReal    a) (ScmInt     b) =
   Right $ ((,)`on`ScmReal) a (fInt b)
pairScmComplex (ScmInt     a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (fInt a) b
pairScmComplex (ScmComplex a) (ScmInt     b) =
   Right $ ((,)`on`ScmComplex) a (fInt b)

-- Rat+{Real,Complex}
pairScmComplex (ScmRat     a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (fRat a) b
pairScmComplex (ScmReal    a) (ScmRat     b) =
   Right $ ((,)`on`ScmReal) a (fRat b)
pairScmComplex (ScmRat     a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (fRat a) b
pairScmComplex (ScmComplex a) (ScmRat     b) =
   Right $ ((,)`on`ScmComplex) a (fRat b)

-- Real+Complex
pairScmComplex (ScmReal    a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (a:+0) b
pairScmComplex (ScmComplex a) (ScmReal    b) =
   Right $ ((,)`on`ScmComplex) a (b:+0)

pairScmComplex _ _ = fail "pairScmComplex :: internal error"

fInt :: Num a => Integer -> a
fInt = fromInteger

fRat :: Fractional a => Rational -> a
fRat = fromRational

-- }}}
