Permalink
Browse files

initial commit

  • Loading branch information...
1 parent ee52d44 commit 57d30686143379ba59a590bcb237a2c4a4cbb71e @JPMoresmau committed Oct 23, 2012
View
@@ -0,0 +1,4 @@
+*.bmp
+.dist-buildwrapper
+.project
+.settings
View
@@ -0,0 +1,63 @@
+name: OpenAlchemistAI
+version: 0.1
+cabal-version: >= 1.2
+build-type: Simple
+author: jean-philippem
+data-files: data/bottle-big.bmp,
+ data/cheese-big.bmp,
+ data/cheese-small.bmp,
+ data/cherries-big.bmp,
+ data/cherries-small.bmp,
+ data/cow-big.bmp,
+ data/cow-small.bmp,
+ data/frog-big.bmp,
+ data/frog-small.bmp,
+ data/green-big.bmp,
+ data/green-small.bmp,
+ data/mosquito-big.bmp,
+ data/mosquito-small.bmp,
+ data/penguin-big.bmp,
+ data/penguin-small.bmp,
+ data/purple-big.bmp,
+ data/purple-small.bmp,
+ data/red-big.bmp,
+ data/red-small.bmp,
+ data/yellow-big.bmp,
+ data/yellow-small.bmp
+
+executable OpenAlchemistAI
+ hs-source-dirs:
+ exe,
+ src
+ main-is: Main.hs
+ build-depends: base >= 4,
+ Win32,
+ bmp >= 1.2.2,
+ containers,
+ bytestring,
+ directory,
+ filepath
+ ghc-options: -O2 -rtsopts -fspec-constr-count=5
+ other-modules: Games.OpenAlchemist.AI.Types,
+ Games.OpenAlchemist.AI.Vision,
+ Games.OpenAlchemist.AI.Game
+
+test-suite OpenAlchemistAI-test
+ type: exitcode-stdio-1.0
+ x-uses-tf: true
+ build-depends:
+ base >= 4,
+ HUnit >= 1.2 && < 2,
+ test-framework >= 0.4.1,
+ test-framework-hunit
+ ghc-options: -Wall -rtsopts
+ main-is: Main.hs
+ hs-source-dirs:
+ test,
+ src
+ other-modules:
+ Games.OpenAlchemist.AI.Game,
+ Games.OpenAlchemist.AI.GameTests,
+ Games.OpenAlchemist.AI.Types,
+ Games.OpenAlchemist.AI.Vision
+
View
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
@@ -0,0 +1,28 @@
+module Main where
+
+import Games.OpenAlchemist.AI.Game
+import Games.OpenAlchemist.AI.Vision
+import Games.OpenAlchemist.AI.Types
+
+main::IO()
+main = do
+ IconFingerPrint smallMM bigMM<-getIconFingerPrint
+ mpcis<-getGamePicture
+ case mpcis of
+ Nothing -> return ()
+ Just (preview,toplay,existing)->do
+ let smallFound=find smallMM preview
+ print smallFound
+ let bigFound1=find bigMM toplay
+ print bigFound1
+ let bigFound2=find bigMM existing
+ print bigFound2
+ let previewTiles=findTiles smallMM preview
+ print previewTiles
+ let toPlayTiles=findTiles bigMM toplay
+ print toPlayTiles
+ let game=readGame bigMM existing
+ print game
+ let advice=bestOn2 game toPlayTiles previewTiles
+ print advice
+ return()
@@ -0,0 +1,170 @@
+
+module Games.OpenAlchemist.AI.Game where
+
+import Games.OpenAlchemist.AI.Types
+
+import Data.Ord
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.List (sortBy)
+
+import Debug.Trace
+
+maxWidth :: Int
+maxWidth = 6
+
+maxHeight :: Int
+maxHeight = 7
+
+multiForResolution :: Int
+multiForResolution = 3
+
+gameValid :: Tiles -> Bool
+gameValid =M.foldrWithKey f True
+ where
+ f :: Coord -> Tile -> Bool -> Bool
+ f _ _ False=False
+ f (x,y) _ _
+ | x<0 || x>=maxWidth=False
+ | y<0 || y>=maxHeight=False
+ | otherwise=True
+
+dropBall :: Tiles -> Tile -> Int -> Tiles
+dropBall ms m col=let
+ pos=[(col,-y) | y<- [-(maxHeight+1) .. 0]] -- allow two balls over top
+ in fst $ foldr f (ms,False) pos
+ where
+ f :: Coord -> (Tiles,Bool) -> (Tiles,Bool)
+ f _ (ms2,True)= (ms2,True)
+ f c (ms2,False)=let
+ mm=M.lookup c ms2
+ in case mm of
+ Nothing->(M.insert c m ms2,True)
+ Just _ -> (ms2,False)
+
+dropPositions :: (Tile,Tile) -> [DropPosition]
+dropPositions (m1,m2)=[((m1,x),(m2,x+1)) | x <- [0..maxWidth-2]] -- m1 and m2, horizontal
+ ++ [((m2,x),(m1,x+1)) | x <- [0..maxWidth-2]] -- m2 and m1, horizontal
+ ++ [((m1,x),(m2,x)) | x <- [0..maxWidth-1]] -- m1 and m2 on same column, m1 on bottom
+ ++ [((m2,x),(m1,x)) | x <- [0..maxWidth-1]] -- m1 and m2 on same column, m2 on bottom
+
+allDropResults :: Tiles -> (Tile,Tile) -> [(Tiles,DropPosition)]
+allDropResults ts ds=let
+ dps=dropPositions ds
+ in map f dps
+ where
+ f :: DropPosition -> (Tiles,DropPosition)
+ f pos@((t1,col1),(t2,col2))=(dropBall (dropBall ts t1 col1) t2 col2,pos)
+
+bestOn1 :: Tiles -> (Tile,Tile) -> DropPosition
+bestOn1 ts ds=let
+ drs=allDropResults ts ds
+ res= map applyDropPosition drs
+ --res2=trace (show res) res
+ in fst $ head $ sortBy compDropPositions res
+
+bestOn2 :: Tiles -> (Tile,Tile) -> (Tile,Tile) -> DropPosition
+bestOn2 ts ds1 ds2=let
+ drs1=allDropResults ts ds1
+ drs2=concatMap (\(ts1,dp)->map (\x->(fst x,dp)) $
+ allDropResults ts1 ds2) drs1
+ res= map applyDropPosition drs2
+ res2=trace (show res) res
+ in fst $ head $ sortBy compDropPositions res2
+
+applyDropPosition :: (Tiles,DropPosition) -> (DropPosition,Int)
+applyDropPosition (ts1,pos)=let
+ (ts2,sc1)=resolve ts1
+ in (pos,if gameValid ts2 then sc1 else (-1))
+
+compDropPositions :: (DropPosition,Int) -> (DropPosition,Int) -> Ordering
+compDropPositions (dp1,sc1) (dp2,sc2)
+ | sc1 /= sc2=compare sc2 sc1
+ | (snd $ fst dp1) /= (snd $ fst dp2)=compare (snd $ fst dp1) (snd $ fst dp2)
+ | (snd $ snd dp1) /= (snd $ snd dp2)=compare (snd $ snd dp1) (snd $ snd dp2)
+ | otherwise=compare (fst $ fst dp2) (fst $ fst dp1)
+
+resolve :: Tiles -> (Tiles,Score)
+resolve ts=let (ts2,sc1)=resolve1 ts
+ in if ts==ts2
+ then (ts2,sc1)
+ else let (ts3,sc2)=resolve ts2
+ in (ts3,sc1+sc2)
+
+
+resolve1 :: Tiles -> (Tiles,Score)
+resolve1 ts=let
+ (grps,_)= foldr fg ([],S.empty) $ M.keys ts
+ in foldr calc (ts,0) grps
+ where
+ fg :: Coord -> ([Tiles],S.Set Coord) -> ([Tiles],S.Set Coord)
+ fg c (tss,cs)=if S.member c cs
+ then (tss,cs)
+ else let
+ grp=findGroup ts c
+ cs2=foldr S.insert cs $ M.keys grp
+ in if M.size grp >1
+ then ((grp:tss),cs2)
+ else (tss,cs2)
+ calc :: Tiles -> (Tiles,Score) -> (Tiles,Score)
+ calc grp (ts1,sc1)= let
+ rc=resolutionCoord grp
+ mt=M.lookup rc grp
+ in case mt of
+ Just t->
+ let mul=if M.size grp >2
+ then multiForResolution else 1
+ ts2=if M.size grp >2
+ then
+ M.insert rc (succ t) $ M.difference ts1 grp
+ else ts1
+ in (ts2,sc1+(mul * (tileScore t ) * (M.size grp)))
+ Nothing ->(ts1,sc1)
+
+findGroup :: Tiles -> Coord -> Tiles
+findGroup ts c =
+ let
+ mt=M.lookup c ts
+ in case mt of
+ Nothing -> M.empty
+ Just t -> let
+ grp=M.insert c t M.empty
+ ns=neighbourCoords c
+ in foldr (addGroup ts t) grp ns
+
+addGroup :: Tiles -> Tile -> Coord -> Tiles -> Tiles
+addGroup tsFull t1 c grp
+ | M.notMember c grp =
+ let
+ mt=M.lookup c tsFull
+ in case mt of
+ Just t2 | t1==t2->
+ let
+ grp2=M.insert c t1 grp
+ ns=neighbourCoords c
+ in foldr (addGroup tsFull t1) grp2 ns
+ _ -> grp
+ | otherwise = grp
+
+neighbourCoords :: Coord -> [Coord]
+neighbourCoords (x,y)=[(x-1,y),(x+1,y),(x,y-1),(x,y+1)]
+
+resolutionCoord :: Tiles -> Coord
+resolutionCoord ts = foldr f (maxWidth,maxHeight) $ M.keys ts
+ where
+ f :: Coord -> Coord -> Coord
+ f (x,y) (minx,miny)=if (y<miny)
+ then (x,y)
+ else if (y==miny && x<minx)
+ then (x,y)
+ else (minx,miny)
+
+tileScore :: Tile -> Int
+tileScore Green=1
+tileScore Yellow=3
+tileScore Red=9
+tileScore Purple=30
+tileScore Cherries=90
+tileScore Penguin=30
+tileScore Cheese=900
+tileScore Cow=3000
@@ -0,0 +1,46 @@
+
+module Games.OpenAlchemist.AI.Types where
+
+import qualified Data.Map as M
+
+data Pixel = Pixel {
+ r :: Int,
+ g :: Int,
+ b :: Int,
+ a :: Int
+ }
+ deriving (Eq,Read,Show,Ord)
+
+type Coord = (Int,Int)
+
+type PMap=M.Map Coord Pixel
+
+data PMapInfo=PMapInfo Coord PMap
+ deriving (Eq,Read,Show,Ord)
+
+type Histo=M.Map Pixel Int
+
+type Tiles=M.Map Coord Tile
+
+type Score=Int
+
+type DropPosition=((Tile,Int),(Tile,Int))
+
+data Tile= Green | Yellow | Red | Purple | Cherries | Penguin | Cheese | Cow
+ deriving (Eq,Read,Show,Enum,Bounded,Ord)
+
+data Marker = Marker Pixel Coord Coord
+ deriving (Eq,Read,Show,Ord)
+
+data IconFingerPrint = IconFingerPrint {
+ smalls :: M.Map Pixel (Tile,Marker),
+ bigs :: M.Map Pixel (Tile,Marker)
+ }
+ deriving (Eq,Read,Show,Ord)
+
+data GameState = GameState {
+ preview :: (Tile,Tile),
+ next :: (Tile,Tile),
+ existing :: Tiles
+ }
+ deriving (Eq,Read,Show,Ord)
Oops, something went wrong.

0 comments on commit 57d3068

Please sign in to comment.