Skip to content

Instantly share code, notes, and snippets.

@pcl-code

pcl-code/ai03.hs

Created Oct 15, 2020
Embed
What would you like to do?
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
You can’t perform that action at this time.