├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── cf.cabal ├── src └── Math │ ├── ContinuedFraction.hs │ └── ContinuedFraction │ ├── Interval.hs │ └── Simple.hs ├── tests └── Tests.hs └── wip └── Effective.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hpc 9 | .hsenv 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | cabal.config 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Mitchell Riley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CF 2 | == 3 | 4 | This package implements Gosper's algorithm for arithmetic on (often 5 | infinite) continued fractions. This allows us to do arbitrary 6 | precision calculations without deciding in advance how much precision 7 | we need. Following Vuillemin, our continued fractions may contain zero 8 | and negative terms, so that the functions in `Floating` can be 9 | supported. 10 | 11 | The type `CF` has instances for the following typeclasses. 12 | * `Eq` 13 | * `Ord` 14 | * `Num` 15 | * `Fractional` 16 | * `RealFrac` 17 | * `Floating` (currently missing `asin`, `acos`, `atan`) 18 | 19 | Because equality of real numbers is not computable, we consider two 20 | numbers `==` if they are closer than `epsilon = 1 % 10^10`. For the 21 | same reason, `floor` and its cousins may give an incorrect result when 22 | the argument is within `epsilon` of an integer. 23 | 24 | References 25 | ---------- 26 | 27 | * Gosper, Ralph W. "Continued fraction arithmetic." HAKMEM Item 101B, MIT Artificial Intelligence Memo 239 (1972). APA 28 | * Vuillemin, Jean E. "Exact real computer arithmetic with continued fractions." Computers, IEEE Transactions on 39.8 (1990): 1087-1105. 29 | * Lester, David R. "Vuillemin’s exact real arithmetic." Functional Programming, Glasgow 1991. Springer London, 1992. 225-238. APA 30 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cf.cabal: -------------------------------------------------------------------------------- 1 | name: cf 2 | version: 0.4.2 3 | synopsis: Exact real arithmetic using continued fractions 4 | license: MIT 5 | license-file: LICENSE 6 | author: Mitchell Riley 7 | maintainer: mitchell.v.riley@gmail.com 8 | homepage: http://github.com/mvr/cf 9 | category: Math 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | description: 13 | Continued fraction arithmetic using Gosper's algorithm for the 14 | basic operations, and Vuillemin and Lester's techniques for 15 | transcendental functions. 16 | 17 | source-repository head 18 | type: git 19 | location: git://github.com/mvr/cf.git 20 | 21 | library 22 | hs-source-dirs: src 23 | exposed-modules: Math.ContinuedFraction, 24 | Math.ContinuedFraction.Simple, 25 | Math.ContinuedFraction.Interval 26 | build-depends: base >= 4.4 && < 5 27 | default-language: Haskell2010 28 | 29 | test-suite tests 30 | type: exitcode-stdio-1.0 31 | main-is: Tests.hs 32 | default-language: Haskell2010 33 | hs-source-dirs: 34 | tests 35 | build-depends: 36 | base, 37 | cf, 38 | QuickCheck >= 2.4, 39 | test-framework >= 0.6, 40 | test-framework-quickcheck2 >= 0.2, 41 | test-framework-th >= 0.2 42 | -------------------------------------------------------------------------------- /src/Math/ContinuedFraction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- | 6 | -- A continued fraction whose terms may be positive, negative or 7 | -- zero. The methods in @Floating@ are supported, with the exception 8 | -- of @asin@, @acos@ and @atan@. 9 | module Math.ContinuedFraction ( 10 | CF, 11 | CF'(..), 12 | cfString, 13 | cfcf 14 | ) where 15 | 16 | import Data.Maybe (catMaybes, mapMaybe) 17 | import Data.Ratio 18 | 19 | import Math.ContinuedFraction.Interval 20 | 21 | newtype CF' a = CF [a] 22 | type CF = CF' Integer 23 | 24 | type Hom a = (a, a, 25 | a, a) 26 | 27 | type Bihom a = (a, a, a, a, 28 | a, a, a, a) 29 | 30 | class (Fractional (FractionField a)) => HasFractionField a where 31 | type FractionField a :: * 32 | insert :: a -> FractionField a 33 | frac :: (a, a) -> FractionField a 34 | extract :: FractionField a -> (a, a) 35 | 36 | instance HasFractionField Integer where 37 | type FractionField Integer = Rational 38 | insert = fromInteger 39 | {-# INLINE insert #-} 40 | frac = uncurry (%) 41 | {-# INLINE frac #-} 42 | extract r = (numerator r, denominator r) 43 | {-# INLINE extract #-} 44 | 45 | instance HasFractionField Rational where 46 | type FractionField Rational = Rational 47 | insert = id 48 | {-# INLINE insert #-} 49 | frac = uncurry (/) 50 | {-# INLINE frac #-} 51 | extract r = (numerator r % 1, denominator r % 1) 52 | {-# INLINE extract #-} 53 | 54 | instance HasFractionField CF where 55 | type FractionField CF = CF 56 | insert = id 57 | {-# INLINE insert #-} 58 | frac = uncurry (/) 59 | {-# INLINE frac #-} 60 | extract r = (r, 1) 61 | {-# INLINE extract #-} 62 | 63 | homEmit :: Num a => Hom a -> a -> Hom a 64 | homEmit (n0, n1, 65 | d0, d1) x = (d0, d1, 66 | n0 - d0*x, n1 - d1*x) 67 | 68 | homAbsorb :: Num a => Hom a -> a -> Hom a 69 | homAbsorb (n0, n1, 70 | d0, d1) x = (n0*x + n1, n0, 71 | d0*x + d1, d0) 72 | 73 | det :: Num a => Hom a -> a 74 | det (n0, n1, 75 | d0, d1) = n0 * d1 - n1 * d0 76 | 77 | homEval :: (Eq a, Num a, HasFractionField a) => Hom a -> Extended (FractionField a) -> Extended (FractionField a) 78 | homEval (n0, n1, 79 | d0, d1) (Finite q) | denom /= 0 = Finite $ frac (num, denom) 80 | | num == 0 = error "0/0 in homQ" 81 | | otherwise = Infinity 82 | where (qnum, qdenom) = extract q 83 | num = n0 * qnum + n1 * qdenom 84 | denom = d0 * qnum + d1 * qdenom 85 | homEval (n0, _n1, 86 | d0, _d1) Infinity = Finite $ frac (n0, d0) 87 | 88 | constantFor :: (Eq a, Num a, HasFractionField a) => Hom a -> Extended (FractionField a) 89 | constantFor (_, _, 90 | 0, 0) = Infinity 91 | constantFor (0, 0, 92 | 0, _) = Finite 0 93 | constantFor (0, 0, 94 | _, 0) = Finite 0 95 | constantFor (a, 0, 96 | b, 0) = Finite $ frac (a, b) 97 | constantFor (_, a, 98 | _, b) = Finite $ frac (a, b) 99 | 100 | boundHom :: (Ord a, Num a, HasFractionField a, Ord (FractionField a)) => Hom a -> Interval (FractionField a) -> Interval (FractionField a) 101 | boundHom h (Interval i s _) | d > 0 = interval i' s' 102 | | d < 0 = interval s' i' 103 | | otherwise = Interval c c True 104 | where d = det h 105 | i' = homEval h i 106 | s' = homEval h s 107 | c = constantFor h 108 | 109 | primitiveBound :: forall a. (Ord a, Num a, HasFractionField a) => a -> Interval (FractionField a) 110 | primitiveBound n | abs n < 1 = Interval (Finite $ insert bot) (Finite $ insert top) True 111 | where bot = (-2) :: a 112 | top = 2 :: a 113 | primitiveBound n = Interval (Finite $ an - 0.5) (Finite $ 0.5 - an) False 114 | where an = insert $ abs n 115 | 116 | -- TODO: just take the rational answer from the hom 117 | nthPrimitiveBounds :: (Ord a, Num a, HasFractionField a, Ord (FractionField a)) => 118 | CF' a -> [Interval (FractionField a)] 119 | nthPrimitiveBounds (CF cf) = zipWith boundHom homs (map primitiveBound cf) ++ repeat (Interval ev ev True) 120 | where homs = scanl homAbsorb (1,0,0,1) cf 121 | ev = evaluate (CF cf) 122 | 123 | evaluate :: (HasFractionField a, Eq (FractionField a)) => CF' a -> Extended (FractionField a) 124 | evaluate (CF []) = Infinity 125 | evaluate (CF [c]) = Finite $ insert c 126 | evaluate (CF (c:cs)) = case next of 127 | (Finite 0) -> Infinity 128 | Infinity -> Finite $ insert c 129 | (Finite r) -> Finite $ insert c + recip r 130 | where next = evaluate (CF cs) 131 | 132 | valueToCF :: RealFrac a => a -> CF 133 | valueToCF r = if rest == 0 then 134 | CF [d] 135 | else 136 | let (CF ds) = valueToCF (recip rest) in CF (d:ds) 137 | where (d, rest) = properFraction r 138 | 139 | 140 | existsEmittable :: (RealFrac a, Integral b) => Interval a -> Maybe b 141 | existsEmittable (Interval Infinity Infinity _) = Nothing 142 | existsEmittable (Interval Infinity (Finite _) _) = Nothing 143 | existsEmittable (Interval (Finite _) Infinity _) = Nothing 144 | existsEmittable int@(Interval (Finite a) (Finite b) _) = euclideanCheck int a b 145 | 146 | euclideanCheck :: (Num a, Ord a, RealFrac a, Integral b) => Interval a -> a -> a -> Maybe b 147 | euclideanCheck int a b 148 | | not isThin = Nothing 149 | | 0 `elementOf` int && not subsetZero = Nothing 150 | | zi /= 0 && zs /= 0 = Just z 151 | | subsetZero = Just 0 152 | | otherwise = Nothing 153 | where zi = round a 154 | zs = round b 155 | z = if abs zs < abs zi then zs else zi 156 | isThin = abs z > 3 || abs (zi - zs) < 2 157 | subsetZero = int `subset` Interval (Finite (-2)) (Finite 2) True 158 | 159 | hom :: (Ord a, Num a, HasFractionField a, RealFrac (FractionField a)) => Hom a -> CF' a -> CF 160 | hom (_n0, _n1, 161 | 0, 0) _ = CF [] 162 | hom (_n0, _n1, 163 | 0, _d1) (CF []) = CF [] 164 | hom (n0, _n1, 165 | d0, _d1) (CF []) = valueToCF $ frac (n0, d0) 166 | hom h (CF (x:xs)) = case existsEmittable $ boundHom h (primitiveBound x) of 167 | Just n -> CF $ n : rest 168 | where (CF rest) = hom (homEmit h (fromInteger n)) (CF (x:xs)) 169 | Nothing -> hom (homAbsorb h x) (CF xs) 170 | 171 | bihomEmit :: Num a => Bihom a -> a -> Bihom a 172 | bihomEmit (n0, n1, n2, n3, 173 | d0, d1, d2, d3) x = (d0, d1, d2, d3, 174 | n0 - d0*x, n1 - d1*x, n2 - d2*x, n3 - d3*x) 175 | 176 | bihomAbsorbX :: Num a => Bihom a -> a -> Bihom a 177 | bihomAbsorbX (n0, n1, n2, n3, 178 | d0, d1, d2, d3) x = (n0*x + n1, n0, n2*x + n3, n2, 179 | d0*x + d1, d0, d2*x + d3, d2) 180 | 181 | bihomAbsorbY :: Num a => Bihom a -> a -> Bihom a 182 | bihomAbsorbY (n0, n1, n2, n3, 183 | d0, d1, d2, d3) y = (n0*y + n2, n1*y + n3, n0, n1, 184 | d0*y + d2, d1*y + d3, d0, d1) 185 | 186 | bihomSubstituteX :: (Num a, HasFractionField a) => Bihom a -> Extended (FractionField a) -> Hom a 187 | bihomSubstituteX (n0, n1, n2, n3, 188 | d0, d1, d2, d3) (Finite x) = (n0*num + n1*den, n2*num + n3*den, 189 | d0*num + d1*den, d2*num + d3*den) 190 | where (num, den) = extract x 191 | bihomSubstituteX (n0, _n1, n2, _n3, 192 | d0, _d1, d2, _d3) Infinity = (n0, n2, 193 | d0, d2) 194 | 195 | bihomSubstituteY :: (Num a, HasFractionField a) => Bihom a -> Extended (FractionField a) -> Hom a 196 | bihomSubstituteY (n0, n1, n2, n3, 197 | d0, d1, d2, d3) (Finite y) = (n0*num + n2*den, n1*num + n3*den, 198 | d0*num + d2*den, d1*num + d3*den) 199 | where (num, den) = extract y 200 | bihomSubstituteY (n0, n1, _n2, _n3, 201 | d0, d1, _d2, _d3) Infinity = (n0, n1, 202 | d0, d1) 203 | 204 | boundBihomAndSelect :: (Ord a, Num a, HasFractionField a, Eq (FractionField a), Ord (FractionField a)) => 205 | Bihom a -> Interval (FractionField a) -> Interval (FractionField a) -> (Interval (FractionField a), Bool) 206 | boundBihomAndSelect bh x@(Interval ix sx _) y@(Interval iy sy _) = (interval, intX `smallerThan` intY) 207 | where interval = ixy `mergeInterval` iyx `mergeInterval` sxy `mergeInterval` syx 208 | ixy = boundHom (bihomSubstituteX bh ix) y 209 | iyx = boundHom (bihomSubstituteY bh iy) x 210 | sxy = boundHom (bihomSubstituteX bh sx) y 211 | syx = boundHom (bihomSubstituteY bh sy) x 212 | intX = if ixy `smallerThan` sxy then sxy else ixy 213 | intY = if iyx `smallerThan` syx then syx else iyx 214 | 215 | bihom :: (Ord a, Num a, HasFractionField a, RealFrac (FractionField a)) 216 | => Bihom a -> CF' a -> CF' a -> CF 217 | bihom bh (CF []) y = hom (bihomSubstituteX bh Infinity) y 218 | bihom bh x (CF []) = hom (bihomSubstituteY bh Infinity) x 219 | bihom bh (CF (x:xs)) (CF (y:ys)) = 220 | let (bound, which) = boundBihomAndSelect bh (primitiveBound x) (primitiveBound y) in 221 | case existsEmittable bound of 222 | Just n -> CF $ n : rest 223 | where (CF rest) = bihom (bihomEmit bh (fromInteger n)) (CF (x:xs)) (CF (y:ys)) 224 | Nothing -> if which then 225 | let bh' = bihomAbsorbX bh x in bihom bh' (CF xs) (CF (y:ys)) 226 | else 227 | let bh' = bihomAbsorbY bh y in bihom bh' (CF (x:xs)) (CF ys) 228 | 229 | homchain :: [Hom Integer] -> CF 230 | homchain (h:h':hs) = case quotEmit h of 231 | Just n -> CF $ n : rest 232 | where (CF rest) = homchain ((homEmit h n):h':hs) 233 | Nothing -> homchain ((h `mult` h'):hs) 234 | where quotEmit (n0, n1, 235 | d0, d1) = if d0 /= 0 && d1 /= 0 && n0 `quot` d0 == n1 `quot` d1 then Just $ n0 `quot` d0 else Nothing 236 | mult (n0, n1, 237 | d0, d1) 238 | (n0', n1', 239 | d0', d1') =(n0*n0' + n1*d0', n0*n1' + n1*d1', 240 | d0*n0' + d1*d0', d0*n1' + d1*d1') 241 | 242 | instance Num CF where 243 | (+) = bihom (0, 1, 1, 0, 244 | 0, 0, 0, 1) 245 | (-) = bihom (0, -1, 1, 0, 246 | 0, 0, 0, 1) 247 | (*) = bihom (1, 0, 0, 0, 248 | 0, 0, 0, 1) 249 | 250 | fromInteger n = CF [n] 251 | 252 | signum x = case 0 `compare` x of 253 | EQ -> 0 254 | LT -> 1 255 | GT -> -1 256 | 257 | abs x | x < 0 = -x 258 | | otherwise = x 259 | 260 | instance Fractional CF where 261 | (/) = bihom (0, 0, 1, 0, 262 | 0, 1, 0, 0) 263 | 264 | fromRational = valueToCF 265 | 266 | base :: Integer 267 | base = 10 268 | 269 | rationalDigits :: Rational -> [Integer] 270 | rationalDigits 0 = [] 271 | rationalDigits r = let d = num `quot` den in 272 | d : rationalDigits (fromInteger base * (r - fromInteger d)) 273 | where num = numerator r 274 | den = denominator r 275 | 276 | digits :: CF -> [Integer] 277 | digits = go (1, 0, 0, 1) 278 | where go (0, 0, _, _) _ = [] 279 | go (p, _, q, _) (CF []) = rationalDigits (p % q) 280 | go h (CF (c:cs)) = case intervalDigit $ boundHom h (primitiveBound c) of 281 | Nothing -> let h' = homAbsorb h c in go h' (CF cs) 282 | Just d -> d : go (homEmitDigit h d) (CF (c:cs)) 283 | homEmitDigit (n0, n1, 284 | d0, d1) d = (base * (n0 - d0*d), base * (n1 - d1*d), 285 | d0, d1) 286 | 287 | -- | Produce the (possibly infinite) decimal expansion of a continued 288 | -- fraction 289 | cfString :: CF -> String 290 | cfString (CF []) = "Infinity" 291 | cfString cf | cf < 0 = '-' : cfString (-cf) 292 | cfString cf = case digits cf of 293 | [] -> "0" 294 | [i] -> show i 295 | (i:is) -> show i ++ "." ++ concatMap show is 296 | 297 | instance Show CF where 298 | show = take 50 . cfString 299 | 300 | instance Eq CF where 301 | a == b = a `compare` b == EQ 302 | 303 | instance Ord CF where 304 | a `compare` b = head $ catMaybes $ zipWith comparePosition (nthPrimitiveBounds a) (nthPrimitiveBounds b) 305 | 306 | instance Real CF where 307 | toRational = error "CF: toRational" 308 | 309 | instance RealFrac CF where 310 | properFraction cf = head $ mapMaybe checkValid $ nthPrimitiveBounds cf 311 | where checkValid (Interval (Finite a) (Finite b) True) = 312 | if truncate a == truncate b then 313 | Just (truncate a, cf - fromInteger (truncate a)) 314 | else 315 | Nothing 316 | checkValid _ = Nothing 317 | 318 | -- | Convert a continued fraction whose terms are continued fractions 319 | -- into an ordinary continued fraction with integer terms 320 | cfcf :: CF' CF -> CF 321 | cfcf = hom (1, 0, 0, 1) 322 | 323 | instance Floating CF where 324 | pi = homchain ((0,4,1,0) : map go [1..]) 325 | where go n = (2*n-1, n^2, 326 | 1, 0) 327 | 328 | exp r | r < -1 || r > 1 = (exp (r / 2))^2 329 | exp r = cfcf (CF $ 1 : concatMap go [0..]) 330 | where go n = [fromInteger (4*n+1) / r, 331 | -2, 332 | -fromInteger (4*n+3) / r, 333 | 2] 334 | 335 | log r | r < 0.5 = log (2 * r) - log 2 336 | log r | r > 2 = log (r / 2) + log 2 337 | log r = cfcf (CF $ 0 : concatMap go [0..]) 338 | where go n = [fromInteger (2*n+1) / (r-1), 339 | fromRational $ 2 % (n+1)] 340 | 341 | tan r | r < -1 || r > 1 = bihom ( 0,1,1,0, 342 | -1,0,0,1) tanhalf tanhalf 343 | where tanhalf = tan (r / 2) 344 | tan r = cfcf (CF $ 0 : concatMap go [0..]) 345 | where go n = [fromInteger (4*n+1) / r, 346 | -fromInteger (4*n+3) / r] 347 | 348 | sin r = bihom (0,2,0,0, 349 | 1,0,0,1) tanhalf tanhalf 350 | where tanhalf = tan (r / 2) 351 | 352 | cos r = bihom (-1,0,0,1, 353 | 1,0,0,1) tanhalf tanhalf 354 | where tanhalf = tan (r / 2) 355 | 356 | sinh r = bihom (1,0,0,-1, 357 | 0,1,1, 0) expr expr 358 | where expr = exp r 359 | 360 | cosh r = bihom (1,0,0,1, 361 | 0,1,1,0) expr expr 362 | where expr = exp r 363 | 364 | tanh r = bihom (1,0,0,-1, 365 | 1,0,0, 1) expr expr 366 | where expr = exp r 367 | -------------------------------------------------------------------------------- /src/Math/ContinuedFraction/Interval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Math.ContinuedFraction.Interval where 3 | 4 | import Data.Ratio 5 | import Numeric 6 | 7 | data Extended a = Finite a | Infinity deriving (Eq) 8 | 9 | data Interval a = Interval (Extended a) (Extended a) Bool deriving (Eq) 10 | 11 | instance Show (Interval Rational) where 12 | show (Interval a b _) = "(" ++ showE a ++ ", " ++ showE b ++ ")" 13 | where showE Infinity = "Infinity" 14 | showE (Finite r) = show (fromRat r) 15 | 16 | instance Num a => Num (Extended a) where 17 | Finite a + Finite b = Finite (a + b) 18 | Infinity + Finite _ = Infinity 19 | Finite _ + Infinity = Infinity 20 | Infinity + Infinity = error "Infinity + Infinity" 21 | 22 | Finite a * Finite b = Finite (a * b) 23 | Infinity * Finite a = Infinity 24 | -- Infinity * Finite a | a == 0 = error "Infinity * 0" 25 | -- | otherwise = Infinity 26 | Finite a * i = i * Finite a 27 | Infinity * Infinity = undefined "Infinity * Infinity" 28 | 29 | negate (Finite r) = Finite (-r) 30 | negate Infinity = Infinity 31 | 32 | signum (Finite r) = Finite $ signum r 33 | signum Infinity = error "signum Infinity" 34 | 35 | abs (Finite r) = Finite $ abs r 36 | abs Infinity = Infinity 37 | 38 | fromInteger = Finite . fromInteger 39 | 40 | instance (Show a) => Show (Extended a) where 41 | show (Finite r) = show r 42 | show Infinity = "Infinity" 43 | 44 | interval :: Ord a => Extended a -> Extended a -> Interval a 45 | interval (Finite i) (Finite s) = Interval (Finite i) (Finite s) (i <= s) 46 | interval i s = Interval i s True 47 | {-# INLINE interval #-} 48 | 49 | smallerThan :: (Num a, Ord a) => Interval a -> Interval a -> Bool 50 | Interval _ _ _ `smallerThan` Interval Infinity Infinity _ = False -- TODO CHECK 51 | Interval Infinity Infinity _ `smallerThan` Interval _ _ _ = True 52 | Interval (Finite a) Infinity _ `smallerThan` Interval (Finite b) Infinity _ = a >= b 53 | Interval (Finite a) Infinity _ `smallerThan` Interval Infinity (Finite b) _ = a >= -b 54 | Interval Infinity (Finite a) _ `smallerThan` Interval (Finite b) Infinity _ = a <= -b 55 | Interval Infinity (Finite a) _ `smallerThan` Interval Infinity (Finite b) _ = a <= b 56 | Interval (Finite i1) (Finite s1) _ `smallerThan` Interval Infinity (Finite _) _ = i1 <= s1 57 | Interval (Finite i1) (Finite s1) _ `smallerThan` Interval (Finite _) Infinity _ = i1 <= s1 58 | Interval Infinity (Finite _) _ `smallerThan` Interval (Finite i2) (Finite s2) False = True 59 | Interval (Finite _) Infinity _ `smallerThan` Interval (Finite i2) (Finite s2) False = True 60 | Interval Infinity (Finite _) _ `smallerThan` Interval (Finite i2) (Finite s2) True = False 61 | Interval (Finite _) Infinity _ `smallerThan` Interval (Finite i2) (Finite s2) True = False 62 | Interval (Finite i1) (Finite s1) True `smallerThan` Interval (Finite i2) (Finite s2) True 63 | = s1 - i1 <= s2 - i2 64 | Interval (Finite i1) (Finite s1) False `smallerThan` Interval (Finite i2) (Finite s2) False 65 | = i1 - s1 >= i2 - s2 66 | Interval (Finite i1) (Finite s1) True `smallerThan` Interval (Finite i2) (Finite s2) False 67 | = True 68 | Interval (Finite i1) (Finite s1) False `smallerThan` Interval (Finite i2) (Finite s2) True 69 | = False 70 | 71 | epsilon :: Rational 72 | epsilon = 1 % 10^10 73 | 74 | comparePosition :: Interval Rational -> Interval Rational -> Maybe Ordering 75 | Interval (Finite i1) (Finite s1) True `comparePosition` Interval (Finite i2) (Finite s2) True 76 | | s1 < i2 = Just LT 77 | | s2 < i1 = Just GT 78 | | (s1 - i1) < epsilon && (s2 - i2) < epsilon = Just EQ 79 | _ `comparePosition` _ = Nothing 80 | 81 | intervalDigit :: (RealFrac a) => Interval a -> Maybe Integer 82 | intervalDigit (Interval (Finite i) (Finite s) True) = 83 | if floor i == floor s && floor i >= 0 then 84 | Just $ floor i 85 | else 86 | Nothing 87 | intervalDigit _ = Nothing 88 | 89 | subset :: Ord a => Interval a -> Interval a -> Bool 90 | Interval _ _ _ `subset` Interval Infinity Infinity _ = True 91 | Interval Infinity Infinity _ `subset` Interval _ _ _ = False 92 | Interval Infinity (Finite s1) _ `subset` Interval Infinity (Finite s2) _ = s1 <= s2 93 | Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) Infinity _ = i1 >= i2 94 | Interval Infinity (Finite _) _ `subset` Interval (Finite _) Infinity _ = False 95 | Interval (Finite _) Infinity _ `subset` Interval Infinity (Finite _) _ = False 96 | Interval (Finite i1) (Finite s1) True `subset` Interval Infinity (Finite s2) _ 97 | | s1 <= s2 = True 98 | | otherwise = False 99 | Interval (Finite i1) (Finite s1) False `subset` Interval Infinity (Finite s2) _ 100 | = False 101 | Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) Infinity _ 102 | | i2 <= i1 = True 103 | | otherwise = False 104 | Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) Infinity _ 105 | = False 106 | Interval Infinity (Finite s1) _ `subset` Interval (Finite i2) (Finite s2) False 107 | | s1 <= s2 = True 108 | | otherwise = False 109 | Interval Infinity (Finite s1) _ `subset` Interval (Finite i2) (Finite s2) True 110 | = False 111 | Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) (Finite s2) False 112 | | i2 <= i1 = True 113 | | otherwise = False 114 | Interval (Finite i1) Infinity _ `subset` Interval (Finite i2) (Finite s2) True 115 | = False 116 | Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) (Finite s2) True 117 | | i2 <= i1 && s1 <= s2 = True 118 | | otherwise = False 119 | Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) (Finite s2) False 120 | | i2 <= i1 && s1 <= s2 = True 121 | | otherwise = False 122 | Interval (Finite i1) (Finite s1) True `subset` Interval (Finite i2) (Finite s2) False 123 | | i2 <= i1 && i2 <= s1 = True 124 | | i1 <= s2 && s1 <= s2 = True 125 | | otherwise = False 126 | Interval (Finite i1) (Finite s1) False `subset` Interval (Finite i2) (Finite s2) True 127 | = False 128 | 129 | elementOf :: (Ord a) => Extended a -> Interval a -> Bool 130 | Infinity `elementOf` (Interval Infinity Infinity _) = True 131 | (Finite _) `elementOf` (Interval Infinity Infinity _) = True 132 | Infinity `elementOf` (Interval (Finite _) Infinity _) = True 133 | (Finite x) `elementOf` (Interval (Finite a) Infinity _) = x >= a 134 | Infinity `elementOf` (Interval Infinity (Finite _) _) = True 135 | (Finite x) `elementOf` (Interval Infinity (Finite b) _) = x <= b 136 | Infinity `elementOf` (Interval (Finite i) (Finite s) _) = i > s 137 | (Finite x) `elementOf` (Interval (Finite i) (Finite s) True) = i <= x && x <= s 138 | (Finite x) `elementOf` (Interval (Finite i) (Finite s) False) = i <= x || x <= s 139 | 140 | -- Here we interpret Interval Infinity Infinity as the whole real line 141 | mergeInterval :: (Ord a) => Interval a -> Interval a -> Interval a 142 | mergeInterval (Interval Infinity Infinity _) (Interval Infinity Infinity _) 143 | = Interval Infinity Infinity True 144 | mergeInterval (Interval (Finite i) Infinity _) (Interval Infinity Infinity _) 145 | = Interval Infinity Infinity True 146 | mergeInterval (Interval Infinity (Finite s) _) (Interval Infinity Infinity _) 147 | = Interval Infinity Infinity True 148 | mergeInterval (Interval (Finite i) (Finite s) _) (Interval Infinity Infinity _) 149 | = Interval Infinity Infinity True 150 | mergeInterval (Interval Infinity (Finite s) _) (Interval (Finite i) Infinity _) 151 | | s >= i = Interval Infinity Infinity True 152 | | otherwise = Interval (Finite i) (Finite s) False 153 | mergeInterval (Interval Infinity (Finite s1) _) (Interval Infinity (Finite s2) _) 154 | = Interval Infinity (Finite $ max s1 s2) True 155 | mergeInterval (Interval (Finite i1) Infinity _) (Interval (Finite i2) Infinity _) 156 | = Interval Infinity (Finite $ min i1 i2) True 157 | mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval (Finite i2) Infinity _) 158 | = Interval (Finite $ min i1 i2) Infinity True 159 | mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval (Finite i2) Infinity _) 160 | | i1 <= i2 = Interval (Finite i1) (Finite s1) False 161 | | i2 <= s1 = Interval Infinity Infinity True 162 | | i2 > s1 = Interval (Finite i2) (Finite s1) False 163 | mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval Infinity (Finite s2) _) 164 | = Interval Infinity (Finite $ max s1 s2) True 165 | mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval Infinity (Finite s2) _) 166 | | s2 <= s1 = Interval (Finite i1) (Finite s1) False 167 | | i1 <= s2 = Interval Infinity Infinity True 168 | | i1 > s2 = Interval (Finite i1) (Finite s2) False 169 | mergeInterval (Interval (Finite i1) (Finite s1) True) (Interval (Finite i2) (Finite s2) True) 170 | = Interval (Finite $ min i1 i2) (Finite $ max s1 s2) True 171 | mergeInterval (Interval (Finite i1) (Finite s1) False) (Interval (Finite i2) (Finite s2) False) 172 | | (i1 <= s2 || i2 <= s1) = Interval Infinity Infinity True 173 | | otherwise = Interval (Finite $ min i1 i2) (Finite $ max s1 s2) False 174 | mergeInterval int1@(Interval (Finite i1) (Finite s1) True) int2@(Interval (Finite i2) (Finite s2) False) 175 | = doTricky int1 int2 176 | mergeInterval int1@(Interval (Finite i1) (Finite s1) False) int2@(Interval (Finite i2) (Finite s2) True) 177 | = doTricky int2 int1 178 | mergeInterval int1 int2 = mergeInterval int2 int1 179 | 180 | doTricky int1@(Interval (Finite i1) (Finite s1) True) int2@(Interval (Finite i2) (Finite s2) False) 181 | | int1 `subset` int2 = int2 182 | | i2 <= s1 && i1 <= s2 = Interval Infinity Infinity True 183 | | s1 < i2 = Interval (Finite i2) (Finite s1) False 184 | | s2 < i1 = Interval (Finite i1) (Finite s2) False 185 | | otherwise = error "The impossible happened in mergeInterval" 186 | -------------------------------------------------------------------------------- /src/Math/ContinuedFraction/Simple.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A "standard" continued fraction, whose terms are all either 3 | -- positive or negative. 4 | module Math.ContinuedFraction.Simple 5 | ( 6 | CF, 7 | showCF, 8 | sqrt2, 9 | exp1 10 | ) where 11 | 12 | import Data.Ratio 13 | 14 | newtype CF = CF [Integer] 15 | 16 | -- The coefficients of the homographic function (ax + b) / (cx + d) 17 | type Hom = (Integer, Integer, 18 | Integer, Integer) 19 | 20 | -- Possibly output a term 21 | homEmittable :: Hom -> Maybe Integer 22 | homEmittable (n0, n1, 23 | d0, d1) = if d0 /= 0 && d1 /= 0 && r == s then 24 | Just r 25 | else 26 | Nothing 27 | where r = n0 `quot` d0 28 | s = n1 `quot` d1 29 | 30 | homEmit :: Hom -> Integer -> Hom 31 | homEmit (n0, n1, 32 | d0, d1) x = (d0, d1, 33 | n0 - d0*x, n1 - d1*x) 34 | 35 | homAbsorb :: Hom -> Integer -> Hom 36 | homAbsorb (n0, n1, 37 | d0, d1) x = (n0*x + n1, n0, 38 | d0*x + d1, d0) 39 | 40 | -- Apply a hom to a continued fraction 41 | hom :: Hom -> CF -> CF 42 | hom (0, 0, 43 | _, _) _ = CF [0] 44 | hom (_, _, 45 | 0, 0) _ = CF [] 46 | hom (n0, _, 47 | d0, _) (CF []) = fromRational (n0 % d0) 48 | hom h (CF (x:xs)) = case homEmittable h of 49 | Just d -> let (CF rest) = hom (homEmit h d) (CF (x:xs)) in CF (d : rest) 50 | Nothing -> hom (homAbsorb h x) (CF xs) 51 | 52 | -- The coefficients of the bihomographic function (axy + by + cx + d) / (exy + fy + gx + h) 53 | type Bihom = (Integer, Integer, Integer, Integer, 54 | Integer, Integer, Integer, Integer) 55 | 56 | bihomEmittable :: Bihom -> Maybe Integer 57 | bihomEmittable (n0, n1, n2, n3, 58 | d0, d1, d2, d3) = if d0 /= 0 && d1 /= 0 && d2 /= 0 && d3 /= 0 && ratiosAgree then 59 | Just r 60 | else 61 | Nothing 62 | where r = n0 `quot` d0 63 | ratiosAgree = r == n1 `quot` d1 && r == n2 `quot` d2 && r == n3 `quot` d3 64 | 65 | bihomEmit :: Bihom -> Integer -> Bihom 66 | bihomEmit (n0, n1, n2, n3, 67 | d0, d1, d2, d3) x = (d0, d1, d2, d3, 68 | n0 - d0*x, n1 - d1*x, n2 - d2*x, n3 - d3*x) 69 | 70 | bihomAbsorbX :: Bihom -> Integer -> Bihom 71 | bihomAbsorbX (n0, n1, n2, n3, 72 | d0, d1, d2, d3) x = (n0*x + n1, n0, n2*x + n3, n2, 73 | d0*x + d1, d0, d2*x + d3, d2) 74 | 75 | bihomAbsorbY :: Bihom -> Integer -> Bihom 76 | bihomAbsorbY (n0, n1, n2, n3, 77 | d0, d1, d2, d3) y = (n0*y + n2, n1*y + n3, n0, n1, 78 | d0*y + d2, d1*y + d3, d0, d1) 79 | 80 | -- Decide which of x and y to pull a term from 81 | shouldIngestX :: Bihom -> Bool 82 | shouldIngestX (_, _, _, _, 83 | _, 0, _, 0) = True 84 | shouldIngestX (_, _, _, _, 85 | _, _, 0, 0) = False 86 | shouldIngestX (_a, b, c, d, 87 | _e, f, g, h) = abs (g*h*b - g*d*f) < abs (f*h*c - g*d*f) 88 | 89 | -- Apply a bihom to two continued fractions 90 | bihom :: Bihom -> CF -> CF -> CF 91 | bihom (_, _, _, _, 92 | 0, 0, 0, 0) _ _ = CF [] 93 | bihom (0, 0, 0, 0, 94 | _, _, _, _) _ _ = CF [0] 95 | bihom (n0, _n1, n2, _n3, 96 | d0, _d1, d2, _d3) (CF []) y = hom (n0, n2, 97 | d0, d2) y 98 | bihom (n0, n1, _n2, _n3, 99 | d0, d1, _d2, _d3) x (CF []) = hom (n0, n1, 100 | d0, d1) x 101 | bihom bh (CF (x:xs)) (CF (y:ys)) = case bihomEmittable bh of 102 | Just d -> CF $ d : rest 103 | where (CF rest) = bihom (bihomEmit bh d) (CF (x:xs)) (CF (y:ys)) 104 | Nothing -> if shouldIngestX bh then 105 | bihom (bihomAbsorbX bh x) (CF xs) (CF (y:ys)) 106 | else 107 | bihom (bihomAbsorbY bh y) (CF (x:xs)) (CF ys) 108 | 109 | -- | The square root of 2 110 | sqrt2 :: CF 111 | sqrt2 = CF $ 1 : repeat 2 112 | 113 | -- | e 114 | exp1 :: CF 115 | exp1 = CF (2 : concatMap triple [1..]) 116 | where triple n = [1, 2 * n, 1] 117 | 118 | instance Eq CF where 119 | x == y = compare x y == EQ 120 | 121 | instance Ord CF where 122 | -- As [..., n, 1] represents the same number as [..., n+1] 123 | compare (CF [x]) (CF [y, 1]) = compare x (y+1) 124 | compare (CF [x, 1]) (CF [y]) = compare (x+1) y 125 | compare (CF [x]) (CF [y]) = compare x y 126 | 127 | compare (CF (x:_)) (CF [y]) = if x < y then LT else GT 128 | compare (CF [x]) (CF (y:_)) = if x > y then GT else LT 129 | 130 | compare (CF (x:xs)) (CF (y:ys)) = case compare x y of 131 | EQ -> opposite $ compare (CF xs) (CF ys) 132 | o -> o 133 | where opposite LT = GT 134 | opposite EQ = EQ 135 | opposite GT = LT 136 | 137 | instance Num CF where 138 | (+) = bihom (0, 1, 1, 0, 139 | 0, 0, 0, 1) 140 | (*) = bihom (1, 0, 0, 0, 141 | 0, 0, 0, 1) 142 | (-) = bihom (0, -1, 1, 0, 143 | 0, 0, 0, 1) 144 | 145 | fromInteger i = CF [i] 146 | abs x = if x > 0 then 147 | x 148 | else 149 | -x 150 | signum x | x < 0 = -1 151 | | x == 0 = 0 152 | | x > 0 = 1 153 | 154 | 155 | instance Fractional CF where 156 | (/) = bihom (0, 0, 1, 0, 157 | 0, 1, 0, 0) 158 | 159 | recip (CF [1]) = CF [1] 160 | recip (CF (0:xs)) = CF xs 161 | recip (CF xs) = CF (0:xs) 162 | 163 | fromRational r = if rest == 0 then 164 | CF [d] 165 | else 166 | let (CF ds) = fromRational (recip rest) in CF (d:ds) 167 | where (d, rest) = properFraction r 168 | 169 | instance Real CF where 170 | toRational _ = undefined 171 | 172 | instance RealFrac CF where 173 | properFraction (CF [i]) = (fromIntegral i, 0) 174 | properFraction cf | cf < 0 = case properFraction (-cf) of 175 | (b, a) -> (-b, -a) 176 | properFraction (CF (i:r)) = (fromIntegral i, CF r) 177 | 178 | rationalDigits :: Rational -> [Integer] 179 | rationalDigits 0 = [] 180 | rationalDigits r = let d = num `quot` den in 181 | d : rationalDigits (10 * (r - fromInteger d)) 182 | where num = numerator r 183 | den = denominator r 184 | 185 | digits :: CF -> [Integer] 186 | digits = go (1, 0, 0, 1) 187 | where go (0, 0, _, _) _ = [] 188 | go (p, _, q, _) (CF []) = rationalDigits (p % q) 189 | go h (CF (c:cs)) = case homEmittable h of 190 | Nothing -> let h' = homAbsorb h c in go h' (CF cs) 191 | Just d -> d : go (homEmitDigit h d) (CF (c:cs)) 192 | homEmitDigit (n0, n1, 193 | d0, d1) d = (10 * (n0 - d0*d), 10 * (n1 - d1*d), 194 | d0, d1) 195 | 196 | -- | Produce the (possibly infinite) decimal expansion of a continued 197 | -- fraction 198 | showCF :: CF -> String 199 | showCF cf | cf < 0 = "-" ++ show (-cf) 200 | showCF (CF [i]) = show i 201 | showCF (CF (i:r)) = show i ++ "." ++ decimalDigits 202 | where decimalDigits = concatMap show $ tail $ digits (CF (0:r)) 203 | 204 | -- Should make this cleverer 205 | instance Show CF where 206 | show = take 15 . showCF 207 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | import Data.Maybe 5 | 6 | import Math.ContinuedFraction.Effective 7 | import Math.ContinuedFraction.Interval 8 | 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Function 11 | import Test.Framework.TH 12 | import Test.Framework.Providers.QuickCheck2 13 | 14 | instance Arbitrary Extended where 15 | arbitrary = do 16 | b <- arbitrary :: Gen Bool 17 | if b then 18 | return Infinity 19 | else 20 | fmap Finite arbitrary 21 | 22 | instance Arbitrary Interval where 23 | arbitrary = do 24 | (i, s) <- suchThat arbitrary (\(i,s) -> i /= s) :: Gen (Extended, Extended) 25 | return $ Interval i s 26 | 27 | prop_sensibleEmittable x = isJust $ existsEmittable (primitiveBound x) 28 | where types = x :: Integer 29 | 30 | prop_sensiblePrimitiveBound x = fromInteger x `elementOf` primitiveBound x 31 | where types = x :: Integer 32 | 33 | prop_sensibleMergeInterval a b = a `subset` ab && b `subset` ab 34 | where types = (a :: Interval, b :: Interval) 35 | ab = a `mergeInterval` b 36 | 37 | main :: IO () 38 | main = $defaultMainGenerator 39 | -------------------------------------------------------------------------------- /wip/Effective.hs: -------------------------------------------------------------------------------- 1 | module Math.ContinuedFraction.Effective where 2 | 3 | import Data.Maybe (listToMaybe) 4 | import Data.Ratio 5 | 6 | import Math.ContinuedFraction.Interval 7 | 8 | newtype CF = CF [Integer] 9 | type CF' = [Integer] 10 | 11 | type Hom = (Integer, Integer, 12 | Integer, Integer) 13 | 14 | type Bihom = (Integer, Integer, Integer, Integer, 15 | Integer, Integer, Integer, Integer) 16 | 17 | homQ :: Hom -> Extended -> Extended 18 | homQ (n0, n1, 19 | d0, d1) (Finite q) | denom /= 0 = Finite $ num / denom 20 | | num == 0 = error "0/0 in homQ" 21 | | otherwise = Infinity 22 | where num = fromInteger n0 * q + fromInteger n1 23 | denom = fromInteger d0 * q + fromInteger d1 24 | homQ (n0, _n1, 25 | d0, _d1) Infinity = Finite $ n0 % d0 26 | 27 | homEmit :: Hom -> Integer -> Hom 28 | homEmit (n0, n1, 29 | d0, d1) x = (d0, d1, 30 | n0 - d0*x, n1 - d1*x) 31 | 32 | homAbsorb :: Hom -> CF' -> (Hom, CF') 33 | homAbsorb h xs = (foldl homAbsorbOne h (take (fromInteger n) xs'), drop (fromInteger n) xs') 34 | where (n, xs') = absorbHowMany xs 35 | 36 | homAbsorbOne :: Hom -> Integer -> Hom 37 | homAbsorbOne (n0, n1, 38 | d0, d1) x = (n0*x + n1, n0, 39 | d0*x + d1, d0) 40 | 41 | det :: Hom -> Integer 42 | det (n0, n1, 43 | d0, d1) = n0 * d1 - n1 * d0 44 | 45 | cfFromRational :: Rational -> CF' 46 | cfFromRational r = if den == 1 then 47 | [num] 48 | else 49 | d : cfFromRational (recip $ r - fromInteger d) 50 | where num = numerator r 51 | den = denominator r 52 | d = num `quot` den 53 | 54 | boundHom :: Hom -> Interval -> Interval 55 | boundHom h (Interval i s) | det h > 0 = Interval i' s' 56 | | det h < 0 = Interval s' i' 57 | | otherwise = error "0 det in boundHom" 58 | where i' = homQ h i 59 | s' = homQ h s 60 | 61 | hom' :: Hom -> CF' -> CF' 62 | hom' (_n0, _n1, 63 | 0, _d1) [] = [] 64 | hom' (n0, _n1, 65 | d0, _d1) [] = cfFromRational (n0 % d0) 66 | hom' h xs = case existsEmittable $ boundHom h (bound xs) of 67 | Just n -> n : hom' (homEmit h n) xs 68 | Nothing -> hom' h' xs' 69 | where (h', xs') = homAbsorb h xs 70 | 71 | hom :: Hom -> CF -> CF 72 | hom bh (CF xs) = CF $ hom' bh xs 73 | 74 | bihomEmit :: Bihom -> Integer -> Bihom 75 | bihomEmit (n0, n1, n2, n3, 76 | d0, d1, d2, d3) x = (d0, d1, d2, d3, 77 | n0 - d0*x, n1 - d1*x, n2 - d2*x, n3 - d3*x) 78 | 79 | bihomAbsorbOneX :: Bihom -> Integer -> Bihom 80 | bihomAbsorbOneX (n0, n1, n2, n3, 81 | d0, d1, d2, d3) x = (n0*x + n1, n0, n2*x + n3, n2, 82 | d0*x + d1, d0, d2*x + d3, d2) 83 | 84 | bihomAbsorbOneY :: Bihom -> Integer -> Bihom 85 | bihomAbsorbOneY (n0, n1, n2, n3, 86 | d0, d1, d2, d3) y = (n0*y + n2, n1*y + n3, n0, n1, 87 | d0*y + d2, d1*y + d3, d0, d1) 88 | 89 | bihomAbsorbX :: Bihom -> CF' -> (Bihom, CF') 90 | bihomAbsorbX bh xs = (foldl bihomAbsorbOneX bh (take (fromInteger n) xs'), drop (fromInteger n) xs') 91 | where (n, xs') = absorbHowMany xs 92 | 93 | bihomAbsorbY :: Bihom -> CF' -> (Bihom, CF') 94 | bihomAbsorbY bh ys = (foldl bihomAbsorbOneY bh (take (fromInteger n) ys'), drop (fromInteger n) ys') 95 | where (n, ys') = absorbHowMany ys 96 | 97 | bihomSubstituteX :: Bihom -> Extended -> Hom 98 | bihomSubstituteX (n0, n1, n2, n3, 99 | d0, d1, d2, d3) (Finite x) = (n0*num + n1*den, n2*num + n3*den, 100 | d0*num + d1*den, d2*num + d3*den) 101 | where num = numerator x 102 | den = denominator x 103 | bihomSubstituteX (n0, _n1, n2, _n3, 104 | d0, _d1, d2, _d3) Infinity = (n0, n2, 105 | d0, d2) 106 | 107 | bihomSubstituteY :: Bihom -> Extended -> Hom 108 | bihomSubstituteY (n0, n1, n2, n3, 109 | d0, d1, d2, d3) (Finite y) = (n0*num + n2*den, n1*num + n3*den, 110 | d0*num + d2*den, d1*num + d3*den) 111 | where num = numerator y 112 | den = denominator y 113 | bihomSubstituteY (n0, n1, _n2, _n3, 114 | d0, d1, _d2, _d3) Infinity = (n0, n1, 115 | d0, d1) 116 | 117 | boundBihom :: Bihom -> Interval -> Interval -> Interval 118 | boundBihom bh x@(Interval ix sx) y@(Interval iy sy) = r1 `mergeInterval` r2 `mergeInterval` r3 `mergeInterval` r4 119 | where r1 = boundHom (bihomSubstituteX bh ix) y 120 | r2 = boundHom (bihomSubstituteY bh iy) x 121 | r3 = boundHom (bihomSubstituteX bh sx) y 122 | r4 = boundHom (bihomSubstituteY bh sy) x 123 | 124 | select :: Bihom -> Interval -> Interval -> Bool 125 | select bh x@(Interval ix sx) y@(Interval iy sy) = intY <= intX 126 | where intX = max r3 r4 127 | intY = max r1 r2 128 | r1 = boundHom (bihomSubstituteX bh ix) y 129 | r2 = boundHom (bihomSubstituteX bh sx) y 130 | r3 = boundHom (bihomSubstituteY bh iy) x 131 | r4 = boundHom (bihomSubstituteY bh sy) x 132 | 133 | bihom' :: Bihom -> CF' -> CF' -> CF' 134 | bihom' bh [] ys = hom' (bihomSubstituteX bh Infinity) ys 135 | bihom' bh xs [] = hom' (bihomSubstituteY bh Infinity) xs 136 | bihom' bh xs ys = case existsEmittable $ boundBihom bh (bound xs) (bound ys) of 137 | Just n -> n : bihom' (bihomEmit bh n) xs ys 138 | Nothing -> if select bh (bound xs) (bound ys) then 139 | let (bh', xs') = bihomAbsorbX bh xs in bihom' bh' xs' ys 140 | else 141 | let (bh', ys') = bihomAbsorbY bh ys in bihom' bh' xs ys' 142 | 143 | bihom :: Bihom -> CF -> CF -> CF 144 | bihom bh (CF xs) (CF ys) = CF $ bihom' bh xs ys 145 | 146 | primitiveBound :: Integer -> Interval 147 | primitiveBound 0 = Interval (-0.5) 0.5 148 | primitiveBound (-1) = Interval (-1.6) (-0.4) 149 | primitiveBound 1 = Interval 0.4 1.6 150 | primitiveBound x | x <= -2 = Interval (-(fromInteger x) + 0.5) ((fromInteger x) + 0.5) 151 | primitiveBound x | x >= 2 = Interval ((fromInteger x) - 0.5) (-(fromInteger x) - 0.5) 152 | 153 | evaluate :: CF' -> Rational 154 | evaluate [c] = fromInteger c 155 | evaluate (c:cs) = fromInteger c + recip (evaluate cs) 156 | 157 | nthPrimitiveBounds :: CF' -> [Interval] 158 | nthPrimitiveBounds cf = zipWith boundHom homs (map primitiveBound cf) ++ repeat (Interval (Finite ev) (Finite ev)) 159 | where homs = scanl homAbsorbOne (1,0,0,1) cf 160 | ev = evaluate cf 161 | 162 | existsEmittable :: Interval -> Maybe Integer 163 | existsEmittable i | i `subset` Interval (-1.6) (-0.4) = Just (-1) 164 | | i `subset` Interval 0.4 1.6 = Just 1 165 | | i `subset` Interval (-0.5) 0.5 = Just 0 166 | existsEmittable i = listToMaybe $ filter (\n -> i `subset` primitiveBound n) (candidates i) 167 | 168 | topCandidates :: Interval -> [Integer] 169 | topCandidates (Interval (Finite r) _) = [round r, - floor (r - 0.5)] 170 | topCandidates (Interval Infinity _) = [] 171 | 172 | botCandidates :: Interval -> [Integer] 173 | botCandidates (Interval _ (Finite r)) = [round r, - ceiling (r + 0.5)] 174 | botCandidates (Interval _ Infinity) = [] 175 | 176 | candidates :: Interval -> [Integer] 177 | candidates i = topCandidates i ++ botCandidates i 178 | 179 | emittableRange :: Interval -> [Integer] 180 | emittableRange i = case cs of 181 | [] -> [] 182 | _ -> [minimum cs .. maximum cs] 183 | where cs = filter (\n -> i `subset` primitiveBound n) (candidates i) 184 | 185 | existsRestrictedEmittable :: Interval -> Integer -> Integer -> Maybe Integer 186 | existsRestrictedEmittable int n m = listToMaybe $ traceShowId [ i | i <- blended, abs n < abs (n + i), int `subset` primitiveBound (n + i) ] 187 | where range = [2..(abs m)] 188 | blended = blend range (map negate range) 189 | blend (x:xs) ys = x : blend ys xs 190 | blend [] ys = ys 191 | 192 | data State = Normal | Stored Integer | Zero Integer deriving (Show) 193 | 194 | -- homz :: State -> Hom -> CF' -> CF' 195 | -- -- todo verify this works 196 | -- homz _ (_n0, _n1, 197 | -- 0, _d1) [] = [] 198 | -- homz _ (n0, _n1, 199 | -- d0, _d1) [] = cfFromRational (n0 % d0) 200 | 201 | -- --homz status h xs | traceShow (status, h) False = undefined 202 | 203 | -- homz Normal h xs = case existsEmittable $ boundHom h (bound xs) of 204 | -- Just n -> if abs n <= 1 then 205 | -- n : homz Normal (homEmit h n) xs 206 | -- else 207 | -- n : homz (Stored n) h xs 208 | -- Nothing -> homz Normal h' xs' 209 | -- where (h', xs') = homAbsorb h xs 210 | 211 | -- homz (Stored n) h xs = case existsEmittable $ boundHom (homEmit h n) (bound xs) of 212 | -- Just m -> if m == 0 then 213 | -- m : homz (Zero n) h xs 214 | -- else 215 | -- m : homz Normal (homEmit (homEmit h n) m) xs 216 | -- Nothing -> homz (Stored n) h' xs' 217 | -- where (h', xs') = homAbsorb h xs 218 | 219 | -- homz (Zero n) h xs = case existsEmittable $ boundHom (homEmit (homEmit h n) 0) (bound xs) of 220 | -- Just m -> case existsRestrictedEmittable (boundHom (homEmit (homEmit h n) 0) (bound xs)) n m of 221 | -- Just i -> (i-n) : homz (Stored (n+i)) h xs 222 | -- Nothing -> homz (Zero n) h' xs' 223 | -- Nothing -> homz (Zero n) h' xs' 224 | -- where (h', xs') = homAbsorb h xs 225 | 226 | absorbHowMany :: CF' -> (Integer, CF') 227 | absorbHowMany xs = (min n m, xs') 228 | where (n, m, xs') = d xs 229 | 230 | d :: CF' -> (Integer, Integer, CF') 231 | d xs@(x0 : 2 : x2 : _) | abs x0 == 1 && (x2 >= 3 || x2 == 1 || x2 <= -4) = (2, 2, xs) 232 | d xs@(x0 : 2 : 2 : x3 : _) | abs x0 == 1 && (x3 >= 1 || x3 <= -3) = (3, 3, xs) 233 | d xs@(x0 : 2 : 2 : -2 : _) | abs x0 == 1 = (2, 3, xs) 234 | d xs@(x0 : 2 : -2 : -1 : 2 : x5 : _) | abs x0 == 1 && (x5 == 2 || x5 == -2 || x5 == -3) = (3, 5, xs) 235 | d xs@(x0 : 2 : -2 : -1 : 2 : x5 : _) | abs x0 == 1 && (x5 >= 3 || x5 == 1 || x5 <= -4) = (5, 5, xs) 236 | d xs@(x0 : 2 : -2 : -1 : x4 : -2 : _) | abs x0 == 1 && x4 >= 3 = (4, 5, xs) 237 | d xs@(x0 : 2 : -2 : -1 : x4 : x5 : _) | abs x0 == 1 && x4 >= 3 && (x5 >= 1 || x5 <= -3) = (5, 5, xs) 238 | d xs@(x0 : 2 : -3 : -1 : _) | abs x0 == 1 = (3, 3, xs) 239 | d xs@(x0 : 2 : -3 : x3 : 2 : _) | abs x0 == 1 && x3 <= -2 = (3, 4, xs) 240 | d xs@(x0 : 2 : -3 : x3 : x4 : _) | abs x0 == 1 && x3 <= -2 && (x4 >= 3 || x4 <= -1) = (4, 4, xs) 241 | d xs@(x0 : 2 : 1 : _) | x0 == 0 || x0 <= -2 = (2, 2, xs) 242 | d xs@(x0 : 2 : x2 : -2 : _) | (x0 == 0 || x0 <= -2) && x2 >= 2 = (2, 3, xs) 243 | d xs@(x0 : 2 : x2 : x3 : _) | (x0 == 0 || x0 <= -2) && x2 >= 2 && (x3 >= 1 || x3 <= -3) = (3, 3, xs) 244 | 245 | -- d (x0 : 0 : x2 : xs) = (0, 0, (x0+x2) : xs) 246 | -- d (x0 : 2 : 0 : x3 : xs) = d (x0 : x3+2 : xs) 247 | -- d (x0 : -2 : 0 : x3 : xs) = d (x0 : x3-2 : xs) 248 | -- d (x0 : x1 : 0 : x3 : xs) = (1, 0, x0 : (x1+x3) : xs) 249 | -- d (x0 : 2 : 2 : 0 : -5 : xs) = d (x0 : 2 : -3 : xs) 250 | -- d (x0 : 2 : x2 : 0 : x4 : xs) = (2, 0, x0 : 2 : (x2+x4) : xs) 251 | -- d (x0 : 2 : x2 : -2 : 0 : x5 : xs) = d (x0 : 2 : x2 : x5-2 : xs) 252 | -- d (x0 : 2 : -3 : x3 : 0 : x5 : xs) = (3, 0, x0 : 2 : -3 : (x3+x5) : xs) 253 | -- d (x0 : 2 : -2 : -1 : 2 : 0 : x6 : xs) = d (x0 : 2 : -2 : -1 : x6+2 : xs) 254 | -- d (x0 : 2 : -2 : -1 : x4 : 0 : x6 : xs) = (4, 0, x0 : 2 : -2 : -1 : (x4+x6) : xs) 255 | -- d (x0 : 2 : -2 : -1 : 2 : 2 : 0 : x7 : xs) = d (x0 : 2 : -2 : -1 : 2 : x7+2 : xs) 256 | -- d (x0 : 2 : -2 : -1 : x4 : -2 : 0 : x7 : xs) = d (x0 : 2 : -2 : -1 : x4 : x7-2 : xs) 257 | -- d (x0 : 2 : -2 : -1 : 2 : -3 : 0 : x7 : xs) = d (x0 : 2 : -2 : -1 : 2 : x7-3 : xs) 258 | 259 | d xs@(_ : -2 : _) = (j, i, map negate xs') 260 | where (i, j, xs') = d $ map negate xs 261 | d xs = (1, 1, xs) 262 | 263 | bound :: CF' -> Interval 264 | bound xs = Interval i s 265 | where (n, m, xs') = d xs 266 | Interval i _ = nthPrimitiveBounds xs' !! fromInteger n 267 | Interval _ s = nthPrimitiveBounds xs' !! fromInteger m 268 | 269 | nextBound :: CF' -> Interval 270 | nextBound xs = if a == 0 then 271 | bound xs' 272 | else 273 | go a xs' 274 | where (n, m, xs') = d xs 275 | a = min n m 276 | go 0 cs = bound cs 277 | go i (c:cs) = c .+ recips (go (i-1) cs) 278 | 279 | sqrt2 :: CF 280 | sqrt2 = CF $ 1 : repeat 2 281 | 282 | exp1 :: CF 283 | exp1 = CF $ 2 : concatMap triple [1..] 284 | where triple n = [1, 2 * n, 1] 285 | 286 | instance Num CF where 287 | (+) = bihom (0, 1, 1, 0, 288 | 0, 0, 0, 1) 289 | (-) = bihom (0, -1, 1, 0, 290 | 0, 0, 0, 1) 291 | (*) = bihom (1, 0, 0, 0, 292 | 0, 0, 0, 1) 293 | 294 | fromInteger n = CF [n] 295 | 296 | instance Fractional CF where 297 | (/) = bihom (0, 0, 1, 0, 298 | 0, 1, 0, 0) 299 | 300 | fromRational = CF . cfFromRational 301 | 302 | digits :: CF' -> [Integer] 303 | digits = go (1, 0, 0, 1) 304 | where go h cs = case intervalDigit $ boundHom h (bound cs) of 305 | Nothing -> let (h', cs') = homAbsorb h cs in go h' cs' 306 | Just d -> d : go (homEmitDigit h d) cs 307 | base = 10 308 | homEmitDigit (n0, n1, 309 | d0, d1) d = (base * (n0 - d0*d), base * (n1 - d1*d), 310 | d0, d1) 311 | 312 | cfString :: CF -> String 313 | cfString (CF cf) = case digits cf of 314 | [i] -> show i 315 | (i:is) -> show i ++ "." ++ concatMap show is 316 | 317 | instance Show CF where 318 | show = take 50 . cfString 319 | --------------------------------------------------------------------------------