├── Reference.hs
└── Fractions.hs


/Reference.hs:
--------------------------------------------------------------------------------
  1 | -- |
  2 | --
  3 | -- ICreals.hs
  4 | -- Haskell implementation of exact real arithmetic using
  5 | -- Linear Fractional Transformations.
  6 | --
  7 | -- Usage:
  8 | -- eshow <expression> <digits>
  9 | --   where <expression> is expression to be calculated up to
 10 | --   <digits> number of digit matrices (which roughly corresponds
 11 | --   to (<digits>/3) decimal digits.
 12 | --
 13 | -- Examples:
 14 | -- eshow epi 100 - calculate pi up to 100 digit matrices
 15 | -- eshow (esin (ExpV (1,2))) 100 - calculate sin(1/2)
 16 | --
 17 | -- Original version by Peter Potts, circa 1998.
 18 | -- Updated by Edward Kmett to Haskell 98 in 2015 
 19 | 
 20 | module Reference where
 21 | 
 22 | import Data.Char
 23 | import Data.Ratio
 24 | 
 25 | type Vector     = (Integer, Integer)
 26 | type Matrix     = (Vector,Vector)
 27 | type Tensor     = (Matrix,Matrix)
 28 | type Uuefp      = [Integer]
 29 | type Usefp      = (String,Uuefp)
 30 | data Lft        = LftV Vector | LftM Matrix | LftT Tensor Integer
 31 |                 deriving (Eq, Show)
 32 | 
 33 | data Expression = ExpV Vector | ExpM Matrix Expression |
 34 |                 ExpT Tensor Integer Expression Expression
 35 |                 deriving (Eq, Show)
 36 | 
 37 | data Sefp       = Spos Uefp | Sinf Uefp | Sneg Uefp | Szer Uefp
 38 |                 deriving (Eq, Show)
 39 | data Uefp       = Dneg Uefp | Dzer Uefp | Dpos Uefp | Term Vector
 40 |                 deriving (Eq, Show)
 41 | 
 42 | instance Num Expression where
 43 |   (+) = ExpT (((0,0),(1,0)),((1,0),(0,1))) 0
 44 |   (-) = ExpT (((0,0),(1,0)),((-1,0),(0,1))) 0
 45 |   (*) = ExpT (((1,0),(0,0)),((0,0),(0,1))) 0
 46 |   negate = ExpM ((-1,0),(0,1))
 47 |   fromInteger n = ExpV (n,1)
 48 | 
 49 | instance Fractional Expression where
 50 |   recip = ExpM ((0,1),(1,0))
 51 |   (/) = ExpT (((0,0),(1,0)),((0,1),(0,0))) 0
 52 |   fromRational r = ExpV (numerator r,denominator r)
 53 | 
 54 | instance Enum Expression where
 55 |   succ = ExpM ((1,0),(1,1))
 56 |   pred = ExpM ((1,0),(-1,1))
 57 | 
 58 | --------------------------------------------------------------------------------
 59 | -- Basic Functions
 60 | --------------------------------------------------------------------------------
 61 | one :: a -> Integer -> a
 62 | one f 1 = f
 63 | 
 64 | identity :: Matrix
 65 | identity = ((1,0),(0,1))
 66 | 
 67 | trans :: ((t1,t2),(t3,t4)) -> ((t1,t3),(t2,t4))
 68 | trans ((a,b),(c,d)) = ((a,c),(b,d))
 69 | 
 70 | determinant :: Matrix -> Integer
 71 | determinant ((a,b),(c,d))   = a * d - b * c
 72 | 
 73 | inverse :: Matrix -> Matrix
 74 | inverse ((a,b),(c,d)) = mscale ((d,-b),(-c,a))
 75 | 
 76 | --------------------------------------------------------------------------------
 77 | -- Binary Scaling Functions
 78 | --------------------------------------------------------------------------------
 79 | vscale :: Vector -> Vector
 80 | vscale (a,b)
 81 |     | ar && br  = vscale (div a 2, div b 2)
 82 |     | otherwise = (a,b)
 83 |     where
 84 |     ar = (mod a 2 == 0)
 85 |     br = (mod b 2 == 0)
 86 | 
 87 | mscale :: Matrix -> Matrix
 88 | mscale ((a,b),(c,d))
 89 |     | ar && br && cr && dr  = mscale ((div a 2, div b 2), (div c 2, div d 2))
 90 |     | otherwise             = ((a,b),(c,d))
 91 |     where
 92 |     ar = (mod a 2 == 0)
 93 |     br = (mod b 2 == 0)
 94 |     cr = (mod c 2 == 0)
 95 |     dr = (mod d 2 == 0)
 96 |     
 97 | tscale :: Tensor -> Tensor
 98 | tscale (((a,b),(c,d)),((e,f),(g,h)))
 99 |     | ar && br && cr && dr &&
100 |       er && fr && gr && hr  = tscale (((div a 2, div b 2), (div c 2, div d 2)),
101 |                                       ((div e 2, div f 2), (div g 2, div h 2)))
102 |     | otherwise             = (((a,b),(c,d)),((e,f),(g,h)))
103 |     where
104 |     ar = (mod a 2 == 0)
105 |     br = (mod b 2 == 0)
106 |     cr = (mod c 2 == 0)
107 |     dr = (mod d 2 == 0)
108 |     er = (mod e 2 == 0)
109 |     fr = (mod f 2 == 0)
110 |     gr = (mod g 2 == 0)
111 |     hr = (mod h 2 == 0)
112 | 
113 | 
114 | --------------------------------------------------------------------------------
115 | -- Exact Floating Point
116 | --------------------------------------------------------------------------------
117 | spos, sinf, sneg, szer :: Matrix
118 | spos = ((1,0),(0,1))
119 | sinf = ((1,-1),(1,1))
120 | sneg = ((0,1),(-1,0))
121 | szer = ((1,1),(-1,1))
122 | 
123 | ispos, isinf, isneg, iszer :: Lft
124 | ispos = LftM (inverse spos)
125 | isinf = LftM (inverse sinf)
126 | isneg = LftM (inverse sneg)
127 | iszer = LftM (inverse szer)
128 | 
129 | dneg, dzer, dpos :: Matrix
130 | dneg = ((1,1),(0,2))
131 | dzer = ((3,1),(1,3))
132 | dpos = ((2,0),(1,1))
133 | 
134 | idneg, idzer, idpos :: Lft
135 | idneg = LftM (inverse dneg)
136 | idzer = LftM (inverse dzer)
137 | idpos = LftM (inverse dpos)
138 | 
139 | 
140 | --------------------------------------------------------------------------------
141 | -- Type Cast Functions
142 | --------------------------------------------------------------------------------
143 | utoe :: Uefp -> Expression
144 | utoe (Dneg u) = ExpM dneg (utoe u)
145 | utoe (Dzer u) = ExpM dzer (utoe u)
146 | utoe (Dpos u) = ExpM dpos (utoe u)
147 | utoe (Term v) = ExpV v
148 | 
149 | utom :: Uefp -> Integer -> Matrix
150 | utom u 0        = identity
151 | utom (Dneg u) j = mscale (mdotm dneg (utom u (j-1)))
152 | utom (Dzer u) j = mscale (mdotm dzer (utom u (j-1)))
153 | utom (Dpos u) j = mscale (mdotm dpos (utom u (j-1)))
154 | utom (Term v) j = mscale (v,v)
155 | 
156 | stom :: Sefp -> Integer -> Matrix
157 | stom (Spos u) j = mscale (mdotm spos (utom u j))
158 | stom (Sinf u) j = mscale (mdotm sinf (utom u j))
159 | stom (Sneg u) j = mscale (mdotm sneg (utom u j))
160 | stom (Szer u) j = mscale (mdotm szer (utom u j))
161 | 
162 | --------------------------------------------------------------------------------
163 | -- Basic Arithmetic Operations
164 | --------------------------------------------------------------------------------
165 | tadd, tsub, tmul, tdiv :: Tensor
166 | tadd = (((0,0),(1,0)),((1,0),(0,1)))
167 | tsub = (((0,0),(1,0)),((-1,0),(0,1)))
168 | tmul = (((1,0),(0,0)),((0,0),(0,1)))
169 | tdiv = (((0,0),(1,0)),((0,1),(0,0)))
170 | 
171 | srec :: Sefp -> Sefp
172 | srec (Spos u) = Spos (urec u)
173 | srec (Sneg u) = Sneg (urec u)
174 | srec (Szer u) = Sinf (urec u)
175 | srec (Sinf u) = Szer (urec u)
176 | 
177 | urec :: Uefp -> Uefp
178 | urec (Dneg u)     = Dpos (urec u)
179 | urec (Dzer u)     = Dzer (urec u)
180 | urec (Dpos u)     = Dneg (urec u)
181 | urec (Term (a,b)) = Term (b,a)
182 | 
183 | 
184 | --------------------------------------------------------------------------------
185 | -- Linear Fractional Transformation Products
186 | --------------------------------------------------------------------------------
187 | mdotv :: Matrix -> Vector -> Vector
188 | mdotv ((a,b),(c,d)) (e,f)   = (a * e + c * f,b * e + d * f)
189 | 
190 | mdotm :: Matrix -> Matrix -> Matrix
191 | mdotm m (v,w) = (mdotv m v,mdotv m w)
192 | 
193 | mdott :: Matrix -> Tensor -> Tensor
194 | mdott m (n,o) = (mdotm m n,mdotm m o)
195 | 
196 | tleftv :: Tensor -> Vector -> Matrix
197 | tleftv t v = trightv (trans t) v
198 | 
199 | tleftm :: Tensor -> Matrix -> Tensor
200 | tleftm t m = trans (trightm (trans t) m)
201 | 
202 | trightv :: Tensor -> Vector -> Matrix
203 | trightv (m,n) v = (mdotv m v,mdotv n v)
204 | 
205 | trightm :: Tensor -> Matrix -> Tensor
206 | trightm (m,n) o = (mdotm m o,mdotm n o)
207 | 
208 | dot :: Integer -> Lft -> Lft -> Lft
209 | dot 1 (LftM m) (LftV v)     = LftV (vscale (mdotv m v))
210 | dot 1 (LftM m) (LftM n)     = LftM (mscale (mdotm m n))
211 | dot 1 (LftM m) (LftT t i)   = LftT (tscale (mdott m t)) i
212 | dot 1 (LftT t i) (LftV v)   = LftM (mscale (tleftv t v))
213 | dot 1 (LftT t i) (LftM m)
214 |     | m == identity         = LftT t i
215 |     | otherwise             = LftT (tscale (tleftm t m)) (i+1)
216 | dot 2 (LftT t i) (LftV v)   = LftM (mscale (trightv t v))
217 | dot 2 (LftT t i) (LftM m)
218 |     | m == identity         = LftT t i
219 |     | otherwise             = LftT (tscale (trightm t m)) (i+1)
220 | 
221 | --------------------------------------------------------------------------------
222 | -- The Refinement Property
223 | --------------------------------------------------------------------------------
224 | sign :: Vector -> Integer
225 | sign (a,b)
226 |     | a< 0 && b<=0          = -1
227 |     | a< 0 && b> 0          =  0
228 |     | a==0 && b< 0          = -1
229 |     | a==0 && b==0          =  0
230 |     | a==0 && b> 0          =  1
231 |     | a> 0 && b< 0          =  0
232 |     | a> 0 && b>=0          =  1
233 | 
234 | vrefine :: Vector -> Bool
235 | vrefine v = sign v /= 0
236 | 
237 | mrefine :: Matrix -> Bool
238 | mrefine (v,w) = a == b && b /= 0
239 |     where
240 |     a = sign v
241 |     b = sign w
242 | 
243 | trefine :: Tensor -> Bool
244 | trefine ((v,w),(x,y)) = a == b && b == c && c == d && d /= 0
245 |     where
246 |     a = sign v
247 |     b = sign w
248 |     c = sign x
249 |     d = sign y
250 | 
251 | refine :: Lft -> Bool
252 | refine (LftV v) = vrefine v
253 | refine (LftM m) = mrefine m
254 | refine (LftT t i) = trefine t
255 | 
256 | --------------------------------------------------------------------------------
257 | -- Square Bracket Application
258 | --------------------------------------------------------------------------------
259 | app :: Lft -> (Integer -> Expression) -> Expression
260 | app (LftM m) g = cons (dot 1 (LftM m) (hd (g 1))) (tl (g 1))
261 | app (LftT t i) g = cons (dot 1 (dot 2 (LftT t i) (hd (g 2))) (hd (g 1))) h
262 |     where
263 |     c = branch (hd (g 1))
264 |     h i
265 |         | i <= c            = tl (g 1) i
266 |         | otherwise         = tl (g 2) (i-c)
267 | 
268 | 
269 | --------------------------------------------------------------------------------
270 | -- Tensor Absorption Strategy
271 | --------------------------------------------------------------------------------
272 | vlessv :: Vector -> Vector -> Bool
273 | vlessv v w = determinant (v,w) < 0
274 | 
275 | mlessv :: Matrix -> Vector -> Bool
276 | mlessv (v,w) x = vlessv v x && vlessv w x
277 | 
278 | mlessm :: Matrix -> Matrix -> Bool
279 | mlessm m (v,w) = mlessv m v && mlessv m w
280 | 
281 | mdisjointm :: Matrix -> Matrix -> Bool
282 | mdisjointm m n = mlessm m n || mlessm n m
283 | 
284 | strategyf :: Tensor -> Integer -> Integer
285 | strategyf t i = mod i 2 + 1
286 | 
287 | strategyo :: Tensor -> Integer -> Integer
288 | strategyo t
289 |     | trefine t = strategyr t
290 |     | otherwise = strategyf t
291 | 
292 | strategyr :: Tensor -> Integer -> Integer
293 | strategyr t i
294 |     | mdisjointm t1 t2 = 2
295 |     | otherwise        = 1
296 |     where
297 |     t1 = fst (trans t)
298 |     t2 = snd (trans t)
299 | 
300 | decision :: Integer -> Lft -> Bool
301 | decision 1 (LftM m)   = True
302 | decision 1 (LftT t i) = strategyo t i == 1
303 | decision 2 (LftT t i) = strategyo t i == 2
304 | 
305 | 
306 | --------------------------------------------------------------------------------
307 | -- Basic Expression Tree Functions
308 | --------------------------------------------------------------------------------
309 | branch :: Lft -> Integer
310 | branch (LftV v) = 0
311 | branch (LftM m) = 1
312 | branch (LftT t i) = 2
313 | 
314 | vis :: Lft -> Bool
315 | vis (LftV v) = True
316 | vis e = False
317 | 
318 | mis :: Lft -> Bool
319 | mis (LftM m) = True
320 | mis e = False
321 | 
322 | tis :: Lft -> Bool
323 | tis (LftT t i) = True
324 | tis e = False
325 | 
326 | cons :: Lft -> (Integer -> Expression) -> Expression
327 | cons (LftV v) f = ExpV v
328 | cons (LftM m) f = ExpM m (f 1)
329 | cons (LftT t i) f = ExpT t i (f 1) (f 2)
330 | 
331 | hd :: Expression -> Lft
332 | hd (ExpV v) = LftV v
333 | hd (ExpM m e) = LftM m
334 | hd (ExpT t i e f) = LftT t i
335 | 
336 | tl :: Expression -> Integer -> Expression
337 | tl (ExpM m e) 1     = e
338 | tl (ExpT t i e f) 1 = e
339 | tl (ExpT t i e f) 2 = f
340 | 
341 | --------------------------------------------------------------------------------
342 | -- Normalization Functions
343 | --------------------------------------------------------------------------------
344 | sem :: Expression -> Sefp
345 | sem (ExpV v)
346 |     | refine (dot 1 ispos (LftV v)) = Spos (dem (app ispos (one (ExpV v))))
347 |     | refine (dot 1 isneg (LftV v)) = Sneg (dem (app isneg (one (ExpV v))))
348 | sem e
349 |     | refine (dot 1 iszer l) = Szer (dem (app iszer (one e)))
350 |     | refine (dot 1 isinf l) = Sinf (dem (app isinf (one e)))
351 |     | refine (dot 1 ispos l) = Spos (dem (app ispos (one e)))
352 |     | refine (dot 1 isneg l) = Sneg (dem (app isneg (one e)))
353 |     | otherwise              = sem (app l f)
354 |     where
355 |     l = hd e
356 |     f d = ab l (tl e d) (decision d l)
357 | 
358 | dem :: Expression -> Uefp
359 | dem (ExpV v) = Term v
360 | dem e
361 |     | refine (dot 1 idneg l) = Dneg (dem (app idneg (one e)))
362 |     | refine (dot 1 idpos l) = Dpos (dem (app idpos (one e)))
363 |     | refine (dot 1 idzer l) = Dzer (dem (app idzer (one e)))
364 |     | otherwise              = dem (app l f)
365 |     where
366 |     l = hd e
367 |     f d = ab l (tl e d) (decision d l)
368 | 
369 | ab :: Lft -> Expression -> Bool -> Expression
370 | ab k e b
371 |     | not b               = ExpM identity e
372 |     | tis k && tis (hd e) = utoe (dem e)
373 |     | otherwise           = e
374 | 
375 | 
376 | --------------------------------------------------------------------------------
377 | -- Decimal Output Function
378 | --------------------------------------------------------------------------------
379 | eshow :: Expression -> Integer -> [Char]
380 | eshow e i = mshow (stom (sem e) i)
381 | 
382 | mshow :: Matrix -> [Char]
383 | mshow m
384 |     | d==0 && q==1 = show p
385 |     | d==0 && q/=1 = show p ++ "/" ++ show q
386 |     | d/=0         = sshow (scientific m 0)
387 |     where
388 |     d = determinant m
389 |     (p,q)
390 |         | b < 0     = (-a,-b)
391 |         | otherwise = (a,b)
392 |     (a,b) = vscale (fst m)
393 | 
394 | sshow :: [Integer] -> [Char]
395 | sshow []      = "unbounded"
396 | sshow (e : m) = (showsign v) ++ (showm v) ++ (showe h)
397 |     where
398 |     f = (foldr g 0) . reverse
399 |     g d c = d+10*c
400 |     (h,l,v) = normalize (e,fromIntegral (length m), f m)
401 | 
402 | normalize :: (Integer, Integer, Integer) -> (Integer, Integer, Integer)
403 | normalize (e,l,v)
404 |     | l>0 && (abs v)<10^(l-1) = normalize (e-1,l-1,v)
405 |     | otherwise               = (e,l,v)
406 | 
407 | showsign :: Integer -> [Char]
408 | showsign v
409 |   | v < 0     = "-"
410 |   | otherwise = ""
411 | 
412 | showm :: Integer -> [Char]
413 | showm v
414 |     | v == 0 = "0"
415 |     | v /= 0 = "0." ++ show (abs v)
416 | 
417 | showe :: Integer -> [Char]
418 | showe e = "e" ++ show e
419 | 
420 | scientific :: Matrix -> Integer -> [Integer]
421 | scientific m n
422 |     | vrefine (mdotv (inverse m) (1,0)) = []
423 |     | mrefine (mdotm (inverse szer) m)  = n : (mantissa (-9) 9 m)
424 |     | otherwise                         = scientific (mdotm ((1,0),(0,10)) m) (n+1)
425 | 
426 | mantissa :: Integer -> Integer -> Matrix -> [Integer]
427 | mantissa i n m
428 |     | c i       = i : mantissa (-9) 9 (e i)
429 |     | i < n     = mantissa (i+1) n m
430 |     | otherwise = []
431 |     where
432 |     c n = mrefine (mdotm (inverse (d n)) m)
433 |     d n = ((n+1,10),(n-1,10))
434 |     e n = mdotm ((10,0),(-n,1)) m
435 | 
436 | 
437 | --------------------------------------------------------------------------------
438 | -- Elementary functions
439 | --------------------------------------------------------------------------------
440 | eiterate :: (Integer -> Matrix) -> Integer -> Expression
441 | eiterate i n = ExpM (i n) (eiterate i (n+1))
442 | 
443 | eiteratex :: (Integer -> Tensor) -> Integer -> Expression -> Expression
444 | eiteratex i n x = ExpT (i n) 0 x (eiteratex i (n+1) x)
445 | 
446 | esqrtrat :: Integer -> Integer -> Expression
447 | esqrtrat p q = rollover p q (p-q)
448 | 
449 | rollover :: Integer -> Integer -> Integer -> Expression
450 | rollover a b c
451 |     | d>=0      = ExpM dneg (rollover (4*a) d c)
452 |     | otherwise = ExpM dpos (rollover (-d) (4*b) c)
453 |     where
454 |     d = 2*(b-a) + c
455 | 
456 | itersqrtspos :: Integer -> Tensor
457 | itersqrtspos n = (((1,0),(2,1)),((1,2),(0,1)))
458 | 
459 | iterlogspos :: Integer -> Tensor
460 | iterlogspos 0 = (((1,0),(1,1)),((-1,1),(-1,0)))
461 | iterlogspos n = (((n,0),(2*n+1,n+1)),((n+1,2*n+1),(0,n)))
462 | 
463 | ee :: Expression
464 | ee = eiterate itere 0
465 | 
466 | itere :: Integer -> Matrix
467 | itere n = ((2*n+2,2*n+1),(2*n+1,2*n))
468 | 
469 | eexpszer :: Expression -> Expression
470 | eexpszer = eiteratex iterexpszer 0
471 | 
472 | iterexpszer :: Integer -> Tensor
473 | iterexpszer n = (((2*n+2,2*n+1),(2*n+1,2*n)),
474 |                  ((2*n,2*n+1),(2*n+1,2*n+2)))
475 | 
476 | 
477 | eomega :: Expression
478 | eomega = eiterate iteromega 0
479 | iteromega :: Integer -> Matrix
480 | 
481 | iteromega 0 = ((6795705,213440),(6795704,213440))
482 | iteromega n = ((e-d-c,e+d+c),(e+d-c,e-d+c))
483 |     where
484 |     b = (2*n-1)*(6*n-5)*(6*n-1)
485 |     c = b*(545140134*n + 13591409)
486 |     d = b*(n+1)
487 |     e = 10939058860032000*n^4
488 | 
489 | etanszer :: Expression -> Expression
490 | etanszer = eiteratex itertanszer 0
491 | 
492 | itertanszer :: Integer -> Tensor
493 | itertanszer 0 = (((1,2),(1,0)),((-1,0),(-1,2)))
494 | itertanszer n = (((2*n+1,2*n+3),(2*n-1,2*n+1)),
495 |                  ((2*n+1,2*n-1),(2*n+3,2*n+1)))
496 | 
497 | earctanszer :: Expression -> Expression
498 | earctanszer = eiteratex iterarctanszer 0
499 | 
500 | iterarctanszer :: Integer -> Tensor
501 | iterarctanszer 0 = (((1,2),(1,0)),((-1,0),(-1,2)))
502 | iterarctanszer n = (((2*n+1,n+1),(n,0)),((0,n),(n+1,2*n+1)))
503 | 
504 | -----------------------------------------------------------------------
505 | -- half, dbl, quad - multiplication with 1/2, 2, 4
506 | -- sinT, cosT, tanT - tensor used for construction of
507 | --  sin, cos, tan function
508 | -----------------------------------------------------------------------
509 | half, dbl, quad :: Matrix
510 | half = ((1,0),(0,2))
511 | dbl  = ((2,0),(0,1))
512 | quad = ((4,0),(0,1))
513 | 
514 | reconePx2 :: Tensor
515 | reconePx2 = (((0,1),(0,0)),((0,0),(1,1)))
516 | 
517 | --------------------------------------------------------------------------
518 | -- stoe - converts signed efp to expression
519 | -- s - signed efp, u - unsigned efp
520 | -- us - uncompressed signed efp, uu - uncompressed unsigned efp
521 | --------------------------------------------------------------------------
522 | stoe :: Sefp -> Expression
523 | stoe (Spos u) = ExpM spos (utoe u)
524 | stoe (Sneg u) = ExpM sneg (utoe u)
525 | stoe (Szer u) = ExpM szer (utoe u)
526 | stoe (Sinf u) = ExpM sinf (utoe u)
527 | 
528 | stous :: Sefp -> Usefp
529 | stous (Spos u) = ("spos", utouu u)
530 | stous (Sinf u) = ("sinf", utouu u)
531 | stous (Sneg u) = ("sneg", utouu u)
532 | stous (Szer u) = ("szer", utouu u)
533 | 
534 | utouu :: Uefp -> Uuefp
535 | utouu (Dneg u) = (-1) : utouu u
536 | utouu (Dzer u) =   0  : utouu u
537 | utouu (Dpos u) =   1  : utouu u
538 | utouu (Term (v1,v2)) =  [2,v1,v2]
539 | 
540 | ustos :: Usefp -> Sefp
541 | ustos ("spos", u) = Spos (uutou u)
542 | ustos ("sneg", u) = Sneg (uutou u)
543 | ustos ("szer", u) = Szer (uutou u)
544 | ustos ("sinf", u) = Sinf (uutou u)
545 | 
546 | uutou :: Uuefp -> Uefp
547 | uutou []      = Term (1,1)
548 | uutou (-1:xs) = Dneg (uutou xs)
549 | uutou ( 0:xs) = Dzer (uutou xs)
550 | uutou ( 1:xs) = Dpos (uutou xs)
551 | 
552 | --------------------------------------------------------------------------
553 | --------------------------------------------------------------------------
554 | 
555 | instance Floating Expression where
556 |   pi = ExpT tdiv 0 (esqrtrat 10005 1) eomega
557 |   exp e = head (mrgExps tmul xL) where
558 |     xL = map (eexpszer . (app iszer) . one) yL
559 |     yL = replicate (fromInteger 2^k) y
560 |     y  = app (LftM ((1,0),(0,2^k))) (one e)
561 |     k  = findk e
562 |   -- quadratic fractional transformation
563 |   sin e = app (LftT sinT 0) f where
564 |     sinT = (((0,1),(1,0)),((1,0),(0,1)))
565 |     f _ = stoe $ sem $ tan (app (LftM half) (one e) ) 
566 |   -- quadratic fractional transformation
567 |   cos e = app (LftT cosT 0) f where
568 |     cosT = (((-1,1),(0,0)),((0,0),(1,1)))
569 |     f _ = stoe $ sem $ tan (app (LftM half) (one e) )
570 |   -- quadratic fractional transformation
571 |   sinh e = app (LftT sinhT 0) f where
572 |     sinhT = (((1,0),(0,1)),((0,1),(-1,0)))
573 |     f _ = stoe $ sem $ exp e
574 |   -- quadratic fractional transformation
575 |   cosh e = app (LftT coshT 0) f where
576 |     coshT = (((1,0),(0,1)),((0,1),(1,0)))
577 |     f _ = stoe $ sem $ exp e
578 |   -- quadratic fractional transformation
579 |   tanh e = app (LftT tanhT 0) f where
580 |     tanhT = (((1,1),(0,0)),((0,0),(-1,1)))
581 |     f _ = stoe $ sem $ exp e
582 |   sqrt = eiteratex itersqrtspos 0
583 |   log = eiteratex iterlogspos 0
584 |   tan e = head (mrgExps tanT xL) where
585 |     tanT = (((0,-1),(1,0)),((1,0),(0,1)))
586 |     xL = map (etanszer . (app iszer) . one) yL
587 |     yL = replicate (fromInteger 2^k) y
588 |     y  = app (LftM ((1,0),(0,2^k))) (one e)
589 |     k  = findk e
590 | 
591 |   atan e = earctanszer (app iszer (one e))
592 | {-
593 |   atan e
594 |     | m > 0         = app (LftT (((0,0),(4,0)),((1,0),(0,4))) 0) f
595 |     | otherwise     = app (LftT (((0,0),(4,0)),((3,0),(0,4))) 0) g
596 |     where
597 |     f 1 = (stoe . sem) (earctanszer e)
598 |     f 2 = (stoe . sem) epi
599 |     g 1 = (stoe . sem) (earctanszer (app isneg (one e)))
600 |     g 2 = (stoe . sem) epi
601 |     m   = fst (splitres (eshow e 5))
602 | -}
603 | 
604 | --------------------------------------------------------------------------
605 | --------------------------------------------------------------------------
606 | findk :: Expression -> Integer
607 | findk a
608 |     | f a < 1       = 0
609 |     | otherwise     = ceiling (logBase 2.0 (f a))
610 |     where
611 |     f x   = fromInteger (abs m) * 10^^(fromInteger e)
612 |     (m,e) = splitres (eshow a 10)
613 | 
614 | mrgExps :: Tensor -> [Expression] -> [Expression]
615 | mrgExps t []            = []
616 | mrgExps t [x]           = [x]
617 | mrgExps t (x:y:xs)      = mrgExps t ( (app (LftT t 0) f) : (mrgExps t xs) )
618 |     where
619 |     f 1 = (stoe . sem) x
620 |     f 2 = (stoe . sem) y
621 | 
622 | splitres :: [Char] -> (Integer, Integer)
623 | splitres ('0':'e':xs)       = (0,0)
624 | splitres "unbounded"        = error "Error, the value is unbounded"
625 | splitres res
626 |     | elem '/' res          = splitres (mshow ((a,b),(a*10^9,b*10^9+1)))
627 |     | not (elem '.' res)    = f (read res, 0)
628 |     | otherwise             = (finde . findm . finds) res
629 |     where
630 |     a  = read ( takeWhile (/= '/') res )
631 |     b  = read ( tail (dropWhile (/= '/') res) )
632 |     f (x,y)
633 |         | mod x 10 == 0 && x>0 = f (div x 10, y+1)
634 |         | otherwise            = (x,y)
635 | 
636 | finds :: [Char] -> (Integer, [Char])
637 | finds ('-':'0':'.':xs)      = (-1,xs)
638 | finds ('0':'.':xs)          = (1,xs)
639 | finds _                     = error "Error No 21"
640 | 
641 | findm :: (Integer, [Char]) -> (Integer, [Char])
642 | findm (s,me)                = (s * m,e)
643 |     where
644 |     m = read (takeWhile isDigit me)
645 |     e = dropWhile isDigit me
646 | 
647 | finde :: (Integer, [Char]) -> (Integer, Integer)
648 | finde (sm,'e':xs)           = (sm, read xs - fromIntegral len)
649 |     where
650 |     len
651 |         | sm<0              = length (show sm) - 1
652 |         | otherwise         = length (show sm)
653 | finde (sm,_)                = error "Error No 22"
654 | 
655 | 


--------------------------------------------------------------------------------
/Fractions.hs:
--------------------------------------------------------------------------------
   1 | {-# LANGUAGE BangPatterns #-}
   2 | {-# LANGUAGE DeriveFunctor #-}
   3 | {-# LANGUAGE DeriveFoldable #-}
   4 | {-# LANGUAGE DeriveTraversable #-}
   5 | {-# LANGUAGE DefaultSignatures #-}
   6 | {-# LANGUAGE ViewPatterns #-}
   7 | {-# LANGUAGE MagicHash #-}
   8 | 
   9 | module Fractions where
  10 | 
  11 | import Control.Applicative
  12 | import Control.Monad.Zip
  13 | import Data.Bits
  14 | import Data.Foldable
  15 | import Data.Ratio
  16 | import Data.Semigroup
  17 | import Data.Traversable
  18 | import Data.Word
  19 | import GHC.Real (Ratio((:%)))
  20 | import GHC.Types (Int(..))
  21 | import GHC.Integer.Logarithms
  22 | import Linear (Additive(..))
  23 | import Prelude hiding (foldr, foldl1, all, any)
  24 | 
  25 | type Z = Integer
  26 | 
  27 | -- | An integral domain has no zero divisors.
  28 | --
  29 | -- We care primarily about "nice integral domains" where we can compare for equality
  30 | class (Eq a, Num a) => IntegralDomain a where
  31 | 
  32 | instance IntegralDomain Integer
  33 | instance (IntegralDomain a, Integral a) => IntegralDomain (Ratio a)
  34 | instance IntegralDomain Float
  35 | instance IntegralDomain Double
  36 | 
  37 | --------------------------------------------------------------------------------
  38 | -- * Polynomials
  39 | --------------------------------------------------------------------------------
  40 | 
  41 | data P a = P [a]
  42 |   deriving (Show, Eq, Foldable, Functor)
  43 | 
  44 | zeroes :: Num a => Int -> [a] -> [a]
  45 | zeroes 0 xs = xs
  46 | zeroes n xs = 0 : zeroes (n-1) xs
  47 | 
  48 | xTimes :: Num a => P a -> P a
  49 | xTimes (P []) = P []
  50 | xTimes (P as) = P (0:as)
  51 | 
  52 | (*^) :: IntegralDomain a => a -> P a -> P a
  53 | 0 *^ _ = 0
  54 | a *^ P bs = P $ map (a*) bs
  55 | 
  56 | lift :: IntegralDomain a => a -> P a
  57 | lift 0 = P []
  58 | lift a = P [a]
  59 | 
  60 | -- evaluate a polynomial at 0
  61 | at0 :: Num a => P a -> a
  62 | at0 (P (a:_)) = a
  63 | at0 (P [])    = 0
  64 | 
  65 | -- evaluate using Horner's rule
  66 | at :: Num a => a -> P a -> a
  67 | at x (P as) = foldr (\a r -> a + x*r) 0 as
  68 | 
  69 | instance IntegralDomain a => Semigroup (P a) where
  70 |   P as <> x = foldr (\a r -> lift a + x*r) 0 as
  71 | 
  72 | instance IntegralDomain a => Monoid (P a) where
  73 |   mempty = P [0,1]
  74 |   mappend = (<>)
  75 | 
  76 | instance IntegralDomain a => Num (P a) where
  77 |   P as0 + P bs0 = P $ go 0 as0 bs0 where
  78 |     go n (a:as) (b:bs) = case a + b of
  79 |       0 -> go (n + 1) as bs
  80 |       c -> zeroes n (c : go 0 as bs)
  81 |     go _ [] [] = []
  82 |     go n [] bs = zeroes n bs
  83 |     go n as [] = zeroes n as
  84 |   P as0 - P bs0 = P $ go 0 as0 bs0 where
  85 |     go n (a:as) (b:bs) = case a - b of
  86 |       0 -> go (n + 1) as bs
  87 |       c -> zeroes n (c : go 0 as bs)
  88 |     go _ [] [] = []
  89 |     go n [] bs = zeroes n (map negate bs)
  90 |     go n as [] = zeroes n as
  91 |   P as0 * bs = go as0 where
  92 |     go [] = P []
  93 |     go (0:as) = xTimes (go as)
  94 |     go (a:as) = a *^ bs + xTimes (go as)
  95 |   negate (P as) = P (map negate as)
  96 |   abs xs = signum xs * xs
  97 |   signum (P []) = P []
  98 |   signum (P as) = P [signum (last as)]
  99 |   fromInteger 0 = P []
 100 |   fromInteger n = P [fromInteger n]
 101 | 
 102 | instance IntegralDomain a => IntegralDomain (P a)
 103 | 
 104 | --------------------------------------------------------------------------------
 105 | -- * Extended Rationals
 106 | --------------------------------------------------------------------------------
 107 | 
 108 | -- | Extended, unreduced, field of fractions
 109 | --
 110 | -- @
 111 | -- V a = Frac a ∪ {∞,⊥}
 112 | -- @
 113 | --
 114 | -- @
 115 | -- ⊥ = V 0 0
 116 | -- ∞ = V a 0, a /= 0
 117 | -- @
 118 | data V a = V !a !a
 119 |   deriving (Show, Functor, Traversable)
 120 | 
 121 | instance Foldable V where
 122 |   foldMap k (V a b) = k a `mappend` k b
 123 |   foldl1 k (V a b) = k a b
 124 | 
 125 | mediant :: Num a => V a -> V a -> V a
 126 | mediant (V a b) (V c d) = V (a + c) (b + d)
 127 | 
 128 | indeterminate :: IntegralDomain a => V a -> Bool
 129 | indeterminate (V a b) = a == 0 && b == 0
 130 | 
 131 | infinite :: IntegralDomain a => V a -> Bool
 132 | infinite (V a b) = a /= 0 && b == 0
 133 | 
 134 | instance (IntegralDomain a, Eq a) => Eq (V a) where
 135 |   V a b == V c d = b /= 0 && d /= 0 && a*d == b*c
 136 |   V a b /= V c d = b /= 0 && d /= 0 && a*d /= b*c
 137 | 
 138 | instance (IntegralDomain a, Ord a) => Ord (V a) where
 139 |   compare (V a b) (V c d)
 140 |     | b * d == 0 = GT -- undefined
 141 |     | otherwise = compare (a * d) (b * c)
 142 |   V a b <= V c d = b * d /= 0 && a*d <= b*c
 143 |   V a b <  V c d = b * d /= 0 && a*d <  b*c
 144 |   V a b >  V c d = b * d /= 0 && a*d >  b*c
 145 |   V a b >= V c d = b * d /= 0 && a*d >= b*c
 146 |   min u@(V a b) v@(V c d)
 147 |     | b * d == 0 = V (hard a b c d) 0
 148 |     | a*d <= b*c = u
 149 |     | a*d <= b*c = v
 150 |     where -- min ∞ ∞ = ∞, min ∞ a = ⊥, min ∞ b = ⊥
 151 |       hard 0 0 _ _ = 0
 152 |       hard _ _ 0 0 = 0
 153 |       hard _ 0 _ _ = 0
 154 |       hard _ _ _ 0 = 0
 155 |       hard _ _ _ _ = 1 -- min ∞ ∞ = ∞
 156 |   max u@(V a b) v@(V c d)
 157 |     | b * d == 0 = V (hard a b c d) 0
 158 |     | a*d <= b*c = v
 159 |     | a*d <= b*c = u
 160 |     where -- max ∞ ∞ = ∞, max ∞ a = ⊥, max ∞ b = ⊥
 161 |       hard 0 0 _ _ = 0
 162 |       hard _ _ 0 0 = 0
 163 |       hard _ 0 _ _ = 0
 164 |       hard _ _ _ 0 = 0
 165 |       hard _ _ _ _ = 1 -- max ∞ ∞ = ∞
 166 | 
 167 | minmax :: (IntegralDomain a, Ord a) => V a -> V a -> (V a, V a)
 168 | minmax u@(V a b) v@(V c d)
 169 |   | b * d == 0, w <- V (hard a b c d) 0 = (w,w)
 170 |   | a*d <= b*c = (u,v)
 171 |   | a*d <= b*c = (v,u)
 172 |   where -- max ∞ ∞ = ∞, max ∞ a = ⊥, max ∞ b = ⊥
 173 |     hard 0 0 _ _ = 0
 174 |     hard _ _ 0 0 = 0
 175 |     hard _ 0 _ _ = 0
 176 |     hard _ _ _ 0 = 0
 177 |     hard _ _ _ _ = 1 -- max ∞ ∞ = ∞
 178 | 
 179 | instance IntegralDomain a => Num (V a) where
 180 |   V a b + V c d = V (if b*d == 0 then hard a b c d else a*d+b*c) (b*d) where
 181 |     hard _ _ 0 0 = 0 -- ⊥ + a = ⊥
 182 |     hard 0 0 _ _ = 0 -- a + ⊥ = ⊥
 183 |     hard _ 0 _ 0 = 0 -- ∞ + ∞ = ⊥
 184 |     hard _ _ _ _ = 1 -- ∞ - a = ∞
 185 |                      -- a - ∞ = ∞
 186 | 
 187 |   V a b - V c d = V (if b*d == 0 then hard a b c d else a*d-b*c) (b*d) where
 188 |     hard _ _ 0 0 = 0 -- ⊥ - a = ⊥
 189 |     hard 0 0 _ _ = 0 -- a - ⊥ = ⊥
 190 |     hard _ 0 _ 0 = 0 -- ∞ - ∞ = ⊥
 191 |     hard _ _ _ _ = 1 -- ∞ - a = ∞
 192 |                      -- a - ∞ = ∞
 193 | 
 194 |   V a b * V c d = V (if b*d == 0 then hard a b c d else a*c) (b*d) where
 195 |     hard _ _ 0 0 = 0 -- a * ⊥ = ⊥
 196 |     hard 0 0 _ _ = 0 -- ⊥ * a = ⊥
 197 |     hard _ 0 0 _ = 0 -- ∞ * 0 = ⊥
 198 |     hard 0 _ _ 0 = 0 -- 0 * ∞ = ⊥
 199 |     hard _ _ _ _ = 1 -- ∞ * ∞ = ∞
 200 | 
 201 |   abs xs = signum xs * xs
 202 |   signum = fmap signum
 203 |   fromInteger n = V (fromInteger n) 1
 204 | 
 205 | -- |
 206 | -- @
 207 | -- recip ⊥ = ⊥
 208 | -- recip ∞ = 0
 209 | -- recip 0 = ∞
 210 | -- recip (V a b) = V b a
 211 | -- @
 212 | instance IntegralDomain a => Fractional (V a) where
 213 |   recip (V a b) = V b a
 214 |   p / q = p * recip q
 215 |   fromRational r = V (fromInteger (numerator r)) (fromInteger (denominator r))
 216 | 
 217 | instance (Integral a, IntegralDomain a) => Real (V a) where
 218 |   toRational (V k n) = toInteger k % toInteger n -- blows up on indeterminate and ∞ forms
 219 | 
 220 | instance (Integral a, IntegralDomain a) => RealFrac (V a) where
 221 |   properFraction (V a b) = case divMod a b of
 222 |     (q, r) -> (fromIntegral q, V r b)
 223 | 
 224 | instance IntegralDomain a => IntegralDomain (V a)
 225 | 
 226 | --------------------------------------------------------------------------------
 227 | -- * Rescaling Results
 228 | --------------------------------------------------------------------------------
 229 | 
 230 | integerLog2 :: Integer -> Int
 231 | integerLog2 i = I# (integerLog2# i)
 232 | 
 233 | -- | divide out all residual powers of 2
 234 | --
 235 | -- Used for rescaling @V Z@, @M Z@, @T Z@, and @Q Z@ intermediate results.
 236 | scale :: (Foldable f, Functor f) => f Z -> f Z
 237 | scale xs
 238 |   | n <= 1 = xs -- lsb is a 1, or we're 0, keep original
 239 |   | s <- integerLog2 n = fmap (`unsafeShiftR` s) xs
 240 |   where
 241 |     m = foldl1 (.|.) xs -- of all the bits
 242 |     n = m .&. negate m  -- keep least significant set bit
 243 | 
 244 | -- | divide out all residual powers of 2
 245 | --
 246 | -- Used for rescaling @V (P Z)@, @M (P Z)@, @T (P Z)@, @Q (P Z)@ intermediate results.
 247 | scaleP :: (Foldable f, Functor f, Foldable p, Functor p) => f (p Z) -> f (p Z)
 248 | scaleP xs
 249 |   | n <= 1 = xs -- lsb is a 1, or we're 0, keep original
 250 |   | s <- integerLog2 n = fmap (`unsafeShiftR` s) <$> xs
 251 |   where
 252 |     m = (foldl'.foldl') (.|.) 0 xs -- of all the bits
 253 |     n = m .&. negate m  -- keep least significant set bit
 254 | 
 255 | --------------------------------------------------------------------------------
 256 | -- * Decimal reductions
 257 | --------------------------------------------------------------------------------
 258 | 
 259 | -- |
 260 | --
 261 | -- Z w/ Z mod 10 maintained in parallel
 262 | --
 263 | -- optimized for reduction in scale by factors of 10, which arise in decimal expansion.
 264 | data Dec = Dec !Integer {-# UNPACK #-} !Word8
 265 |   deriving Show
 266 | 
 267 | -- TODO: figure out a fancy bit hack
 268 | rem10 :: Word8 -> Word8
 269 | rem10 x = rem x 10
 270 | 
 271 | instance Eq Dec where
 272 |   Dec a _ == Dec c _ = a == c
 273 | 
 274 | instance Ord Dec where
 275 |   Dec a _ `compare` Dec c _ = compare a c
 276 | 
 277 | instance Num Dec where
 278 |   Dec a b + Dec c d = Dec (a + c) (rem10 $ b + d)
 279 |   Dec a b - Dec c d = Dec (a - c) (rem10 $ b - d)
 280 |   Dec a b * Dec c d = Dec (a * c) (rem10 $ b * d)
 281 |   abs x@(Dec a b)
 282 |     | a < 0 = Dec (negate a) (10 - b)
 283 |     | otherwise = x
 284 |   signum (Dec a _) = fromInteger (signum a)
 285 |   fromInteger i = Dec i (fromInteger $ rem i 10)
 286 | 
 287 | instance Real Dec where
 288 |   toRational (Dec a _) = toRational a
 289 | 
 290 | instance Enum Dec where
 291 |   fromEnum (Dec a _) = fromInteger a
 292 |   toEnum = fromIntegral
 293 |   succ (Dec a b) = Dec (succ a) (rem10 $ b + 1)
 294 |   pred (Dec a b) = Dec (pred a) (rem10 $ b - 1)
 295 | 
 296 | -- div10 ms = unsafeShiftR (ms * 205) 11 -- computes div10 legally for [0,2047] in a 22 bit+ register
 297 | 
 298 | instance Integral Dec where
 299 |   toInteger (Dec a _) = a
 300 |   quot (Dec a _) (Dec c _) = fromInteger (quot a c)
 301 |   rem (Dec a _) (Dec c _) = fromInteger (rem a c)
 302 |   quotRem (Dec a _) (Dec c _) = case quotRem a c of
 303 |     (e, f) -> (fromInteger e, fromInteger f)
 304 |   div (Dec a _) (Dec c _) = fromInteger (div a c)
 305 |   mod (Dec a _) (Dec c _) = fromInteger (mod a c)
 306 |   divMod (Dec a _) (Dec c _) = case divMod a c of
 307 |     (e, f) -> (fromInteger e, fromInteger f)
 308 | 
 309 | instance IntegralDomain Dec
 310 | 
 311 | -- remove common factors of 10
 312 | scale10 :: (Foldable f, Functor f) => f Dec -> f Dec
 313 | scale10 xs
 314 |   | any (\(Dec _ b) -> b /= 0) xs = xs
 315 |   | all (\(Dec a _) -> a == 0) xs = xs
 316 |   | otherwise = scale10 $ fmap (`div` 10) xs
 317 | 
 318 | --------------------------------------------------------------------------------
 319 | -- * Intervals
 320 | --------------------------------------------------------------------------------
 321 | 
 322 | data I
 323 |   = U               -- the entire universe R∞
 324 |   | I {-# UNPACK #-} !(V Z) {-# UNPACK #-} !(V Z) -- a closed interval
 325 | 
 326 | class Columns f where
 327 |   columns :: Semigroup m => (V a -> m) -> f a -> m
 328 | 
 329 | instance Columns V where
 330 |   columns f v = f v
 331 | 
 332 | sigma :: V Z -> Z
 333 | sigma (V a b) = case compare a 0 of
 334 |   LT | b <= 0 -> -1
 335 |   GT | b >= 0 -> 1
 336 |   _           -> signum b
 337 | 
 338 | -- | Is V ∈ V⁺ ?
 339 | --
 340 | -- @
 341 | -- posV v = sigma v /= 0
 342 | -- @
 343 | posV :: V Z -> Bool
 344 | posV (V a b) = case compare a 0 of
 345 |   LT -> b <= 0
 346 |   EQ -> b /= 0
 347 |   GT -> b >= 0
 348 | 
 349 | --------------------------------------------------------------------------------
 350 | -- * r((1+√5)/2) = r(√5)
 351 | --
 352 | -- Fib a b * Fib c d ≡ (ax+b)*(cx+d) (mod x^2-x-1)
 353 | --------------------------------------------------------------------------------
 354 | 
 355 | -- |
 356 | -- @Fib a b :: Fib r@ denotes @aΦ + b@ ∈ r(Φ)
 357 | data Fib a = Fib !a !a
 358 |   deriving (Show, Functor, Foldable, Traversable, Eq)
 359 | 
 360 | instance (IntegralDomain a, Ord a) => Ord (Fib a) where
 361 |   compare (Fib a b) (Fib c d) = case compare a c of
 362 |     LT | b <= d    -> LT
 363 |        | otherwise -> go compare (a-c) (b-d)
 364 |     EQ -> compare b d
 365 |     GT | b >= d    -> GT
 366 |        | otherwise -> go (flip compare) (a-c) (b-d)
 367 |    where
 368 |      -- convert to a(√5) and compare squares
 369 |      go k e f = k (sq (e+2*f)) (5*sq e)
 370 |      sq x = x*x
 371 | 
 372 | instance Num a => Num (Fib a) where
 373 |   Fib a b + Fib c d = Fib (a + c) (b + d)
 374 |   -- Φ^2 = Φ+1, so (aΦ+b)(cΦ+d) = ac(Φ+1) + (ad+bc)Φ + bd == (ac+ad+bc)Φ + (ac+bd)
 375 |   Fib a b * Fib c d = Fib (a*(c + d) + b*c) (a*c + b*d)
 376 |   Fib a b - Fib c d = Fib (a - c) (b - d)
 377 |   negate (Fib a b) = Fib (negate a) (negate b)
 378 |   abs x = x
 379 |   signum _ = Fib 0 1 -- with our current constraints this is all we can say, not willing to give up instances to do better.
 380 |   fromInteger n = Fib 0 (fromInteger n)
 381 | 
 382 | instance Fractional a => Fractional (Fib a) where
 383 |   recip (Fib a b) = Fib (-a/d) ((a+b)/d) where
 384 |     d = b*b + a*b - a*a
 385 |   fromRational r = Fib 0 (fromRational r)
 386 | 
 387 | instance Applicative Fib where
 388 |   pure a = Fib a a
 389 |   Fib a b <*> Fib c d = Fib (a c) (b d)
 390 | 
 391 | instance Monad Fib where
 392 |   return a = Fib a a
 393 |   Fib a b >>= f = Fib a' b' where
 394 |     Fib a' _ = f a
 395 |     Fib _ b' = f b
 396 | 
 397 | instance MonadZip Fib where
 398 |   mzipWith f (Fib a b) (Fib c d) = Fib (f a c) (f b d)
 399 |   munzip (Fib (a,b) (c,d)) = (Fib a c, Fib b d)
 400 | 
 401 | instance Additive Fib where
 402 |   zero = Fib 0 0
 403 |   (^+^) = (+)
 404 |   (^-^) = (-)
 405 | 
 406 | instance IntegralDomain a => IntegralDomain (Fib a)
 407 | 
 408 | class IntegralDomain a => Golden a where
 409 |   -- | (1 + sqrt 5)/2
 410 |   phi :: a
 411 |   default phi :: Floating a => a
 412 |   phi = (1 + sqrt 5)*0.5
 413 | 
 414 |   -- |
 415 |   -- @
 416 |   -- sqrt 5 = phi + iphi
 417 |   -- @
 418 |   sqrt5 :: a
 419 |   sqrt5 = 2*phi - 1
 420 | 
 421 |   -- |
 422 |   -- @
 423 |   -- phi * iphi = 1
 424 |   -- @
 425 |   iphi :: a
 426 |   iphi = phi - 1
 427 | 
 428 | instance IntegralDomain a => Golden (Fib a) where
 429 |   phi = Fib 1 0
 430 | 
 431 | instance Golden Float
 432 | instance Golden Double
 433 | instance Golden E
 434 | instance Golden a => Golden (V a) where
 435 |   phi = V phi 1
 436 | 
 437 | unfib :: Golden a => Fib a -> a
 438 | unfib (Fib a b) = a*phi + b
 439 | 
 440 | -- fast fibonacci transform
 441 | fib :: IntegralDomain a => Integer -> a
 442 | fib n
 443 |   | n >= 0 = getPhi (phi ^ n)
 444 |   | otherwise = getPhi (iphi ^ negate n)
 445 | 
 446 | getPhi :: Fib a -> a
 447 | getPhi (Fib a _) = a
 448 | 
 449 | -- |
 450 | -- redundant digits in base Φ
 451 | -- @
 452 | -- dphin = scaleP $ digit phi (negate iphi)
 453 | -- dphip = scaleP $ digit phi iphi
 454 | -- @
 455 | dphin, dphip :: M (Fib Z)
 456 | dphin = M (Fib 1 0) (Fib 0 0) (Fib 0 1) (Fib 1 1)
 457 | dphip = M (Fib 1 1) (Fib 0 1) (Fib 0 0) (Fib 1 0)
 458 | 
 459 | --------------------------------------------------------------------------------
 460 | -- * Affine transformations
 461 | --------------------------------------------------------------------------------
 462 | 
 463 | -- | @'Af' a b@ represents a function @f@ such that
 464 | --
 465 | -- @
 466 | -- f(x) = ax + b
 467 | -- @
 468 | --
 469 | -- @
 470 | -- M a ~ Af (V a)
 471 | -- T a ~ Af (Af (V a))
 472 | -- @
 473 | --
 474 | data Af a = Af a a
 475 |   deriving (Eq, Show, Functor, Foldable, Traversable)
 476 | 
 477 | -- | composition
 478 | --
 479 | -- @
 480 | -- f(g(x)) = a(cx+d)+b = (ac)x + (ad+b)
 481 | -- @
 482 | instance Num a => Semigroup (Af a) where
 483 |   Af a b <> Af c d = Af (a*c) (a*d+b)
 484 | 
 485 | instance Num a => Monoid (Af a) where
 486 |   mempty = Af 1 0
 487 |   mappend = (<>)
 488 | 
 489 | -- | convert an affine transform into a polynomial
 490 | ap :: IntegralDomain a => Af a -> P a
 491 | ap (Af 0 0) = P []
 492 | ap (Af 0 b) = P [b]
 493 | ap (Af a b) = P [b,a]
 494 | 
 495 | -- | evaluate an affine transformation
 496 | affine :: Num a => Af a -> a -> a
 497 | affine (Af a b) x = a*x + b
 498 | 
 499 | --------------------------------------------------------------------------------
 500 | -- * composite digit matrices
 501 | --------------------------------------------------------------------------------
 502 | 
 503 | -- | b = base, d = digit
 504 | digit :: Num a => a -> a -> M a
 505 | digit b d | a <- b-1, c <- b+1 = M (c+d) (a+d) (a-d) (c-d)
 506 | 
 507 | -- | b = base, n = number of bits, c = counter
 508 | digits :: Num a => a -> Int -> a -> M a
 509 | digits b n c = digit (b^n) c
 510 | 
 511 | --------------------------------------------------------------------------------
 512 | -- * Mobius Transformations
 513 | --------------------------------------------------------------------------------
 514 | 
 515 | -- | Linear fractional transformation
 516 | data M a = M
 517 |   a a
 518 |   ---
 519 |   a a
 520 |   deriving (Functor, Show, Traversable)
 521 | 
 522 | instance Num a => Semigroup (M a) where
 523 |   M a b c d <> M e f g h = M (a*e+b*g) (a*f+b*h) (c*e+d*g) (c*f+d*h)
 524 | 
 525 | instance Num a => Monoid (M a) where
 526 |   mempty = M 1 0 0 1
 527 |   mappend = (<>)
 528 | 
 529 | instance Foldable M where
 530 |   foldMap f (M a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
 531 |   foldl1 f (M a b c d) = f (f (f a b) c) d
 532 | 
 533 | instance Columns M where
 534 |   columns f (M a b c d) = f (V a c) <> f (V b d)
 535 | 
 536 | -- | determinant of the matrix
 537 | --
 538 | -- @
 539 | -- det m * det n = det (m <> n)
 540 | -- @
 541 | det :: Num a => M a -> a
 542 | det (M a b c d) = a*d - b*c
 543 | 
 544 | -- | The "tame inverse" of a linear fractional transformation
 545 | --
 546 | --
 547 | -- @
 548 | -- inv m <> m = Hom (det m) 0 0 (det m) = mempty, given det m /= 0
 549 | -- @
 550 | inv :: Num a => M a -> M a
 551 | inv (M a b c d) = M (negate d) b c (negate a)
 552 | 
 553 | -- | construct a homographic transform from an affine transform
 554 | am :: Num a => Af a -> M a
 555 | am (Af a b) = M a b 0 1
 556 | 
 557 | -- | Apply a Mobius transformation to an extended rational.
 558 | mv :: Num a => M a -> V a -> V a
 559 | mv (M a b c d) (V e f) = V (a*e+b*f) (c*e+d*f)
 560 | 
 561 | -- | Transpose a matrix
 562 | transposeM :: M a -> M a
 563 | transposeM (M a b c d) = M a c b d
 564 | 
 565 | -- | is m ∈ M⁺ ?
 566 | posM :: M Z -> Bool
 567 | posM (M a b c d) = sigma (V a c) * sigma (V b d) == 1
 568 | 
 569 | class Informed f where
 570 |   -- # of digit matrices we can emit
 571 |   most :: f Z -> Int
 572 |   least :: f Z -> Int
 573 | 
 574 | instance Informed V where
 575 |   most _ = maxBound
 576 |   least _ = maxBound
 577 | 
 578 | instance Informed M where
 579 |   most (fmap fromInteger -> m@(M a b c d)) = floor $ logBase 2 $ abs $
 580 |     (a+b) * (c+d) / det m
 581 |   least m = most m - 1
 582 | 
 583 | trace :: Num a => M a -> a
 584 | trace (M a _ _ d) = a + d
 585 | 
 586 | -- | characteristic polynomial of a linear fractional transformation
 587 | --
 588 | -- @
 589 | -- χ(λ,M) = char M ∈ a[λ]
 590 | -- @
 591 | char :: Num a => M a -> P a
 592 | char m = P [det m,trace m,1]
 593 | 
 594 | -- | Compute the invariance in the (needlessly extended) field of fractions of the coefficients.
 595 | -- of a non-singular matrix m.
 596 | --
 597 | -- @
 598 | -- invariance m = (trace m)^2 / det m
 599 | -- @
 600 | invariance :: IntegralDomain a => M a -> V a
 601 | invariance m
 602 |   | tr <- trace m
 603 |   , dt <- det m
 604 |   = V (tr*tr) dt
 605 | 
 606 | conjugate :: IntegralDomain a => M a -> M a -> Bool
 607 | conjugate m n
 608 |   | i <- invariance m
 609 |   = i /= 4 && i == invariance n
 610 | 
 611 | -- | m ∈ M⁺ ∩ M* ?
 612 | unsignedM :: M Z -> Bool
 613 | unsignedM (M 0 _ 0 _) = False
 614 | unsignedM (M _ 0 _ 0) = False
 615 | unsignedM (M a b c d) = a >= 0 && b >= 0 && c >= 0 && d >= 0
 616 | 
 617 | -- | Compute order of a linear homographic transformation
 618 | --
 619 | -- @order m == Just n@ means @n@ is the smallest positive integer such that @mtimes n m == mempty@
 620 | order :: IntegralDomain a => M a -> Maybe Int -- these are at most 6, return it as an Int
 621 | order m = case invariance m of
 622 |   0 -> Just 2
 623 |   1 -> Just 3
 624 |   2 -> Just 4
 625 |   3 -> Just 6
 626 |   4 -> Just 1
 627 |   _ -> Nothing
 628 | 
 629 | -- | rotation by @'pi'/2@
 630 | --
 631 | -- @{'mempty', 'sinf', 'sneg', 'szer'}@ is a finite cyclic group of order 4 generated by 'sinf' or 'szer'
 632 | --
 633 | -- >>> order sinf == Just 4
 634 | -- True
 635 | --
 636 | -- @
 637 | -- mempty([0,∞]) = [0,∞]
 638 | -- sinf([0,∞]) = [1,-1]
 639 | -- sneg([0,∞]) = [∞,0]
 640 | -- szer([0,∞]) = [-1,1]
 641 | -- @
 642 | sinf :: Num a => M a
 643 | sinf = M 1 1 (-1) 1
 644 | 
 645 | -- | rotation by pi
 646 | --
 647 | -- >>> order sneg == Just 2
 648 | -- True
 649 | --
 650 | -- >>> sneg == sinf <> sinf
 651 | -- True
 652 | sneg :: Num a => M a
 653 | sneg = M 0 1 (-1) 0
 654 | 
 655 | -- | rotation by 3pi/2
 656 | --
 657 | -- >>> order szer == Just 4
 658 | -- True
 659 | --
 660 | -- >>> szer == sinf <> sinf <> sinf
 661 | -- True
 662 | szer :: Num a => M a
 663 | szer = M 1 (-1) 1 1
 664 | 
 665 | --
 666 | -- @{mempty, sh, sl}@ forms a finite cyclic group of order 3 generated by 'sh' or 'sl'
 667 | --
 668 | -- @
 669 | -- x |-> 1/(1-x)
 670 | -- @
 671 | --
 672 | -- >>> order sh == Just 3
 673 | -- True
 674 | --
 675 | -- >>> sh <> sh <> sh
 676 | -- M 1 0 0 1
 677 | --
 678 | -- @
 679 | -- mempty([0,∞]) = [0,∞]
 680 | -- sh([0,∞]) = [1,0]
 681 | -- sl([0,∞]) = [∞,1]
 682 | -- @
 683 | sh :: Num a => M a
 684 | sh = M 0 1 (-1) 1
 685 | 
 686 | -- @
 687 | -- x |-> x - 1
 688 | -- @
 689 | --
 690 | -- >>> order sl == Just 3
 691 | -- True
 692 | --
 693 | -- >>> sl == sh <> sh
 694 | -- True
 695 | --
 696 | -- >>> sl <> sl <> sl == mempty
 697 | -- True
 698 | sl :: Num a => M a
 699 | sl = M 1 (-1) 1 0
 700 | 
 701 | -- |
 702 | -- @
 703 | -- bounds (M a 1 1 0) = (a, ∞)
 704 | -- @
 705 | bounds :: (Num a, Ord a) => M a -> (V a, V a)
 706 | bounds (M a b c d)
 707 |   | a*d > b*c = (V b d, V a c)
 708 |   | otherwise = (V a c, V b d)
 709 | 
 710 | 
 711 | -- | much tighter bounds assuming we derive from a digits of a continued fraction
 712 | --
 713 | -- @
 714 | -- cfbounds (M a 1 1 0) = (a, a+1)
 715 | -- @
 716 | cfbounds :: (Num a, Ord a) => M a -> (V a, V a)
 717 | cfbounds (M a b c d)
 718 |   | a*d > b*c = (m, V a c)
 719 |   | otherwise = (V a c, m)
 720 |   where
 721 |     m | c * d >= 0 = V (a+b) (c+d) -- we agree on the sign, so use the mediant
 722 |       | otherwise  = V b d
 723 | 
 724 | --------------------------------------------------------------------------------
 725 | -- * Bihomographic Transformations
 726 | --------------------------------------------------------------------------------
 727 | 
 728 | -- |
 729 | -- @
 730 | -- z = T a b c d e f g h
 731 | -- @
 732 | --
 733 | -- represents the function
 734 | --
 735 | -- @
 736 | -- z(x,y) = axy + bx + cy + d
 737 | --          -----------------
 738 | --          exy + fx + gy + d
 739 | -- @
 740 | --
 741 | -- and can be viewed as being simultaneously a homographic transformation
 742 | -- @z(x)[y]@ with coefficients in @Z[y]@:
 743 | --
 744 | -- z(x)[y] = (ay + b)x + (cy + d)
 745 | --           --------------------
 746 | --           (ey + f)x + (gy + h)
 747 | --
 748 | -- or as @z(y)[x]@ with coefficients in @Z[x]@:
 749 | --
 750 | -- z(y)[x] = (ax + c)y + (bx + d)
 751 | --           --------------------
 752 | --           (ey + g)y + (fy + h)
 753 | --
 754 | -- or in Z[y].
 755 | data T a = T
 756 |   a a a a
 757 |   -------
 758 |   a a a a
 759 |   deriving (Functor, Show, Traversable)
 760 | 
 761 | instance Foldable T where
 762 |   foldMap k (T a b c d e f g h) = k a `mappend` k b `mappend` k c `mappend` k d `mappend` k e `mappend` k f `mappend` k g `mappend` k h
 763 |   foldl1 k (T a b c d e f g h) = k (k (k (k (k (k (k a b) c) d) e) f) g) h
 764 | 
 765 | instance Columns T where
 766 |   columns k (T a b c d e f g h) = k (V a e) <> k (V b f) <> k (V c g) <> k (V d h)
 767 | 
 768 | -- | @mt f z x y = f(z(x,y))@
 769 | mt :: Num a => M a -> T a -> T a
 770 | mt (M a b c d) (T e e' f f' g g' h h') = T
 771 |   (a*e+b*g) (a*e'+b*g') (a*f+b*h) (a*f'+b*h')
 772 |   -------------------------------------------
 773 |   (c*e+d*g) (c*e'+d*g') (c*f+d*h) (c*f'+d*h')
 774 | 
 775 | -- | @tm1 z f x y = z(f(x),y) = z(f(x))[y]@
 776 | tm1 :: Num a => T a -> M a -> T a
 777 | tm1 (T a a' b b' c c' d d') (M e f g h) = T
 778 |   (a*e+b*g) (a'*e+b'*g) (a*f+b*h) (a'*f+b'*h)
 779 |   -------------------------------------------
 780 |   (c*e+d*g) (c'*e+d'*g) (c*f+d*h) (c'*f+d'*h)
 781 | 
 782 | -- | @tm2 z g x y = z(x,g(y)) = z(g(y))[x]@
 783 | tm2 :: Num a => T a -> M a -> T a
 784 | tm2 (T a b a' b' c d c' d') (M e f g h) = T
 785 |   (a*e+b*g) (a*f+b*h) (a'*e+b'*g) (a'*f+b'*h)
 786 |   -------------------------------------------
 787 |   (c*e+d*g) (c*f+d*h) (c'*e+d'*g) (c'*f+d'*h)
 788 | 
 789 | -- |
 790 | -- Apply a bihomographic transformation to an extended rational.
 791 | -- The result is a residual homographic transformation.
 792 | --
 793 | -- @
 794 | -- z(k/n,y) = (a(k/n) + c)y + (b(k/n) + d)
 795 | --            ----------------------------
 796 | --            (e(k/n) + g)y + (f(k/n) + h)
 797 | --
 798 | --          = (ka + nc)y + (kb+nd)
 799 | --            --------------------
 800 | --            (ke + ng)y + (kf+nh)
 801 | -- @
 802 | tv1 :: Num a => T a -> V a -> M a
 803 | tv1 (T a b c d e f g h) (V k n) = M
 804 |   (k*a+n*c) (k*b+n*d)
 805 |   -------------------
 806 |   (k*e+n*g) (k*f+n*h)
 807 | 
 808 | -- |
 809 | --
 810 | -- Apply a bihomographic transformation to an extended rational.
 811 | -- The result is a residual homographic transformation.
 812 | --
 813 | -- @
 814 | -- z(x,k/n) = ax(k/n) + bx + c(k/n) + d
 815 | --            -------------------------
 816 | --            ex(k/n) + fx + g(k/n) + d
 817 | --
 818 | --          = (ka + nb)x + (kc + nd)
 819 | --            ----------------------
 820 | --            (ke + nf)x + (kg + nh)
 821 | -- @
 822 | tv2 :: Num a => T a -> V a -> M a
 823 | tv2 (T a b c d e f g h) (V k n) = M
 824 |   (k*a+n*b) (k*c+n*d)
 825 |   -------------------
 826 |   (k*e+n*f) (k*g+n*h)
 827 | 
 828 | tq :: Num a => T a -> Q a
 829 | tq (T a b c d e f g h) = Q a (b+c) d e (f+g) h
 830 | 
 831 | transposeT :: T a -> T a
 832 | transposeT (T a b c d e f g h) = T a c b d e g f h
 833 | 
 834 | -- | best naive homographic approximation
 835 | approx :: (IntegralDomain a, Ord a) => T a -> M a
 836 | approx (T a b c d e f g h)
 837 |   | (i,j) <- minmax (V a e) (V b f)
 838 |   , (k,l) <- minmax (V c g) (V g h)
 839 |   , V m o <- min i k
 840 |   , V n p <- max j l
 841 |   = M m n o p
 842 | 
 843 | --------------------------------------------------------------------------------
 844 | -- * Binary Quadratic Forms?
 845 | --------------------------------------------------------------------------------
 846 | 
 847 | -- @
 848 | -- q(x,y) = Ax^2 + Bxy + C^2
 849 | -- @
 850 | data BQF a = BQF a a a deriving (Show, Functor, Foldable, Traversable)
 851 | 
 852 | --------------------------------------------------------------------------------
 853 | -- * Quadratic Fractional Transformations
 854 | --------------------------------------------------------------------------------
 855 | 
 856 | -- |
 857 | -- @
 858 | -- z(x) = ax^2 + bx + c
 859 | --        -------------
 860 | --        dx^2 + ex + f
 861 | -- @
 862 | data Q a = Q
 863 |   a a a
 864 |   -----
 865 |   a a a
 866 |   deriving (Show, Functor, Traversable)
 867 | 
 868 | instance Foldable Q where
 869 |   foldMap k (Q a b c d e f) = k a `mappend` k b `mappend` k c `mappend` k d `mappend` k e `mappend` k f
 870 |   foldl1 k (Q a b c d e f) = k (k (k (k (k a b) c) d) e) f
 871 | 
 872 | instance Columns Q where
 873 |   columns k (Q a b c d e f) = k (V a d) <> k (V b e) <> k (V c f)
 874 | 
 875 | -- z(g/h) = a(g/h)^2 + b(g/h) + c
 876 | --          ---------------------
 877 | --          d(g/h)^2 + e(g/h) + f
 878 | --        = ag^2 + bgh + ch^2
 879 | --          -----------------
 880 | --        = dg^2 + egh + eh^2
 881 | 
 882 | qv :: Num a => Q a -> V a -> V a
 883 | qv (Q a b c d e f) (V g h)
 884 |   | gg <- g*g
 885 |   , gh <- g*h
 886 |   , hh <- h*h
 887 |   = V (a*gg + b*gh + c*hh) (d*gg + e*gh + f*hh)
 888 | 
 889 | -- |
 890 | -- @
 891 | -- z(m(x)) = a((gx+h)/(ix+j))^2 + b(gx+h)/(ix+j) + c
 892 | --           ---------------------------------------
 893 | --           d((gx+h)/(ix+j))^2 + e(gx+h)/(ix+j) + f
 894 | --
 895 | --         = a(gx+h)^2 + b(gx+h)(ix+j) + c(ix+j)^2
 896 | --           -------------------------------------
 897 | --           d(gx+h)^2 + e(gx+h)(ix+j) + f(ix+j)^2
 898 | --
 899 | --         = (agg + bgi + cii)x^2 + (2ahg + b(hi + gj) + 2cij)x  + (ahh + bhj + cjj)
 900 | --           ---------------------------------------------------------------------
 901 | --         = (dgg + egi + fii)x^2 + (2dhg + e(hi + gj) + 2fij)x  + (dhh + ehj + fjj)
 902 | -- @
 903 | qm :: Num a => Q a -> M a -> Q a
 904 | qm (Q a b c d e f) (M g h i j)
 905 |   | gg <- g*g
 906 |   , gi <- g*i
 907 |   , ii <- i*i
 908 |   , hg2 <- 2*h*g
 909 |   , hi_gj <- h*i+g*j
 910 |   , ij2 <- 2*i*j
 911 |   , hh <- h*h
 912 |   , hj <- h*j
 913 |   , jj <- j*j
 914 |   = Q
 915 |   (a*gg + b*gi + c*ii) (a*hg2 + b*hi_gj + c*ij2) (a*hh + b*hj + c*jj)
 916 |   -------------------------------------------------------------------
 917 |   (d*gg + e*gi + f*ii) (d*hg2 + e*hi_gj + f*ij2) (d*hh + e*hj + f*jj)
 918 | 
 919 | -- |
 920 | -- @
 921 | -- m(z(x)) = a(ex^2+fx+g) + b(hx^2+ix+j)
 922 | --           ---------------------------
 923 | --           c(ex^2+fx+g) + d(hx^2+ix+j)
 924 | --
 925 | --         = (ae+bh)x^2 + (af+bi)x + ag+bj
 926 | --           -----------------------------
 927 | --           (ce+dh)x^2 + (cf+di)x + cg+dj
 928 | -- @
 929 | mq :: Num a => M a -> Q a -> Q a
 930 | mq (M a b c d) (Q e f g h i j) = Q
 931 |   (a*e+b*h) (a*f+b*i) (a*g+b*j)
 932 |   (c*e+d*h) (c*f+d*i) (c*g+d*j)
 933 | 
 934 | --------------------------------------------------------------------------------
 935 | -- * Exact Real Arithmetic
 936 | --------------------------------------------------------------------------------
 937 | 
 938 | -- nested linear fractional transformations
 939 | --
 940 | -- (m :* n :* ...) implies that all matrices from n onward always narrow a suitable interval.
 941 | -- (m :* ...) = singular matrices m simplify to Q
 942 | 
 943 | data F
 944 |   = Quot    {-# UNPACK #-} !(V Z)     -- extended rational
 945 |   | Hom     {-# UNPACK #-} !(M Z) F   -- unapplied linear fractional transformation
 946 |   | Hurwitz {-# UNPACK #-} !(M (P Z)) -- (generalized) hurwitz numbers
 947 |   deriving Show
 948 | 
 949 | instance Eq F where
 950 |   (==) = error "TODO"
 951 | 
 952 | instance Ord F where
 953 |   compare = error "TODO"
 954 | 
 955 | class Hom a where
 956 |   hom :: M Z -> a -> a
 957 | 
 958 | instance Hom F where
 959 |   hom m (Quot v) = Quot $ scale $ mv m v
 960 |   hom m (Hom n x) = Hom (scale $ m <> n) x -- check for efficiency
 961 |   hom (fmap lift -> m) (Hurwitz o) | det m /= 0 = hurwitz (m <> o <> inv m)
 962 |   hom m x = Hom (scale m) x -- deferred hom
 963 | 
 964 | class Eff a where
 965 |   eff :: F -> a
 966 | 
 967 | instance Eff F where
 968 |   eff = id
 969 | 
 970 | data E
 971 |   = Eff F
 972 |   | Quad {-# UNPACK #-} !(Q Z) E                           -- quadratic fractional transformation
 973 |   | Mero {-# UNPACK #-} !(T Z) {-# UNPACK #-} !(T (P Z)) E -- nested bihomographic transformations
 974 |   | Bihom {-# UNPACK #-} !(T Z) E E                        -- bihomographic transformation
 975 |   deriving Show
 976 | 
 977 | instance Eff E where
 978 |   eff = Eff
 979 | 
 980 | instance Hom E where
 981 |   hom m (Eff f)       = eff (hom m f)
 982 |   hom m (Quad q x)    = quad (scale $ mq m q) x
 983 |   hom m (Mero s t x)  = mero (scale $ mt m s) t x
 984 |   hom m (Bihom s x y) = bihom (mt m s) x y
 985 | 
 986 | -- | apply a meromorphic function
 987 | --
 988 | -- @
 989 | --    |
 990 | --    s
 991 | --   / \
 992 | --  x   t 0
 993 | --     / \
 994 | --    x   t 1
 995 | --       / .
 996 | --      x   .
 997 | --           .
 998 | -- @
 999 | mero :: T Z -> T (P Z) -> E -> E
1000 | -- TODO: simplify if the matrix has no x component? y component?
1001 | mero s t (Eff (Quot r)) = hom (tv1 s r) (hurwitz (tv1 t (fmap lift r)))
1002 | mero s t x = Mero (scale s) (scaleP t) x
1003 | 
1004 | -- | apply a bihomographic transformation
1005 | bihom :: T Z -> E -> E -> E
1006 | bihom m (Eff (Quot r)) y = hom (tv1 m r) y
1007 | bihom m x (Eff (Quot r)) = hom (tv2 m r) x
1008 | bihom m x y = Bihom (scale m) x y
1009 | {-# NOINLINE bihom #-}
1010 | 
1011 | quad :: Q Z -> E -> E
1012 | quad q (Eff (Quot v)) = Eff (Quot (qv q v))
1013 | quad (Q 0 a b 0 c d) x = hom (M a b c d) x
1014 | quad (Q a b c d e f) x
1015 |   | a*e == b*d, a*f == d*c, b*f == c*e, False = undefined
1016 |   -- TODO: we can factor our quadratic form into @Q (p*r) (p*s) (p*t) (q*r) (q*s) (q*t)@
1017 |   -- do something with that fact
1018 | quad q x = Quad q x
1019 | 
1020 | -- smart constructor
1021 | hurwitz :: Eff f => M (P Z) -> f
1022 | -- hurwitz (fmap at0 -> M a b c d) | a*d == c*b = Quot (V a c) -- singular: TODO: check this
1023 | hurwitz m = eff $ Hurwitz (scaleP m)
1024 | 
1025 | -- extract a partial quotient
1026 | nextF :: F -> Maybe (Z, F)
1027 | nextF (Quot (V k n)) = case quotRem k n of
1028 |   (q, r) -> Just (q, Quot (V n r))
1029 | nextF (Hom (M a b 0 0) xs) = Nothing -- ∞ or ⊥
1030 | nextF (Hom m@(M a b c d) xs)
1031 |   | c /= 0, d /= 0
1032 |   , signum c * signum (c + d) > 0 -- knuth style warmup?
1033 |   , q <- quot a c
1034 |   , q == quot b d
1035 |   , n <- cfdigit q = Just (q, Hom (inv n <> m) xs)
1036 | nextF (Hom m xs) = nextF (hom m xs) -- fetch more
1037 | nextF (Hurwitz m) = nextF (Hom (fmap at0 m) $ Hurwitz (fmap (<> P [1,1]) m)) -- explicitly used Hom to keep it from merging back
1038 | 
1039 | square :: E -> E
1040 | square x = quad (Q 1 0 0 0 0 1) x
1041 | 
1042 | {-# RULES "bihomographic to quadratic" forall t x. bihom t x x = quad (tq t) x #-}
1043 | 
1044 | instance Eq E
1045 | instance Ord E
1046 | 
1047 | instance Num E where
1048 |   -- x + x -> quad (Q 0 2 0 0 0 1) x = hom (2 0 0 1) x = 2x
1049 |   x + y = bihom (T 0 1 1 0 0 0 0 1) x y
1050 |   {-# INLINE (+) #-}
1051 |   -- x - x -> quad (Q 0 0 0 0 0 1) x = hom (0 0 0 1) x = 0x
1052 |   x - y = bihom (T 0 1 (-1) 0 0 0 0 1) x y
1053 |   {-# INLINE (-) #-}
1054 |   -- x * x -> quad (Q 1 0 0 0 0 1) x = x^2
1055 |   x * y = bihom (T 1 0 0 0 0 0 0 1) x y
1056 |   {-# INLINE (*) #-}
1057 |   negate x = hom (M (-1) 0 0 1) x
1058 |   abs xs | xs < 0 = negate xs
1059 |          | otherwise = xs
1060 |   signum xs = fromInteger $ case compare xs 0 of LT -> -1; EQ -> 0; GT -> 1
1061 |   fromInteger n = Eff $ Quot $ V n 1
1062 | 
1063 | instance Fractional E where
1064 |   -- x / x -> quad (Q 0 1 0 0 1 0) x = hom (1 0 1 0) x = 1 for nice x
1065 |   x / y = bihom (T 0 1 0 0 0 0 1 0) x y
1066 |   {-# INLINE (/) #-}
1067 |   recip x = hom (M 0 1 1 0) x
1068 |   fromRational (k :% n) = Eff $ Quot $ V k n
1069 | 
1070 | instance Floating E where
1071 |   pi     = Eff $ M 0 4 1 0 `Hom` hurwitz (M (P [1,2]) (P [1,2,1]) 1 0)
1072 |   exp    = mero (T 1 1 2 0 (-1) 1 2 0) (T 0 1 (P [6,4]) 0 1 0 0 0)
1073 |   sin x  = quad (Q 0 2 0 1 0 1)    (tan (x/2))
1074 |   cos x  = quad (Q (-1) 0 1 1 0 1) (tan (x/2))
1075 |   sinh x = quad (Q 1 0 (-1) 0 2 0) (exp x)
1076 |   cosh x = quad (Q 1 0 1 0 2 0)    (exp x)
1077 |   tanh x = quad (Q 1 0 (-1) 1 0 1) (exp x)
1078 | 
1079 | instance IntegralDomain E
1080 | 
1081 | sqrt2 :: Eff f => f
1082 | sqrt2 = eff $ cfdigit 1 `hom` hurwitz (M 2 1 1 0)
1083 | 
1084 | --------------------------------------------------------------------------------
1085 | -- * Continued Fractions
1086 | --------------------------------------------------------------------------------
1087 | 
1088 | -- continued fraction digit
1089 | cfdigit :: Num a => a -> M a
1090 | cfdigit a = M a 1 1 0
1091 | 
1092 | -- generalized continued fraction digit
1093 | gcfdigit :: Num a => a -> a -> M a
1094 | gcfdigit a b = M a b 1 0
1095 | 
1096 | --------------------------------------------------------------------------------
1097 | -- * Redundant Binary Representation
1098 | --------------------------------------------------------------------------------
1099 | 
1100 | --------------------------------------------------------------------------------
1101 | -- * Decimal
1102 | --------------------------------------------------------------------------------
1103 | 


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