Commit 4cf1fbc7 authored by partain's avatar partain

[project @ 1996-01-11 14:21:31 by partain]

parent 6f510a33
......@@ -45,6 +45,7 @@ SUBDIRS = arith001 \
cg034 \
cg035 \
cg036 \
cg037 \
ghclib001 \
io001 /* 1.3 I/O */ \
io002 \
......@@ -81,13 +82,14 @@ SUBDIRS = arith001 \
po011 \
po012 \
net001 /* SocketPrim, BSD, Socket */ \
net002 \
net002 \
net003 \
net004 \
net005 \
net006 \
net007 \
net008
net008 \
stable001
/* LATER: specialise */
......@@ -100,18 +102,3 @@ runtests::
@echo '###############################################################'
@echo '# GHC tests that need to be *run* #'
@echo '###############################################################'
NoFibOneModuleCompileAndRun(10queens,)
module Main (main) -- q
where {
--import Fast2haskell;
f_queens a_n=f_queens' (enumFromTo (1 :: Int) a_n) a_n;
f_queens' a_positions 0=(:) [] [];
f_queens' a_positions a_n=c_concat (f_map (f_place (f_queens' a_positions (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)))) a_positions);
f_place a_boards a_q=[(:) a_q a_bs|a_bs<-a_boards,f_safe (1 :: Int) a_q a_bs];
f_safe a_d a_q []=True;
f_safe a_d a_q (a_h:a_t)=
if (((==) :: (Int -> Int -> Bool)) a_q a_h)
then False
else
if (((==) :: (Int -> Int -> Bool)) (f_absi (((-) :: (Int -> Int -> Int)) a_q a_h)) a_d)
then False
else
(f_safe (((+) :: (Int -> Int -> Int)) a_d (1 :: Int)) a_q a_t);
f_absi a_n=
if (((<) :: (Int -> Int -> Bool)) a_n (0 :: Int))
then (((negate) :: (Int -> Int)) a_n)
else
a_n;
f_main a_n=(++) (show (length (f_queens a_n))) "\n";
c_input=(10 :: Int);
c_concat=f_foldr (++) [];
f_foldr a_op a_r []=a_r;
f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x);
f_map a_f a_x=[a_f a_a|a_a<-a_x];
main r = [AppendChan "stdout" (f_main c_input)]
}
#define IHaveSubdirs
SUBDIRS = 10queens \
andy_cherry \
cvh_unboxing \
dmgob_native1 \
dmgob_native2 \
fast2haskell \
ipoole_spec_class \
jq_readsPrec \
jl_defaults \
jtod_circint \
jules_xref \
jules_xref2 \
lennart_array \
lennart_range \
lex \
life_space_leak \
north_array \
sanders_array \
waugh_neural \
zhang_ccall
/* andre_monad: boring -- the correct answer is a divide-by-zero */
/* NOT REALLY A BUG: fun_insts */
/* NOT A BUG AS FAR AS I CAN TELL: north_lias */
/* NOT A BUG: stk overflow is expected w/ stranal: hill_stk_oflow */
/* TESTS OLD ccall (now irrelevant): areid_pass */
runtests::
@echo '###############################################################'
@echo '# GHC tests to *run* -- from reported bugs #'
@echo '###############################################################'
These are bug-programs (fixed) that I haven't turned into tests yet.
Will
val1 :: Array Int Int
val1 = array (12,10) []
main = print [val1 == val1]
main = prints (exponent (2.0 :: Float), significand (2.0 :: Float),
exponent (2.0 :: Double),significand (2.0 :: Double)) "\n"
NoFibOneModuleCompileAndRun(andre_monad,)
-- Evaluator in a monad: with execution counts
-- Phil Wadler, 11 October 1991
-- Types are optional. Some must be commented out to
-- work around a bug in Gofer.
-- The count monad
type M a = (a, Int)
unit :: a -> M a
unit a = (a, 0)
bind :: M a -> (a -> M b) -> M b
m `bind` k = case m of
(a,i) -> case k a of
(b,j) -> (b,i+j)
-- disp :: Text a => M a -> String
disp (a,i) = show a ++ "\nCount: " ++ show i
tick :: M ()
tick = ((), 1)
-- The evaluator
-- Lines with * are only change from evalIdent
data Op = Add | Sub | Mul | Quo
data Term = Con Int | Bin Op Term Term
eval :: Term -> M Int
eval (Con i) = unit i
eval (Bin op u v) = eval u `bind` (\a ->
eval v `bind` (\b ->
do op a b `bind` (\c -> -- *
tick `bind` (\() -> -- *
unit c)))) -- *
do :: Op -> Int -> Int -> M Int
do Add a b = unit (a+b)
do Sub a b = unit (a-b)
do Mul a b = unit (a*b)
do Quo a b = unit (a `quot` b) -- WDP: was "div"
test :: Term -> String
test t = disp (eval t)
-- Test data
add, sub, mul, quo :: Term -> Term -> Term
u `add` v = Bin Add u v
u `sub` v = Bin Sub u v
u `mul` v = Bin Mul u v
u `quo` v = Bin Quo u v
term0,term1,term2 :: Term
term0 = Con 6 `mul` Con 9
term1 = (Con 4 `mul` Con 13) `add` Con 2
term2 = (Con 1 `quo` Con 0) `add` Con 2
term3 = ((((((((((((((((((((((((((((((((
((((((((((((((((((((((((((((((
Con 7777 `mul` Con 13) `quo` Con 13)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
`mul` Con 755) `quo` Con 755) `mul` Con 333)
`quo` Con 755) `mul` Con 755) `mul` Con 333)
sb 0 = term2
sb n = if (n `mod` 2) == 0
then term2 `add` (sb (n-1))
else term2 `sub` (sb (n-1))
main = print (show (eval (sb 5000)))
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface DataTypes where
import GenUtils(Maybe)
import PreludeArray(Array)
class Presentable a where
userFormat :: a -> [Char]
{-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Char]) -> u1 _N_
{-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{Presentable u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [Char]) } [ _NOREP_S_ "%DDataTypes.Presentable.userFormat\"", u2 ] _N_ #-}
type AbsGame = Game Token
data Board = Board (Array (Int, Int) BoardSquare) MoveNumber (Maybe Int)
type BoardPos = (Int, Int)
data BoardSquare = VacantSq | WhitesSq Piece | BlacksSq Piece
type ChessFile = Int
type ChessRank = Int
data Colour = Black | White
type ExBoardPos = (Maybe Int, Maybe Int)
data Game a = Game [TagStr] [a]
data MoveNumber = MoveNumber Int Colour
data MoveTok = PieceTok Piece | RankTok Int | FileTok Int | PartCastleTok | CaptureTok | MoveToTok | QueensWith | CheckTok | MateTok
data Piece = King | Queen | Rook | Knight | Bishop | Pawn
data PlayMove = PlayMove Piece (Int, Int) (Int, Int) SpecialMove
data Quantum = QuantumMove [Char] [Char] [Char] Board | QuantumNAG Int | QuantumComment [[Char]] | QuantumResult [Char] | QuantumAnalysis [Quantum] | QuantumPrintBoard
type RealGame = Game Quantum
data Result = Win | Draw | Loss | Unknown
data SpecialMove = NothingSpecial | BigPawnMove | Queening Piece | EnPassant
data SquareContent = Vacant | Friendly | Baddy | OffBoard
data TagStr = TagStr [Char] [Char]
data Token = StringToken [Char] | AsterixToken | LeftABToken | RightABToken | NAGToken Int | NAGAnnToken Int [Char] | SymbolToken [Char] | CommentToken [[Char]] | LeftSBToken | RightSBToken | LeftRBToken | RightRBToken | IntToken Int | PeriodToken | AnalToken [Token]
boardSize :: ((Int, Int), (Int, Int))
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
buildBoard :: [Char] -> Board
{-# GHC_PRAGMA _A_ 0 _U_ 1 _N_ _N_ _N_ _N_ #-}
castleK :: [Char]
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
castleQ :: [Char]
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
changeColour :: Colour -> Colour
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: Colour) -> case u0 of { _ALG_ _ORIG_ DataTypes White -> _!_ _ORIG_ DataTypes Black [] []; _ORIG_ DataTypes Black -> _!_ _ORIG_ DataTypes White [] []; _NO_DEFLT_ } _N_ #-}
charToMoveTok :: Char -> Maybe MoveTok
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
compExBPandBP :: (Maybe Int, Maybe Int) -> (Int, Int) -> Bool
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(SL)U(LL)" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
decMove :: MoveNumber -> MoveNumber
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LE)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
displayBoard :: Colour -> Board -> [[Char]]
{-# GHC_PRAGMA _A_ 0 _U_ 21 _N_ _N_ _N_ _N_ #-}
extendBP :: (Int, Int) -> (Maybe Int, Maybe Int)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LL)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extractDestFromPlayMove :: PlayMove -> (Int, Int)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(LL)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: Int) -> _!_ _TUP_2 [Int, Int] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: PlayMove) -> case u0 of { _ALG_ _ORIG_ DataTypes PlayMove (u1 :: Piece) (u2 :: (Int, Int)) (u3 :: (Int, Int)) (u4 :: SpecialMove) -> u3; _NO_DEFLT_ } _N_ #-}
extractSpecialFromPlayMove :: PlayMove -> SpecialMove
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SpecialMove) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: PlayMove) -> case u0 of { _ALG_ _ORIG_ DataTypes PlayMove (u1 :: Piece) (u2 :: (Int, Int)) (u3 :: (Int, Int)) (u4 :: SpecialMove) -> u4; _NO_DEFLT_ } _N_ #-}
extractSrcFromPlayMove :: PlayMove -> (Int, Int)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(LL)AA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: Int) -> _!_ _TUP_2 [Int, Int] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: PlayMove) -> case u0 of { _ALG_ _ORIG_ DataTypes PlayMove (u1 :: Piece) (u2 :: (Int, Int)) (u3 :: (Int, Int)) (u4 :: SpecialMove) -> u2; _NO_DEFLT_ } _N_ #-}
getBoardColour :: Board -> Colour
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(AE)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Colour) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Board) -> case u0 of { _ALG_ _ORIG_ DataTypes Board (u1 :: Array (Int, Int) BoardSquare) (u2 :: MoveNumber) (u3 :: Maybe Int) -> case u2 of { _ALG_ _ORIG_ DataTypes MoveNumber (u4 :: Int) (u5 :: Colour) -> u5; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getHeaderInfo :: [TagStr] -> ([Char], [Char], Maybe Int, Result, [Char], [Char], [Char])
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getMoveColour :: MoveNumber -> Colour
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AE)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Colour) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: MoveNumber) -> case u0 of { _ALG_ _ORIG_ DataTypes MoveNumber (u1 :: Int) (u2 :: Colour) -> u2; _NO_DEFLT_ } _N_ #-}
getOpenName :: Int -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: Int) -> _NOREP_S_ "Foo" _N_ #-}
getOpening :: [Char] -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getSquarePiece :: BoardSquare -> Maybe Piece
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTagStr :: [Char] -> [Char] -> [TagStr] -> [Char]
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
incMove :: MoveNumber -> MoveNumber
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LE)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
initMoveNumber :: MoveNumber
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
lookupBoard :: Board -> (Int, Int) -> SquareContent
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLA)U(U(P)L)" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupBoardPiece :: Board -> (Int, Int) -> Maybe Piece
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(SS)P)AA)U(U(P)U(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupBoardSquare :: Board -> (Int, Int) -> BoardSquare
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(SS)P)AA)U(U(P)U(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupSquare :: Colour -> BoardSquare -> SquareContent
{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-}
mkColBoardSq :: Colour -> Piece -> BoardSquare
{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "EL" _F_ _ALWAYS_ \ (u0 :: Colour) (u1 :: Piece) -> case u0 of { _ALG_ _ORIG_ DataTypes White -> _!_ _ORIG_ DataTypes WhitesSq [] [u1]; _ORIG_ DataTypes Black -> _!_ _ORIG_ DataTypes BlacksSq [] [u1]; _NO_DEFLT_ } _N_ #-}
mkPlayMove :: Piece -> (Int, Int) -> (Int, Int) -> PlayMove
{-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
mkResult :: [Char] -> Result
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
startBoard :: Board
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ DataTypes buildBoard [ _NOREP_S_ "rnbqkbnr/pppppppp/32/PPPPPPPP/RNBQKBNR" ] _N_ #-}
userFormatBoardPos :: (Int, Int) -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LL)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userFormatExBoardPos :: (Maybe Int, Maybe Int) -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userFormatFile :: Int -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
userFormatRank :: Int -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
instance Presentable Board
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Board) _N_
userFormat = _A_ 0 _U_ 1 _N_ _N_ _N_ _N_ #-}
instance Presentable Colour
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Colour) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
instance Presentable a => Presentable (Game a)
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 2 _U_ 2 _N_ _S_ "LS" _N_ _N_ #-}
instance Presentable MoveNumber
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (MoveNumber) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)E)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Presentable Piece
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Piece) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
instance Presentable PlayMove
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (PlayMove) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "U(ELLL)" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Presentable Quantum
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Quantum) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Presentable Result
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Result) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
instance Presentable SpecialMove
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (SpecialMove) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Presentable SquareContent
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (SquareContent) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
instance Presentable TagStr
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (TagStr) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "U(LL)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Presentable Token
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 1 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Presentable userFormat (Token) _N_
userFormat = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Presentable a => Presentable [a]
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 2 _U_ 2 _N_ _S_ "LS" _N_ _N_ #-}
instance Eq Colour
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Colour -> Colour -> Bool), (Colour -> Colour -> Bool)] [_CONSTM_ Eq (==) (Colour), _CONSTM_ Eq (/=) (Colour)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
(/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq Piece
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Piece -> Piece -> Bool), (Piece -> Piece -> Bool)] [_CONSTM_ Eq (==) (Piece), _CONSTM_ Eq (/=) (Piece)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
(/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq SpecialMove
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SpecialMove -> SpecialMove -> Bool), (SpecialMove -> SpecialMove -> Bool)] [_CONSTM_ Eq (==) (SpecialMove), _CONSTM_ Eq (/=) (SpecialMove)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
(/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq SquareContent
{-# GHC_PRAGMA _M_ DataTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SquareContent -> SquareContent -> Bool), (SquareContent -> SquareContent -> Bool)] [_CONSTM_ Eq (==) (SquareContent), _CONSTM_ Eq (/=) (SquareContent)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
(/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
> module DataTypes where
> import GenUtils
%------------------------------------------------------------------------------
The `presentable' class, my own co-class for Text
> class Presentable a where
> userFormat :: a -> String -- in prefered display format
Defaults, in terms of each other
And the default for lists.
> instance (Presentable a) => Presentable [a] where
> userFormat xs = unlines (map userFormat xs)
%------------------------------------------------------------------------------
Here are all the pieces allowed in chess.
> data Piece
> = King
> | Queen
> | Rook
> | Knight
> | Bishop
> | Pawn deriving(Eq)
> instance Presentable Piece where
> userFormat King = "K"
> userFormat Queen = "Q"
> userFormat Rook = "R"
> userFormat Knight = "N"
> userFormat Bishop = "B"
> userFormat Pawn = "P"
%------------------------------------------------------------------------------
> castleK = "O-O"
> castleQ = "O-O-O"
%------------------------------------------------------------------------------
Here are the two sides.
> data Colour = Black | White deriving (Eq)
> instance Presentable Colour where
> userFormat White = "White"
> userFormat Black = "Black"
> changeColour :: Colour -> Colour
> changeColour White = Black
> changeColour Black = White
%------------------------------------------------------------------------------
Now the ranks and files.
> type ChessRank = Int -- 1-8
> type ChessFile = Int -- 1-8
> type BoardPos = (ChessFile,ChessRank) -- ChessFile (0-7) and ChessRank (0-7)
> type ExBoardPos = (Maybe ChessFile,Maybe ChessRank)
> extendBP :: BoardPos -> ExBoardPos
> extendBP (a,b) = (Just a,Just b)
> compExBPandBP :: ExBoardPos -> BoardPos -> Bool
> compExBPandBP (a,b) (c,d) = a `cmp` c && b `cmp` d
> where
> cmp Nothing _ = True
> cmp (Just x) y = x == y
> userFormatBoardPos :: BoardPos -> String
> userFormatBoardPos (f,r) = userFormatFile f ++ userFormatRank r
> userFormatExBoardPos :: ExBoardPos -> String
> userFormatExBoardPos (Just f,Just r) = userFormatFile f ++ userFormatRank r
> userFormatExBoardPos (Just f,Nothing) = userFormatFile f
> userFormatExBoardPos (Nothing,Just r) = userFormatRank r
> userFormatExBoardPos _ = ""
> userFormatRank r = [chr (r + 48)]
> userFormatFile f = [chr (f + 96)]
%------------------------------------------------------------------------------
These are the components of a move.
> data MoveTok
> = PieceTok Piece -- Q,K,R,B,N
> | RankTok ChessRank -- 1 .. 8
> | FileTok ChessFile -- a .. h
> | PartCastleTok -- 0 | O | o
> | CaptureTok -- x
> | MoveToTok -- -
> | QueensWith -- =
> | CheckTok -- +
> | MateTok -- #
> charToMoveTok 'Q' = Just (PieceTok Queen)
> charToMoveTok 'K' = Just (PieceTok King)
> charToMoveTok 'R' = Just (PieceTok Rook)
> charToMoveTok 'B' = Just (PieceTok Bishop)
> charToMoveTok 'N' = Just (PieceTok Knight)
> charToMoveTok '1' = Just (RankTok 1)
> charToMoveTok '2' = Just (RankTok 2)
> charToMoveTok '3' = Just (RankTok 3)
> charToMoveTok '4' = Just (RankTok 4)
> charToMoveTok '5' = Just (RankTok 5)
> charToMoveTok '6' = Just (RankTok 6)
> charToMoveTok '7' = Just (RankTok 7)
> charToMoveTok '8' = Just (RankTok 8)
> charToMoveTok 'a' = Just (FileTok 1)
> charToMoveTok 'b' = Just (FileTok 2)
> charToMoveTok 'c' = Just (FileTok 3)
> charToMoveTok 'd' = Just (FileTok 4)
> charToMoveTok 'e' = Just (FileTok 5)
> charToMoveTok 'f' = Just (FileTok 6)
> charToMoveTok 'g' = Just (FileTok 7)
> charToMoveTok 'h' = Just (FileTok 8)
> charToMoveTok '0' = Just (PartCastleTok)
> charToMoveTok 'O' = Just (PartCastleTok)
> charToMoveTok 'o' = Just (PartCastleTok)
> charToMoveTok 'x' = Just (CaptureTok)
> charToMoveTok '-' = Just (MoveToTok)
> charToMoveTok '=' = Just (QueensWith)
> charToMoveTok '+' = Just (CheckTok)
> charToMoveTok '#' = Just (MateTok)
> charToMoveTok _ = Nothing
%------------------------------------------------------------------------------
> data Quantum
> = QuantumMove String -- Short Description of move
> String -- Check or Mate (+ or #)
> String -- !,??,?!, etc
> Board -- Snap Shot of Board
> | QuantumNAG Int -- !,??,?! stuff
> | QuantumComment [String] -- { comment }
> | QuantumResult String -- 1-0, etc (marks end of game)
> | QuantumAnalysis [Quantum] -- ( analysis )
> | QuantumPrintBoard -- {^D}
> instance Presentable Quantum where
> userFormat (QuantumMove mv ch ann _)
> = mv ++ ch ++ ann
> userFormat (QuantumNAG nag) = "$" ++ show nag
> userFormat (QuantumComment comment)
> = "[" ++ unwords comment ++ "]"
> --userFormat (QuantumNumber num) = userFormat num
> userFormat (QuantumResult str) = str
> userFormat (QuantumAnalysis anal) =
> "( " ++ unwords (map userFormat anal) ++ " )"
%------------------------------------------------------------------------------
> data Result = Win | Draw | Loss | Unknown
> instance Presentable Result where
> userFormat Win = "1-0"
> userFormat Draw = "1/2-1/2"
> userFormat Loss = "0-1"
> userFormat Unknown = "*"
> mkResult :: String -> Result
> mkResult "1-0" = Win
> mkResult "1/2-1/2" = Draw
> mkResult "0-1" = Loss
> mkResult _ = Unknown
%------------------------------------------------------------------------------
> data TagStr = TagStr String String
> instance Presentable TagStr where
> userFormat (TagStr tag str) = "[" ++ tag ++ " \"" ++ str ++ "\"]"