home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101o.zip / Progs / HUGS / Demos / evalred.hs < prev    next >
Text File  |  1995-02-14  |  3KB  |  98 lines
  1. -- This program can be used to solve exercise 1.2.1 in Bird & Wadler's
  2. -- ``Introduction to functional programming'' ....
  3. --
  4. -- Write down the ways to reduce sqr (sqr (3+7)) to normal form
  5. -- (without assuming shared evaluation of function arguments).
  6.  
  7. data  Term  = Square Term      -- The square of a term
  8.             | Plus Term Term   -- The sum of two terms
  9.             | Times Term Term  -- The product of two terms
  10.             | Num Int          -- A numeric constant
  11.  
  12. instance Text Term where
  13.     showsPrec p (Square t)  = showString "sqr " . shows t
  14.     showsPrec p (Plus n m)  = showChar '(' . shows n . showChar '+'
  15.                                            . shows m . showChar ')'
  16.     showsPrec p (Times n m) = showChar '(' . shows m . showChar '*'
  17.                                            . shows n . showChar ')'
  18.     showsPrec p (Num i)     = shows i
  19.  
  20.  
  21. -- What are the subterms of a given term?
  22.  
  23. type Subterm                     = (Term,           -- The subterm expression
  24.                                     Term->Term)     -- A function which embeds
  25.                                                     -- it back in the original
  26.                                                     -- term
  27.  
  28. rebuild                         :: Subterm -> Term
  29. rebuild (t, embed)               = embed t
  30.  
  31. subterms                        :: Term -> [Subterm]
  32. subterms t                       = [ (t,id) ] ++ properSubterms t
  33.  
  34. properSubterms                  :: Term -> [Subterm]
  35. properSubterms (Square t)        = down Square (subterms t)
  36. properSubterms (Plus t1 t2)      = down (flip Plus t2)  (subterms t1) ++
  37.                                    down (Plus t1)       (subterms t2)
  38. properSubterms (Times t1 t2)     = down (flip Times t2) (subterms t1) ++
  39.                                    down (Times t1)      (subterms t2)
  40. properSubterms (Num n)           = []
  41.  
  42. down                            :: (Term -> Term) -> [Subterm] -> [Subterm]
  43. down f                           = map (\(t, e) -> (t, f.e))
  44.  
  45.  
  46. -- Some (semi-)general variations on standard themes:
  47.  
  48. filter'                         :: (a -> Bool) -> [(a, b)] -> [(a, b)]
  49. filter' p                        = filter (p.fst)
  50.  
  51. map'                            :: (a -> b) -> [(a, c)] -> [(b, c)]
  52. map' f                           = map (\(a, c) -> (f a, c))
  53.  
  54.  
  55. -- Reductions:
  56.  
  57. isRedex                         :: Term -> Bool
  58. isRedex (Square _)               = True
  59. isRedex (Plus (Num _) (Num _))   = True
  60. isRedex (Times (Num _) (Num _))  = True
  61. isRedex _                        = False
  62.  
  63. contract                        :: Term -> Term
  64. contract (Square t)              = Times t t
  65. contract (Plus (Num n) (Num m))  = Num (n+m)
  66. contract (Times (Num n) (Num m)) = Num (n*m)
  67. contract _                       = error "Not a redex!"
  68.  
  69. singleStep        :: Term -> [Term]
  70. singleStep         = map rebuild . map' contract . filter' isRedex . subterms
  71.  
  72. normalForms       :: Term -> [Term]
  73. normalForms t 
  74.        | null ts   = [ t ]
  75.        | otherwise = [ n | t'<-ts, n<-normalForms t' ]
  76.                      where ts = singleStep t
  77.  
  78. redSequences      :: Term -> [[Term]]
  79. redSequences t
  80.        | null ts   = [ [t] ]
  81.        | otherwise = [ t:rs | t'<-ts, rs<-redSequences t' ]
  82.                      where ts = singleStep t
  83.  
  84.  
  85. -- Particular example:
  86.  
  87. term0 = Square (Square (Plus (Num 3) (Num 7)))
  88. nfs0  = normalForms term0
  89. rsq0  = redSequences term0
  90.  
  91. -- Using Gofer:
  92. --
  93. -- ? length nfs0
  94. -- 547
  95. -- (188076 reductions, 340335 cells, 4 garbage collections)
  96. -- ?
  97. --
  98.