home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / EvalRed.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  3.4 KB  |  99 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. module EvalRed where
  8.  
  9. data  Term  = Square Term      -- The square of a term
  10.             | Plus Term Term   -- The sum of two terms
  11.             | Times Term Term  -- The product of two terms
  12.             | Num Int          -- A numeric constant
  13.  
  14. instance Show Term where
  15.     showsPrec p (Square t)  = showString "sqr " . shows t
  16.     showsPrec p (Plus n m)  = showChar '(' . shows n . showChar '+'
  17.                                            . shows m . showChar ')'
  18.     showsPrec p (Times n m) = showChar '(' . shows m . showChar '*'
  19.                                            . shows n . showChar ')'
  20.     showsPrec p (Num i)     = shows i
  21.  
  22.  
  23. -- What are the subterms of a given term?
  24.  
  25. type Subterm                     = (Term,           -- The subterm expression
  26.                                     Term->Term)     -- A function which embeds
  27.                                                     -- it back in the original
  28.                                                     -- term
  29.  
  30. rebuild                         :: Subterm -> Term
  31. rebuild (t, embed)               = embed t
  32.  
  33. subterms                        :: Term -> [Subterm]
  34. subterms t                       = [ (t,id) ] ++ properSubterms t
  35.  
  36. properSubterms                  :: Term -> [Subterm]
  37. properSubterms (Square t)        = down Square (subterms t)
  38. properSubterms (Plus t1 t2)      = down (flip Plus t2)  (subterms t1) ++
  39.                                    down (Plus t1)       (subterms t2)
  40. properSubterms (Times t1 t2)     = down (flip Times t2) (subterms t1) ++
  41.                                    down (Times t1)      (subterms t2)
  42. properSubterms (Num n)           = []
  43.  
  44. down                            :: (Term -> Term) -> [Subterm] -> [Subterm]
  45. down f                           = map (\(t, e) -> (t, f.e))
  46.  
  47.  
  48. -- Some (semi-)general variations on standard themes:
  49.  
  50. filter'                         :: (a -> Bool) -> [(a, b)] -> [(a, b)]
  51. filter' p                        = filter (p.fst)
  52.  
  53. map'                            :: (a -> b) -> [(a, c)] -> [(b, c)]
  54. map' f                           = map (\(a, c) -> (f a, c))
  55.  
  56.  
  57. -- Reductions:
  58.  
  59. isRedex                         :: Term -> Bool
  60. isRedex (Square _)               = True
  61. isRedex (Plus (Num _) (Num _))   = True
  62. isRedex (Times (Num _) (Num _))  = True
  63. isRedex _                        = False
  64.  
  65. contract                        :: Term -> Term
  66. contract (Square t)              = Times t t
  67. contract (Plus (Num n) (Num m))  = Num (n+m)
  68. contract (Times (Num n) (Num m)) = Num (n*m)
  69. contract _                       = error "Not a redex!"
  70.  
  71. singleStep        :: Term -> [Term]
  72. singleStep         = map rebuild . map' contract . filter' isRedex . subterms
  73.  
  74. normalForms       :: Term -> [Term]
  75. normalForms t 
  76.        | null ts   = [ t ]
  77.        | otherwise = [ n | t'<-ts, n<-normalForms t' ]
  78.                      where ts = singleStep t
  79.  
  80. redSequences      :: Term -> [[Term]]
  81. redSequences t
  82.        | null ts   = [ [t] ]
  83.        | otherwise = [ t:rs | t'<-ts, rs<-redSequences t' ]
  84.                      where ts = singleStep t
  85.  
  86.  
  87. -- Particular example:
  88.  
  89. term0 = Square (Square (Plus (Num 3) (Num 7)))
  90. nfs0  = normalForms term0
  91. rsq0  = redSequences term0
  92.  
  93. -- Using Hugs:
  94. --
  95. -- ? length nfs0
  96. -- 547
  97. -- ?
  98. --
  99.