A Simple Symbolic Differentiation Program in Haskell

This program is inspired from, again, SICP. Comparing to the Scheme code (section 2.3.2 of SICP), my program has a front-end parser that converts external representation (a String) of an expression to its internal representation (AST). The purpose of writing this program is to get familiar with the Parsec library in particular and to gain a better understanding of monadic parsers in general.

Loading the program in Hugs, a simple session go like this:

Main> deriv_x "x+3"
1
Main> deriv_x "x*y"
y
Main> deriv_x "(x+3)*x*y"
((x)+((x)+(3)))*(y)
Main> deriv_x "(x+3)^2"
(2)*((x)+(3))

The output is unfortunately cluttered with a lot of unnecessary parenthesizes. This can be solved by writing a specific function that normalize expressions to a canonical form. I am sure there is well-defined algorithm to do this but as I said above, writing a well-polished program doing differentiations really is not the purpose here.  The complete program is list below:

-- Simple symbolic differentiation program

module Main where

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as T
import Text.ParserCombinators.Parsec.Language

-- Symbolic Expression

type Symbol = Char

data Expr = Add Expr Expr
         | Mul Expr Expr
         | Exp Expr Integer
         | Var Symbol
         | Num Integer
           deriving (Eq)

instance Show Expr where
   show e = case e' of
              Num x -> show x
          Var x -> [x]
          Add u v -> "(" ++ show u ++ ")" ++ "+" ++ "(" ++ show v ++ ")"
          Mul u v -> "(" ++ show u ++ ")" ++ "*" ++ "(" ++ show v ++ ")"
          Exp u n -> "(" ++ show u ++ ")" ++ "^" ++ show n
       where e' = simplify e

-- Deriving

deriv_ :: Symbol -> Expr -> Expr
deriv_ x e = simplify $ deriv__ x e
   where deriv__ _ (Num _)             = Num 0
         deriv__ x (Var s) | (s == x)  = Num 1
                           | otherwise = Num 0
         deriv__ x (Add u v)           = Add (deriv__ x u) (deriv__ x v)
         deriv__ x (Mul u v)           = Add (Mul (deriv__ x u) v) (Mul u (deriv__ x v))
         deriv__ x (Exp u n)           = Mul (Mul (Num n) (Exp u (n-1))) (deriv__ x u)

-- Expression Simplifier

simplify :: Expr ->; Expr
simplify e = let e' = simplify' e
            in if e == e' then e else simplify e'
   where
     simplify' e@(Num n)        = e
     simplify' e@(Var x)        = e
     simplify' (Add (Num 0) u)        = u
     simplify' (Add u       (Num 0)) = u
     simplify' (Add (Num n) (Num m))  = Num (n + m)
     simplify' (Add u v)          = Add (simplify' u) (simplify' v)
     simplify' (Mul (Num 0) v)        = Num 0
     simplify' (Mul u       (Num 0)) = Num 0
     simplify' (Mul (Num 1) v)        = v
     simplify' (Mul u       (Num 1)) = u
     simplify' (Mul (Num n) (Num m))  = Num (n * m)
     simplify' (Mul u v)          = Mul (simplify' u) (simplify' v)
     simplify' (Exp u 0)        = Num 1
     simplify' (Exp u 1)        = simplify u
     simplify' (Exp (Num m) n)         = Num (m ^ n)
     simplify' (Exp u n)          = Exp (simplify u) n

-- Parser

lang = T.makeTokenParser emptyDef

natural = T.natural lang
operator c = T.lexeme lang (char c)
variable = T.lexeme lang lower


expr = buildExpressionParser table factor
       "expression"

mkNode :: (Expr -> Expr -> Expr) -> Expr -> Expr -> Expr
mkNode op t1 t2 = op t1 t2

mkAdd = mkNode Add
mkMul = mkNode Mul

mkExp :: Expr -> Expr -> Expr
mkExp e (Num n) = Exp e n
mkExp e _ = error "exponent must be a number"

table   = [[op '^' (mkExp) AssocRight]
         ,[op '*' (mkMul) AssocLeft]
         ,[op '+' (mkAdd) AssocLeft]
         ]
       where
         op c f assoc
            = Infix (do{ operator c; return f} <?> "operator") assoc

factor  =   T.parens lang expr
       <|> do {v <- natural; return $ Num v }
       <|> do {v <- variable; return $ Var v}
       <?> "factor"

-- Driver

parseExpr :: String -> Expr
parseExpr input = case parse expr "" input of
                   Left err -> error $ "parse error at " ++ show err
                   Right out -> out

deriv_x = deriv_ 'x' . parseExpr

"Game of Life" in Haskell

This post includes a Haskell implementation of Conway’s game of life. There is nothing particularly fancy here and the implementation is not of the most efficient one either but, hi, this is my first interactive Haskell program (and it is not hard at all).

type Size = Int
type Cell = (Int, Int)

type Board = [Cell]
data Life = Life Size Board
      
instance Show Life where

  show (Life size board) =
      [if c == size then '\n'

       else if (r, c) `elem` board then '@'

       else '-' | r <- [0..size-1],

                  c <- [0..size]]

next_life :: Life -> Life

next_life (Life size board) = Life size new_board where
  new_board = survivors ++ births
  survivors = [cell | cell <- board,

                      let n = living_neighbors cell
                      in n == 2 || n == 3]

  births = [(r,c) | r <- [0..size-1],

                    c <- [0..size-1],
                    let cell = (r, c)

                    in (not (cell `elem` board)) && ((living_neighbors cell) == 3)]

  living_neighbors cell = length $ filter is_living $ neighbors cell
  is_living        cell = cell `elem` board
  neighbors      (r, c) = [((r - 1) `mod` size, ((c - 1) `mod` size)),

                           ((r - 1) `mod` size, c),

                           ((r - 1) `mod` size, ((c + 1) `mod` size)),

                           (r                 , ((c - 1) `mod` size)),

                           (r                 , ((c + 1) `mod` size)),

                           ((r + 1) `mod` size, ((c - 1) `mod` size)),

                           ((r + 1) `mod` size, c),

                           ((r + 1) `mod` size, ((c + 1) `mod` size))]

interactive :: Life -> IO ()
interactive life
  = do print life
       c <- getChar
       if c == 'q' then

           return ()
       else
           interactive $ next_life life

Loading the above program into Hugs and an interactive session goes like this:

Main> interactive $ Life 5 [(1,3), (2,1), (2,3), (3,2), (3,3)]
-----
---@-
-@-@-
--@@-
-----


-----
--@--
---@@
--@@-
-----


-----
---@-
----@
--@@@
-----


-----
-----
--@-@
---@@
---@-

q

Main>

Have fun!

Huffman Tree Decoder

Section 2.3.3 of SICP contains a program that decodes messages from a pre-built Huffman tree.

 

The Scheme code:

 

(define (make-leaf symbol weight)

  (list 'leaf symbol weight))

 

(define (leaf? object)

  (eq? (car object) 'leaf))

 

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)

  (list left

        right

        (append (symbols left) (symbols right))

        (+ (weight left) (weight right))))

 

(define (left-branch tree) (car tree))

(define (right-branch tree) (cadr tree)) 

(define (symbols tree)

  (if (leaf? tree)

      (list (symbol-leaf tree))

      (caddr tree)))

(define (weight tree)

  (if (leaf? tree)

      (weight-leaf tree)

      (cadddr tree))) 

(define (decode bits tree)

  (define (decode-1 bits current-branch)

    (if (null? bits)

        '()

        (let ((next-branch

               (choose-branch (car bits) current-branch)))

          (if (leaf? next-branch)

              (cons (symbol-leaf next-branch)

                    (decode-1 (cdr bits) tree))

              (decode-1 (cdr bits) next-branch)))))

  (decode-1 bits tree))

 

(define (choose-branch bit branch)

  (cond ((= bit 0) (left-branch branch))

        ((= bit 1) (right-branch branch))

        (else (error "bad bit -- CHOOSE-BRANCH" bit))))

 

The Haskell code that does the same thing:

 

data Bit = B0 | B1

           deriving (Eq, Ord)

 

instance Show Bit where

    show B0 = "0"

    show B1 = "1"

 

type Symbol = Char

type Weight = Int

 

data Tree = Leaf Symbol Weight

          | Node [Symbol] Weight Tree Tree

 

decode :: Tree -> [Bit] -> [Symbol]

decode tree [] = []

decode tree bits = s : decode tree rest

    where (s, rest) = decode1 tree bits

 

decode1 :: Tree -> [Bit] -> (Symbol, [Bit])

decode1 (Node _ _ (Leaf sym _) _           ) (B0:rest) = (sym, rest)

decode1 (Node _ _ left         _           ) (B0:rest) = decode1 left rest

decode1 (Node _ _ _            (Leaf sym _)) (B1:rest) = (sym, rest)

decode1 (Node _ _ _            right       ) (B1:rest) = decode1 right rest

 

-- Test

 

sample_message :: [Bit]

sample_message = [B0, B1, B1, B0, B0, B1, B0, B1, B0, B1, B1, B1, B0]

 

sample_tree :: Tree

sample_tree = Node ['A', 'B', 'C', 'D'] 8

                   (Leaf 'A' 4)

                   (Node ['B', 'C', 'D'] 4

                         (Leaf 'B' 2)

                         (Node ['C', 'D'] 2

                               (Leaf 'C' 1)

                               (Leaf 'D' 1)))

 

-- decode sample_tree sample_message

-- "ACABBDA"

 

Comments:

I think everybody will agree that the Haskell code is much cleaner and more concise than the corresponding Scheme code. I attribute the cleanness and conciseness to Haskell's algebraic data type and pattern matching structure: where in Scheme one express any data structure in lists in Haskell one defines data structures more naturally in data types; where in Scheme one fetch fields of data structures using ca(d*)r, in Haskell one binds fields of data structures to formal parameters via pattern matching.

 

During the course of learning Haskell, I come to the feeling that Scheme is the assembly language for functional programming comparing with Haskell (or ML and the like) in the sense that assembly languages are low-level comparing to C or even C++ in the imperative languages world.

 

Saying Scheme is a low-level language by no means implies that Scheme is a bad functional language. No. I thought and still believe that Scheme is the one of the most elegant programming language in the world. Just as learning an assembly language will help make one a better C programmer, learning Scheme will get one closer to the underlying computation model (Lambda Calculus) that underpins all functional programming languages, so that one can distinguish the essentials from the non-essentials and don't get lost in the complex constructs offered by a modern language like Haskell (However, I do think typing is something essential but totally missing in Scheme).

 

All I am saying is that Scheme remains as a good (perhaps the best) programming language for educational purpose, but for real-world product development, Haskell (or the ML family) is probably a better candidate.

 

P.S.:

Philip Walder has a paper discussing the merit of statically typed, lazy functional programming languages (KRC/Miranda) over dynamically typed, eager evaluation languages (Scheme/Lisp). An enlightening reading.

 

Probabilistic Primitivity Testing

I have been learning Haskell and as an exercise once in a while I will pick up SICP and try to implement some of the programs in Haskell. 

Section 1.2.6 of SICP contains the definition of a function that probabilistically tests if a given natural number n is a prime based on Fermat's Little Theorem. Below is the Scheme code:

(define (expmod base exp m)

  (cond ((= exp 0) 1)

        ((even? exp)

         (remainder (square (expmod base (/ exp 2) m))

                    m))

        (else

         (remainder (* base (expmod base (- exp 1) m))

                    m))))        

(define (fermat-test n)

  (define (try-it a)

    (= (expmod a n n) a))

  (try-it (+ 1 (random (- n 1)))))

(define (fast-prime? n times)

  (cond ((= times 0) true)

        ((fermat-test n) (fast-prime? n (- times 1)))

        (else false)))

And here is the equivalent Haskell code that I wrote:

> import System.Random

> import System.IO.Unsafe

>

> fast_prime         :: Integer -> Int -> Bool

> fast_prime n times = and $ map fermat_test (mkRandomList n times)

>     where fermat_test a = expmod a n n == a

>           expmod base exp m 

>               | (exp == 0) = 1

>               | (even exp) = (square (expmod base (exp `div` 2) m)) `mod` m

>               | otherwise  = (base * (expmod base (exp -1) m)) `mod` m

>           square a = a * a

>           

> mkRandomList :: Integer -> Int -> [Integer]

> mkRandomList n len = 

>     take len $ 

>         unsafePerformIO $ 

>             do g <- getStdGen

>                return $ randomRs (1, n - 1) g

The major difference between the Haskell code and the Scheme code is the part dealing with the random number generator. Where in Scheme a simple call to random() can do, in Haskell, I have to resort to monad, which makes the Haskell code less cleaner than its Scheme counterpart (which is usually not the case in my experience).  But the part that makes me feel most uncomfortable is the call to unsafePerformIO whose very existence implies something "incorrect" here. 

But I have my reasons: I do not want mkRandomList itself to be a monad because that would force all the functions along the calling chain to be inside a monad which is way too clumsy from the point of view of the callers of that function (fast_prime in this case). After all, conceptually mkRandomList is a pure function whose very responsibility is to return a list of seemingly non-related numbers in a certain range. It is supposed to be used just once so it does not matter that subsequent call to it produce the same list.

Or maybe there are better approaches that did not occur to me?