Haskell implementation of a CHREST discrimination tree
-- 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 "" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment