From bbc90e163842fe8941ddd43b172887ad8bfaf3f2 Mon Sep 17 00:00:00 2001
From: rnhmjoj <micheleguerinirocco@me.com>
Date: Mon, 1 Jun 2015 17:08:39 +0200
Subject: [PATCH] Initial commit

---
 LICENSE                      | 20 ++++++++
 Setup.hs                     |  2 +
 number.cabal                 | 25 ++++++++++
 src/Data/Number.hs           | 11 +++++
 src/Data/Number/Functions.hs | 28 +++++++++++
 src/Data/Number/Instances.hs | 73 ++++++++++++++++++++++++++++
 src/Data/Number/Internal.hs  | 93 ++++++++++++++++++++++++++++++++++++
 src/Data/Number/Types.hs     |  9 ++++
 src/test.hs                  |  7 +++
 9 files changed, 268 insertions(+)
 create mode 100644 LICENSE
 create mode 100644 Setup.hs
 create mode 100644 number.cabal
 create mode 100644 src/Data/Number.hs
 create mode 100644 src/Data/Number/Functions.hs
 create mode 100644 src/Data/Number/Instances.hs
 create mode 100644 src/Data/Number/Internal.hs
 create mode 100644 src/Data/Number/Types.hs
 create mode 100644 src/test.hs

diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..3ef0658
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2015 Michele Guerini Rooc
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/number.cabal b/number.cabal
new file mode 100644
index 0000000..8ac791d
--- /dev/null
+++ b/number.cabal
@@ -0,0 +1,25 @@
+name:                number
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             MIT
+license-file:        LICENSE
+author:              Michele Guerini Rocco
+maintainer:          micheleguerinirocco@me.com
+-- copyright:        
+category:            Math
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:   Data.Number,
+                     Data.Number.Functions,
+                     Data.Number.Types,
+                     Data.Number.Instances,
+                     Data.Number.Internal
+   
+  other-extensions:    TypeSynonymInstances, FlexibleInstances
+  build-depends:       base >=4.8, numericpeano
+  hs-source-dirs:      src
+  default-language:    Haskell2010
\ No newline at end of file
diff --git a/src/Data/Number.hs b/src/Data/Number.hs
new file mode 100644
index 0000000..43a5d80
--- /dev/null
+++ b/src/Data/Number.hs
@@ -0,0 +1,11 @@
+module Data.Number
+( module Data.Number.Types
+, module Data.Number.Functions
+, module Data.Number.Instances
+, Nat(..)
+) where
+
+import Data.Number.Types
+import Data.Number.Instances
+import Data.Number.Functions
+import Numeric.Peano
\ No newline at end of file
diff --git a/src/Data/Number/Functions.hs b/src/Data/Number/Functions.hs
new file mode 100644
index 0000000..03a5bb5
--- /dev/null
+++ b/src/Data/Number/Functions.hs
@@ -0,0 +1,28 @@
+module Data.Number.Functions where
+
+import Numeric.Peano
+import Data.Number.Types
+import Data.Number.Instances
+import Data.Number.Internal
+
+-- Various --
+
+precision :: Number -> Nat
+precision E       = Z
+precision (_:|xs) = S (precision xs)
+
+show' :: Number -> String
+show' E           = "0"
+show' (x:|E)      = show (toInteger x)
+show' (x:|xs)     = show (toInteger x) ++ " + 1/(" ++ show' xs ++ ")"
+show' (M (x:|xs)) = "-" ++ show (toInteger x) ++ " - 1/(" ++ show' xs ++ ")"
+
+-- Conversion --
+
+fromList :: [Nat] -> Number
+fromList []     = E
+fromList (x:xs) = x :| fromList xs
+
+toList :: Number -> [Nat]
+toList E = []
+toList (x:|xs) = x : toList xs
\ No newline at end of file
diff --git a/src/Data/Number/Instances.hs b/src/Data/Number/Instances.hs
new file mode 100644
index 0000000..58b5a0c
--- /dev/null
+++ b/src/Data/Number/Instances.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module Data.Number.Instances where
+
+import Data.Number.Types
+import Data.Number.Internal
+
+instance Functor Continued where
+  fmap _ E       = E
+  fmap f (M x)   = M (fmap f x)
+  fmap f (x:|xs) = f x :| fmap f xs 
+
+instance Num Number where
+  (+) = operator (0, 1,  1, 0, 1, 0, 0, 0)
+  (-) = operator (0, 1, -1, 0, 1, 0, 0, 0)
+  (*) = operator (0, 0,  0, 1, 1, 0, 0, 0)
+
+  abs (M x) = x
+  abs x = x
+
+  negate (M x) = x
+  negate x = M x
+
+  fromInteger = toNumber . fromIntegral
+
+  signum E     = 0
+  signum (M _) = -1
+  signum _     = 1
+
+instance Real Number where
+  toRational = fromNumber
+
+instance Fractional Number where
+  (/) = operator (0, 1, 0, 0, 0, 0, 1, 0)
+  fromRational = toNumber
+
+
+-- Helpers --
+
+fromNumber :: RealFrac a => Number -> a
+fromNumber E         = 0
+fromNumber (M x)     = negate (fromNumber x)
+fromNumber (x :| E)  = fromIntegral x
+fromNumber (x :| xs) = fromIntegral x + 1 / (fromNumber xs)
+
+toNumber :: (Show a, RealFrac a) => a -> Number
+toNumber 0  = E
+toNumber x0
+  | x0 < 0    = M (n :| toNumber x1)
+  | otherwise =    n :| toNumber x1
+  where
+    (n,f) = properFraction (abs x0)
+    x1 | f < 1e-6  = 0
+       | otherwise = 1/f
+
+
+-- constants --
+
+φ :: Number
+φ = 1 :| φ
+
+σ :: Number
+σ = σ' 0 where
+  σ' n = n :| σ' (succ n)
+
+π :: Number
+π = toNumber pi
+
+e :: Number
+e = fmap a σ where 
+  a n | p == 0    = 2*q
+      | otherwise = 1
+    where (q, p) = quotRem n 3
diff --git a/src/Data/Number/Internal.hs b/src/Data/Number/Internal.hs
new file mode 100644
index 0000000..8ff6f81
--- /dev/null
+++ b/src/Data/Number/Internal.hs
@@ -0,0 +1,93 @@
+module Data.Number.Internal
+( operator
+, cut
+, first
+, rest
+, split
+) where
+
+import Data.Number.Types
+import Data.Ratio
+import Numeric.Peano
+
+
+type Matrix = (Whole, Whole, Whole, Whole, Whole, Whole, Whole, Whole)
+
+
+operator :: Matrix -> Number -> Number -> Number
+operator c x y =
+  case operator' c x y False of
+    [] -> E
+    m  -> if head m < 0
+      then M $ fromList (map toNat m)
+      else     fromList (map toNat m)
+  where
+    fromList []     = E
+    fromList (x:xs) = x :| fromList xs
+
+operator' :: Matrix -> Number -> Number -> Bool -> [Whole]
+operator' (_,_,_,_,0,0,0,0) _ _ _ = []
+operator' (a,b,c,d,e,f,g,h) x y end
+  | t         = r : operator' (e, f, g, h, a-e*r, b-f*r, c-g*r, d-h*r) x  y  end
+  | x/=E && s =     operator' (b, a+b*p, d, c+d*p, f, e+f*p, h, g+h*p) x' y  end
+  | x==E && s =     operator' (b, b, d, d, f, f, h, h)                 E  y  end
+  | y/=E      =     operator' (c, d, a+c*q, b+d*q, g, h, e+g*q, f+h*q) x  y' end
+  | otherwise =     operator' (c, d, c, d, g, h, g, h)                 x  E  True
+  where
+    r = a // e
+    (p, x') = split x
+    (q, y') = split y
+    t = not (any (==0) [e,f,g,h]) && all (==r) [b//f, c//g, d//h]
+    s | end                 = True
+      | any (==0) [f,g,e,h] = False
+      | otherwise           = abs (b%f - a%e) > abs (c%g - a%e)
+
+
+cut :: Nat -> Number -> Number
+cut _ E          = E
+cut n (M x)      = M (cut n x)
+cut n _ | n <= 0 = E
+cut n (x :| xs)  = x :| cut (n-1) xs
+
+
+split :: Number -> (Whole, Number)
+split x = (first x, rest x)
+
+
+first :: Number -> Whole
+first E          = 0
+first (M E)      = 0
+first (M (x:|_)) = Whole x Neg
+first (x:|_)     = Whole x Pos
+
+
+rest :: Number -> Number
+rest E       = E
+rest (M E)   = E
+rest (M x)   = M (rest x)
+rest (_:|xs) = xs
+
+
+-- Peano arithmethics --
+
+toNat :: Whole -> Nat
+toNat (Whole n _) = n
+
+(//) :: Integral a => a -> a -> a
+(//) = quot
+
+instance Real Whole where
+  toRational = (%1) . toInteger
+
+instance Integral Whole where
+  toInteger (Whole z Pos) =  (fromPeano z)
+  toInteger (Whole z Neg) = -(fromPeano z)
+
+  quotRem (Whole a s) (Whole b s') = (Whole q sign, Whole r Pos)
+    where
+      q = quot a b
+      r = a - q * b
+      sign | s == s' && s == Pos = Pos
+           | s == s' && s == Neg = Pos
+           | otherwise           = Neg
+
diff --git a/src/Data/Number/Types.hs b/src/Data/Number/Types.hs
new file mode 100644
index 0000000..618b490
--- /dev/null
+++ b/src/Data/Number/Types.hs
@@ -0,0 +1,9 @@
+module Data.Number.Types where
+
+import Numeric.Peano
+
+infixr 5 :|
+data Continued a =  M (Continued a) | a :| (Continued a) | E
+  deriving (Eq, Ord, Show, Read)
+
+type Number = Continued Nat
\ No newline at end of file
diff --git a/src/test.hs b/src/test.hs
new file mode 100644
index 0000000..0b25f39
--- /dev/null
+++ b/src/test.hs
@@ -0,0 +1,7 @@
+import Data.Number
+
+print' = putStrLn . show'
+
+main = do
+  let x = toNumber pi
+  mapM (print . toInteger) (toList x)
\ No newline at end of file