content: module ImplicitCatenableDeque (Sized(..), ImplicitCatDeque) where
    import Prelude hiding (head,tail,last,init,(++))
    import CatenableDeque
    import Deque ( Deque(..) )
  
    class Sized d where
      size :: d a -> Int
  
    data ImplicitCatDeque d a =
      Shallow (d a)
      | Deep (d a) (ImplicitCatDeque d (CmpdElem d a)) (d a)
          (ImplicitCatDeque d (CmpdElem d a)) (d a)
  
    data CmpdElem d a =
      Simple (d a)
      | Cmpd (d a) (ImplicitCatDeque d (CmpdElem d a)) (d a)
  
    share f r = (init f, m, tail r)
      where m = cons (last f) (cons (head r) empty)
  
    dappendL d1 d2 =
      if isEmpty d1 then d2 else dappendL (init d1) (cons (last d1) d2)
    dappendR d1 d2 =
      if isEmpty d2 then d1 else dappendR (snoc d1 (head d2)) (tail d2)
  
    replaceHead x (Shallow d) = Shallow (cons x (tail d))
    replaceHead x (Deep f a m b r) = Deep (cons x (tail f)) a m b r
  
    instance (Deque d, Sized d) => Deque (ImplicitCatDeque d) where
      empty = Shallow empty
      isEmpty (Shallow d) = isEmpty d
      isEmpty _ = False
  
      cons x (Shallow d) = Shallow (cons x d)
      cons x (Deep f a m b r) = Deep (cons x f) a m b r
  
      head (Shallow d) = head d
      head (Deep f a m b r) = head f
  
      tail (Shallow d) = Shallow (tail d)
      tail (Deep f a m b r)
        | size f > 3 = Deep (tail f) a m b r
        | not (isEmpty a) =
          case head a of
            Simple d -> Deep f' (tail a) m b r
              where f' = dappendL (tail f) d
            Cmpd f' c' r' -> Deep f'' a'' m b r
              where
                f'' = dappendL (tail f) f'
                a'' = c' ++ replaceHead (Simple r') a
        | not (isEmpty b) =
          case head b of
            Simple d -> Deep f' empty d (tail b) r
              where f' = dappendL (tail f) m
            Cmpd f' c' r' -> Deep f'' a'' r' (tail b) r
              where
                f'' = dappendL (tail f) m
                a'' = cons (Simple f') c'
        | otherwise = Shallow (dappendL (tail f) m) ++ Shallow r
  
      -- snoc, last, init も対称的に定義される. . .
      snoc = undefined
      last = undefined
      init = undefined
  
    instance (Deque d, Sized d) => CatenableDeque (ImplicitCatDeque d)
      where
        (Shallow d1) ++ (Shallow d2)
          | size d1 < 4 = Shallow (dappendL d1 d2)
          | size d2 < 4 = Shallow (dappendR d1 d2)
          | otherwise = let (f, m, r) = share d1 d2 in Deep f empty m empty r
        (Shallow d) ++ (Deep f a m b r)
          | size d < 4 = Deep (dappendL d f) a m b r
          | otherwise = Deep d (cons (Simple f) a) m b r
        (Deep f a m b r) ++ (Shallow d)
          | size d < 4 = Deep f a m b (dappendR r d)
          | otherwise = Deep f a m (snoc b (Simple r)) d
        (Deep f1 a1 m1 b1 r1) ++ (Deep f2 a2 m2 b2 r2) = Deep f1 a'1 m b'2 r2
          where
            (r'1, m, f'2) = share r1 f2
            a'1 = snoc a1 (Cmpd m1 b1 r'1)
            b'2 = cons (Cmpd f'2 a2 m2) b2
  