Change file structure / introduce specific multiset

7startups.cabal

@@ -17,49 +17,51 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
+  hs-source-dirs:      src
   exposed-modules:     Startups.CardList,
-                        Startups.Base,
-                        Startups.Cards,
-                        Startups.GameTypes,
-                        Startups.Utils,
-                        Startups.Game,
-                        Startups.PrettyPrint,
-                        Startups.Interpreter,
-                        Startups.Json,
-                        Startups.Exported,
-                        Backends.Pure,
-                        Backends.Common,
-                        Backends.Hub,
-                        Backends.GenericHub,
-                        Strategies.Random,
-                        Strategies.Compose,
-                        Strategies.Bot1
-                        STM.Promise
+                       Startups.Base,
+                       Startups.Cards,
+                       Startups.GameTypes,
+                       Startups.Utils,
+                       Startups.Game,
+                       Startups.PrettyPrint,
+                       Startups.Interpreter,
+                       Startups.Json,
+                       Startups.Exported,
+                       Backends.Pure,
+                       Backends.Common,
+                       Backends.Hub,
+                       Backends.GenericHub,
+                       Strategies.Random,
+                       Strategies.Compose,
+                       Strategies.Bot1
+                       STM.Promise
+                       RMultiSet
   ghc-options:         -Wall -O2
   ghc-prof-options:    -auto-all -caf-all
   other-extensions:    OverloadedStrings, GeneralizedNewtypeDeriving
   build-depends:       base >=4.7 && <5,
-                        containers >=0.5 && <0.6,
-                        text >=1.1 && <1.3,
-                        multiset >=0.2 && <0.4,
-                        lens >= 4.7 && < 5,
-                        mtl,
-                        random == 1.*,
-                        split == 0.2.*,
-                        operational == 0.2.*,
-                        semigroups >= 0.13 && < 0.19,
-                        stm == 2.4.*,
-                        xml-types == 0.3.*,
-                        network >= 2.4 &&  < 2.7,
-                        mvc == 1.*,
-                        attoparsec >= 0.12 && < 0.14,
-                        yaml == 0.8.*,
-                        directory == 1.3.*,
-                        ansi-wl-pprint == 0.6.*,
-                        transformers == 0.5.*,
-                        aeson,
-                        elm-bridge,
-                        stateWriter
+                       containers >=0.5 && <0.6,
+                       text >=1.1 && <1.3,
+                       lens >= 4.7 && < 5,
+                       mtl,
+                       vector,
+                       random == 1.*,
+                       split == 0.2.*,
+                       operational == 0.2.*,
+                       semigroups >= 0.13 && < 0.19,
+                       stm == 2.4.*,
+                       xml-types == 0.3.*,
+                       network >= 2.4 &&  < 2.7,
+                       mvc == 1.*,
+                       attoparsec >= 0.12 && < 0.14,
+                       yaml == 0.8.*,
+                       directory == 1.3.*,
+                       ansi-wl-pprint == 0.6.*,
+                       transformers == 0.5.*,
+                       aeson,
+                       elm-bridge,
+                       stateWriter
   -- hs-source-dirs:      
   default-language:    Haskell2010
 
@@ -68,27 +70,27 @@ Test-Suite tests
     type:                 exitcode-stdio-1.0
     ghc-options:          -Wall
     other-extensions:     OverloadedStrings
-    build-depends:        7startups, base, containers, hspec, QuickCheck, lens, text, random, mtl, transformers
+    build-depends:        7startups, base, containers, hspec, QuickCheck, lens, text, random, mtl, transformers, multiset
     main-is:              tests.hs
     default-language:     Haskell2010
 
 Executable console
-    hs-source-dirs:       src
+    hs-source-dirs:       app
     main-is:              Console.hs
     ghc-options:          -Wall
     build-depends:        base, 7startups, random, ansi-wl-pprint, lens, semigroups
     default-language:     Haskell2010
 
 Executable xmpp
-    hs-source-dirs:       src
+    hs-source-dirs:       app
     main-is:              Xmpp.hs
     other-modules:        Xmpp.Backend
     ghc-options:          -Wall
     build-depends:        base, 7startups, text, pontarius-xmpp == 0.5.*, lens,  containers, yaml, directory, network, xml-types, stm, ansi-wl-pprint, attoparsec, tls
     default-language:     Haskell2010
 
 Executable testia
-    hs-source-dirs:       src
+    hs-source-dirs:       app
     main-is:              TestIA.hs
     ghc-options:          -Wall -threaded
     build-depends:        base, 7startups, lens, containers, random, parallel

Backends/Common.hs → src/Backends/Common.hs

@@ -12,6 +12,7 @@ import Startups.Utils
 import Startups.CardList
 
 import qualified Data.Map.Strict as M
+import qualified RMultiSet as MS
 import Control.Lens
 import Data.Monoid
 import qualified Data.Foldable as F
@@ -48,11 +49,11 @@ playerActionDesc showmode pid pmap (PlayerAction a card, exch, si) = actiondesc
         actiondesc BuildCompany = withCardColor Community "Build a company stage" <+> secret "using"
         nn n = pmap ^. ix pid . neighbor n
         exchdesc = sepBy ", " . map (uncurry exchdesc') . itoList
-        exchdesc' neigh resources = "exch." <+> F.foldMap pe resources
+        exchdesc' neigh resources = "exch." <+> MS.foldMap pe resources
                                             <+> "with"
                                             <+> showPlayerId (nn neigh)
                                             <+> "for"
-                                            <+> pe (F.foldMap (getExchangeCost pid neigh pmap) resources)
+                                            <+> pe (MS.foldMap (getExchangeCost pid neigh pmap) resources)
         sidesc (Just UseOpportunity) = " using the opportunity capability"
         sidesc Nothing = mempty
 

src/RMultiSet.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+module RMultiSet
+  ( ResourceSet
+  , singleton
+  , toList
+  , fromList
+  , toOccurList
+  , fromOccurList
+  , RMultiSet.foldMap
+  , insertMany
+  , isSubsetOf
+  , member
+  , insert
+  , delete
+  , difference
+  , toSet
+  ) where
+
+import qualified Data.Vector.Unboxed as V
+import qualified Data.Vector.Unboxed.Mutable as VM
+import qualified Data.Set as S
+import Data.Aeson
+
+import Startups.Base
+
+newtype ResourceSet
+    = ResourceSet { getMultiSet :: V.Vector Int }
+    deriving (Eq, Ord)
+
+instance Show ResourceSet where
+    show = show . toList
+
+instance Monoid ResourceSet where
+    mempty = ResourceSet (V.replicate 7 0)
+    {-# INLINE mempty #-}
+    mappend (ResourceSet a) (ResourceSet b) = ResourceSet (V.zipWith (+) a b)
+    {-# INLINE mappend #-}
+
+singleton :: Resource -> ResourceSet
+singleton r = insert r mempty
+{-# INLINE singleton #-}
+
+fromList :: [Resource] -> ResourceSet
+fromList = foldr insert mempty
+{-# INLINE fromList #-}
+
+resources :: [Resource]
+resources = [minBound .. maxBound]
+
+toList :: ResourceSet -> [Resource]
+toList = concatMap (uncurry (flip replicate)) . toOccurList
+{-# INLINE toList #-}
+
+toOccurList :: ResourceSet -> [(Resource, Int)]
+toOccurList = zip resources . V.toList . getMultiSet
+{-# INLINE toOccurList #-}
+
+fromOccurList :: [(Resource, Int)] -> ResourceSet
+fromOccurList = foldr (uncurry insertMany) mempty
+{-# INLINE fromOccurList #-}
+
+foldMap :: Monoid m => (Resource -> m) -> ResourceSet -> m
+foldMap f = Prelude.foldMap f . toList
+{-# INLINE foldMap #-}
+
+insertMany :: Resource -> Int -> ResourceSet -> ResourceSet
+insertMany r n (ResourceSet s) = ResourceSet (V.modify im s)
+  where
+    im t = VM.unsafeModify t (+n) (fromEnum r)
+{-# INLINE insertMany #-}
+
+insert :: Resource -> ResourceSet -> ResourceSet
+insert r (ResourceSet s) = ResourceSet (V.modify im s)
+  where
+    im t = VM.unsafeModify t (+1) (fromEnum r)
+{-# INLINE insert #-}
+
+isSubsetOf :: ResourceSet -> ResourceSet -> Bool
+isSubsetOf (ResourceSet s1) (ResourceSet s2) =
+    not (V.any (< 0) (V.zipWith (-) s2 s1))
+{-# INLINE isSubsetOf #-}
+
+member :: Resource -> ResourceSet -> Bool
+member r (ResourceSet s) = s V.! fromEnum r > 0
+{-# INLINE member #-}
+
+delete :: Resource -> ResourceSet -> ResourceSet
+delete r (ResourceSet s) = ResourceSet (V.modify im s)
+  where
+    im t = VM.unsafeModify t (\x -> max 0 (x-1)) (fromEnum r)
+{-# INLINE delete #-}
+
+difference :: ResourceSet -> ResourceSet -> ResourceSet
+difference (ResourceSet s1) (ResourceSet s2) =
+    ResourceSet (V.zipWith (\a b -> max 0 (a - b)) s1 s2)
+{-# INLINE difference #-}
+
+toSet :: ResourceSet -> S.Set Resource
+toSet = S.fromList . toList
+{-# INLINE toSet #-}
+
+instance ToJSON ResourceSet where
+    toJSON = toJSON . toOccurList
+
+instance FromJSON ResourceSet where
+    parseJSON = fmap fromOccurList . parseJSON
+

Startups/Cards.hs → src/Startups/Cards.hs

@@ -4,7 +4,7 @@ module Startups.Cards where
 
 import qualified Data.Set as S
 import qualified Data.Text as T
-import qualified Data.MultiSet as MS
+import qualified RMultiSet as MS
 import qualified Data.Foldable as F
 import qualified Data.Map.Strict as M
 import Data.Monoid
@@ -73,7 +73,7 @@ data Effect = ProvideResource !Resource !Int !Sharing
             | CopyCommunity
             deriving (Ord, Eq, Show)
 
-data Cost = Cost (MS.MultiSet Resource) !Funding
+data Cost = Cost MS.ResourceSet !Funding
           deriving (Ord, Eq, Show)
 
 instance Monoid Cost where
@@ -108,15 +108,15 @@ data Card = Card { _cName       :: !T.Text
                         }
           deriving (Ord,Eq,Show)
 
-newtype Exchange = RExchange { getExchange :: M.Map Neighbor (MS.MultiSet Resource) }
+newtype Exchange = RExchange { getExchange :: M.Map Neighbor MS.ResourceSet }
                    deriving (Show, Eq)
 
 instance Monoid Exchange where
     mempty = RExchange mempty
     mappend (RExchange a) (RExchange b) = RExchange (M.unionWith (<>) a b)
 
 instance ToJSON Exchange where
-    toJSON = toJSON . map (_2 %~ F.toList) . itoList . getExchange
+    toJSON = toJSON . map (_2 %~ MS.toList) . itoList . getExchange
 
 instance FromJSON Exchange where
     parseJSON = fmap (RExchange . M.fromList) . (parseJSON >=> mapM parsePair)
@@ -129,12 +129,12 @@ makePrisms ''Effect
 makeLenses ''Card
 
 instance ToJSON Cost where
-    toJSON (Cost c f) = object [ "resources" .= MS.toOccurList c
+    toJSON (Cost c f) = object [ "resources" .= c
                                , "funding"   .= f
                                ]
 
 instance FromJSON Cost where
-    parseJSON = withObject "cost" $ \o -> Cost <$> (fmap MS.fromOccurList (o .: "resources"))
+    parseJSON = withObject "cost" $ \o -> Cost <$> o .: "resources"
                                                <*> o .: "funding"
 
 $(deriveElmDef defaultOptions ''Exchange)

Startups/Game.hs → src/Startups/Game.hs

@@ -19,7 +19,7 @@ import Control.Applicative
 import Control.Monad.Except (throwError)
 import System.Random (randomR)
 import qualified Data.Map.Strict as M
-import qualified Data.MultiSet as MS
+import qualified RMultiSet as MS
 import qualified Data.Set as S
 import Data.Monoid
 import Data.List.Split (chunksOf)
@@ -102,12 +102,12 @@ getPlayerState pid = preuse (playermap . ix pid) >>= \m -> case m of
 -- condition where a player could try an exchange that is more expensive
 -- than what he owns, hoping some other player with exchange something with
 -- him.
-resolveExchange :: NonInteractive m => PlayerId -> Exchange -> m (MS.MultiSet Resource, AddMap PlayerId Funding)
+resolveExchange :: NonInteractive m => PlayerId -> Exchange -> m (MS.ResourceSet, AddMap PlayerId Funding)
 resolveExchange pid exch = mconcat  . M.elems <$> itraverse resolveExchange' (getExchange exch)
     where
         resolveExchange' neigh reslist = do
             stt <- use playermap
-            let cost = getSum $ reslist ^. folded . to (Sum . getExchangeCost pid neigh stt)
+            let cost = getSum $ MS.toList reslist ^. folded . to (Sum . getExchangeCost pid neigh stt)
                 playermoney = fromMaybe 0 (stt ^? ix pid . pFunds)
                 neighname = stt ^. ix pid . neighbor neigh
                 neigresources = stt ^. ix neighname . to (availableResources Exchange)
@@ -121,7 +121,7 @@ resolveExchange pid exch = mconcat  . M.elems <$> itraverse resolveExchange' (ge
 playCard :: NonInteractive m
          => Age
          -> PlayerId
-         -> MS.MultiSet Resource
+         -> MS.ResourceSet
          -> Bool -- ^ use opportunity
          -> Card
          -> m ()

Startups/PrettyPrint.hs → src/Startups/PrettyPrint.hs

@@ -5,6 +5,7 @@ module Startups.PrettyPrint where
 
 import Startups.Base
 import Startups.Cards
+import qualified RMultiSet as MS
 
 import Data.Monoid
 import Data.String
@@ -145,7 +146,7 @@ emph :: PrettyDoc -> PrettyDoc
 emph = Emph
 
 pcost :: Cost -> PrettyDoc
-pcost (Cost r m) = F.foldMap pe r <> pe m
+pcost (Cost r m) = MS.foldMap pe r <> pe m
 
 indent :: Int -> PrettyDoc -> PrettyDoc
 indent = Indent