import Data.List (find, mapAccumL)
import Control.Arrow (first, second)



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]}


mkFib s ds =
  case dropWhile (==0) ds of
    [] -> 0
    ds -> Fib s (reverse ds)


instance Show Fib where
  show (Fib s ds) = sig s ++ foldMap show (reverse ds)
    where sig = \case { -1 -> "-"; s -> "" }


instance Eq Fib where
  Fib sa a == Fib sb b = sa == sb && a == b


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


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)
       
      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)
      
      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
      
      table = fibs a (a + a)
      res = sum $ onlyOnes $ zip (digits b) table
      onlyOnes = map snd . filter ((==1) . fst)


instance Enum Fib where
  toEnum = fromInteger . fromIntegral
  fromEnum = fromIntegral . toInteger

instance Real Fib where
  toRational = fromInteger . toInteger


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) 





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)



runRight n f = go
  where
    go []  = []
    go lst = let (w, r) = splitAt n lst 
                 (h: t) = f w
             in h: go (t ++ r)


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)


runLeftR n f = runRightR n (reverse . f . reverse) 


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