AVL tree with Haskell

avl.hs

-- GHCi, version 8.8.4
-- author: Evgeniy Malov
-- AVL delete: https://www.youtube.com/watch?v=DfSeb2fDH3s
-- AVL insert: https://www.youtube.com/watch?v=SlAJirZ0KTE&t=0s
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Monad
import Data.Maybe
import qualified Data.List as L
import qualified Data.Map as M
import PrettyT -- https://gist.github.com/evgenii-malov/1fc29a652751451dbca0d54d454cc1ef
import Control.Applicative

-- IMPORTANT assume all key nodes uniq !

-- data Btree a = Empty | Node a (Btree a) (Btree a) deriving Show

ins :: Ord a => a -> Btree a -> Btree a
ins a Empty = Node a Empty Empty
ins a (Node e l r) | a>=e = Node e l (ins a r)
                   | a<e = Node e (ins a l) r

h :: Btree a -> Int
h Empty = 0
h (Node _ Empty Empty) = 0
h (Node _ l r) = 1 + max (h l) (h r)

balance :: Btree a -> Int
balance Empty = 0
balance (Node _ Empty Empty) = 0
balance (Node _ l Empty) = (h l) + 1
balance (Node _ Empty r) = (h r) + 1
balance (Node _ l r) = abs ((h l) - (h r))

ipath :: Ord a => a -> Btree a -> [Btree a]
ipath a Empty = []
ipath a t@(Node e l r) | a == e = [t]
                       | a>e = t:(ipath a r)
                       | a<e = t:(ipath a l)

fdisb :: Ord a => a -> Btree a -> Maybe (Btree a)
fdisb a t = L.find (\t -> balance t>1) $ reverse (ipath a t)

replace :: Ord a => a -> Btree a -> Btree a -> Btree a
replace a nt (Node e l r) | e == a = nt
                          | a > e = Node e l (replace a nt r)
                          | a < e = Node e (replace a nt l) r

data D = L | R deriving (Show , Eq)

fp :: Ord a => Int -> a -> Btree a -> [D]
fp c a t = go c a t where
                        go _ _ Empty = []
                        go 0 _ _ = []
                        go c a (Node e l r) = if a>=e then R:(go (c-1) a r) else L:(go (c-1) a l)

ll_rotate (Node e (Node el dll dlr) dr) = Node el dll (Node e dlr dr)
rr_rotate (Node e dl (Node er drl drr)) = Node er (Node e dl drl) drr
lr_rotate (Node e (Node el dll (Node elr dlrl dlrr)) dr) = Node elr (Node el dll dlrl) (Node e dlrr dr)
rl_rotate (Node e dl (Node er (Node erl drll drlr) drr)) = Node erl (Node e dl drll) (Node er drlr drr)

insert :: Ord a => a -> Btree a -> Btree a
insert a Empty = Node a Empty Empty
insert a t@(Node e l r) = fromJust $ (rotate <$> (fdisb a ut) <|> Just ut)
                          where
                            rotate d@(Node de _ _)
                                   | is_ll = replace de (ll_rotate d) ut
                                   | is_lr = replace de (lr_rotate d) ut
                                   | is_rr = replace de (rr_rotate d) ut
                                   | is_rl = replace de (rl_rotate d) ut
                                   where
                                      is_ll = (fp 2 a d) == [L,L]
                                      is_lr = (fp 2 a d) == [L,R]
                                      is_rr = (fp 2 a d) == [R,R]
                                      is_rl = (fp 2 a d) == [R,L]


                            ut = ins a t



delmin :: Ord a => Btree a -> Btree a
delmin (Node _ Empty r) = r
delmin (Node e l r) = Node e (delmin l) r

getmin :: Ord a => Btree a -> a
getmin (Node e Empty r) = e
getmin (Node e l r) = getmin l

delmax :: Ord a => Btree a -> Btree a
delmax (Node a l Empty) = l
delmax (Node e l r) = Node e l (delmax r)

getmax :: Ord a => Btree a -> a
getmax (Node e l Empty) = e
getmax (Node _ _ r) = getmax r

empty_ (Empty) = True
empty_ _ = False

del :: Ord a => a -> Btree a -> Btree a
del a Empty = Empty
del a t@(Node e Empty Empty) = if e == a then Empty else t
del a (Node e l r) | a > e = Node e l $ del a r
                   | a < e = Node e (del a l) r
                   | a == e = if empty_ r then Node mx l_ r else Node mn l r_
                     where
                        mn = getmin r
                        l_ = delmax l
                        mx = getmax l
                        r_ = delmin r


-- get max predicessor or max itself
gmx_pred :: Ord a => Btree a -> a
gmx_pred (Node e Empty Empty) = e
gmx_pred (Node _ (Node p _ _) Empty) = p
gmx_pred (Node _ _ r) = gmx_pred r

--get min successor or min itself
gmn_succ :: Ord a => Btree a -> a
gmn_succ (Node e Empty Empty) = e
gmn_succ (Node _ Empty (Node s _ _)) = s
gmn_succ (Node _ l _) = gmn_succ l


-- find start disbalance point on delete a
del_dp :: Ord a => a -> Btree a -> Maybe a
del_dp a Empty = Nothing
del_dp a (Node e Empty Empty) = if e == a then Just e else Nothing
del_dp a (Node e l r)
                   | a > e = del_dp a r
                   | a < e = del_dp a l
                   | a == e = if empty_ r then Just mxp else Just mns
                     where
                        mxp = gmx_pred l
                        mns = gmn_succ r


delete :: forall a.Ord a => a -> Btree a -> Btree a
delete a Empty = Empty
delete a t | isNothing spdn = ut
           | isJust spdn = fromJust $ (((go ut) <$> (fdisb spdn_ ut)) <|> Just ut)
             where
                  ut = del a t :: Btree a
                  spdn = del_dp a t -- find starting possible disbalance node
                  spdn_ :: a
                  spdn_ = fromJust spdn -- start possible disbalance node (go up & check)
                  go :: Ord a => Btree a -> Btree a -> Btree a
                  go ut dn@(Node de _ _) | no_d = rotated
                                         | otherwise = go rotated (fromJust d')
                                         where
                                             no_d = isNothing d'
                                             d' = fdisb de rotated
                                             rotated = replace de (rotate dn) ut
                  rotate dn@(Node de l r)  -- return flag to do move up
                    | go_left_l_ge_r = ll_rotate dn
                    | go_left_r_g_l = lr_rotate dn
                    | go_right_r_ge_l = rr_rotate dn
                    | go_right_l_g_r = rl_rotate dn
                    where
                      (Node _ ll lr) = l
                      (Node _ rl rr) = r
                      ins_left = fp 1 spdn_ dn == [L]
                      ins_right = fp 1 spdn_ dn == [R]
                      go_left_l_ge_r = ins_right && ((h ll) >= (h lr))
                      go_left_r_g_l = ins_right && ((h ll) < (h lr))
                      go_right_r_ge_l = ins_left && ((h rr) >= (h rl))
                      go_right_l_g_r = ins_left && ((h rr) < (h rl))



fromList l | length l == (length (L.nub l)) = foldr insert Empty l
           | otherwise = error "duplicate elements!"


fromList' l | length l == (length (L.nub l)) = foldr ins Empty l
            | otherwise = error "duplicate elements!"

AVL insert - https://www.youtube.com/watch?v=SlAJirZ0KTE
AVL delete - https://www.youtube.com/watch?v=DfSeb2fDH3s