module Silly_3_1
  ( Tree (..),
    height,
    marked,
    --
    Ctx (..),
    Loc,
    left,
    right,
    top,
    up,
    upmost,
    --
    Order (..),
    harvest,
    harvestLeft,
    harvestRight,
    insert,
    delete,
    leaves,
    make,
    mark,
    minLoc,
    maxLoc,
    modify,
    neighbourLoc,
    path,
    postorder,
    predLoc,
    succLoc,
    toBits,
    toNum,
    unmark,
    visit,
    --
    Set' (..),
    setNew', -- New S
    setInsert', -- S ∪ {i}
    setDelete', -- S \ {j}
    setEmpty', -- S = ∅ ?
    setMin', -- -- Compute the least element of S
    setMax', -- Compute the largest element of S
    setPred', -- Compute the largest element of S < j
    setSucc', -- Compute the least element of S > j
    setNeighbour', -- Compute the neighour of j in S
    setExtractMin', -- Delete the least element from S
    setExtractMax', -- Delete the largest element from S
  )
where

import Control.Exception (assert)
import Data.Bits

-- import Data.List qualified as List

data Tree = Leaf Bool | Node Tree Tree Bool
  deriving (Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> String
(Int -> Tree -> ShowS)
-> (Tree -> String) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tree -> ShowS
showsPrec :: Int -> Tree -> ShowS
$cshow :: Tree -> String
show :: Tree -> String
$cshowList :: [Tree] -> ShowS
showList :: [Tree] -> ShowS
Show, Tree -> Tree -> Bool
(Tree -> Tree -> Bool) -> (Tree -> Tree -> Bool) -> Eq Tree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
/= :: Tree -> Tree -> Bool
Eq)

height :: Tree -> Int
height :: Tree -> Int
height (Leaf Bool
_) = Int
0
height (Node Tree
l Tree
_ Bool
_) = Tree -> Int
height Tree
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

marked :: Tree -> Bool
marked :: Tree -> Bool
marked (Leaf Bool
m) = Bool
m
marked (Node Tree
_ Tree
_ Bool
m) = Bool
m

-- Huet zipper. See
-- http://www.st.cs.uni-sb.de/edu/seminare/2005/advanced-fp/docs/huet-zipper.pdf
-- and https://wiki.haskell.org/Zipper
data Ctx = Top | L Ctx Tree | R Tree Ctx
  deriving (Int -> Ctx -> ShowS
[Ctx] -> ShowS
Ctx -> String
(Int -> Ctx -> ShowS)
-> (Ctx -> String) -> ([Ctx] -> ShowS) -> Show Ctx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ctx -> ShowS
showsPrec :: Int -> Ctx -> ShowS
$cshow :: Ctx -> String
show :: Ctx -> String
$cshowList :: [Ctx] -> ShowS
showList :: [Ctx] -> ShowS
Show, Ctx -> Ctx -> Bool
(Ctx -> Ctx -> Bool) -> (Ctx -> Ctx -> Bool) -> Eq Ctx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ctx -> Ctx -> Bool
== :: Ctx -> Ctx -> Bool
$c/= :: Ctx -> Ctx -> Bool
/= :: Ctx -> Ctx -> Bool
Eq)

type Loc = (Tree, Ctx)

left :: Loc -> Loc
left :: Loc -> Loc
left (Node Tree
l Tree
r Bool
_, Ctx
c) = (Tree
l, Ctx -> Tree -> Ctx
L Ctx
c Tree
r)
left (Leaf Bool
_, Ctx
_) = String -> Loc
forall a. HasCallStack => String -> a
error String
"`left` applied to `Leaf`"

right :: Loc -> Loc
right :: Loc -> Loc
right (Node Tree
l Tree
r Bool
_, Ctx
c) = (Tree
r, Tree -> Ctx -> Ctx
R Tree
l Ctx
c)
right (Leaf Bool
_, Ctx
_) = String -> Loc
forall a. HasCallStack => String -> a
error String
"`right` applied to `Leaf`"

top :: Tree -> Loc
top :: Tree -> Loc
top Tree
t = (Tree
t, Ctx
Top)

up :: Loc -> Loc
up :: Loc -> Loc
up (Tree
t, L Ctx
c Tree
r) = (Tree -> Tree -> Bool -> Tree
Node Tree
t Tree
r (Tree -> Bool
marked Tree
t Bool -> Bool -> Bool
|| Tree -> Bool
marked Tree
r), Ctx
c)
up (Tree
t, R Tree
l Ctx
c) = (Tree -> Tree -> Bool -> Tree
Node Tree
l Tree
t (Tree -> Bool
marked Tree
l Bool -> Bool -> Bool
|| Tree -> Bool
marked Tree
t), Ctx
c)
up (Tree
_, Ctx
Top) = String -> Loc
forall a. HasCallStack => String -> a
error String
"`up` applied to location containing `Top`"

upmost :: Loc -> Loc
upmost :: Loc -> Loc
upmost loc :: Loc
loc@(Tree
_, Ctx
Top) = Loc
loc
upmost Loc
loc = Loc -> Loc
upmost (Loc -> Loc
up Loc
loc)

modify :: Loc -> (Tree -> Tree) -> Loc
modify :: Loc -> (Tree -> Tree) -> Loc
modify (Tree
t, Ctx
c) Tree -> Tree
f = (Tree -> Tree
f Tree
t, Ctx
c)

mark :: Loc -> Loc
mark :: Loc -> Loc
mark (Leaf Bool
_, Ctx
c) = (Bool -> Tree
Leaf Bool
True, Ctx
c)
mark (Node Tree
l Tree
r Bool
_, Ctx
c) = (Tree -> Tree -> Bool -> Tree
Node Tree
l Tree
r Bool
True, Ctx
c)

unmark :: Loc -> Loc
unmark :: Loc -> Loc
unmark (Leaf Bool
_, Ctx
c) = (Bool -> Tree
Leaf Bool
False, Ctx
c)
unmark (Node Tree
l Tree
r Bool
_, Ctx
c) = (Tree -> Tree -> Bool -> Tree
Node Tree
l Tree
r Bool
False, Ctx
c)

leaves :: Tree -> [Loc]
leaves :: Tree -> [Loc]
leaves Tree
t = [Loc] -> [Loc]
forall a. [a] -> [a]
reverse ([Loc] -> [Loc]) -> [Loc] -> [Loc]
forall a b. (a -> b) -> a -> b
$ ([Loc] -> Loc -> [Loc]) -> [Loc] -> Loc -> [Loc]
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder [Loc] -> Loc -> [Loc]
forall {b}. [(Tree, b)] -> (Tree, b) -> [(Tree, b)]
f [] (Tree -> Loc
top Tree
t)
  where
    f :: [(Tree, b)] -> (Tree, b) -> [(Tree, b)]
f [(Tree, b)]
acc (Tree, b)
n = case (Tree, b)
n of (Node {}, b
_) -> [(Tree, b)]
acc; (Leaf {}, b
_) -> (Tree, b)
n (Tree, b) -> [(Tree, b)] -> [(Tree, b)]
forall a. a -> [a] -> [a]
: [(Tree, b)]
acc

insert :: Int -> Tree -> Int -> Tree
insert :: Int -> Tree -> Int -> Tree
insert Int
h Tree
t Int
x =
  Loc -> Tree
forall a b. (a, b) -> a
fst (Loc -> Tree) -> (Loc -> Loc) -> Loc -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
upmost (Loc -> Loc) -> (Loc -> Loc) -> Loc -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
mark (Loc -> Tree) -> Loc -> Tree
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> Tree -> Loc
path
      (Bool -> Int -> Int
forall a. HasCallStack => Bool -> a -> a
assert (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
h) Int
x)
      (Bool -> Int -> Int
forall a. HasCallStack => Bool -> a -> a
assert (Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) Int
h)
      Tree
t

delete :: Int -> Tree -> Int -> Tree
delete :: Int -> Tree -> Int -> Tree
delete Int
h Tree
t Int
x =
  Loc -> Tree
forall a b. (a, b) -> a
fst (Loc -> Tree) -> (Loc -> Loc) -> Loc -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
upmost (Loc -> Loc) -> (Loc -> Loc) -> Loc -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
unmark (Loc -> Tree) -> Loc -> Tree
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> Tree -> Loc
path
      (Bool -> Int -> Int
forall a. HasCallStack => Bool -> a -> a
assert (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
h) Int
x)
      (Bool -> Int -> Int
forall a. HasCallStack => Bool -> a -> a
assert (Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) Int
h)
      Tree
t

make :: Int -> Tree
make :: Int -> Tree
make Int
h =
  let (Tree
t, Int
n) = Int -> (Tree, Int)
make_rec Int
h
   in Bool -> Tree -> Tree
forall a. HasCallStack => Bool -> a -> a
assert
        (Tree -> Int
height Tree
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
h)
        ( Bool -> Tree -> Tree
forall a. HasCallStack => Bool -> a -> a
assert
            (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            Tree
t
        )
  where
    make_rec :: Int -> (Tree, Int)
    make_rec :: Int -> (Tree, Int)
make_rec Int
level =
      case Int
level of
        Int
0 -> (Bool -> Tree
Leaf Bool
False, Int
1)
        Int
_ -> (Tree -> Tree -> Bool -> Tree
Node Tree
l Tree
r Bool
False, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2)
          where
            (Tree
l, Int
c1) = Int -> (Tree, Int)
make_rec (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            (Tree
r, Int
c2) = Int -> (Tree, Int)
make_rec (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

path :: Int -> Int -> (Tree -> Loc)
path :: Int -> Int -> Tree -> Loc
path Int
entry Int
h = (Tree -> Loc) -> Int -> Int -> Tree -> Loc
pathRec Tree -> Loc
top (Bool -> Int -> Int
forall a. HasCallStack => Bool -> a -> a
assert (Int
entry Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
entry Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
h) (Int
entry Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Int
0
  where
    pathRec :: (Tree -> Loc) -> Int -> Int -> (Tree -> Loc)
    pathRec :: (Tree -> Loc) -> Int -> Int -> Tree -> Loc
pathRec Tree -> Loc
acc Int
n Int
i =
      if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
h
        then
          Tree -> Loc
acc
        else
          (Tree -> Loc) -> Int -> Int -> Tree -> Loc
pathRec (Int -> Int -> Int -> Loc -> Loc
dir Int
n Int
i Int
h (Loc -> Loc) -> (Tree -> Loc) -> Tree -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Loc
acc) Int
n (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    -- In `dir x i n`, `x` has length `n` bits, `i` is the bit under
    -- consideration. e.g. when n = 4, x can represent values 0..15.
    -- If x = 13 (0b1101) say, we compute `right . right . left .
    -- right`
    dir :: Int -> Int -> Int -> (Loc -> Loc)
    dir :: Int -> Int -> Int -> Loc -> Loc
dir Int
x Int
i Int
n =
      case (Int
x Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
k of
        Int
0 -> Loc -> Loc
left
        Int
1 -> Loc -> Loc
right
        Int
_ -> String -> Loc -> Loc
forall a. HasCallStack => String -> a
error String
"a match on an impossible case"
      where
        k :: Int
k = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        mask :: Int
mask = Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
k

toBits :: Loc -> [Int]
toBits :: Loc -> [Int]
toBits (Tree
_, Ctx
Top) = []
toBits loc :: Loc
loc@(Tree
_, R Tree
_ Ctx
_) = Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Loc -> [Int]
toBits (Loc -> Loc
up Loc
loc)
toBits loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
_) = Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Loc -> [Int]
toBits (Loc -> Loc
up Loc
loc)

toNum :: Loc -> Int
toNum :: Loc -> Int
toNum l :: Loc
l@(Leaf Bool
_, Ctx
_) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> (Int, Int) -> Int) -> Int -> [(Int, Int)] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc (Int
c, Int
i) -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
i) Int
0 ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Loc -> [Int]
toBits Loc
l) ([Int
0 ..] :: [Int]))
toNum Loc
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"toNum called on non-leaf"

--

data Order = Pre | In | Post

visit :: Order -> (a -> Loc -> a) -> a -> Loc -> a
visit :: forall a. Order -> (a -> Loc -> a) -> a -> Loc -> a
visit Order
Post = (a -> Loc -> a) -> a -> Loc -> a
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder
visit Order
Pre = (a -> Loc -> a) -> a -> Loc -> a
forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder
visit Order
In = (a -> Loc -> a) -> a -> Loc -> a
forall t. (t -> Loc -> t) -> t -> Loc -> t
inorder

preorder :: (t -> Loc -> t) -> t -> Loc -> t
preorder :: forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder t -> Loc -> t
f t
acc loc :: Loc
loc@(Leaf Bool
_, Ctx
_) = t -> Loc -> t
f t
acc Loc
loc
preorder t -> Loc -> t
f t
acc Loc
loc =
  let acc' :: t
acc' = t -> Loc -> t
f t
acc Loc
loc
      acc'' :: t
acc'' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder t -> Loc -> t
f t
acc' (Loc -> Loc
left Loc
loc)
      acc''' :: t
acc''' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder t -> Loc -> t
f t
acc'' (Loc -> Loc
right Loc
loc)
   in t
acc'''

inorder :: (t -> Loc -> t) -> t -> Loc -> t
inorder :: forall t. (t -> Loc -> t) -> t -> Loc -> t
inorder t -> Loc -> t
f t
acc loc :: Loc
loc@(Leaf Bool
_, Ctx
_) = t -> Loc -> t
f t
acc Loc
loc
inorder t -> Loc -> t
f t
acc Loc
loc =
  let acc' :: t
acc' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder t -> Loc -> t
f t
acc (Loc -> Loc
left Loc
loc)
      acc'' :: t
acc'' = t -> Loc -> t
f t
acc' Loc
loc
      acc''' :: t
acc''' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
preorder t -> Loc -> t
f t
acc'' (Loc -> Loc
right Loc
loc)
   in t
acc'''

postorder :: (t -> Loc -> t) -> t -> Loc -> t
postorder :: forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder t -> Loc -> t
f t
acc loc :: Loc
loc@(Leaf Bool
_, Ctx
_) = t -> Loc -> t
f t
acc Loc
loc
postorder t -> Loc -> t
f t
acc Loc
loc =
  let acc' :: t
acc' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder t -> Loc -> t
f t
acc (Loc -> Loc
left Loc
loc)
      acc'' :: t
acc'' = (t -> Loc -> t) -> t -> Loc -> t
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder t -> Loc -> t
f t
acc' (Loc -> Loc
right Loc
loc)
      acc''' :: t
acc''' = t -> Loc -> t
f t
acc'' Loc
loc
   in t
acc'''

--

harvest :: [Loc] -> Loc -> [Loc]
harvest :: [Loc] -> Loc -> [Loc]
harvest [Loc]
ns (Node {}, Ctx
_) = [Loc]
ns
harvest [Loc]
ns (Leaf Bool
False, Ctx
_) = [Loc]
ns
harvest [Loc]
ns n :: Loc
n@(Leaf Bool
True, Ctx
_) = Loc
n Loc -> [Loc] -> [Loc]
forall a. a -> [a] -> [a]
: [Loc]
ns

harvestLeft :: Loc -> [Loc]
harvestLeft :: Loc -> [Loc]
harvestLeft = [Loc] -> Loc -> [Loc]
harvestLeftRec []
  where
    harvestLeftRec :: [Loc] -> Loc -> [Loc]
    harvestLeftRec :: [Loc] -> Loc -> [Loc]
harvestLeftRec [Loc]
ns (Tree
_, Ctx
Top) = [Loc]
ns
    harvestLeftRec [Loc]
ns loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
_) = [Loc] -> Loc -> [Loc]
harvestLeftRec [Loc]
ns (Loc -> Loc
up Loc
loc)
    harvestLeftRec [Loc]
ns loc :: Loc
loc@(Tree
_, R Tree
_ Ctx
_) = [Loc] -> Loc -> [Loc]
harvestLeftRec (([Loc] -> Loc -> [Loc]) -> [Loc] -> Loc -> [Loc]
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder [Loc] -> Loc -> [Loc]
harvest [Loc]
ns (Loc -> Loc
left Loc
parent)) Loc
parent
      where
        parent :: Loc
parent = Loc -> Loc
up Loc
loc

harvestRight :: Loc -> [Loc]
harvestRight :: Loc -> [Loc]
harvestRight = [Loc] -> Loc -> [Loc]
harvestRightRec []
  where
    harvestRightRec :: [Loc] -> Loc -> [Loc]
    harvestRightRec :: [Loc] -> Loc -> [Loc]
harvestRightRec [Loc]
ns (Tree
_, Ctx
Top) = [Loc]
ns
    harvestRightRec [Loc]
ns loc :: Loc
loc@(Tree
_, R Tree
_ Ctx
_) = [Loc] -> Loc -> [Loc]
harvestRightRec [Loc]
ns (Loc -> Loc
up Loc
loc)
    harvestRightRec [Loc]
ns loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
_) = [Loc] -> Loc -> [Loc]
harvestRightRec (([Loc] -> Loc -> [Loc]) -> [Loc] -> Loc -> [Loc]
forall t. (t -> Loc -> t) -> t -> Loc -> t
postorder [Loc] -> Loc -> [Loc]
harvest [Loc]
ns (Loc -> Loc
right Loc
parent)) Loc
parent
      where
        parent :: Loc
parent = Loc -> Loc
up Loc
loc

minLoc :: Loc -> Maybe Loc
minLoc :: Loc -> Maybe Loc
minLoc (Node Tree
_ Tree
_ Bool
False, Ctx
_) = Maybe Loc
forall a. Maybe a
Nothing
minLoc loc :: Loc
loc@(Node Tree
l Tree
_ Bool
True, Ctx
_) | Tree -> Bool
marked Tree
l = Loc -> Maybe Loc
minLoc (Loc -> Loc
left Loc
loc)
minLoc loc :: Loc
loc@(Node Tree
_ Tree
_ Bool
True, Ctx
_) = Loc -> Maybe Loc
minLoc (Loc -> Loc
right Loc
loc)
minLoc loc :: Loc
loc@(Leaf Bool
True, Ctx
_) = Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc
minLoc (Leaf Bool
False, Ctx
_) = Maybe Loc
forall a. Maybe a
Nothing

maxLoc :: Loc -> Maybe Loc
maxLoc :: Loc -> Maybe Loc
maxLoc (Node Tree
_ Tree
_ Bool
False, Ctx
_) = Maybe Loc
forall a. Maybe a
Nothing
maxLoc loc :: Loc
loc@(Node Tree
_ Tree
r Bool
True, Ctx
_) | Tree -> Bool
marked Tree
r = Loc -> Maybe Loc
maxLoc (Loc -> Loc
right Loc
loc)
maxLoc loc :: Loc
loc@(Node Tree
_ Tree
_ Bool
True, Ctx
_) = Loc -> Maybe Loc
maxLoc (Loc -> Loc
left Loc
loc)
maxLoc loc :: Loc
loc@(Leaf Bool
True, Ctx
_) = Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc
maxLoc (Leaf Bool
False, Ctx
_) = Maybe Loc
forall a. Maybe a
Nothing

neighbourLoc :: Loc -> Maybe Loc
neighbourLoc :: Loc -> Maybe Loc
neighbourLoc (Tree
_, Ctx
Top) = Maybe Loc
forall a. Maybe a
Nothing
neighbourLoc loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
r) | Tree -> Bool
marked Tree
r = Loc -> Maybe Loc
minLoc (Loc -> Loc
right (Loc -> Loc
up Loc
loc))
neighbourLoc loc :: Loc
loc@(Tree
_, R Tree
l Ctx
_) | Tree -> Bool
marked Tree
l = Loc -> Maybe Loc
maxLoc (Loc -> Loc
left (Loc -> Loc
up Loc
loc))
neighbourLoc Loc
loc = Loc -> Maybe Loc
neighbourLoc (Loc -> Loc
up Loc
loc)

predLoc :: Loc -> Maybe Loc
predLoc :: Loc -> Maybe Loc
predLoc (Tree
_, Ctx
Top) = Maybe Loc
forall a. Maybe a
Nothing
predLoc loc :: Loc
loc@(Tree
_, R Tree
_ Ctx
_) =
  case Loc -> Maybe Loc
maxLoc (Loc -> Loc
left (Loc -> Loc
up Loc
loc)) of
    r :: Maybe Loc
r@(Just Loc
_) -> Maybe Loc
r
    Maybe Loc
Nothing -> Loc -> Maybe Loc
predLoc (Loc -> Loc
up Loc
loc)
predLoc loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
_) = Loc -> Maybe Loc
predLoc (Loc -> Loc
up Loc
loc)

succLoc :: Loc -> Maybe Loc
succLoc :: Loc -> Maybe Loc
succLoc (Tree
_, Ctx
Top) = Maybe Loc
forall a. Maybe a
Nothing
succLoc loc :: Loc
loc@(Tree
_, L Ctx
_ Tree
_) =
  case Loc -> Maybe Loc
minLoc (Loc -> Loc
right (Loc -> Loc
up Loc
loc)) of
    r :: Maybe Loc
r@(Just Loc
_) -> Maybe Loc
r
    Maybe Loc
Nothing -> Loc -> Maybe Loc
succLoc (Loc -> Loc
up Loc
loc)
succLoc loc :: Loc
loc@(Tree
_, R Tree
_ Ctx
_) = Loc -> Maybe Loc
succLoc (Loc -> Loc
up Loc
loc)

--

type Set = Tree

--

data Set' = Set' Int Set

setNew' :: Int -> Set'
setNew' :: Int -> Set'
setNew' Int
h = Int -> Tree -> Set'
Set' Int
h (Int -> Tree
make Int
h)

setInsert' :: Set' -> Int -> Set'
setInsert' :: Set' -> Int -> Set'
setInsert' (Set' Int
h Tree
s) = Int -> Tree -> Set'
Set' Int
h (Tree -> Set') -> (Int -> Tree) -> Int -> Set'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Tree -> Int -> Tree
insert Int
h Tree
s

setDelete' :: Set' -> Int -> Set'
setDelete' :: Set' -> Int -> Set'
setDelete' (Set' Int
h Tree
s) = Int -> Tree -> Set'
Set' Int
h (Tree -> Set') -> (Int -> Tree) -> Int -> Set'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Tree -> Int -> Tree
delete Int
h Tree
s

setEmpty' :: Set' -> Bool
setEmpty' :: Set' -> Bool
setEmpty' (Set' Int
_ Tree
s) = Bool -> Bool
not (Tree -> Bool
marked Tree
s)

setMin' :: Set' -> Maybe Loc
setMin' :: Set' -> Maybe Loc
setMin' (Set' Int
_ Tree
s) = Loc -> Maybe Loc
minLoc (Tree -> Loc
top Tree
s)

setMax' :: Set' -> Maybe Loc
setMax' :: Set' -> Maybe Loc
setMax' (Set' Int
_ Tree
s) = Loc -> Maybe Loc
maxLoc (Tree -> Loc
top Tree
s)

setPred' :: Loc -> Maybe Loc
setPred' :: Loc -> Maybe Loc
setPred' = Loc -> Maybe Loc
predLoc

setSucc' :: Loc -> Maybe Loc
setSucc' :: Loc -> Maybe Loc
setSucc' = Loc -> Maybe Loc
succLoc

setNeighbour' :: Set' -> Int -> Maybe Loc
setNeighbour' :: Set' -> Int -> Maybe Loc
setNeighbour' (Set' Int
h Tree
s) Int
i = Loc -> Maybe Loc
neighbourLoc (Int -> Int -> Tree -> Loc
path Int
i Int
h Tree
s)

setExtractMin' :: Set' -> Set'
setExtractMin' :: Set' -> Set'
setExtractMin' s :: Set'
s@(Set' Int
h Tree
t) = Int -> Tree -> Set'
Set' Int
h (Tree -> (Loc -> Tree) -> Maybe Loc -> Tree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tree
t (Loc -> Tree
forall a b. (a, b) -> a
fst (Loc -> Tree) -> (Loc -> Loc) -> Loc -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
upmost (Loc -> Loc) -> (Loc -> Loc) -> Loc -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
unmark) (Set' -> Maybe Loc
setMin' Set'
s))

setExtractMax' :: Set' -> Set'
setExtractMax' :: Set' -> Set'
setExtractMax' s :: Set'
s@(Set' Int
h Tree
t) = Int -> Tree -> Set'
Set' Int
h (Tree -> (Loc -> Tree) -> Maybe Loc -> Tree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tree
t (Loc -> Tree
forall a b. (a, b) -> a
fst (Loc -> Tree) -> (Loc -> Loc) -> Loc -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
upmost (Loc -> Loc) -> (Loc -> Loc) -> Loc -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Loc
unmark) (Set' -> Maybe Loc
setMax' Set'
s))