tiny tweaks for tail call performance.

Heuristics.hs

@@ -10,8 +10,8 @@ module Heuristics
     ) where
 
 import Types
-import Data.List (transpose, elem, elemIndices, intersperse, (\\))
-import Data.Function
+import Data.List (transpose, elem, elemIndices, intersperse, (\\), foldl')
+import Data.Function (on)
 
 -- Get empty cell positions
 emptyCells :: Board -> [(Int, Int)]
@@ -25,11 +25,11 @@ heuristicSort = flip compare `on` heuristicSum
 
 -- Score from a collection of heuristics
 heuristicSum :: AIScore -> Score
-heuristicSum x = round (s + (log sp * mx) + sp + m - c)
+heuristicSum x = if (sp > 0) then round (s + (sp * m) - w) else -1000000000
     where s = fromIntegral $ score x
           m = fromIntegral $ monotonicity x
           sp = fromIntegral $ space x
-          c = fromIntegral $ weight x
+          w = fromIntegral $ weight x
           mx = fromIntegral $ maxBoard x
 
 monotonic :: Board -> Int
@@ -39,12 +39,12 @@ monotonic b = m left + m down
           down = transpose left
 
 monotonicityList :: Ord a => [a] -> Int
-monotonicityList xs = abs $ ml xs
-    where ml []       = 0
-          ml [x]      = 0
-          ml [x, y]   = (m x y)
-          ml (x:y:xs) = (m x y) + ml (y:xs)
-          m x y 
+monotonicityList xs = abs $ ml 0 xs
+    where ml acc []       = acc
+          ml acc [x]      = acc
+          ml acc [x, y]   = acc + (monoScore x y)
+          ml acc (x:y:xs) = ml (acc + monoScore x y) (y:xs)
+          monoScore x y 
             | x >= y           = 1
             | otherwise        = -1
 
@@ -54,15 +54,20 @@ openSpace = length . emptyCells
 maxOnBoard :: Board -> Int
 maxOnBoard b = maximum $ map (maximum) b
 
+-- Heuristic summing the distance between neighboring cells
+-- This scoring prefers high value tiles to neighor each other and 
+-- amass near the edges of the board.
 neighborWeight :: Board -> Int
-neighborWeight b = (sum (map (rowWeight) b)) + (sum (map (rowWeight) (transpose b)))
+neighborWeight b = left b + down b
+    where sumWeight acc row = acc + rowWeight row
+          left = foldl' (sumWeight) 0
+          down    = left . transpose
 
 rowWeight :: Row -> Int
-rowWeight xs = abs $ (sumRow xs)
-    where rowWeight xs = abs $ sumRow xs
-          sumRow [x, y, z]   = sumNeighbors (Just x, Just y, Just z)
-          sumRow [x, y]   = (sumNeighbors (Just x, Just y, Nothing))
-          sumRow (x:y:z:xs) = (sumNeighbors (Just x, Just y, Just z)) + sumRow (y:z:xs)
+rowWeight xs = abs $ sumRow 0 xs
+    where sumRow acc [x, y, z]   = acc + sumNeighbors (Just x, Just y, Just z)
+          sumRow acc [x, y]   = acc + (sumNeighbors (Just x, Just y, Nothing))
+          sumRow acc (x:y:z:xs) = sumRow (acc + sumNeighbors (Just x, Just y, Just z)) (y:z:xs)
           sumNeighbors (Just x, Just y, Just z) = (abs $ y - x) + (abs $ y - z)
           sumNeighbors (Just x, Just y, Nothing) = (abs $ y - x)
 

Main.hs

@@ -9,6 +9,6 @@ main = do
     grockArg $ args !! 0
     where grockArg a
             | a == "u" = U.main U.userCommand
-            | a == "a" = U.main $ U.aiCommand 5
+            | a == "a" = U.main $ U.aiCommand 3
             | a == "r" = R.main
             | otherwise = U.main U.userCommand

TwentyFortyEight.hs

@@ -173,17 +173,17 @@ moveTree w depth c
           score = snd w
           makeMove command = let (newBoard, moveScore) = moveBoard board command in
               (command, (newBoard, getSum moveScore + score))
-          nextMoves (command, (newBoard, newScore)) = let world = (worstBoard newBoard, newScore) in
+          nextMoves (command, (newBoard, newScore)) = let world = (worstBoard depth newBoard, newScore) in
               moveTree world (depth - 1) (if c == NoCommand then command else c)
 
 -- Sort boards by their heuristic score
 pruneBoards :: [(Command, (Board, Score))] -> [(Command, (Board, Score))]
 pruneBoards bs = take prune $ sortBy (flip compare `on` (heuristicSum . (\(c, (board, score)) -> heuristic c score board))) bs
     where prune = if length bs > 1 then length bs - 1 else 2
 
-worstBoard :: Board -> Board
-worstBoard b = head $ sortBy (compare `on` (length . possibleMoves)) boards
-    where boards = map (\x -> mutateBoard b x 2) (emptyCells b)
+worstBoard :: Int -> Board -> Board
+worstBoard depth b = head $ sortBy (compare `on` (length . possibleMoves)) boards
+    where boards = map (\x -> mutateBoard b x (if (mod depth 3 > 1) then 4 else 2)) (emptyCells b)
 
 bestCommand :: [AIScore] -> AIScore
 bestCommand x = head $ sortBy (heuristicSort) x