Discussion Session 10: Search

Haskell Syntax

Complicated Haskell programs can be built upon the following syntax.

-- Elementary expression
a = 1
b = "abc"
c = (show a) ++ b

-- "let" expression
x = let
  x = 1  -- binding
  y = 2  -- binding
  sum :: Int -> Int -> Int -- function declaration
  sum a b = a + b  -- function definition
  in
  sum x y

-- "if" expression
y = if x > 0 then 'a'
else 
  if x == 0 then 'b'
  else 'c'

data IList =
  Cons Int IList
 | Nil

xs = Cons 1 (Cons 2 Nil)

-- "case" expression
z = case xs of 
  Cons _ _ -> 1  -- all clauses must be of the same indentation
  Nil -> 2

-- "case" expression
z' = case y of
  'a' -> "a"
  'b' -> "b"
  
fz 'a' = "a"
fz 'b' = "b"
z'' = fz y


-- type of main is IO (), "IO" is a type constructor
main :: IO ()
main = do 
  let
    a = 1 -- Indentation is important
    b = let
      c = 1
      in
      a + c
  putStrLn (show z)  -- The following two lines are of the same indentation.
  putStrLn (show z)

Concept

• State
• Search Tree / Graph
• Strategy
• Solution / Best Solution

Code Example

8-Queen problem

module EightQueen where

data Cell = E | Q deriving (Show)
type Position = (Integer, Integer)
data Board = Board [Position]

data Graph = 
   Branch Board [Graph]
 | Finish Board

instance Show Board where
  show (Board xs) = let
    show_line_loop cur pos len accu =
      if cur >= len then accu
      else if cur == pos then show_line_loop (cur + 1) pos len (accu ++ "Q ")
      else show_line_loop (cur + 1) pos len (accu ++ ". ")

    show_loop ((_, pos) : tail) accu = let
        new_line = show_line_loop 0 pos 8 ""
      in
        show_loop tail (accu ++ new_line ++ "\n")
    
    show_loop [] accu = accu

    in
      show_loop xs ""
       
nextMoves :: Board -> [Board]
nextMoves (Board xs) = let
    row = toInteger (length xs)
    cols = [0 .. 7]
    candidates = [(row, y) | y <- cols]

    conflict :: Position -> Position -> Bool
    conflict (x1,y1) (x2,y2) = if y1 == y2 then True
                               else if abs(x1 - x2) == abs(y1 - y2) then True
                               else False

    conflict_list :: Position -> [Position] -> Bool
    conflict_list x (head : tail) = (conflict x head) || (conflict_list x tail)
    conflict_list x [] = False

    new_moves = [c | c <- candidates, (conflict_list c xs) == False]

    new_boards = [Board (xs ++ [pos]) | pos <- new_moves]
  in
    new_boards

graph :: Board -> Graph
graph (Board xs) = if (length xs) >= 8 then Finish (Board xs)
                   else let
                       new_boards = nextMoves (Board xs)
                     in
                       if length(new_boards) == 0 then Finish (Board xs)
                       else let
                           new_graphs = [graph b | b <- new_boards]
                         in
                           Branch (Board xs) new_graphs


is_sol :: Board -> Bool
is_sol (Board xs) = (length xs) == 8

find_sol :: Graph -> [Board]
find_sol (Branch b gs) = let
  bss = [find_sol g | g <- gs]
  bs = foldl (\x -> \y -> x ++ y) [] bss
  in
  if is_sol b then b : bs
  else bs

find_sol (Finish b) = 
  if is_sol b then [b]
  else []

search_space = graph (Board [])
sol = find_sol (search_space)

show_boards (b : bs) = (show b) ++ "\n\n\n" ++ (show_boards bs)
show_boards [] = "\n"

main :: IO ()
main = do putStrLn (show_boards sol)
          putStrLn $ "Total solutions found: " ++ show (length sol)



  

Solution: eightqueens.hs Makefile

Regular Expression Match

module RegExp where

data Regexp = 
   REnil
 | REemp
 | REany
 | REchar Char
 | REalt Regexp Regexp
 | REcat Regexp Regexp
 | REstar Regexp

string_regexp_match str reg = let
  str_isempty :: String -> Bool
  str_isempty [] = True
  str_isempty _ = False
  in
  accept str reg str_isempty

accept str reg k =
  case reg of
  REnil -> False
  REemp -> k str
  REany -> (case str of 
            _ : cs -> k cs
            [] -> False
           )
  REchar c -> (case str of
            c' : cs -> if c == c' then k cs else False
            [] -> False
            )
  REalt reg1 reg2 -> if accept str reg1 k then True
                     else accept str reg2 k
  REcat reg1 reg2 -> let
    k' xs = accept xs reg2 k
    in
    accept str reg1 k'
  REstar reg0 -> if k str then True
                else let
                  k' xs = if (length xs) == (length str) then False
                          else accept xs reg k
                  in
                  accept str reg0 k'


main = do 
  let
    reg_a = REchar 'a'
    reg_b = REchar 'b'
    reg_ab = REalt reg_a reg_b
    reg_abs = REcat reg_ab (REstar reg_ab)
    reg_as = REstar reg_a
    reg_ass = REstar reg_as
  putStrLn $ show $ string_regexp_match "abaaab" reg_abs
  putStrLn (show (string_regexp_match "ac" reg_abs))
  putStrLn (show (string_regexp_match "aa" reg_ass))
  

Solution: regexp.hs Makefile

Misc

Some syntax sugar first.

The followings are equivalent:

putStrLn (show (1 + 1))
putStrLn $ show $ 1 + 1
putStrLn . show $ 1 + 1

The $ sign is used to avoid parenthesis. Whatever on the right of it takes precedence. . sign is used to chain functions. The output of RHS will be the input of LHS.

And here is a very good place to lookup useful functions in the Prelude module of Haskell. http://hackage.haskell.org/package/base-4.6.0.1/docs/Prelude.html