board-games 0.1.0.6 → 0.2

raw patch · 15 files changed

+448/−201 lines, 15 filesdep +non-emptydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: non-empty

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• board-games.cabal +10/−4
• src/Game/Mastermind.hs +120/−40
• src/Game/Mastermind/CodeSet.hs +44/−31
• src/Game/Mastermind/CodeSet/Tree.hs +44/−21
• src/Game/Mastermind/CodeSet/Union.hs +37/−25
• src/Game/Mastermind/HTML.hs +25/−18
• src/Game/Server.hs +1/−0
• src/Game/Test/Mastermind.hs +82/−40
• src/Game/Tree.hs +19/−3
• src/Game/Utility.hs +17/−0
• src/Game/VierGewinnt.hs +16/−3
• src/Game/VierGewinnt/HTML.hs +5/−1
• src/Game/VierGewinnt/Text.hs +3/−1
• src/Game/ZeilenSpalten.hs +18/−4
• src/Game/ZeilenSpalten/HTML.hs +7/−10

@@ -1,5 +1,5 @@ Name:             board-games-Version:          0.1.0.6+Version:          0.2 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -29,14 +29,14 @@   Currently the games use German texts.   I wanted to use gettext, but this is not thread-safe. Tested-With:       GHC==6.4.1, GHC==6.8.2, GHC==6.12.3-Cabal-Version:     >=1.8+Cabal-Version:     1.14 Build-Type:        Simple Source-Repository head   type:     darcs   location: http://code.haskell.org/~thielema/games/  Source-Repository this-  tag:      0.1.0.6+  tag:      0.2   type:     darcs   location: http://code.haskell.org/~thielema/games/ @@ -50,17 +50,19 @@   Build-Depends:     html >=1.0 && <1.1,     cgi >=3001.1 && <3002,+    non-empty >=0.2 && <0.4,     utility-ht >=0.0.3 && <0.1,     transformers >=0.2.2 && <0.6   If flag(splitBase)     Build-Depends:-      containers >=0.2 && <0.6,+      containers >=0.2 && <0.7,       random >=1.0 && <1.2,       array >=0.1 && <0.6,       base >= 2 && <5   Else     Build-Depends: base >= 1.0 && < 2 +  Default-Language: Haskell2010   GHC-Options:      -Wall   Hs-Source-Dirs:   src   Exposed-Modules:@@ -79,6 +81,7 @@     Game.Utility  Executable board-games+  Default-Language: Haskell2010   Main-Is:          Game/Server.hs   GHC-Options:      -Wall   Hs-Source-Dirs:   src@@ -90,6 +93,7 @@       network-uri >=2.6 && <2.7,       html,       cgi,+      non-empty,       utility-ht >=0.0.3 && <0.1,       transformers,       containers,@@ -101,6 +105,7 @@  Test-Suite testsuite   Type:             exitcode-stdio-1.0+  Default-Language: Haskell2010   Main-Is:          Game/Test.hs   GHC-Options:      -Wall   Hs-Source-Dirs:   src@@ -108,6 +113,7 @@     Game.Test.Mastermind   Build-Depends:     QuickCheck >1.2 && <3.0,+    non-empty,     utility-ht >=0.0.3 && <0.1,     transformers,     containers,

@@ -1,19 +1,36 @@-module Game.Mastermind where+module Game.Mastermind (+   Eval(Eval),+   evaluate,+   matching,+   matchingSimple, +   mixedRandomizedAttempt,+   partitionSizes,++   mainSimple,+   mainRandom,+   main,++   propBestSeparatingCode,+   ) where+ import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree -- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion import qualified Game.Mastermind.CodeSet as CodeSet import Game.Mastermind.CodeSet    (flatten, intersection, (*&), (#*&), unit, empty, union, unions, cube, )+import Game.Utility (randomSelect, ) +import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.Map as Map import qualified Data.Set as Set +import Data.NonEmpty ((!:)) import Data.List.HT (partition, ) import Data.Tuple.HT (mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (listToMaybe, )-import Control.Monad (liftM, guard, when, replicateM, )+import Control.Monad (guard, when, replicateM, )  import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Class as Trans@@ -23,7 +40,7 @@   data Eval = Eval Int Int-   deriving (Eq, Show)+   deriving (Eq, Ord, Show)  {- | Given the code and a guess, compute the evaluation.@@ -42,7 +59,7 @@ {- *Game.Mastermind> filter ((Eval 2 0 ==) . evaluate "aabbb") $ replicateM 5 ['a'..'c'] ["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"]-*Game.Mastermind> flatten $ remaining (Set.fromList ['a'..'c']) "aabbb" (Eval 2 0)+*Game.Mastermind> flatten $ matching (Set.fromList ['a'..'c']) "aabbb" (Eval 2 0) ["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"] -} @@ -60,10 +77,10 @@ A variant of the game: It is only possible to specify number of symbols at right places. -The results of 'remaining' and 'remainingSimple' cannot be compared.+The results of 'matching' and 'matchingSimple' cannot be compared. -}-remainingSimple :: Ord a => Set.Set a -> [a] -> Int -> [[Set.Set a]]-remainingSimple alphabet code rightPlaces =+matchingSimple :: Ord a => Set.Set a -> [a] -> Int -> [[Set.Set a]]+matchingSimple alphabet code rightPlaces =    map       (zipWith          (\symbol right ->@@ -73,6 +90,7 @@          code) $    possibleRightPlaces (length code) rightPlaces +-- ToDo: import from combinatorial {- | Combinatorical \"choose k from n\". -}@@ -99,10 +117,10 @@ of codes and their evaluations. The searched code is in the intersection of all corresponding code sets. -}-remaining ::+matching ::    (CodeSet.C set, Ord a) =>    Set.Set a -> [a] -> Eval -> set a-remaining alphabet =+matching alphabet =    let findCodes =           foldr              (\(fixed,c) go rightSymbols floating0 ->@@ -139,7 +157,7 @@       (eval,        CodeSet.size $        (id :: CodeSetTree.T a -> CodeSetTree.T a) $-       remaining alphabet code eval)) $+       matching alphabet code eval)) $    possibleEvaluations (length code)  possibleEvaluations :: Int -> [Eval]@@ -152,14 +170,15 @@ interaction ::    (CodeSetTree.T Char -> State.StateT state Maybe [Char]) ->    state ->-   Set.Set Char -> Int -> IO ()+   NonEmptySet.T Char -> Int -> IO () interaction select initial alphabet n =    let go state set =           case State.runStateT (select set) state of              Nothing -> putStrLn "contradicting evaluations"              Just (attempt, newState) -> do                 putStr $ show attempt ++ " " ++-                   show (CodeSet.size set, CodeSet.representationSize set) ++ " "+                   show (CodeSet.size set, CodeSet.representationSize set,+                         Set.size (CodeSet.symbols set)) ++ " "                 IO.hFlush IO.stdout                 eval <- getLine                 let evalHist = histogram eval@@ -172,23 +191,16 @@                 if rightPlaces >= n                   then putStrLn "I won!"                   else go newState $ intersection set $-                       remaining alphabet attempt $+                       matching (NonEmptySet.flatten alphabet) attempt $                        Eval rightPlaces rightSymbols    in  go initial (cube alphabet n) -mainSimple :: Set.Set Char -> Int -> IO ()+mainSimple :: NonEmptySet.T Char -> Int -> IO () mainSimple =    interaction       (Trans.lift . listToMaybe . flatten)       () --- candidate for random-utility, cf. module htam:Election, markov-chain-randomSelect ::-   (Rnd.RandomGen g, Monad m) =>-   [a] -> State.StateT g m a-randomSelect items =-   liftM (items!!) $ State.StateT $ return . Rnd.randomR (0, length items-1)- {- | minimum of maximums using alpha-beta-pruning -}@@ -204,7 +216,50 @@                else old)       (a0, maximum bs0) rest +{- |+Remove all but one unused symbols from the alphabet.+-}+reduceAlphabet :: (CodeSet.C set, Ord a) => set a -> Set.Set a -> Set.Set a+reduceAlphabet set alphabet =+   let symbols = CodeSet.symbols set+   in  Set.union symbols $ Set.fromList $ take 1 $ Set.toList $+       Set.difference alphabet symbols++bestSeparatingCode ::+   (CodeSet.C set, Ord a) =>+   Int -> set a -> [[a]] -> [a]+bestSeparatingCode n set =+   let alphabet = CodeSet.symbols set+   in  minimax .+       map+         (\attempt ->+            (attempt,+               map (CodeSet.size . intersection set .+                    matching alphabet attempt) $+               possibleEvaluations n))+ {-+For small sets of codes it is faster to evaluate+all matching codes and build a histogram.+-}+bestSeparatingCodeHistogram ::+   (CodeSet.C set, Ord a) => set a -> [[a]] -> [a]+bestSeparatingCodeHistogram set =+   minimax .+   map+      (\attempt ->+         (attempt,+          Map.elems $ histogram $ map (evaluate attempt) $ CodeSet.flatten set))++propBestSeparatingCode ::+   (CodeSet.C set, Ord a) => Int -> set a -> [[a]] -> Bool+propBestSeparatingCode n set attempts =+   bestSeparatingCode n set attempts+   ==+   bestSeparatingCodeHistogram set attempts+++{- Here we optimize for small set sizes. For performance we could optimize for small set representation sizes. However the resulting strategy looks much like the strategy@@ -212,9 +267,8 @@ -} randomizedAttempt ::    (CodeSet.C set, Rnd.RandomGen g, Ord a) =>-   Int -> Set.Set a ->-   set a -> State.StateT g Maybe [a]-randomizedAttempt n alphabet set = do+   Int -> set a -> State.StateT g Maybe [a]+randomizedAttempt n set = do    randomAttempts <-       replicateM 10 $       replicateM n $@@ -222,7 +276,7 @@       CodeSet.symbols set    let possible = flatten set        somePossible =-          -- take 10 possible+          -- take 10 possible codes           let size = CodeSet.size set               num = 10           in  map (CodeSet.select set) $@@ -231,14 +285,37 @@               map (flip div (fromIntegral num)) $               iterate (size+) 0    _ <- Trans.lift $ listToMaybe possible-   return $ minimax $-      map-         (\attempt -> (attempt,-            map (CodeSet.size . intersection set . remaining alphabet attempt) $-            possibleEvaluations n)) $-      somePossible ++ randomAttempts+   return $ bestSeparatingCode n set $ somePossible ++ randomAttempts  {- |+In the beginning we choose codes that separate reasonably well,+based on heuristics.+At the end, when the set becomes small,+we do a brute-force search for an optimally separating code.+-}+{-+The reduced alphabet contains one symbol more than @CodeSet.symbols set@.+Is that necessary or is there always an equally good separating code+without the extra symbol?+-}+separatingRandomizedAttempt ::+   (CodeSet.C set, Rnd.RandomGen g, Ord a) =>+   Int -> Set.Set a -> set a -> State.StateT g Maybe [a]+separatingRandomizedAttempt n alphabet0 set = do+   case CodeSet.size set of+      0 -> Trans.lift Nothing+      1 -> return $ head $ CodeSet.flatten set+      2 -> return $ head $ CodeSet.flatten set+      size ->+         let alphabet = reduceAlphabet set alphabet0+             alphabetSize = Set.size alphabet+             bigSize = toInteger size+         in  if bigSize * (bigSize + toInteger alphabetSize ^ n) <= 1000000+               then return $ bestSeparatingCodeHistogram set $+                    CodeSet.flatten set ++ replicateM n (Set.toList alphabet)+               else randomizedAttempt n set++{- | In the beginning we simply choose a random code from the set of possible codes. In the end, when the set becomes small,@@ -246,29 +323,32 @@ -} mixedRandomizedAttempt ::    (CodeSet.C set, Rnd.RandomGen g, Ord a) =>-   Int -> Set.Set a ->-   set a -> State.StateT g Maybe [a]-mixedRandomizedAttempt n alphabet set = do+   Int -> set a -> State.StateT g Maybe [a]+mixedRandomizedAttempt n set = do    case CodeSet.size set of       0 -> Trans.lift Nothing       1 -> return $ head $ CodeSet.flatten set       2 -> return $ head $ CodeSet.flatten set       size ->          if size <= 100-           then randomizedAttempt n alphabet set+           then randomizedAttempt n set            else               fmap (CodeSet.select set) $               State.StateT $ return . Rnd.randomR (0, size-1) -mainRandom :: Set.Set Char -> Int -> IO ()+mainRandom :: NonEmptySet.T Char -> Int -> IO () mainRandom alphabet n = do    g <- Rnd.getStdGen-   interaction (randomizedAttempt n alphabet) g alphabet n+   interaction+      (separatingRandomizedAttempt n (NonEmptySet.flatten alphabet))+      g alphabet n  main :: IO () main =---   mainSimple (Set.fromList ['a'..'z']) 7-   mainRandom (Set.fromList ['a'..'z']) 5+   let alphabet = NonEmptySet.fromList ('a'!:['b'..'z'])+   in  if True+         then mainRandom alphabet 5+         else mainSimple alphabet 7  {- Bug: (fixed)@@ -283,6 +363,6 @@ contradicting evaluations *Game.Mastermind> map (evaluate "amiga") ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] [Eval 0 1,Eval 0 0,Eval 1 1,Eval 0 2,Eval 0 3,Eval 1 0,Eval 1 1]-*Game.Mastermind> map (\attempt -> member "amiga" $ remaining (Set.fromList $ ['a'..'z']) attempt (evaluate "amiga" attempt)) ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"]+*Game.Mastermind> map (\attempt -> member "amiga" $ matching (Set.fromList $ ['a'..'z']) attempt (evaluate "amiga" attempt)) ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] [True,True,True,True,False,True,False] -}

@@ -1,8 +1,16 @@-module Game.Mastermind.CodeSet where+module Game.Mastermind.CodeSet (+   C(..),+   cube,+   unions,+   intersections,+   intersectionsPQ,+   (*&), (#*&),+   ) where +import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty as NonEmpty import qualified Data.Set as Set-import qualified Data.List as List-import qualified Data.List.Key as Key import Data.Function.HT (nest, ) import Data.Ord.HT (comparing, ) @@ -13,8 +21,7 @@    empty :: set a    union, intersection :: (Ord a) => set a -> set a -> set a    unit :: set a-   -- | the left operand must be non-empty-   leftNonEmptyProduct :: Set.Set a -> set a -> set a+   leftNonEmptyProduct :: NonEmptySet.T a -> set a -> set a    flatten :: (Ord a) => set a -> [[a]]    symbols :: (Ord a) => set a -> Set.Set a    null :: set a -> Bool@@ -24,7 +31,7 @@    -- | simplify set representation by combining set products where possible    compress :: (Ord a) => set a -> set a -cube :: (C set) => Set.Set a -> Int -> set a+cube :: (C set) => NonEmptySet.T a -> Int -> set a cube alphabet n =    nest n (leftNonEmptyProduct alphabet) unit @@ -32,40 +39,46 @@ unions = foldr union empty  --- simulate priority queue-insertSortedBy :: (a -> a -> Ordering) -> a -> [a] -> [a]-insertSortedBy cmp x =-   let recourse [] = [x]-       recourse (y:ys) =-          if cmp x y == GT-            then y : recourse ys-            else x:y:ys-   in  recourse+{-+Use a sorted list as a priority queue. -intersections :: (C set, Ord a) => [set a] -> set a-intersections =-   let go [] = error "intersections: empty list"-       go [(_, set)] = set-       go ((_,x):(_,y):rest) =+Using the set 'size' as priority would be an unnecessary effort.+Intersection makes sets smaller,+thus the procedure would always insert at the front.+This is what 'intersections' does anyway.+-}+intersectionsPQ :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a+intersectionsPQ =+   let go (NonEmpty.Cons (_, set) []) = set+       go (NonEmpty.Cons (_,x) ((_,y):rest)) =           let sec = intersection x y-          in  go (insertSortedBy (comparing fst) (size sec, sec) rest)+          in  go $+              NonEmpty.insertBy+                  (comparing fst) (representationSize sec, sec) rest    in  go .-       List.sortBy (comparing fst) .-       map (\set -> (size set, set))+       NonEmptyC.sortBy (comparing fst) .+       fmap (\set -> (representationSize set, set)) -intersectionsSort :: (C set, Ord a) => [set a] -> set a-intersectionsSort =-   foldl1 intersection . Key.sort size+intersections :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a+intersections = NonEmpty.foldl1 intersection . nonEmptySortKey size +-- cannot be easily generalized for inclusion in non-empty package+nonEmptySortKey :: (Ord b) => (a -> b) -> NonEmpty.T [] a -> NonEmpty.T [] a+nonEmptySortKey f =+   fmap snd . NonEmptyC.sortBy (comparing fst) . fmap (\x -> (f x, x))+++infixr 5 *&, #*&+ {- | Like 'leftNonEmptyProduct' but the left operand can be empty. -}-(*&) :: (C set) => Set.Set a -> set a -> set a+(*&) :: (C set, Ord a) => Set.Set a -> set a -> set a c *& set =-   if Set.null c-     then empty-     else leftNonEmptyProduct c set+   case NonEmptySet.fetch c of+      Nothing -> empty+      Just nec -> leftNonEmptyProduct nec set  (#*&) :: (C set) => a -> set a -> set a c #*& set =-   leftNonEmptyProduct (Set.singleton c) set+   leftNonEmptyProduct (NonEmptySet.singleton c) set

@@ -1,13 +1,22 @@-module Game.Mastermind.CodeSet.Tree where+module Game.Mastermind.CodeSet.Tree (+   T, null, member, intersection,+   propIntersections,+   ) where  import qualified Game.Mastermind.CodeSet as CodeSet+import Game.Utility (nonEmptySetToList, ) +import Control.Monad (liftM2, mfilter, )++import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set  import Data.Tuple.HT (mapFst, swap, )--import Control.Monad (liftM2, )+import Data.Ord.HT (comparing, )+import Data.Eq.HT (equating, )+import Data.Maybe (mapMaybe, )  import Prelude hiding (null, ) @@ -17,8 +26,7 @@ expresses  a x b  union  c x d, where @x@ denotes the set product. -}-data T a =-   End | Products (Map.Map (Set.Set a) (T a))+data T a = End | Products (Map.Map (NonEmptySet.T a) (T a))    deriving (Show)  {-@@ -51,21 +59,22 @@ flatten End = [[]] flatten (Products xs) =    concatMap-      (\(a,b) -> liftM2 (:) (Set.toList a) (flatten b))+      (\(a,b) -> liftM2 (:) (nonEmptySetToList a) (flatten b))       (Map.toList xs)  symbols :: (Ord a) => T a -> Set.Set a symbols End = Set.empty symbols (Products xps) =    Set.unions $-   map (\(x,xs) -> Set.union x (symbols xs)) $+   map (\(x,xs) -> Set.union (NonEmptySet.flatten x) (symbols xs)) $    Map.toList xps   size :: T a -> Integer size End = 1 size (Products xs) =-   sum (map (\(a,b) -> fromIntegral (Set.size a) * size b) $ Map.toList xs)+   sum $ map (\(a,b) -> fromIntegral (NonEmptySet.size a) * size b) $+   Map.toList xs  -- somehow inefficient, because the sizes of subsets are recomputed several times select :: T a -> Integer -> [a]@@ -85,18 +94,19 @@             unzip $             map (\(x,xs) ->                let sz = size xs-               in  (fromIntegral (Set.size x) * sz, sz)) $+               in  (fromIntegral (NonEmptySet.size x) * sz, sz)) $             Map.toList xps of          [] -> error "CodeSet.select: index too large"          ((x,xs), ((n1,_), xsSize)) : _ ->             let (j,k) = divMod n1 xsSize-            in  (Set.toList x !! fromInteger j)+            in  (nonEmptySetToList x !! fromInteger j)                 : select xs k  representationSize :: T a -> Int representationSize End = 1 representationSize (Products xs) =-   sum (map (\(a,b) -> Set.size a + representationSize b) $ Map.toList xs)+   sum $ map (\(a,b) -> NonEmptySet.size a + representationSize b) $+   Map.toList xs   {- |@@ -114,7 +124,9 @@ intersection (Products xps) (Products yps) =    Products $ Map.fromListWith union $ normalizeProducts $    liftM2-      (\(x,xs) (y,ys) -> (Set.intersection x y, intersection xs ys))+      (\(x,xs) (y,ys) ->+         (Set.intersection (NonEmptySet.flatten x) (NonEmptySet.flatten y),+          intersection xs ys))       (Map.toList xps)       (Map.toList yps) intersection _ _ =@@ -123,12 +135,24 @@ {- | Remove empty set products. -}-normalizeProducts ::-   [(Set.Set a, T a)] -> [(Set.Set a, T a)]+normalizeProducts :: (Ord a) => [(Set.Set a, T a)] -> [(NonEmptySet.T a, T a)] normalizeProducts =-   filter (\(x,xs) -> not (Set.null x || null xs))+   mapMaybe+      (\(x,xs) ->+         liftM2 (,) (NonEmptySet.fetch x) (mfilter (not . null) (Just xs)))  +{-+Comparing for structural equivalence is overly strict,+but a lot simpler than comparing for set equivalence.+-}+propIntersections :: (Ord a) => NonEmpty.T [] (T a) -> Bool+propIntersections xs =+   equating Indexable+      (CodeSet.intersections xs)+      (CodeSet.intersectionsPQ xs)++ {- | This allows (T a) to be a key in a Map. I do not want an Ord (T a) instance,@@ -142,8 +166,7 @@    (Indexable x) == (Indexable y) =       case (x,y) of          (End,End) -> True-         (Products xs, Products ys) ->-            fmap Indexable xs == fmap Indexable ys+         (Products xs, Products ys) -> equating (fmap Indexable) xs ys          _ -> False  instance (Ord a) => Ord (Indexable a) where@@ -152,8 +175,7 @@          (End,End) -> EQ          (End,Products _) -> LT          (Products _,End) -> GT-         (Products xs, Products ys) ->-            compare (fmap Indexable xs) (fmap Indexable ys)+         (Products xs, Products ys) -> comparing (fmap Indexable) xs ys   compress :: (Ord a) => T a -> T a@@ -161,13 +183,14 @@ compress (Products xs) =    Products $    Map.fromListWith union $ map swap $ map (mapFst (\(Indexable set) -> set)) $ Map.toList $-   Map.fromListWith Set.union $ map (mapFst Indexable) $ map swap $ Map.toList $+   Map.fromListWith NonEmptySet.union $+   map (mapFst Indexable) $ map swap $ Map.toList $    fmap compress xs  member :: (Ord a) => [a] -> T a -> Bool member [] End = True member (c:cs) (Products xps) =-   any (\(x,xs) -> Set.member c x && member cs xs) $+   any (\(x,xs) -> NonEmptySet.member c x && member cs xs) $    Map.toList xps member _ _ =    error "CodeSet.member: mismatch of tuple size and tuple size in set"

@@ -1,11 +1,19 @@-module Game.Mastermind.CodeSet.Union where+module Game.Mastermind.CodeSet.Union (+   T, member,+   fromLists, cube,+   overlappingPairs, overlapping,+   ) where  import qualified Game.Mastermind.CodeSet as CodeSet+import Game.Utility (nonEmptySetToList, ) +import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty as NonEmpty import qualified Data.Set as Set--import qualified Data.List as List import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe (mapMaybe, )+ import Control.Monad (liftM2, guard, )  @@ -14,7 +22,7 @@ expresses  a x b x c x d  union  e x f x g x h, where @x@ denotes the set product. -}-newtype T a = Cons [[Set.Set a]]+newtype T a = Cons [[NonEmptySet.T a]]  instance (Ord a, Show a) => Show (T a) where    showsPrec n cs =@@ -37,21 +45,18 @@   toLists :: (Ord a) => T a -> [[[a]]]-toLists (Cons xs) =-   map (map Set.toList) xs+toLists (Cons xs) = map (map nonEmptySetToList) xs -fromLists :: (Ord a) => [[[a]]] -> T a-fromLists =-   Cons . map (map Set.fromList)+fromLists :: (Ord a) => [[NonEmpty.T [] a]] -> T a+fromLists = Cons . map (map NonEmptySet.fromList)  flatten :: (Ord a) => T a -> [[a]] flatten = concatMap sequence . toLists  symbols :: (Ord a) => T a -> Set.Set a-symbols (Cons xs) =-   Set.unions $ map Set.unions xs+symbols = Set.unions . map Set.unions . flattenFactors -cube :: Int -> Set.Set a -> T a+cube :: Int -> NonEmptySet.T a -> T a cube n alphabet = Cons [replicate n alphabet]  @@ -60,7 +65,7 @@  productSizes :: T a -> [Integer] productSizes (Cons x) =-   map (product . map (fromIntegral . Set.size)) $ x+   map (product . map (fromIntegral . NonEmptySet.size)) $ x  select :: T a -> Integer -> [a] select set@(Cons xs) n0 =@@ -78,13 +83,16 @@                      else error "CodeSet.select: at the end index must be zero") $                 List.mapAccumR                    (\n2 componentSet ->-                      let (n3,i) = divMod n2 (fromIntegral $ Set.size componentSet)-                      in  (n3, Set.toList componentSet !! fromInteger i))+                      let (n3,i) =+                              divMod n2+                                 (fromIntegral $ NonEmptySet.size componentSet)+                      in  (n3,+                           nonEmptySetToList componentSet !! fromInteger i))                    n1 prod  representationSize :: T a -> Int representationSize (Cons x) =-   sum . map (sum . map Set.size) $ x+   sum . map (sum . map NonEmptySet.size) $ x   {- |@@ -95,21 +103,24 @@ union (Cons x) (Cons y) = Cons (x++y)  intersection :: (Ord a) => T a -> T a -> T a-intersection (Cons x) (Cons y) =-   normalize $ Cons $ liftM2 (zipWith Set.intersection) x y+intersection x y =+   normalize $+   liftM2 (zipWith Set.intersection) (flattenFactors x) (flattenFactors y)  member :: (Ord a) => [a] -> T a -> Bool member code (Cons xs) =-   any (and . zipWith Set.member code) xs+   any (and . zipWith NonEmptySet.member code) xs  {- | Remove empty set products. -}-normalize :: T a -> T a-normalize (Cons x) =-   Cons $ filter (all (not . Set.null)) x+normalize :: (Ord a) => [[Set.Set a]] -> T a+normalize = Cons . mapMaybe (mapM NonEmptySet.fetch) +flattenFactors :: (Ord a) => T a -> [[Set.Set a]]+flattenFactors (Cons xs) = map (map NonEmptySet.flatten) xs + disjointProduct :: (Ord a) => [Set.Set a] -> [Set.Set a] -> Bool disjointProduct prod0 prod1 =    any Set.null $ zipWith Set.intersection prod0 prod1@@ -118,8 +129,8 @@ for debugging: list all pairs of products, that overlap -} overlappingPairs :: (Ord a) => T a -> [([Set.Set a], [Set.Set a])]-overlappingPairs (Cons xs) = do-   prod0:rest <- ListHT.tails xs+overlappingPairs set = do+   prod0:rest <- ListHT.tails $ flattenFactors set    prod1 <- rest    guard $ not $ disjointProduct prod0 prod1    return (prod0, prod1)@@ -128,7 +139,8 @@ for debugging: list all subsets, that are contained in more than one product -} overlapping :: (Ord a) => T a -> [([Set.Set a], [[Set.Set a]])]-overlapping (Cons xs) = do+overlapping set = do+   let xs = flattenFactors set    subset <- Set.toList $ Set.fromList $ do       prod0:rest <- ListHT.tails xs       prod1 <- rest

@@ -1,10 +1,14 @@ {- | Input and output for Game.Mastermind -}-module Game.Mastermind.HTML where+module Game.Mastermind.HTML (+   complete,+   generate,+   main,+   ) where  import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree import qualified Game.Mastermind.CodeSet as CodeSet import qualified Game.Mastermind as MM-import Game.Utility (readMaybe, nullToMaybe, )+import Game.Utility (readMaybe, nullToMaybe, randomSelect, nonEmptySetToList, )  import Text.Html((<<), (+++), concatHtml, toHtml) import qualified Text.Html as Html@@ -13,11 +17,15 @@  import qualified Data.List as List import qualified Data.List.HT as ListHT+import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.Set as Set+import Data.NonEmpty ((!:))+import Data.Tuple.HT (mapPair, )+import Data.Maybe.HT (toMaybe, )+ import qualified Control.Monad.Trans.State as State import Control.Monad (liftM2, replicateM, ) -import Data.Tuple.HT (mapPair, ) import qualified System.Random as Rnd  @@ -25,13 +33,9 @@ labelAnchor ref label =    Html.anchor label Html.! [Html.href ref] -relHeight, relWidth :: Int -> Html.HtmlAttr-relHeight r = Html.strAttr "HEIGHT" (show r ++ "%")-relWidth  r = Html.strAttr "WIDTH"  (show r ++ "%") - type Move = (String, MM.Eval)-type Config = (Int, Set.Set Char, Int, Maybe [Move], Maybe String)+type Config = (Int, NonEmptySet.T Char, Int, Maybe [Move], Maybe String)  evaluation :: MM.Eval -> Html.Html evaluation (MM.Eval rightPlaces rightSymbols) =@@ -72,7 +76,7 @@        (Html.! [Html.action "Mastermind"]) $        Html.form $ concatHtml $           [Html.hidden "width" (show width),-           Html.hidden "alphabet" (Set.toAscList alphabet),+           Html.hidden "alphabet" (nonEmptySetToList alphabet),            Html.hidden "seed" (show seed),            Html.hidden "moves" (unwords $ map formatMove moves)]           ++@@ -146,14 +150,15 @@                let remaining =                       CodeSet.compress $                       CodeSet.intersections $-                      CodeSet.cube alphabet width :-                      map (uncurry (MM.remaining alphabet)) moves+                      CodeSet.cube alphabet width !:+                      map (uncurry (MM.matching+                              (NonEmptySet.flatten alphabet))) moves                    (attempt,newSeed) =                       maybe                          (Nothing, seed)                          (mapPair (Just, fst . Rnd.random)) $                       State.runStateT-                         (MM.mixedRandomizedAttempt width alphabet remaining)+                         (MM.mixedRandomizedAttempt width remaining)                          (Rnd.mkStdGen seed)                in  state                       (width, alphabet, newSeed, Just moves, attempt)@@ -163,7 +168,7 @@                let code =                       State.evalState                          (replicateM width-                            (MM.randomSelect (Set.toList alphabet)))+                              (randomSelect (nonEmptySetToList alphabet)))                          (Rnd.mkStdGen seed)                in  state                       (width, alphabet, seed,@@ -184,11 +189,12 @@                 labelAnchor                     ("Mastermind?"++                        formatQuery-                          (4, Set.fromList alphabet, seed,-                           if computerAttempts then Just [] else Nothing, Nothing))+                          (4, NonEmptySet.fromList alphabet, seed,+                           toMaybe computerAttempts [], Nothing))                  << ("der "++player++" "++typ++"."))             [(False,"Mensch"),(True,"Computer")])-      [(['0'..'9'], "Zahlen"),(['a'..'z'], "W\246rter")]) Html.! [Html.border 2]+      [('0'!:['1'..'9'], "Zahlen"),('a'!:['b'..'z'], "W\246rter")])+         Html.! [Html.border 2]   complete :: Html.Html -> Html.Html@@ -207,7 +213,7 @@ formatQuery (width, alphabet, seed, mMoves, mAttempt) =    CGI.formEncode $       ("width", show width) :-      ("alphabet", Set.toAscList alphabet) :+      ("alphabet", nonEmptySetToList alphabet) :       ("seed", show seed) :       (case mAttempt of           Nothing -> []@@ -225,7 +231,8 @@ parseQuery query =    let pairs = CGI.formDecode query    in  do width    <- readMaybe =<< List.lookup "width" pairs-          alphabet <- fmap Set.fromList $ List.lookup "alphabet" pairs+          alphabet <-+             NonEmptySet.fetch . Set.fromList =<< List.lookup "alphabet" pairs           seed     <- readMaybe =<< List.lookup "seed" pairs           mMoves <-              maybe (Just Nothing)

@@ -27,6 +27,7 @@ main = do   opt <- Option.get   HTTPd.initServer (Option.port opt) $ \ req -> do+    -- FixMe: should check for HTTP method here     Option.printVerbose opt 1 req     let uri = HTTPd.reqURI req     Option.printVerbose opt 2 $ uriQuery uri

@@ -5,43 +5,60 @@ import qualified Game.Mastermind.CodeSet as CodeSet import qualified Game.Mastermind as MM -import qualified Data.Set as Set import Control.Monad (liftM2, )+import Control.Applicative ((<$>), ) +import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.Traversable as Trav+import qualified Data.Set as Set+import Data.NonEmpty ((!:))+ import qualified Test.QuickCheck as QC-import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, )+import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, (==>), )   alphabet :: Set.Set Int-alphabet = Set.fromList [0..9]+alphabet = NonEmptySet.flatten neAlphabet +neAlphabet :: NonEmptySet.T Int+neAlphabet = NonEmptySet.fromList $ 0!:[1..9] + newtype Code = Code [Int]    deriving (Show) ++genElement :: QC.Gen Int+genElement = QC.choose (0,9)+ -- can we get it working with empty lists, too?+genCode :: Int -> QC.Gen Code+genCode width =+   fmap (Code . take width) $ QC.listOf1 genElement+--    fmap (Code . take width) (QC.listOf genElement)+ instance Arbitrary Code where-   arbitrary =-      fmap (Code . take 5 . map (flip mod 10)) $-      liftM2 (:) arbitrary arbitrary---      fmap (Code . take 5 . map (flip mod 10)) arbitrary+   arbitrary = genCode 5   data CodePair = CodePair [Int] [Int]    deriving (Show) +genCodePair :: Int -> QC.Gen CodePair+genCodePair width =+   liftM2+      (\(Code xs) (Code ys) ->+         uncurry CodePair $ unzip $ zip xs ys)+      (genCode width) (genCode width)+ instance Arbitrary CodePair where-   arbitrary =-      liftM2-         (\(Code xs) (Code ys) ->-            uncurry CodePair $ unzip $ zip xs ys)-         arbitrary arbitrary+   arbitrary = genCodePair 5  -remainingMember :: CodePair -> Bool-remainingMember (CodePair secret attempt) =+matchingMember :: CodePair -> Bool+matchingMember (CodePair secret attempt) =    CodeSetTree.member secret $-   MM.remaining alphabet attempt (MM.evaluate secret attempt)+   MM.matching alphabet attempt (MM.evaluate secret attempt)  genEval :: Int -> QC.Gen MM.Eval genEval size = do@@ -52,23 +69,21 @@ forAllEval :: QC.Testable prop => [a] -> (MM.Eval -> prop) -> Property forAllEval code = QC.forAll (genEval (length code)) -remainingNotMember :: CodePair -> Property-remainingNotMember (CodePair secret attempt) =+matchingNotMember :: CodePair -> Property+matchingNotMember (CodePair secret attempt) =    forAllEval secret $ \eval ->-       (eval == MM.evaluate secret attempt)-       ==-       (CodeSetTree.member secret $-        MM.remaining alphabet attempt eval)+      (eval == MM.evaluate secret attempt)+      ==+      (CodeSetTree.member secret $ MM.matching alphabet attempt eval) -remainingDisjoint :: Code -> Property-remainingDisjoint (Code attempt) =+matchingDisjoint :: Code -> Property+matchingDisjoint (Code attempt) =    forAllEval attempt $ \eval0 ->    forAllEval attempt $ \eval1 ->-   let remaining0 = MM.remaining alphabet attempt eval0-       remaining1 = MM.remaining alphabet attempt eval1+   let matching0 = MM.matching alphabet attempt eval0+       matching1 = MM.matching alphabet attempt eval1    in  eval0 == eval1 ||-       CodeSetTree.null-          (CodeSetTree.intersection remaining0 remaining1)+       CodeSetTree.null (CodeSetTree.intersection matching0 matching1)  evaluateCommutative :: CodePair -> Bool evaluateCommutative (CodePair secret attempt) =@@ -76,13 +91,13 @@    ==    MM.evaluate attempt secret -evaluateRemaining :: Code -> Property-evaluateRemaining (Code attempt) =+evaluateMatching :: Code -> Property+evaluateMatching (Code attempt) =    forAllEval attempt $ \eval ->        all ((eval ==) . MM.evaluate attempt) $        take 100 $        CodeSet.flatten $-       (MM.remaining alphabet attempt eval :: CodeSetTree.T Int)+       (MM.matching alphabet attempt eval :: CodeSetTree.T Int)  {- A more precise test would be to check@@ -102,13 +117,39 @@ selectFlatten (Code attempt) =    forAllEval attempt $ \eval ->    let set :: CodeSetTree.T Int-       set = MM.remaining alphabet attempt eval+       set = MM.matching alphabet attempt eval    in  map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1]        ==        take 100 (CodeSet.flatten set)  --- should also work, when selecting any code from the set of remaining possibilities+genFixedLengthCodes :: Int -> QC.Gen [[Int]]+genFixedLengthCodes width = QC.listOf1 $ QC.vectorOf width genElement++bestSeparatingCode :: Property+bestSeparatingCode =+   QC.forAll (genCodePair 4) $ \(CodePair base0 base1) ->+   forAllEval base0 $ \eval0 ->+   forAllEval base1 $ \eval1 -> do+   let width = length base0+       set =+         CodeSet.intersection+            (MM.matching alphabet base0 eval0)+            (MM.matching alphabet base1 eval1)+   not (CodeSet.null set) ==>+      QC.forAll (fmap (take 10) $ genFixedLengthCodes width) $+         MM.propBestSeparatingCode width (set :: CodeSetTree.T Int)++intersections :: Property+intersections =+   QC.forAll (genCode 4) $ \(Code code) ->+   QC.forAll (fmap (take 10) $ genFixedLengthCodes (length code)) $ \codes ->+   QC.forAll (Trav.mapM (\x -> (,) x <$> genEval (length code)) (code!:codes)) $+      CodeSetTree.propIntersections . fmap (uncurry $ MM.matching alphabet)++++-- should also work, when selecting any code from the set of matching codes solve :: Code -> Bool solve (Code secret) =    let recourse remain =@@ -117,15 +158,14 @@              [attempt] -> secret == attempt              attempt:_ ->                 recourse $ CodeSet.intersection remain $-                MM.remaining alphabet attempt $ MM.evaluate secret attempt-   in  recourse-         (CodeSet.cube alphabet (length secret) :: CodeSetTree.T Int)+                MM.matching alphabet attempt $ MM.evaluate secret attempt+   in  recourse (CodeSet.cube neAlphabet (length secret) :: CodeSetTree.T Int)   {- Other possible tests: -the products in a set produced by 'remaining' must be disjoint.+the products in a set produced by 'MM.matching' must be disjoint.  set laws for the two set implementations,    such as distributivity of union and intersection@@ -135,12 +175,14 @@  tests :: [(String, IO ())] tests =-   ("remainingMember", quickCheck remainingMember) :-   ("remainingNotMember", quickCheck remainingNotMember) :-   ("remainingDisjoint", quickCheck remainingDisjoint) :+   ("matchingMember", quickCheck matchingMember) :+   ("matchingNotMember", quickCheck matchingNotMember) :+   ("matchingDisjoint", quickCheck matchingDisjoint) :    ("evaluateCommutative", quickCheck evaluateCommutative) :-   ("evaluateRemaining", quickCheck evaluateRemaining) :+   ("evaluateMatching", quickCheck evaluateMatching) :    ("partitionSizes", quickCheck partitionSizes) :    ("selectFlatten", quickCheck selectFlatten) :+   ("bestSeparatingCode", quickCheck bestSeparatingCode) :+   ("intersections", quickCheck intersections) :    ("solve", quickCheck solve) :    []

@@ -1,4 +1,20 @@-module Game.Tree where+module Game.Tree (+   T,+   build,+   mapNodesLeaves,+   mapTrees,+   maximumMove,+   maximumMoveFast,+   minimumMove,+   minimumMoveFast,+   pruneVolume,+   pruneDepth,+   selectDeepSubTree,+   selectSubTree,+   state,+   subTrees,+   scanChildren,+   ) where  import Data.Maybe (fromMaybe, ) import Data.List  (maximumBy, minimumBy, sortBy, )@@ -46,13 +62,13 @@ selectDeepSubTree =    flip (foldl (flip selectSubTree)) -{- prune the tree to a fixed depth -}+{- | prune the tree to a fixed depth -} pruneDepth :: Int -> T move state -> T move state pruneDepth 0 (Cons st _) = Cons st [] pruneDepth n (Cons st subs) =    Cons st (mapTrees (pruneDepth (n-1)) subs) -{- prune the tree roughly to a fixed volume -}+{- | prune the tree roughly to a fixed volume -} pruneVolume :: Int -> T move state -> T move state pruneVolume 0 (Cons st _) = Cons st [] pruneVolume n (Cons st subs) =

@@ -1,5 +1,14 @@ module Game.Utility where +import qualified System.Random as Rnd++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM, )++import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty as NonEmpty++ readMaybe :: (Read a) => String -> Maybe a readMaybe str =    case reads str of@@ -9,3 +18,11 @@ nullToMaybe :: [a] -> Maybe [a] nullToMaybe [] = Nothing nullToMaybe s  = Just s++-- candidate for random-utility, cf. module htam:Election, markov-chain+randomSelect :: (Rnd.RandomGen g, Monad m) => [a] -> MS.StateT g m a+randomSelect items =+   liftM (items!!) $ MS.StateT $ return . Rnd.randomR (0, length items-1)++nonEmptySetToList :: NonEmptySet.T a -> [a]+nonEmptySetToList = NonEmpty.flatten . NonEmptySet.toAscList

@@ -1,4 +1,17 @@-module Game.VierGewinnt where+module Game.VierGewinnt (+   Spieler(..),+   Spielstand,+   Zug,+   anfangundzuege,+   berechneSpielstand,+   brettVon,++   grundstellung,+   istMatt,+   moeglicheZuege,+   wertung,+   ) where+ {- <plaintext>  http://sim.mathematik.uni-halle.de/~helmut/Fun/Game.VierGewinnt/vierg.hs@@ -111,8 +124,8 @@     (anfang,altezuege)= anfangundzuege spielstand     zuege=altezuege++(zug:[]) -fmtwertung :: Wertung -> String-fmtwertung w =+_fmtWertung :: Wertung -> String+_fmtWertung w =     if -5000 < w && w < 5000       then show w       else " Matt in " ++ show (6000 - abs w)

@@ -1,5 +1,9 @@ {- | Ein- und Ausgabe fuer Game.VierGewinnt getrennt von Zugberechnung -}-module Game.VierGewinnt.HTML where+module Game.VierGewinnt.HTML (+   komplett,+   erzeuge,+   main,+   ) where  import Game.VierGewinnt    (Spieler(..), Zug, Spielstand, grundstellung, brettVon, wertung,

@@ -1,4 +1,6 @@-module Game.VierGewinnt.Text where+module Game.VierGewinnt.Text (+   spiel,+   ) where  import Game.VierGewinnt    (Spieler(..), Zug, Spielstand, brettVon,

@@ -1,5 +1,22 @@-module Game.ZeilenSpalten where+module Game.ZeilenSpalten (+   Koordinate,+   Spieler(..),+   Spielstand,+   Zug,+   berechneSpielstandUndZug,+   moeglicheZuege,+   amZug,+   grundstellung,+   koordinate,+   optimalerZug,+   punkte,+   spielfeld,+   zahlenfeld, +   spiel,+   optimalesSpiel,+   ) where+ {-   Benutzung in GHCi:   Game.ZeilenSpalten> spiel (5,5) 123 Spalte [0,1,2]@@ -31,9 +48,6 @@      Spalte    | Zeile    deriving (Show,Read,Eq,Ord,Ix)--spielfeldSymbol :: Maybe Spieler -> Char-spielfeldSymbol = maybe ' ' spielerSymbol  spielerSymbol :: Spieler -> Char spielerSymbol Spalte = '+'

@@ -1,5 +1,9 @@ {- | Ein- und Ausgabe fuer Game.ZeilenSpalten getrennt von Zugberechnung -}-module Game.ZeilenSpalten.HTML where+module Game.ZeilenSpalten.HTML (+   komplett,+   erzeuge,+   main,+   ) where  import Game.ZeilenSpalten hiding (spiel) import qualified Game.Tree as GameTree@@ -17,9 +21,6 @@ import System.Random (randomIO, )  -spielfeldFarbe :: Maybe Spieler -> String-spielfeldFarbe = maybe Html.white spielerFarbe- spielerFarbe :: Spieler -> String spielerFarbe Zeile    = Html.blue spielerFarbe Spalte   = Html.red@@ -28,10 +29,6 @@ labelAnchor ref label =    Html.anchor label Html.! [Html.href ref] -relHeight, relWidth :: Int -> Html.HtmlAttr-relHeight r = Html.strAttr "HEIGHT" (show r ++ "%")-relWidth  r = Html.strAttr "WIDTH"  (show r ++ "%")- type Beschreibung = ((Koordinate,Koordinate), Int, Spieler, Bool, [Zug])  spielstand :: Beschreibung -> Spielstand -> Html.Html@@ -75,8 +72,8 @@   -- umstaendlich, weil Spielfeld zweimal aufgebaut wird-spiel' :: String -> Html.Html-spiel' s =+_spiel :: String -> Html.Html+_spiel s =    let (groesse, saat, beginner, macheGegenzug, zuege) = read s        (_,computerZug) = berechneSpielstandUndZug groesse saat beginner zuege        zuegeMitComputer = zuege ++ maybeToList computerZug