1votos

Montículo binario en Haskell

por josejuan hace 6 años

Una forma sencilla de conseguir un heap binario no basado en arrays es almacenar el nº de nodos que contiene cada nodo; con ésto, las claves pueden ser arbitrariamente largas (sin necesidad de usar ninguna estructura alternativa). Quizás pueda hacerse con Rojo/Negro, pero no veo como alcanzar eficientemente las posiciones de interés (dónde insertar, de dónde sacar para eliminar).

Montículo binario o "binary heap". Estructura optimizada para insertar eficientemente elementos en el montículo y recuperarlos rápidamente por prioridad (primero el menor o primero el mayor).

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 
module Heap 
 ( DCTree 
 , insert 
 , pop 
 , empty 
 ) where 
 
import Prelude hiding (Left, Right) 
import Test.QuickCheck hiding ((.&.)) 
import Data.Maybe (fromJust) 
import Data.Bits ((.&.)) 
 
-- === Tree ================================================================== 
data Tree k e = Empty 
              | Node k e (Tree k e) (Tree k e) 
 
-- lprFold :: (fold function) -> (level -> nextLevel) -> (level data) -> (empty value) -> (tree) -> (folded result) 
lprFold' :: (l -> k -> e -> b -> b -> b) -> (l -> l) -> l -> b -> (Tree k e) -> b 
lprFold' _ _ _ b Empty = b 
lprFold' f nd d b (Node k e l r) = f d k e (lprFold' f nd d' b l) (lprFold' f nd d' b r) where d' = nd d 
 
instance (Show k, Show e) => Show (Tree k e) where 
  show t = tail $ lprFold' (\d k e l r -> d ++ show k ++ ", " ++ show e ++ l ++ r) (\d -> d ++ "   ") "\n" "" t 
 
empty :: Tree k e -> Bool 
empty Empty = True 
empty _     = False 
 
-- === Deep Count Tree ==================================================== 
data DeepCount e = DeepCount Int e 
 
instance Show e => Show (DeepCount e) where 
  show (DeepCount d e) = show e ++ " (" ++ show d ++ ")" 
 
type DCTree k e = Tree k (DeepCount e) 
 
-- count total nodes (this included) 
deep :: DCTree k e -> Int 
deep Empty                        = 0 
deep (Node _ (DeepCount d _) _ _) = d 
 
insert :: Ord k => k -> e -> DCTree k e -> DCTree k e 
insert k e Empty = Node k (DeepCount 1 e) Empty Empty 
insert k e (Node kp (DeepCount dp ep) l r) = 
  let toLeft  = Node kp (DeepCount (dp + 1) ep) (insert k e l) r 
      toRight = Node kp (DeepCount (dp + 1) ep) l (insert k e r) 
      dl = deep l 
  in fst $ adjust $ 
       if dl == 0 || ((dl + 1) .&. dl) /= 0 || (dl == deep r) 
         then toLeft 
         else toRight 
 
data Swap = None | Left | Right deriving Show 
 
adjust :: Ord k => DCTree k e -> (DCTree k e, Swap) 
adjust t = 
  if empty t || empty l         then noswap 
  else if empty r || kl >= kr   then if kp >= kl then noswap 
                                                 else (Node kl (DeepCount dp el) (Node kp (DeepCount dl ep) ll rl) r, Left) 
                                else if kp >= kr then noswap 
                                                 else (Node kr (DeepCount dp er) l (Node kp (DeepCount dr ep) lr rr), Right) 
  where Node kp (DeepCount dp ep) l  r  = t 
        Node kl (DeepCount dl el) ll rl = l 
        Node kr (DeepCount dr er) lr rr = r 
        noswap = (t, None) 
 
adjust' :: Ord k => DCTree k e -> DCTree k e 
adjust' t = case adjust t of 
            (Node kp dp l r, Left ) -> Node kp dp (adjust' l) r 
            (Node kp dp l r, Right) -> Node kp dp l (adjust' r) 
            (t', None) -> t' 
 
pop :: Ord k => DCTree k e -> Maybe (DCTree k e, k, e) 
pop Empty = Nothing 
pop (Node k (DeepCount _ e) Empty Empty) = Just (Empty, k, e) 
pop t = Just (adjust' (Node kL (DeepCount dp eL) l r), kp, ep) 
  where (Node kp (DeepCount dp ep) l r, kL, eL) = dropLast t 
        dropLast (Node k (DeepCount _ e) Empty Empty) = (Empty, k, e) 
        dropLast (Node k (DeepCount d e) l r) = 
          if dr == dl || (dr > 0 && ((dr + 1) .&. dr) /= 0) 
            then (Node k (DeepCount (d - 1) e) l drt, drk, dre) 
            else (Node k (DeepCount (d - 1) e) dlt r, dlk, dle) 
          where dl = deep l 
                dr = deep r 
                (dlt, dlk, dle) = dropLast l 
                (drt, drk, dre) = dropLast r 
 
-- == QuickChecking =========================================== 
 
instance Arbitrary (DCTree Int Int) where 
  arbitrary = listOf1 (arbitrary :: Gen Int) >>= return . foldl (\t k -> insert (abs k) k t) (Empty :: DCTree Int Int) 
 
-- Revisa consistencia 
--     si falla, devuelve el árbol actual. 
--     si correcto, elimina elemento y sigue revisando. 
-- será todo correcto si no quedan elementos. 
checkDCTree :: DCTree Int Int -> DCTree Int Int 
checkDCTree Empty = Empty 
checkDCTree t = if isComplete t && isOrdered t then checkDCTree next 
                                               else t -- Ouch! 
  where (next, _, _) = fromJust $ pop t 
 
 
-- Un árbol es completo si todos sus nodos 2^n están cubiertos 
-- para cada nivel, salvo, quizás, los más a la derecha del último 
-- nivel. 
 
-- Así, un árbol con N nodos, ocupará exactamente L = ceil(log (N + 1) / log 2) 
-- niveles y, además, en el último nivel, los últimos 2^L - 1 - N nodos deben 
-- estar vacíos. 
 
-- Podemos enumerar un árbol de arriba a abajo y de izquierda a derecha, de la 
-- siguiente forma: 
-- 
-- A. El nodo raíz tiene por inicio de enumeración (n=1, p=1). 
-- B. Dado un nodo con enumeración (n, p), las de sus dos hojas inferiores es: 
-- 
--      (n + 1, 2 * p - 1) 
--      (n + 1, 2 * p    ) 
-- 
-- Así, si los niveles son 1..L y Q = N + 1 - 2^(L-1), recorrer el árbol hasta 
-- cada nodo vacío, deberá cumplir que 
-- 
--    if n > L || (n == L && p >= Q) then debe estar vacío 
--                                   else debe estar lleno 
 
isComplete :: DCTree k e -> Bool 
isComplete Empty = True 
isComplete t@(Node _ (DeepCount nodes _) l r) = 
  let levels = ceiling (log (fromIntegral nodes + 1) / log 2) 
      q = nodes + 1 - 2^(levels - 1) 
      check Empty (n, p) = n > levels || (n == levels && p >= q) 
      check (Node _ (DeepCount nodes _) l r) (n, p) = 
        if n > levels || (n == levels && p > q) then False 
                                                 else check l (n + 1, p + p - 1) && check r (n + 1, p + p) 
  in check t (1, 1) 
 
-- Lo de la ordenación es mucho más fácil de checar: 
isOrdered :: Ord k => DCTree k e -> Bool 
isOrdered Empty = True 
isOrdered t@(Node k _ l r) = chk l lk && chk r rk 
  where Node lk _ _ _ = l 
        Node rk _ _ _ = r 
        chk u uk = empty u || (uk <= k && isOrdered u) 
 
-- Hacer un test completo 
doQuickCheck = quickCheck $ empty . checkDCTree 
doLongCheck = quickCheckWith stdArgs { maxSuccess = 5000 } $ empty . checkDCTree 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.