bundles/org.simantics.scl.runtime/scl/ISet.scl

   1 import "Prelude"
   2
   3 data Set a = Empty
   4            | Cons Integer (Set a) a (Set a)
   5
   6 @private
   7 cons :: Set a -> a -> Set a -> Set a
   8 cons l x r = Cons (size l + size r + 1) l x r
   9
  10 @private
  11 rotateSingleL l x (Cons _ m y r) = cons (cons l x m) y r
  12
  13 @private
  14 rotateSingleR (Cons _ l x m) y r = cons l x (cons m y r)
  15
  16 @private
  17 rotateDoubleL l x (Cons _ (Cons _ m1 y m2) z r) = cons (cons l x m1) y (cons m2 z r)
  18
  19 @private
  20 rotateDoubleR (Cons _ l x (Cons _ m1 y m2)) z r = cons (cons l x m1) y (cons m2 z r)
  21
  22 @private
  23 balance :: Set a -> a -> Set a -> Set a
  24 balance l x r =
  25     let ln = size l
  26         rn = size r
  27     in  if ln + rn < 2 then cons l x r
  28         else if rn > 4*ln then
  29             let (Cons _ rl _ rr) = r
  30             in  if size rl < 2 * size rr
  31                 then rotateSingleL l x r
  32                 else rotateDoubleL l x r
  33         else if ln > 4*rn then
  34             let (Cons _ ll _ lr) = l
  35             in  if size lr < 2 * size ll
  36                 then rotateSingleR l x r
  37                 else rotateDoubleR l x r
  38         else cons l x r
  39
  40 isEmpty :: Set a -> Boolean
  41 isEmpty Empty = True
  42 isEmpty _ = False
  43
  44 size :: Set a -> Integer
  45 size Empty = 0
  46 size (Cons s _ _ _) = s
  47
  48 member :: Ord a => a -> Set a -> Boolean
  49 member _ Empty = False
  50 member x (Cons _ l y r) =
  51     let cmp = compare x y in
  52     if cmp < 0
  53     then member x l
  54     else if cmp > 0
  55     then member x r
  56     else True
  57
  58 empty :: Set a
  59 empty = Empty
  60
  61 singleton :: a -> Set a
  62 singleton x = Cons 1 Empty x Empty
  63
  64 insert :: Ord a => Set a -> a -> Set a
  65 insert Empty x = singleton x
  66 insert c@(Cons i l y r) x =
  67     let cmp = compare x y in
  68     if cmp < 0
  69     then balance (insert l x) y r
  70     else if cmp > 0
  71     then balance l y (insert r x)
  72     else c
  73
  74 delete :: Ord a => Set a -> a -> Set a
  75 delete Empty _ = Empty
  76 delete (Cons _ l y r) x =
  77     let cmp = compare x y in
  78     if cmp < 0
  79     then balance (delete l x) y r
  80     else if cmp > 0
  81     then balance l y (delete r x)
  82     else aux l r
  83   where
  84     aux Empty r = r
  85     aux l Empty = l
  86     aux l r = let (x, rr) = delmin r
  87               in balance l x rr
  88
  89 delmin :: Ord a => Set a -> (a, Set a)
  90 delmin (Cons _ Empty x r) = (x, r)
  91 delmin (Cons _ l x r) = let (y, ll) = delmin l
  92                         in (y, balance ll x r)
  93 delmin _ = fail "Empty set given to delmin."
  94
  95 union :: Ord a => Set a -> Set a -> Set a
  96 union Empty b = b
  97 union a Empty = a
  98 union a (Cons _ l x r) =
  99     let l' = splitL a x
 100         r' = splitR a x
 101     in concat3 (union l' l) x (union r' r)
 102
 103 splitL :: Ord a => Set a -> a -> Set a
 104 splitL Empty _ = Empty
 105 splitL (Cons _ l x r) y =
 106     let cmp = compare x y in
 107     if cmp < 0
 108     then concat3 l x (splitL r y)
 109     else if cmp > 0
 110     then splitL l y
 111     else l
 112
 113 splitR :: Ord a => Set a -> a -> Set a
 114 splitR Empty _ = Empty
 115 splitR (Cons _ l x r) y =
 116     let cmp = compare x y in
 117     if cmp < 0
 118     then splitR r y
 119     else if cmp > 0
 120     then concat3 (splitR l y) x r
 121     else r
 122
 123 concat3 :: Ord a => Set a -> a -> Set a -> Set a
 124 concat3 Empty x r = insert r x
 125 concat3 l x Empty = insert l x
 126 concat3 l@(Cons n1 l1 v1 r1) x r@(Cons n2 l2 v2 r2) =
 127     if 4*n1 < n2
 128     then balance (concat3 l x l2) v2 r2
 129     else if 4*n2 < n1
 130     then balance l1 v1 (concat3 r1 x r)
 131     else cons l x r
 132
 133 fold :: (a -> b -> a) -> a -> Set b -> a
 134 fold f init Empty = init
 135 fold f init (Cons _ l x r) = fold f (f (fold f init l) x) r
 136
 137 instance (Show a) => Show (Set a) where
 138     sb <+ t = p True True t
 139       where
 140         p lm rm Empty = sb <<
 141             if lm
 142             then (if rm then "empty" else "set [")
 143             else (if rm then "]" else ", ")
 144         p lm rm (Cons _ l x r) = do
 145             p lm False l
 146             sb <+ x
 147             p False rm r
 148
 149 set :: Ord a => [a] -> Set a
 150 set = foldl insert empty