Rationals in Haskell

rats.hs

{-# LANGUAGE GADTs          #-}
{-# LANGUAGE KindSignatures #-}

module Main where

import Data.Ratio
import Data.List
import Data.Maybe
import Data.Tuple

data Tree :: * -> * where
  Node :: a -> Tree a -> Tree a -> Tree a
  deriving (Show)

nodeValue :: Tree a -> a
nodeValue (Node x _ _) = x

children :: Tree a -> [Tree a]
children (Node _ x y) = [x, y]

-- http://blogs.msdn.com/b/matt/archive/2008/05/11/breadth-first-tree-traversal-in-haskell.aspx
toList :: Tree a -> [a]
toList t = map nodeValue (concat (iterate (concatMap children) [t]))

-- http://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree
sternBrocotTree :: Tree Rational
sternBrocotTree = sternBrocotTreeHelp (Rat [1])
  where sternBrocotTreeHelp :: Rat -> Tree Rational
        sternBrocotTreeHelp r@(Rat l) = Node (ratToRational r) left right
          where c1 = sternBrocotTreeHelp (Rat ((init l) ++ [last l + 1]))
                c2 = sternBrocotTreeHelp (Rat ((init l) ++ [last l - 1, 2]))
                (left, right) = (if odd k then id else swap) (c1, c2)
                k = length l + 1

positiveRationals :: [Rational]
positiveRationals = 0 : toList sternBrocotTree

-- Continued fractions
data Rat :: * where
  Rat :: [Int] -> Rat

ratToRational :: Rat -> Rational
ratToRational (Rat []) = 0
ratToRational (Rat [x]) = fromIntegral x
ratToRational (Rat (x : xs)) = (fromIntegral x) + (1 / (ratToRational (Rat xs)))

interloc :: [a] -> [a] -> [a]
interloc xs ys = concat $ zipWith (\x y -> [x, y]) xs ys

ints :: [Int]
ints = 0 : interloc [1..] (map negate [1..])

rationals :: [Rational]
rationals = 0 : l
  where l = interloc ll (map negate ll)
        ll = toList sternBrocotTree

intRat :: Int -> Rational
intRat n = rationals !! n

ratInt :: Rational -> Int
ratInt r = fromJust (findIndex (== r) rationals)

plus :: Int -> Int -> Int
plus x y = ratInt (intRat x + intRat y)

minus :: Int -> Int -> Int
minus x y = x `plus` (negate y)

mult :: Int -> Int -> Int
mult x y = ratInt (intRat x * intRat y)

dive :: Int -> Int -> Int
dive x y = x `mult` (inverse y)

negatee :: Int -> Int
negatee 0 = 0
negatee n = if odd n then n + 1 else n - 1

inverse :: Int -> Int
inverse 0 = error "division by zero"
inverse x = f 0 rationals
  where f :: Int -> [Rational] -> Int
        f n (a : as) = if x `mult` (ratInt a) == 1 then n else f (n + 1) as

main :: IO ()
main = do
  print $ negatee 0
  print $ negatee 1
  print $ negatee 42