Initial commit

.gitignore

@@ -0,0 +1 @@
+/dist

LICENSE

@@ -0,0 +1,17 @@
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.

README.md

@@ -0,0 +1,9 @@
+The solve package
+=================
+
+The solve package implements a basic Haskell library for solving and
+analyzing simple games (e.g., Fox & Hounds).
+
+This software is released under the [MIT License][].
+
+[MIT License]: https://github.com/gilith/solve/blob/master/LICENSE "MIT License"

Setup.hs

@@ -0,0 +1,6 @@
+module Main ( main ) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

solve.cabal

@@ -0,0 +1,25 @@
+name: solve
+version: 1.0
+category: Game
+synopsis: Solving simple games
+license: MIT
+license-file: LICENSE
+cabal-version: >= 1.8.0.2
+build-type: Simple
+extra-source-files: README.md
+author: Joe Leslie-Hurd <[email protected]>
+maintainer: Joe Leslie-Hurd <[email protected]>
+description:
+  The solve package implements a basic Haskell library for solving and
+  analyzing simple games (e.g., Fox & Hounds).
+
+Library
+  build-depends:
+    base >= 4.0 && < 5.0,
+    containers >= 0.5.7.1
+  hs-source-dirs: src
+  ghc-options: -Wall
+  exposed-modules:
+    Solve.FoxHounds,
+    Solve.Game,
+    Solve.Util

src/Solve/FoxHounds.hs

@@ -0,0 +1,140 @@
+{- |
+module: $Header$
+description: Fox & Hounds
+license: MIT
+
+maintainer: Joe Leslie-Hurd <[email protected]>
+stability: provisional
+portability: portable
+-}
+
+module Solve.FoxHounds
+where
+
+import qualified Data.Char as Char
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Solve.Game (Game)
+import qualified Solve.Game as Game
+import Solve.Util
+
+-------------------------------------------------------------------------------
+-- Constants
+-------------------------------------------------------------------------------
+
+-- The code assumes the board size is even
+boardSize :: Int
+boardSize = 8
+
+-------------------------------------------------------------------------------
+-- Coordinates
+-------------------------------------------------------------------------------
+
+data Coord =
+    Coord Int Int
+  deriving (Eq,Ord)
+
+instance Show Coord where
+  show (Coord x y) = Char.chr (Char.ord 'a' + x) : show (y + 1)
+
+onBoard :: Coord -> Bool
+onBoard (Coord x y) =
+    0 <= x && x < boardSize &&
+    0 <= y && y < boardSize
+
+rankAdjacent :: Int -> Int -> [Coord]
+rankAdjacent x y = filter onBoard [Coord (x - 1) y, Coord (x + 1) y]
+
+foxAdjacent :: Coord -> [Coord]
+foxAdjacent (Coord x y) = rankAdjacent x (y - 1) ++ rankAdjacent x (y + 1)
+
+houndAdjacent :: Coord -> [Coord]
+houndAdjacent (Coord x y) = rankAdjacent x (y + 1)
+
+-------------------------------------------------------------------------------
+-- Positions
+-------------------------------------------------------------------------------
+
+data Pos =
+    Pos
+      {foxOnMove :: Bool,
+       fox :: Coord,
+       hounds :: Set Coord}
+  deriving (Eq,Ord,Show)
+
+initial :: Pos
+initial =
+    Pos
+      {foxOnMove = True,
+       fox = Coord (2 * (n `div` 2)) (boardSize - 1),
+       hounds = Set.fromList (map (\x -> Coord (2 * x + 1) 0) [0..(n-1)])}
+  where
+    n = boardSize `div` 2
+
+occupied :: Pos -> Coord -> Bool
+occupied p c = c == fox p || Set.member c (hounds p)
+
+empty :: Pos -> Coord -> Bool
+empty p = not . occupied p
+
+-------------------------------------------------------------------------------
+-- Legal moves
+-------------------------------------------------------------------------------
+
+foxMove :: Pos -> [Pos]
+foxMove p = map mk cl
+  where
+    mk c = p {foxOnMove = False, fox = c}
+    cl = filter (empty p) (foxAdjacent (fox p))
+
+houndsMove :: Pos -> [Pos]
+houndsMove p = map mk (updateSet mv (hounds p))
+  where
+    mk hs = p {foxOnMove = True, hounds = hs}
+    mv h = filter (empty p) (houndAdjacent h)
+
+move :: Pos -> [Pos]
+move p = if foxOnMove p then foxMove p else houndsMove p
+
+gameOver :: Pos -> Bool
+gameOver = null . move
+
+-------------------------------------------------------------------------------
+-- Position evaluations
+-------------------------------------------------------------------------------
+
+data Eval =
+    FoxEscape Int
+  | FoxCapture Int
+  deriving (Eq,Show)
+
+instance Ord Eval where
+  compare (FoxEscape n1) (FoxEscape n2) = compare n2 n1
+  compare (FoxEscape _) (FoxCapture _) = GT
+  compare (FoxCapture _) (FoxEscape _) = LT
+  compare (FoxCapture n1) (FoxCapture n2) = compare n1 n2
+
+foxWin :: Eval
+foxWin = FoxEscape 0
+
+houndsWin :: Eval
+houndsWin = FoxCapture 0
+
+delay :: Eval -> Eval
+delay (FoxEscape n) = FoxEscape (n + 1)
+delay (FoxCapture n) = FoxCapture (n + 1)
+
+eval :: Pos -> Either Eval ([Eval] -> Bool -> Eval)
+eval p = if gameOver p then Left result else Right lift
+  where
+    m = foxOnMove p
+    result = if m then houndsWin else foxWin
+    lift es _ = delay (if m then maximum es else minimum es)
+
+-------------------------------------------------------------------------------
+-- Game definition
+-------------------------------------------------------------------------------
+
+game :: Game Pos Eval
+game = Game.Game {Game.move = move, Game.eval = eval}

src/Solve/Game.hs

@@ -0,0 +1,48 @@
+{- |
+module: $Header$
+description: General games
+license: MIT
+
+maintainer: Joe Leslie-Hurd <[email protected]>
+stability: provisional
+portability: portable
+-}
+
+module Solve.Game
+where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Solve.Util
+
+-------------------------------------------------------------------------------
+-- Game definition
+-------------------------------------------------------------------------------
+
+data Game p e =
+  Game
+    {move :: p -> [p],
+     eval :: p -> Either e ([e] -> Bool -> e)}
+
+-------------------------------------------------------------------------------
+-- Game solution
+-------------------------------------------------------------------------------
+
+solve :: Ord p => Game p e -> p -> (e, Map p e)
+solve game = go Set.empty Map.empty
+  where
+    go g db p = (e, Map.insert p e db')
+      where
+        (e,db') = play g db p (eval game p)
+
+    play _ db _ (Left e) = (e,db)
+    play g db p (Right f) = (e,db')
+      where
+        g' = Set.insert p g
+        cs = move game p
+        ps = filter (flip Set.notMember g') cs
+        (es,db') = mapLR (go g') db ps
+        e = f es (length ps < length es)
+

src/Solve/Util.hs

@@ -0,0 +1,82 @@
+{- |
+module: $Header$
+description: Utility functions
+license: MIT
+
+maintainer: Joe Leslie-Hurd <[email protected]>
+stability: provisional
+portability: portable
+-}
+
+module Solve.Util
+where
+
+import Data.List (sortBy)
+import Data.Ord (comparing)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-------------------------------------------------------------------------------
+-- Finding the first satisfying element of a list
+-------------------------------------------------------------------------------
+
+find :: (a -> Bool) -> [a] -> Maybe ([a],a,[a])
+find p = go []
+  where
+    go _ [] = Nothing
+    go xs (x : ys) = if p x then Just (reverse xs, x, ys) else go (x : xs) ys
+
+-------------------------------------------------------------------------------
+-- Mapping with state over a list
+-------------------------------------------------------------------------------
+
+mapLR :: (s -> a -> (b,s)) -> s -> [a] -> ([b],s)
+mapLR _ s [] = ([],s)
+mapLR f s (x : xs) = (y : ys, s'')
+  where
+    (y,s') = f s x
+    (ys,s'') = mapLR f s' xs
+
+mapRL :: (a -> s -> (s,b)) -> [a] -> s -> (s,[b])
+mapRL f = \xs s -> foldr g (s,[]) xs
+  where
+    g x (s,ys) = (s', y : ys) where (s',y) = f x s
+
+-------------------------------------------------------------------------------
+-- Ordering and reordering
+-------------------------------------------------------------------------------
+
+orderBy :: (a -> a -> Ordering) -> [a] -> [(Int,a)]
+orderBy cmp = sortBy cmp2 . zip [0..]
+  where cmp2 (_,x) (_,y) = cmp x y
+
+reorder :: [(Int,a)] -> [a]
+reorder = map snd . sortBy (comparing fst)
+
+-------------------------------------------------------------------------------
+-- An integer nth root function [1] satisfying
+--
+--  0 < n /\ 0 <= k /\ p = nthRoot n k
+-- ------------------------------------
+--        p ^ n <= k < (p + 1) ^ n
+--
+-- 1. https://en.wikipedia.org/wiki/Nth_root_algorithm
+-------------------------------------------------------------------------------
+
+nthRoot :: Integer -> Integer -> Integer
+nthRoot 1 k = k
+nthRoot _ 0 = 0
+nthRoot n k = if k < n then 1 else go (k `div` n)
+  where
+    go x = if x' >= x then x else go x'
+      where
+        x' = ((n - 1) * x + k `div` (x ^ (n - 1))) `div` n
+
+-------------------------------------------------------------------------------
+-- Updating elements of a set
+-------------------------------------------------------------------------------
+
+updateSet :: Ord a => (a -> [a]) -> Set a -> [Set a]
+updateSet f s = Set.foldr g [] s
+  where
+    g x l = map (flip Set.insert (Set.delete x s)) (f x) ++ l