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

-- file: splay.hs
 
import Prelude hiding (null)
 
data (Ord n) => Splay n = Leaf
    | Bin n (Splay n) (Splay n)
    deriving (Show)
 
null Leaf = True
null (Bin {}) = False
 
singleton k = Bin k Leaf Leaf
 
splay Leaf _ = Leaf
splay tr k =
    let
        (kk, ll, rr) = lookup tr [] []
    in
        Bin kk (connl ll) (connr rr)
    where
        connl [] = Leaf
        connl lts = foldl1 ( acc (Bin k l _) -> (Bin k l acc)) lts
        connr [] = Leaf
        connr rts = foldl1 ( acc (Bin k _ r) -> (Bin k acc r)) rts
        lookup tr@(Bin tk lt rt) lts rts =
            if k == tk then
                (tk, lt : lts, rt : rts)
            else if k < tk then
                if null lt then
                    (tk, lt : lts, rt : rts)
                else
                    let 
                        (Bin ltk _ _) = lt
                        tr1@(Bin tk1 lt1 rt1) =
                            if k < ltk then
                                zig tr
                            else
                                tr
                    in
                        if null lt then
                            (tk1, lt1 : lts, rt1 : rts)
                        else
                            lookup lt1 lts (tr1 : rts)
            else
                if null rt then
                    (tk, lt : lts, rt : rts)
                else
                    let
                        (Bin rtk _ _) = rt
                        tr1@(Bin tk1 lt1 rt1) =
                            if k > rtk then
                                zag tr
                            else
                                tr
                    in
                        if null rt then
                            (tk1, lt1 : lts, rt1 : rts)
                        else
                            lookup lt1 (tr1 : lts) rts
            where
                zig (Bin x (Bin y at bt) ct) = Bin y at (Bin x bt ct)
                zag (Bin y at (Bin x bt ct)) = Bin x (Bin y at bt) ct