186 lines
5 KiB
Haskell
186 lines
5 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
import Data.List (find, mapAccumL)
|
|
import Control.Arrow (first, second)
|
|
|
|
-- Generalized Fibonacci series defined for any Num instance, and for Zeckendorf numbers as well.
|
|
-- Used to build Zeckendorf tables.
|
|
fibs :: Num a => a -> a -> [a]
|
|
fibs a b = res
|
|
where
|
|
res = a : b : zipWith (+) res (tail res)
|
|
|
|
data Fib = Fib { sign :: Int, digits :: [Int]}
|
|
|
|
-- smart constructor
|
|
mkFib s ds =
|
|
case dropWhile (==0) ds of
|
|
[] -> 0
|
|
ds -> Fib s (reverse ds)
|
|
|
|
-- Textual representation
|
|
instance Show Fib where
|
|
show (Fib s ds) = sig s ++ foldMap show (reverse ds)
|
|
where sig = \case { -1 -> "-"; s -> "" }
|
|
|
|
-- Equivalence relation
|
|
instance Eq Fib where
|
|
Fib sa a == Fib sb b = sa == sb && a == b
|
|
|
|
-- Order relation
|
|
instance Ord Fib where
|
|
a `compare` b =
|
|
sign a `compare` sign b <>
|
|
case find (/= 0) $ alignWith (-) (digits a) (digits b) of
|
|
Nothing -> EQ
|
|
Just 1 -> if sign a > 0 then GT else LT
|
|
Just (-1) -> if sign a > 0 then LT else GT
|
|
|
|
-- Arithmetic
|
|
instance Num Fib where
|
|
negate (Fib s ds) = Fib (negate s) ds
|
|
abs (Fib s ds) = Fib 1 ds
|
|
signum (Fib s _) = fromIntegral s
|
|
|
|
fromInteger n =
|
|
case compare n 0 of
|
|
LT -> negate $ fromInteger (- n)
|
|
EQ -> Fib 0 [0]
|
|
GT -> Fib 1 . reverse . fst $ divModFib n 1
|
|
|
|
0 + a = a
|
|
a + 0 = a
|
|
a + b =
|
|
case (sign a, sign b) of
|
|
( 1, 1) -> res
|
|
(-1, 1) -> b - (-a)
|
|
( 1,-1) -> a - (-b)
|
|
(-1,-1) -> - ((- a) + (- b))
|
|
where
|
|
res = mkFib 1 . process $ 0:0:c
|
|
c = alignWith (+) (digits a) (digits b)
|
|
-- use cellular automata
|
|
process =
|
|
runRight 3 r2 . runLeftR 3 r2 . runRightR 4 r1
|
|
|
|
0 - a = -a
|
|
a - 0 = a
|
|
a - b =
|
|
case (sign a, sign b) of
|
|
( 1, 1) -> res
|
|
(-1, 1) -> - ((-a) + b)
|
|
( 1,-1) -> a + (-b)
|
|
(-1,-1) -> - ((-a) - (-b))
|
|
where
|
|
res = case find (/= 0) c of
|
|
Just 1 -> mkFib 1 . process $ c
|
|
Just (-1) -> - (b - a)
|
|
Nothing -> 0
|
|
c = alignWith (-) (digits a) (digits b)
|
|
-- use cellular automata
|
|
process =
|
|
runRight 3 r2 . runLeftR 3 r2 . runRightR 4 r1 . runRight 3 r3
|
|
|
|
0 * a = 0
|
|
a * 0 = 0
|
|
1 * a = a
|
|
a * 1 = a
|
|
a * b =
|
|
case (sign a, sign b) of
|
|
(1, 1) -> res
|
|
(-1, 1) -> - ((-a) * b)
|
|
( 1,-1) -> - (a * (-b))
|
|
(-1,-1) -> ((-a) * (-b))
|
|
where
|
|
-- use Zeckendorf table
|
|
table = fibs a (a + a)
|
|
res = sum $ onlyOnes $ zip (digits b) table
|
|
onlyOnes = map snd . filter ((==1) . fst)
|
|
|
|
-- Enumeration
|
|
instance Enum Fib where
|
|
toEnum = fromInteger . fromIntegral
|
|
fromEnum = fromIntegral . toInteger
|
|
|
|
instance Real Fib where
|
|
toRational = fromInteger . toInteger
|
|
|
|
-- Integral division
|
|
instance Integral Fib where
|
|
toInteger (Fib s ds) = signum (fromIntegral s) * res
|
|
where
|
|
res = sum (zipWith (*) (fibs 1 2) (fromIntegral <$> ds))
|
|
|
|
quotRem 0 _ = (0, 0)
|
|
quotRem a 0 = error "divide by zero"
|
|
quotRem a b = case (sign a, sign b) of
|
|
(1, 1) -> first (mkFib 1) $ divModFib a b
|
|
(-1, 1) -> second negate . first negate $ quotRem (-a) b
|
|
( 1,-1) -> first negate $ quotRem a (-b)
|
|
(-1,-1) -> second negate $ quotRem (-a) (-b)
|
|
|
|
------------------------------------------------------------
|
|
-- helper funtions
|
|
|
|
-- general division using Zeckendorf table
|
|
divModFib :: (Ord a, Num c, Num a) => a -> a -> ([c], a)
|
|
divModFib a b = (q, r)
|
|
where
|
|
(r, q) = mapAccumL f a $ reverse $ takeWhile (<= a) table
|
|
table = fibs b (b+b)
|
|
f n x = if n < x then (n, 0) else (n - x, 1)
|
|
|
|
-- application of rewriting rules
|
|
-- runs window from left to right
|
|
runRight n f = go
|
|
where
|
|
go [] = []
|
|
go lst = let (w, r) = splitAt n lst
|
|
(h: t) = f w
|
|
in h : go (t ++ r)
|
|
|
|
-- runs window from left to right and reverses the result
|
|
runRightR n f = go []
|
|
where
|
|
go res [] = res
|
|
go res lst = let (w, r) = splitAt n lst
|
|
(h: t) = f w
|
|
in go (h : res) (t ++ r)
|
|
|
|
-- runs reversed window and reverses the result
|
|
runLeftR n f = runRightR n (reverse . f . reverse)
|
|
|
|
-- rewriting rules from [C. Ahlbach et. all]
|
|
r1 = \case [0,3,0] -> [1,1,1]
|
|
[0,2,0] -> [1,0,1]
|
|
[0,1,2] -> [1,0,1]
|
|
[0,2,1] -> [1,1,0]
|
|
[x,0,2] -> [x,1,0]
|
|
[x,0,3] -> [x,1,1]
|
|
[0,1,2,0] -> [1,0,1,0]
|
|
[0,2,0,x] -> [1,0,0,x+1]
|
|
[0,3,0,x] -> [1,1,0,x+1]
|
|
[0,2,1,x] -> [1,1,0,x ]
|
|
[0,1,2,x] -> [1,0,1,x ]
|
|
l -> l
|
|
|
|
r2 = \case [0,1,1] -> [1,0,0]
|
|
l -> l
|
|
|
|
r3 = \case [1,-1] -> [0,1]
|
|
[2,-1] -> [1,1]
|
|
[1, 0, 0] -> [0,1,1]
|
|
[1,-1, 0] -> [0,0,1]
|
|
[1,-1, 1] -> [0,0,2]
|
|
[1, 0,-1] -> [0,1,0]
|
|
[2, 0, 0] -> [1,1,1]
|
|
[2,-1, 0] -> [1,0,1]
|
|
[2,-1, 1] -> [1,0,2]
|
|
[2, 0,-1] -> [1,1,0]
|
|
l -> l
|
|
|
|
alignWith :: (Int -> Int -> a) -> [Int] -> [Int] -> [a]
|
|
alignWith f a b = go [] a b
|
|
where
|
|
go res as [] = ((`f` 0) <$> reverse as) ++ res
|
|
go res [] bs = ((0 `f`) <$> reverse bs) ++ res
|
|
go res (a:as) (b:bs) = go (f a b : res) as bs
|