ghc/tests/programs/andy_cherry/Interp.lhs

   1
   2 > module Interp (runInterp) where
   3
   4 > import GenUtils
   5 > import DataTypes
   6 > import InterpUtils
   7 > import Parser (pgnLexer)
   8
   9 This is a Interp for PGN.
  10
  11 > runInterp :: AbsGame -> RealGame
  12 > runInterp (Game tags toks) = Game tags (pgnInterp toks initParState)
  13
  14 %------------------------------------------------------------------------------
  15
  16 > initParState = (FirstBoard startBoard)
  17
  18 > type Par a = StoreBoard -> a
  19 > thenP :: Par a -> (a -> Par b) -> Par b
  20 > returnP :: a -> Par a
  21
  22 > returnP a = \s -> a
  23 > thenP m k s = case m s of
  24 >                 r -> k r s
  25 >
  26 > failP a = \s -> error a
  27 > consP q rest = \s -> q : pgnInterp rest s
  28 > thenP' :: Par StoreBoard -> Par a -> Par a
  29 > thenP' m k s = case m s of
  30 >                 r -> k r
  31 > newGameP :: Par a -> Par a
  32 > newGameP m = \ _ -> m initParState
  33
  34 > getCurrColour :: Par Colour
  35 > getCurrColour =
  36 >       getBoard                `thenP` \ (Board _ (MoveNumber _ col) _) ->
  37 >       returnP col
  38
  39 > checkColour :: MoveNumber -> Par ()
  40 > checkColour (MoveNumber i col) =
  41 >       getBoard                `thenP` \ (Board _ (MoveNumber i' col') _) ->
  42 >       if i == i' && col == col'
  43 >       then returnP ()
  44 >       else failP ("number mis-match: "
  45 >               ++ userFormat (MoveNumber i col)
  46 >               ++ " (looking for "
  47 >               ++ userFormat (MoveNumber i' col')
  48 >               ++ ")\n")
  49
  50 %------------------------------------------------------------------------------
  51
  52 > data StoreBoard
  53 >       = FirstBoard Board
  54 >       | UndoableBoard Board {- new -} Board {- back one -}
  55
  56 > updateBoard :: Board -> Par StoreBoard
  57 > updateBoard brd (FirstBoard old_brd)
  58 >       = UndoableBoard brd old_brd
  59 > updateBoard brd (UndoableBoard old_brd _)
  60 >       = UndoableBoard brd old_brd
  61
  62 > getBoard :: Par Board
  63 > getBoard s@(FirstBoard brd)
  64 >       = brd
  65 > getBoard s@(UndoableBoard brd _)
  66 >       = brd
  67
  68 > undoBoard :: Par StoreBoard
  69 > undoBoard (FirstBoard _)
  70 >       = error "Incorrect start to some analysis"
  71 > undoBoard (UndoableBoard _ old_brd)
  72 >       = FirstBoard old_brd
  73
  74 %------------------------------------------------------------------------------
  75
  76 > pgnInterp :: [Token] -> Par [Quantum]
  77 > pgnInterp (IntToken n:PeriodToken:PeriodToken:PeriodToken:rest) =
  78 >       checkColour (MoveNumber n Black)                `thenP` \ () ->
  79 >       pgnInterp rest
  80 > pgnInterp (IntToken n:PeriodToken:rest) =
  81 >       checkColour (MoveNumber n White)                `thenP` \ () ->
  82 >       pgnInterp rest
  83
  84 > pgnInterp (SymbolToken str:CommentToken (ann:rs):r)
  85 >       | all (flip elem "!?") ann =
  86 >       pgnInterp (SymbolToken str:pgnLexer ann ++ (CommentToken rs:r))
  87
  88 This hack lets us add in analysis, as done by Fritz2,
  89 taking it from the comment, and adding as a variation.
  90
  91 > pgnInterp (CommentToken (n:tag:rest):r)
  92 >       | head tag == '(' && take 2 (reverse tag) == ":)" && length rest > 1 =
  93 >       getCurrColour                           `thenP` \ col ->
  94 >       let
  95 >           invert Black r   = r -- because the move has *already* happend
  96 >           invert _ "0.00"  = "0.00"   -- dont negate 0
  97 >           invert _ ('-':r) = r
  98 >           invert _ r       = '-':r
  99 >       in
 100 >       pgnInterp (LeftRBToken:map SymbolToken (take (length rest-1) rest)
 101 >               ++ [CommentToken ["Score:",invert col n],RightRBToken] ++ r)
 102
 103
 104 > pgnInterp (CommentToken []:rest) = pgnInterp rest
 105 > pgnInterp (CommentToken comm:rest) =
 106 >       consP (QuantumComment comm) rest
 107 > pgnInterp (NAGToken nag:rest) =
 108 >       consP (QuantumNAG nag) rest
 109 > pgnInterp (NAGAnnToken nag _:rest) =
 110 >       consP (QuantumNAG nag) rest
 111 > pgnInterp (SymbolToken "0-1":rest) =
 112 >       consP (QuantumResult "0-1") rest
 113 > pgnInterp (SymbolToken "1-0":rest) =
 114 >       consP (QuantumResult "1-0") rest
 115 > pgnInterp (SymbolToken "1/2-1/2":rest) =
 116 >       consP (QuantumResult "1/2-1/2") rest
 117 > pgnInterp (AsterixToken:rest) =
 118 >       consP (QuantumResult "*") rest
 119 > pgnInterp (SymbolToken move:rest@(NAGAnnToken _ str:_)) =
 120 >       getBoard                `thenP` \ brd ->
 121 >       parseMove move brd      `thenP` \ (mv,ch,corrMv,new_brd) ->
 122 >       updateBoard new_brd     `thenP'`
 123 >       consP (QuantumMove mv ch str new_brd) rest
 124 > pgnInterp (SymbolToken move:rest) =
 125 >       getBoard                `thenP` \ brd ->
 126 >       parseMove move brd      `thenP` \ (mv,ch,corrMv,new_brd) ->
 127 >       updateBoard new_brd     `thenP'`
 128 >       consP (QuantumMove mv ch "" new_brd) rest
 129 > pgnInterp (LeftRBToken:rest) =
 130 >       getAnalysis rest 0 []   `thenP` \ (anal,rest) ->
 131 >       (undoBoard              `thenP'`
 132 >       pgnInterp anal)         `thenP` \ anal' ->
 133 >       consP (QuantumAnalysis anal') rest
 134 > pgnInterp [] = returnP []
 135 > pgnInterp toks = failP ("when reading: "
 136 >               ++ unwords (map userFormat (take 10 toks)))
 137
 138 This has a *horable* complexity
 139
 140 > getAnalysis (t@LeftRBToken:r) n anal = getAnalysis r (n+1) (t:anal)
 141 > getAnalysis (t@RightRBToken:r) n anal
 142 >       | n == (0 :: Int) = returnP (reverse anal,r)
 143 >       | otherwise = getAnalysis r (n-1) (t:anal)
 144 > getAnalysis (t:r) n anal = getAnalysis r n (t:anal)
 145 > getAnalysis [] n anal = failP "no closing ')'"
 146
 147 This is the *real* Interpreter, that makes sense of the move,
 148 and checks that it is possible to do, etc, etc.
 149
 150 > parseMove :: String -> Board -> Par (String,String,String,Board)
 151 > parseMove move brd@(Board _ (MoveNumber _ col) _) =
 152 >   case mapMaybeFail charToMoveTok move of
 153 >    Nothing -> failP ("strange move:" ++ move)
 154 >    Just mv_toks ->
 155 >       let
 156 >          (chs,mv_toks') = getChecks (reverse mv_toks)
 157 >          (queen,mv_toks'') = getQueen mv_toks'
 158 >       in
 159 >       case parseAlgMove mv_toks'' queen brd of
 160 >         (the_mv,new_brd) -> returnP (the_mv,chs,"$$",new_brd)
 161
 162 O-O
 163
 164 > parseAlgMove
 165 >       :: [MoveTok]
 166 >       -> Maybe Piece
 167 >       -> Board
 168 >       -> (String,Board)
 169 > parseAlgMove [PartCastleTok,MoveToTok,PartCastleTok] Nothing
 170 >               = findCastleKMove
 171 > parseAlgMove [PartCastleTok,MoveToTok,PartCastleTok,
 172 >                   MoveToTok,PartCastleTok] Nothing
 173 >               = findCastleQMove
 174
 175 > parseAlgMove (PieceTok King:r) Nothing   = parsePieceMove r King
 176 > parseAlgMove (PieceTok Queen:r) Nothing  = parsePieceMove r Queen
 177 > parseAlgMove (PieceTok Rook:r) Nothing   = parsePieceMove r Rook
 178 > parseAlgMove (PieceTok Knight:r) Nothing  = parsePieceMove r Knight
 179 > parseAlgMove (PieceTok Bishop:r) Nothing  = parsePieceMove r Bishop
 180
 181 f5[-x]g8
 182
 183 > parseAlgMove [FileTok sf,RankTok sr,MoveToTok,FileTok df,RankTok dr] q  =
 184 >       findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q
 185 > parseAlgMove [FileTok sf,RankTok sr,CaptureTok,FileTok df,RankTok dr] q  =
 186 >       findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q
 187
 188 f5g7
 189
 190 > parseAlgMove [FileTok sf,RankTok sr,FileTok df,RankTok dr] q = \ brd ->
 191 >   case lookupBoardPiece brd (sf,sr) of
 192 >       Nothing -> error ("cant find piece at: " ++ userFormatBoardPos (sf,sr))
 193 >       Just Pawn -> findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q brd
 194 >       Just King | sf == 5 && df == 7 -> findCastleKMove brd
 195 >       Just King | sf == 5 && df == 3 -> findCastleQMove brd
 196 >       Just p -> findAMove p (extendBP (sf,sr)) (extendBP (df,dr)) brd
 197
 198 > -- later !
 199
 200 f3
 201
 202 > parseAlgMove [FileTok df,RankTok dr] q =
 203 >       findAPawnMove (Nothing,Nothing) (extendBP (df,dr)) q
 204
 205 fxg4
 206
 207 > parseAlgMove [FileTok sf,CaptureTok,FileTok df,RankTok dr] q  =
 208 >       findAPawnMove (Just sf,Nothing) (extendBP (df,dr)) q
 209
 210 fg
 211
 212 > parseAlgMove [FileTok sf,FileTok df] q  =
 213 >       findAPawnMove (Just sf,Nothing) (Just df,Nothing) q
 214
 215 fxg
 216
 217 > parseAlgMove [FileTok sf,CaptureTok,FileTok df] q  =
 218 >       findAPawnMove (Just sf,Nothing) (Just df,Nothing) q
 219 > parseAlgMove _ _ = error "!>!"
 220
 221 Rf8
 222
 223 > parsePieceMove [FileTok df,RankTok dr] p
 224 >       = findAMove p (Nothing,Nothing) (extendBP (df,dr))
 225
 226 Rxf8
 227
 228 > parsePieceMove [CaptureTok,FileTok df,RankTok dr] p
 229 >       = findAMove p (Nothing,Nothing) (extendBP (df,dr))
 230
 231 R4x?f8
 232
 233 > parsePieceMove [RankTok sr,FileTok df,RankTok dr] p
 234 >       = findAMove p (Nothing,Just sr) (extendBP (df,dr))
 235 > parsePieceMove [RankTok sr,CaptureTok,FileTok df,RankTok dr] p
 236 >       = findAMove p (Nothing,Just sr) (extendBP (df,dr))
 237
 238 Rfx?f8
 239
 240 > parsePieceMove [FileTok sf,FileTok df,RankTok dr] p
 241 >       = findAMove p (Just sf,Nothing) (extendBP (df,dr))
 242 > parsePieceMove [FileTok sf,CaptureTok,FileTok df,RankTok dr] p
 243 >       = findAMove p (Just sf,Nothing) (extendBP (df,dr))
 244
 245 Rf8[-x]?g8
 246
 247 > parsePieceMove [FileTok sf,RankTok sr,MoveToTok,FileTok df,RankTok dr] p
 248 >       = findAMove p (extendBP (sf,sr)) (extendBP (df,dr))
 249 > parsePieceMove [FileTok sf,RankTok sr,CaptureTok,FileTok df,RankTok dr] p
 250 >       = findAMove p (extendBP (sf,sr)) (extendBP (df,dr))
 251 > parsePieceMove _ p = failP ("syntax error in move:")
 252
 253 > getChecks (CheckTok:CheckTok:r) = ("#",r)
 254 > getChecks (CheckTok:r) = ("+",r)
 255 > getChecks (MateTok:r)  = ("#",r)
 256 > getChecks r            = ("",r)
 257
 258 > getQueen (PieceTok p:QueensWith:r) = (Just p,reverse r)
 259 > getQueen r = (Nothing,reverse r)
 260
 261