content: {-# 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
  