作者 Anonymous [actionscript] 2012-01-14 16:09 (点击下载)

  1. -- file: splay.hs
  2.  
  3. import Prelude hiding (null)
  4.  
  5. data (Ord n) => Splay n = Leaf
  6.     | Bin n (Splay n) (Splay n)
  7.     deriving (Show)
  8.  
  9. null Leaf = True
  10. null (Bin {}) = False
  11.  
  12. singleton k = Bin k Leaf Leaf
  13.  
  14. toList Leaf = []
  15. toList (Bin k l r) = toList l ++ [k] ++ toList r
  16.  
  17. fromSorted [] = Leaf
  18. fromSorted (x : xs) = Bin x Leaf (fromSorted xs)
  19.  
  20. splay Leaf _ = Leaf
  21. splay tr k =
  22.     let
  23.         (kk, ll, rr) = lookup tr [] []
  24.     in
  25.         Bin kk (connl ll) (connr rr)
  26.     where
  27.         connl [] = Leaf
  28.         connl lts = foldl1 ( acc (Bin k l _) -> (Bin k l acc)) lts
  29.         connr [] = Leaf
  30.         connr rts = foldl1 ( acc (Bin k _ r) -> (Bin k acc r)) rts
  31.         lookup tr@(Bin tk lt rt) lts rts =
  32.             if k == tk then
  33.                 (tk, lt : lts, rt : rts)
  34.             else if k < tk then
  35.                 if null lt then
  36.                     (tk, lt : lts, rt : rts)
  37.                 else
  38.                     let 
  39.                         (Bin ltk _ _) = lt
  40.                         tr1@(Bin tk1 lt1 rt1) =
  41.                             if k < ltk then
  42.                                 zig tr
  43.                             else
  44.                                 tr
  45.                     in
  46.                         if null lt1 then
  47.                             (tk1, lt1 : lts, rt1 : rts)
  48.                         else
  49.                             lookup lt1 lts (tr1 : rts)
  50.             else
  51.                 if null rt then
  52.                     (tk, lt : lts, rt : rts)
  53.                 else
  54.                     let
  55.                         (Bin rtk _ _) = rt
  56.                         tr1@(Bin tk1 lt1 rt1) =
  57.                             if k > rtk then
  58.                                 zag tr
  59.                             else
  60.                                 tr
  61.                     in
  62.                         if null rt1 then
  63.                             (tk1, lt1 : lts, rt1 : rts)
  64.                         else
  65.                             lookup rt1 (tr1 : lts) rts
  66.             where
  67.                 zig (Bin x (Bin y at bt) ct) = Bin y at (Bin x bt ct)
  68.                 zag (Bin y at (Bin x bt ct)) = Bin x (Bin y at bt) ct
  69.  
  70. insert Leaf x = singleton x
  71. insert tr x =
  72.     let (Bin k l r) = splay tr x in
  73.         if x < k then
  74.             Bin x l (Bin k Leaf r)
  75.         else
  76.             Bin x (Bin k l Leaf) r
  77.  
  78. delete Leaf x = Leaf
  79. delete tr x =
  80.     let tr1@(Bin k l r) = splay tr x in
  81.         if x /= k then
  82.             tr1
  83.         else
  84.             if null l then
  85.                 r
  86.             else
  87.                 let (Bin kk _ rr) = splay r (x - 1) in
  88.                     Bin kk l rr
  89.  
  90.

提交下面的校正或者修改. (点击这里开始一个新的帖子)
姓名: 在 cookie 中记住我的名字

屏幕抓图:(jpeg 或 png)