Cartesian tree with implcit key in Haskell

cartesiant_ik.hs

-- explain video https://youtu.be/Ln_tVErialQ
-- GHCi, version 8.8.4
{-# LANGUAGE RankNTypes    #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

import PrettyT -- https://www.youtube.com/watch?v=Ud-1Z0hBlB8&t=379s
-- data Btree a = Empty | Node a (Btree a) (Btree a) deriving Show
import Data.Ord
import Data.List
import Data.Maybe 
import System.Random
import Data.Monoid


-- Cartesian tree facts:
-- tree of pairs (X,Y)
-- binary search tree by X
-- heap by Y
-- structure of ctree is uniqly defined
-- X is uniq
-- Y is uniq
-- x1 < x2 < x3 ... < xN

-- https://en.wikipedia.org/wiki/Cartesian_tree

-- Cartesian tree by implicit key:
-- no X stored (X stored implicitly in a tree structure)
-- store value and size of a tree in every node
-- also we can store some data to do query on subintervals
-- store Y in node

-- segment tree - https://www.youtube.com/watch?v=nckWiHmeNXU
-- cartesian tree - https://www.youtube.com/watch?v=E8Fxtpr24Zg&t=4560s

extract Empty = (0,mempty)
extract (Node (s,_,q,_) _ _) = (s,q)

merge :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Btree (Int, q, q, y) -> Btree (Int, q, q, y) 
merge Empty t2 = t2
merge t1 Empty = t1
merge t1@(Node (s1,v1,q1,y1) l1 r1) t2@(Node (s2,v2,q2,y2) l2 r2) 
  | y1 > y2 = Node (s1',v1,q1',y1) l1 nr
  | y1 < y2 = Node (s2',v2,q2',y2) nl r2 
    where 
      s1' = 1 + fst (extract l1) + fst (extract nr)
      s2' = 1 + fst (extract nl) + fst (extract r2)
      q1' = snd (extract l1) <> v1 <> snd (extract nr)  
      q2' = snd (extract nl) <> v2 <> snd (extract r2)  
      nr@(Node (ns1,_,nq1,_) _ _) = merge r1 t2
      nl@(Node (ns2,_,nq2,_) _ _) = merge t1 l2


splt :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> (Btree (Int, q, q, y), Btree (Int, q, q, y))
splt Empty _ = (Empty,Empty)
splt t@(Node e l r) i 
  | i == sl = (l,Node e' Empty r) 
  | i < sl = (ls1, Node e'' ls2 r)
  | i > sl = (Node e''' l rs1, rs2)  
    where
      (ls1,ls2) = splt l i
      (rs1,rs2) = splt r (i-(sl+1))
      (s,v,q,y) = e
      e' = (sr+1,v,v <> qr,y)
      e'' = (ls2_s+sr+1, v, ls2_q <> v <> qr,y)
      e''' = (sl+rs1_s+1,v, ql <> v <> rs1_q,y)
      (ls2_s,ls2_q) = extract ls2
      (rs1_s,rs1_q) = extract rs1
      (sl,ql) = extract l
      (sr,qr) = extract r


ino :: Btree (Int, q, q, y) -> [q]
ino Empty = []
ino t@(Node (_,v,_,_) l r) = ino l ++ [v] ++ ino r

ins :: (Monoid q, Ord y) => Int -> Btree (Int, q, q, y) -> (q,y) -> Btree (Int, q, q, y)
ins i t (v,y) = merge (merge t1 n) t2
  where
    (t1,t2) = splt t i
    n = Node (1,v,v,y) Empty Empty

len :: Btree (Int, q, q, y) -> Int
len Empty = 0
len t@(Node (s,_,_,_) _ _ ) = s

insertFirst :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> (q,y) -> Btree (Int, q, q, y)
insertFirst t (v,y) = merge t1 t where t1 = Node (1,v,v,y) Empty Empty

insertLast :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> (q,y) -> Btree (Int, q, q, y)
insertLast t (v,y) = merge t t1 where t1 = Node (1,v,v,y) Empty Empty

del :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> Btree (Int, q, q, y)
del t i = merge t1 t2 
  where 
    (t1,tt) = splt t i
    (_,t2) = splt tt 1

delRange :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> Int -> Btree (Int, q, q, y)   
delRange t a b = merge t1 t2 
  where 
    (t1,_) = splt t a
    (_,tt) = splt t b
    (_,t2) = splt tt 1

get :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> Maybe q
get t i 
  | i<0 = Nothing
  | otherwise = ex rt
  where
    (_,tt) = splt t i    
    (rt,_)= splt tt 1
    ex Empty = Nothing 
    ex (Node (_,v,_,_) _ _) = Just v

set :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> (q,y) -> Btree (Int, q, q, y)
set t i p = ins i dt p 
  where
    dt = del t i

query :: (Monoid q, Ord y) => Btree (Int, q, q, y) -> Int -> Int -> Maybe q
query t a b 
  | (a < 0) || (b < 0) || (b<a) = Nothing
  | otherwise = ex tl
  where
    (_,tr) = splt t a
    (tl,_) = splt tr (b-a+1)
    ex Empty = Nothing
    ex (Node (_,_,q,_) _ _) = Just q



d = [("A",5),("B",3),("C",4),("D",2)] :: [(String,Int)]
--d = [(10,5),(20,3),(30,4),(40,2)] :: [(Sum Int,Int)]
b d = foldl (ins 0) Empty d

t = b d

video - https://youtu.be/Ln_tVErialQ