staticfm.hs

深入理解计算机系统（computer system：a programmer s perpective)是一本非常经典的教材

{------------------------------------------------------------------------}
{--- Trivial finite maps implemented by balanced trees, where the     ---}
{--- set of keys is known at the outset.                  StaticFM.hs ---}
{------------------------------------------------------------------------}

{- 
   This file is part of Cacheprof, a profiling tool for finding
   sources of cache misses in programs.

   Copyright (C) 1999 Julian Seward ([e-mail])
   Home page: http://www.cacheprof.org

   This program is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of the
   License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
   02111-1307, USA.

   The GNU General Public License is contained in the file LICENSE.
-}

module StaticFM (
   StaticFM,
   createSFM,
   maybeFindSFM,
   findSFM,
   updateSFM,
   flattenSFM
) 
where

import List(sort)

data StaticFM k v 
   = SFM_Nil
   | SFM_Node (StaticFM k v) k v (StaticFM k v)
     deriving Show

-- Try to find something in the mapping, failing gracefully
maybeFindSFM :: Ord k => StaticFM k v -> k -> Maybe v
maybeFindSFM SFM_Nil k 
   = Nothing
maybeFindSFM (SFM_Node ll kk vv rr) k
   = case compare k kk of
        LT -> maybeFindSFM ll k
        EQ -> Just vv
        GT -> maybeFindSFM rr k

-- harsher version of the above; die if we can't find the key
findSFM :: Ord k => StaticFM k v -> k -> v
findSFM SFM_Nil k 
   = error "StaticFM.findSFM: can't find key"
findSFM (SFM_Node ll kk vv rr) k
   = case compare k kk of
        LT -> findSFM ll k
        EQ -> vv
        GT -> findSFM rr k


-- update a mapping, given some function to apply to a
-- specified key.  Die if the key isn't present.
updateSFM :: Ord k => StaticFM k v -> k -> (v -> v) -> StaticFM k v
updateSFM SFM_Nil k f
   = error "StaticFM.updateSFM: can't find key"
updateSFM (SFM_Node ll kk vv rr) k f
   = case compare k kk of
        LT -> SFM_Node (updateSFM ll k f) kk vv rr
        EQ -> SFM_Node ll kk (f vv) rr
        GT -> SFM_Node ll kk vv (updateSFM rr k f)


-- flatten a mapping into a list of (key,value) pairs,
-- guaranteed to be in increasing (Ord-)order of they keys.
flattenSFM sfm
   = loop [] sfm
     where
        loop acc SFM_Nil            = acc
        loop acc (SFM_Node l k v r) = loop ((k,v):loop acc r) l


-- Construct a tree, as close to balanced as possible, given a 
-- bunch of keys and a default value.  This is the only place we
-- bother to think about balancing.
createSFM :: Ord k => [k] -> v -> StaticFM k v
createSFM ks v
   = let ks2 = deDup (sort ks)
         len = length ks2

         --loop :: Ord k => Int -> [k] -> StaticFM k v
         loop len_ks ks
            | len_ks == 0
            = SFM_Nil
            | otherwise
            = let len2_ks = (len_ks-1) `div` 2
              in  case splitAt len2_ks ks of
                     (lesses, (eq:greaters))
                        -> SFM_Node
                              (loop len2_ks lesses)
                              eq v
                              (loop (len_ks - len2_ks - 1) greaters)
                     (_, [])
                        -> error "createSFM: internal consistency error"
     in
         loop len ks2

-- nuke adjacent duplicates in a list
deDup :: Eq a => [a] -> [a]
deDup []  = []
deDup [x] = [x]
deDup (x:y:rest)
   = if x == y then deDup (y:rest) else x: deDup (y:rest)

{------------------------------------------------------------------------}
{--- end                                                  StaticFM.hs ---}
{------------------------------------------------------------------------}