Skip to content

Commit db1b41c

Browse files
KarolSKarolS
committed
first commit
0 parents  commit db1b41c

15 files changed

+1352
-0
lines changed

‎README

Whitespace-only changes.

‎Setup.lhs

+6
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
#!/usr/bin/runhaskell
2+
> module Main where
3+
> import Distribution.Simple
4+
> main :: IO ()
5+
> main = defaultMain
6+

‎chess.cabal

+47
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
name: chess
2+
version: 0.0.1
3+
cabal-version: -any
4+
build-type: Simple
5+
license: AllRightsReserved
6+
license-file: ""
7+
copyright:
8+
maintainer:
9+
build-depends: array -any, base -any, containers -any, parsec -any
10+
stability:
11+
homepage:
12+
package-url:
13+
bug-reports:
14+
synopsis:
15+
description: .
16+
category:
17+
author:
18+
tested-with:
19+
data-files:
20+
data-dir: ""
21+
extra-source-files:
22+
extra-tmp-files:
23+
24+
executable: chess
25+
main-is: Main.hs
26+
buildable: True
27+
build-tools:
28+
cpp-options:
29+
cc-options:
30+
ld-options:
31+
pkgconfig-depends:
32+
frameworks:
33+
c-sources:
34+
extensions: CPP
35+
extra-libraries:
36+
extra-lib-dirs:
37+
includes:
38+
install-includes:
39+
include-dirs:
40+
hs-source-dirs: src
41+
other-modules:
42+
ghc-prof-options:
43+
ghc-shared-options:
44+
ghc-options:
45+
hugs-options:
46+
nhc98-options:
47+
jhc-options:

‎src/Ai.hs

+76
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,76 @@
1+
#include "common.h"
2+
3+
module Ai (alphaBeta, minmax)where
4+
import Chess
5+
import Data.Array.Base
6+
7+
boundedMax alpha beta [] = alpha
8+
boundedMax alpha beta (x:xs) =
9+
if alpha>=beta
10+
then alpha
11+
else
12+
let m = max alpha x
13+
in boundedMax m beta xs
14+
boundedSafeEval alpha beta oldPosition [] =
15+
if isKingInCheck oldPosition
16+
then if whoseTurn oldPosition == White then -10000000 else 10000000
17+
else 0
18+
boundedSafeEval alpha beta _ moves =
19+
negate $ boundedMax (-beta) (-alpha) moves
20+
21+
safeEval oldPosition [] =
22+
if isKingInCheck oldPosition
23+
then if (whoseTurn oldPosition == White) then -10000000 else 10000000
24+
else 0
25+
safeEval _ moves =
26+
negate $ foldr1 max moves
27+
28+
boundedEvaluatePosition::Double->Double->Int->Board->Double
29+
boundedEvaluatePosition a b 0 position =
30+
let
31+
value = rawEvaluate position
32+
isWhite = whoseTurn position == White
33+
in if isWhite then value else -value
34+
35+
boundedEvaluatePosition a b depth position =
36+
boundedSafeEval a b position [
37+
boundedEvaluatePosition a b (depth-1) (doMove move position)
38+
| move <- getAllLegalMoves position
39+
]
40+
evaluatePosition 0 position =
41+
let
42+
value = rawEvaluate position
43+
isWhite = whoseTurn position == White
44+
in if isWhite then value else -value
45+
evaluatePosition depth position =
46+
safeEval position [
47+
evaluatePosition (depth-1) (doMove move position)
48+
| move <- getAllLegalMoves position ]
49+
50+
minmax depth isWhite position =
51+
let
52+
moves = getAllLegalMoves position
53+
variants = [(evaluatePosition depth (doMove move position), move) | move<-moves]
54+
in if variants==[]
55+
then Nothing
56+
else Just $ snd $ foldr1 max variants
57+
58+
alphaBeta depth isWhite position =
59+
let
60+
moves = getAllLegalMoves position
61+
variants = [(boundedEvaluatePosition (-10000001) 10000000 depth (doMove move position), move) | move<-moves]
62+
in if variants==[]
63+
then Nothing
64+
else Just $ snd $ foldr1 max variants
65+
66+
pieceValue :: Piece -> Double
67+
--pieceValue c = va ! fromEnum c
68+
-- where va = listArray (0,19::Int) [ 0.0, 1.0, 3.0, 3.0, 5.0, 9.5, 1000000.0, 0.0, 0.0, 0.0, 0.0,-1.0,-3.0,-3.0,-5.0,-9.5,-1000000.0, 0.0, 0.0, 0.0 ]
69+
pieceValue c = va !! fromEnum c
70+
where va = [ 0.0, 1.0, 3.0, 3.0, 5.0, 9.5, 1000000.0, 0.0, 0.0, 0.0, 0.0,-1.0,-3.0,-3.0,-5.0,-9.5,-1000000.0, 0.0, 0.0, 0.0 ]
71+
72+
-- TODO: szachmat i remis
73+
rawEvaluate b@Board{pieceArray=a} =
74+
sum [pieceValue(a!(x,y)) | x<-[0..7], y<-[0..7]] +
75+
fromIntegral(length(getAllLegalMovesForWhite b))/60.0 -
76+
fromIntegral(length(getAllLegalMovesForBlack b))/60.0

‎src/AltParser.hs

+126
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,126 @@
1+
module AltParser where
2+
3+
type ParseResult a = Either String a
4+
data ParserStatus = ParserStatus {
5+
parserRest :: !String
6+
} deriving (Show)
7+
8+
data Parser a = Parser {applyParser::(ParserStatus -> (ParserStatus,ParseResult a))}
9+
10+
char :: Char -> Parser Char
11+
char a = Parser (\status ->
12+
case parserRest status of
13+
[] -> (ParserStatus [], Left $ '`':a:"`")
14+
(x:tail) -> if x==a
15+
then (ParserStatus tail, Right $! a )
16+
else (ParserStatus (x:tail), Left $ '`':a:"`")
17+
)
18+
19+
anyChar :: Parser Char
20+
anyChar = Parser (\status ->
21+
case parserRest status of
22+
[] -> (ParserStatus [], Left $! "any char")
23+
(x:tail) -> (ParserStatus tail, Right $! x)
24+
)
25+
26+
fromRight (Right r) = r
27+
28+
spaces :: Parser String
29+
spaces = many $ char ' ' --TODO
30+
many :: Parser a -> Parser [a]
31+
many p = Parser (\status ->
32+
let (status',result) = p `applyParser` status
33+
in case result of
34+
Left _ -> (status, Right $! [])
35+
Right x -> (status'', Right $! (x : fromRight results))
36+
where (status'',results) = (many p) `applyParser` status'
37+
)
38+
many1 :: Parser a -> Parser [a]
39+
many1 p = do
40+
x <- p
41+
xs <- many p
42+
return $! x:xs
43+
44+
optionMaybe :: Parser a -> Parser (Maybe a)
45+
optionMaybe p = Parser (\status ->
46+
let (status',result) = p `applyParser` status
47+
in case result of
48+
Left _ -> (status, Right $! Nothing)
49+
Right x -> (status', Right $! Just x)
50+
)
51+
52+
eof :: Parser ()
53+
eof = Parser (\s ->
54+
if parserRest s == "" then (s, Right $! ())
55+
else (s, Left "end of file") )
56+
string :: String -> Parser String
57+
string [] = return ""
58+
string (x:xs) = liftError ('`':x:xs ++ "'") $ do
59+
y <- char x
60+
ys <- string xs
61+
return $! y:ys
62+
63+
oneOf :: String -> Parser Char
64+
oneOf [] = error "Calling oneOf with empty argument"
65+
oneOf (x:[]) = char x
66+
oneOf (x:xs) = liftError ("any of "++('`':x:xs)++"'") $ char x <|> oneOf xs
67+
68+
noneOf :: String -> Parser Char
69+
noneOf forbiddenChars = Parser (\status ->
70+
case parserRest status of
71+
[] -> (ParserStatus [], Left $ "any char except `"++forbiddenChars++"'")
72+
(x:tail) -> if x `elem` forbiddenChars
73+
then (ParserStatus (x:tail), Left $ "any char except `"++forbiddenChars++"'")
74+
else (ParserStatus tail, Right $! x )
75+
)
76+
77+
digit = oneOf "1234567890"
78+
79+
liftError :: String -> Parser a -> Parser a
80+
liftError newErr p = Parser (\s ->
81+
let (s',r) = p `applyParser` s
82+
in case r of
83+
Left err -> (s', Left newErr)
84+
Right _ -> (s', r)
85+
)
86+
87+
instance Monad Parser where
88+
return x = Parser (\s -> (s,Right x))
89+
p1 >>= p2 = Parser(\s ->
90+
let (s', result) = p1 `applyParser` s
91+
in case result of
92+
Left err -> (s, Left err)
93+
Right x ->
94+
let (s'',result2) = (p2 x) `applyParser` s'
95+
in case result2 of
96+
Left err -> (s, Left err)
97+
Right x -> (s'',Right $! x)
98+
)
99+
100+
instance Functor Parser where
101+
fmap f p = do
102+
x <- p
103+
return $! f x
104+
105+
p <|> q = Parser(\s ->
106+
let (s',result) = p `applyParser` s
107+
in case result of
108+
Left err ->
109+
let (s'',result') = q `applyParser` s
110+
in case result' of
111+
Left err' -> (s, Left (err++" or "++err'))
112+
Right _ -> (s'', result')
113+
Right _ -> (s', result) )
114+
115+
try = id
116+
117+
data ParseError =
118+
ParseError String Int String
119+
instance Show ParseError where
120+
show (ParseError sourceName i err) = sourceName ++ ":" ++ (show i) ++": expected "++err
121+
parse :: Parser a -> String -> String -> Either ParseError a
122+
parse parser sourceName text =
123+
case (applyParser parser) (ParserStatus text) of
124+
(rest, Left err) -> Left $ ParseError sourceName (length text - length (parserRest rest)) err
125+
(_, Right reslt) -> Right $! reslt
126+

0 commit comments

Comments
 (0)