Haskell implementation of a CHREST discrimination tree

ai03.hs

-- This code was used in the paper: 
-- P.C.R. Lane and F.Gobet, 
-- 'Developing reproducible and comprehensible computational models,' 
-- Artificial Intelligence, 144:251-263, 2003.
--
-- Run it using the Glasgow Haskell Compiler, e.g.: ghci ai03.hs -e main

data PIECE = PIECE{xCoord, yCoord::Int, piece::Char}
      deriving (Eq,Show)
data NODE = NODE{image::[PIECE], children::[LINK]}
      deriving (Eq,Show)
data LINK = LINK{test::PIECE, node::NODE}
      deriving (Eq,Show)

learn (NODE image links) example
  | (null validLinks) && (image `matches` example)
    = familiarise (NODE image links) example
  | (null validLinks) && (not(image `matches` example))
    = discriminate (NODE image links) example
  | otherwise = NODE image newLinks
  where validLinks = [link | link <- links, (test link) `elem` example]
        takenLink = head validLinks
        otherLinks = [link | link <- links,link /= takenLink]
        newLinks = (LINK (test takenLink) (learn (node takenLink) example))
                    : otherLinks
        xs `matches` ys = (take (length xs) ys) == xs

familiarise (NODE image links) example 
  | image /= example = NODE (image++[nextItem]) links
  | otherwise = NODE image links
  where nextItem = example!!(length image)

discriminate (NODE image links) example = NODE image (newLink:links)
  where newTest = snd(head (dropWhile (\(x,y) -> x==y) (zip image example)))
        newLink = LINK newTest (NODE[][])

runTests = performTests [((tree1'==tree2),"Familiarise"),
                         ((tree2'==tree3),"Discriminate")]
  where tree1 = NODE [PIECE 7 8 'n']
                     [LINK (PIECE 1 2 'P')
                           (NODE[PIECE 1 2 'P'] [])]
        tree2 = NODE [PIECE 7 8 'n']
                      [LINK (PIECE 1 2 'P')
                            (NODE [PIECE 1 2 'P',PIECE 1 1 'R'] [])]
        tree3 = NODE [PIECE 7 8 'n']
                     [LINK(PIECE 1 2 'P')
                          (NODE [PIECE 1 2 'P',PIECE 1 1 'R']
                                [LINK(PIECE 1 1 'Q')(NODE [] [])])]
        tree1' = learn tree1 [PIECE 1 2 'P', PIECE 1 1 'R']
        tree2' = learn tree2 [PIECE 1 2 'P', PIECE 1 1 'Q']

performTests = putStr.concat.(map doTest)
  where doTest(bool,str)
            | bool = "."
            | otherwise = "\n"++str++"\n"

main = do 
        putStrLn "Running Tests: "
        runTests
        putStrLn ""