Commit a686e0c6 authored by sewardj's avatar sewardj
Browse files

[project @ 2001-07-11 16:06:23 by sewardj]

Assimilate ghc/tests/programs.  This includes bringing several of them
back from the dead.
parent 6b071de2
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 = putStr (f_main c_input)
}
TOP = ..
include $(TOP)/mk/boilerplate.mk
all :: runtest
include $(TOP)/mk/test.mk
include ($confdir ++ "/../multimod-test.T")
-- Args to mtr are: extra compile flags
-- extra run flags
-- expected process return value, if not zero
test "10queens" { mtr("", "", "") }
#-----------------------------------------------------------------------------
# $Id: Makefile-OLD,v 1.1 2001/07/11 16:06:23 sewardj Exp $
#
# (c) The GHC Team, 1999-2000
#
TOP = .
include $(TOP)/mk/boilerplate.mk
NOT_THESE = CVS mk
NOT_THESE += hill_stk_oflow
# Correctly fails to terminate
NOT_THESE += ipoole_spec_class
# Dialogue style IO
NOT_THESE += areid_pass
# Old-style I/O
NOT_THESE += north_lias
# Deliberately causes divide by zero, and
# we can't catch that yet
NOT_THESE += andy_cherry barton-mangler-bug cvh_unboxing dmgob_native1 dmgob_native2 fast2haskell fexport jtod_circint okeefe_neural
# doesn't compile
NOT_THESE += jeff-bug lennart_array
# compiles but doesn't run
NOT_THESE += dmgob_native1 dmgob_native2
# Native library doens't exist
ifneq "$(HWL_NOFIB_HACK)" ""
NOT_THESE += callback zhang_ccall
# HWL: tmp disabled for testing GUM-merged version (20/3/01)
# don't compile: failed to load interface for `IOExts'
endif
SUBDIRS = $(filter-out $(patsubst %, %/, $(NOT_THESE)), $(wildcard */))
include $(TOP)/mk/test.mk
-- 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 ->
go op a b `bind` (\c -> -- *
tick `bind` (\ () -> -- *
unit c)))) -- *
go :: Op -> Int -> Int -> M Int
go Add a b = unit (a+b)
go Sub a b = unit (a-b)
go Mul a b = unit (a*b)
go 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 2) `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)))
TOP = ..
include $(TOP)/mk/boilerplate.mk
all :: runtest
include $(TOP)/mk/test.mk
include ($confdir ++ "/../multimod-test.T")
-- Args to mtr are: extra compile flags
-- extra run flags
-- expected process return value, if not zero
test "andre_monad" { mtr("", "", "") }
module DataTypes where
import GenUtils
import Array -- 1.3
import Ix
import Char
infix 1 =: -- 1.3
(=:) a b = (a,b)
class Presentable a where
userFormat :: a -> String -- in prefered display format
instance (Presentable a) => Presentable [a] where
userFormat xs = unlines (map userFormat xs)
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"
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
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 = [toEnum (r + 48)]
userFormatFile f = [toEnum (f + 96)]
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 ++ "\"]"
getTagStr :: String -> String -> [TagStr] -> String
getTagStr str def [] = def
getTagStr str def (TagStr st ans:rest)
| str == st = ans
| otherwise = getTagStr str def rest
getHeaderInfo
:: [TagStr]
-> (
String, -- Date
String, -- Site
Maybe Int, -- Game Number
Result, -- W/D/L
String, -- White
String, -- Black
String -- Opening
)
getHeaderInfo tags = (
date,
site,
gameno,
result,
white `par` whiteElo,
black `par` blackElo,
opening)
where
date = case getTagStr "Date" "?" tags of
[a,b,c,d,'.','?','?','.','?','?'] -> [a,b,c,d]
[a,b,c,d,'.',x,y,'.','?','?'] -> getMonth [x,y] ++ " " ++ [a,b,c,d]
def -> "?"
site = getTagStr "Site" "?" tags
gameno = case getTagStr "GameNumber" "" tags of
xs | all isDigit xs && not (null xs) -> Just (read xs)
_ -> Nothing
result = mkResult (getTagStr "Result" "*" tags)
white = cannon (getTagStr "White" "?" tags)
whiteElo = getTagStr "WhiteElo" "" tags
black = cannon (getTagStr "Black" "?" tags)
blackElo = getTagStr "BlackElo" "" tags
opening = getOpening (getTagStr "ECO" "" tags)
par xs "" = xs
par xs ys = xs ++ " (" ++ ys ++ ")"
getMonth "01" = "Jan"
getMonth "02" = "Feb"
getMonth "03" = "Mar"
getMonth "04" = "Apr"
getMonth "05" = "May"
getMonth "06" = "Jun"
getMonth "07" = "Jul"
getMonth "08" = "Aug"
getMonth "09" = "Sep"
getMonth "10" = "Oct"
getMonth "11" = "Nov"
getMonth "12" = "Dec"
cannon name = case span (/= ',') name of
(a,[',',' ',b]) -> b : ". " ++ a
(a,[',',b]) -> b : ". " ++ a
(a,',':' ':b) -> b ++ " " ++ a
(a,',':b) -> b ++ " " ++ a
_ -> name
getOpening eco@[a,b,c] | a >= 'A' && a <= 'E' && isDigit b && isDigit c
= getOpenName ((fromEnum a - fromEnum 'A') * 100
+ (fromEnum b - fromEnum '0') * 10
+ (fromEnum c - fromEnum '0')) ++ " " ++ eco
getOpening other = other
getOpenName :: Int -> String
getOpenName eco
| otherwise = "Foo"
{-
| eco == 000 = "Irregular Openings"
| eco == 001 = "Larsen Opening"
| eco == 002 = "From's Gambit and Bird's Open"
| eco == 003 = "Bird's Opening"
| eco == 004 = "Dutch System"
| eco == 005 = "Transposition to various Open"
| eco == 006 = "Zukertort Opening"
| eco >= 007 && eco <= 008
= "Barcza System"
| eco == 009 = "Reti Opening"
| eco == 010 = "Variations of Dutch, QI, KI"
| eco >= 011 && eco <= 014
= "Reti Opening"
| eco == 015 = "English counter King's Fianch"
| eco >= 016 && eco <= 039
= "English Opening"
| eco == 040 = "Unusual replies to 1.d4"
| eco == 041 = "Modern Defence counter 1.d4"
| eco == 042 = "Modern Defence with c2-c4"
| eco >= 043 && eco <= 044
= "Old Benoni"
| eco == 045 = "Queen's Pawn-Trompowski Var"
| eco == 046 = "Queen's Pawn Opening"
| eco == 047 = "Queen's Indian"
| eco >= 048 && eco <= 049
= "King's Indian"
| eco == 050 = "Queen's Indian"
| eco >= 051 && eco <= 052
= "Budapest Defence"
| eco >= 053 && eco <= 056
= "Old Indian Defence"
| eco >= 057 && eco <= 059
= "Volga-Benko Gambit"
| eco >= 060 && eco <= 079
= "Benoni"
| eco >= 080 && eco <= 099
= "Dutch Defence"
| eco == 100 = "Owen Def, Nimzowitsch Def"
| eco == 101 = "Center Counter"
| eco >= 102 && eco <= 105
= "Alekhine's Defence"
| eco == 106 = "Modern Defence"
| eco >= 107 && eco <= 109
= "Pirc Defence"
| eco >= 110 && eco <= 119
= "Caro-Kann Defence"
| eco >= 120 && eco <= 199
= "Sicilian Defence"
| eco >= 200 && eco <= 219
= "French Defence"
| eco == 220 = "Rare moves"
| eco == 221 = "Nordic Gambit"
| eco == 222 = "Central Gambit"
| eco >= 223 && eco <= 224
= "Bishop's Opening"
| eco >= 225 && eco <= 229
= "Vienna Game"
| eco == 230 = "King's Gambit Declined"
| eco >= 231 && eco <= 232
= "Falkbeer Counter Gambit"
| eco >= 233 && eco <= 239
= "King's Gambit"
| eco == 240 = "Latvian Gambit"
| eco == 241 = "Philidor Defence"
| eco >= 242 && eco <= 243
= "Russian Defence-Petrov"
| eco >= 244 && eco <= 245
= "Scotch Opening"
| eco >= 246 && eco <= 249
= "Four Knight's"
| eco == 250 = "Italian Opening"
| eco >= 251 && eco <= 252
= "Evans Gambit"
| eco >= 253 && eco <= 254
= "Italian Opening"
| eco >= 255 && eco <= 259
= "Two Knight's Play"
| eco >= 260 && eco <= 299
= "Ruy Lopez"
| eco >= 300 && eco <= 305
= "Queen Pawn's Opening"
| eco >= 306 && eco <= 307
= "Queen's Gambit"
| eco >= 308 && eco <= 309
= "Albins Counter Gambit"
| eco >= 310 && eco <= 319
= "Slav Defence"
| eco >= 320 && eco <= 329
= "Queen's Gambit Accepted"
| eco >= 330 && eco <= 369
= "Queen's Gambit"
| eco >= 370 && eco <= 399
= "Gruenfeld Defence"
| eco >= 400 && eco <= 409
= "Catalan"
| eco == 410 = "Blumenfeld Gambit"
| eco >= 411 && eco <= 419
= "Queen's Indian"
| eco >= 420 && eco <= 459
= "Nimzo Indian"
| eco >= 460 && eco <= 499
= "King's Indian"
-}
data MoveNumber = MoveNumber Int Colour
instance Presentable MoveNumber where
userFormat (MoveNumber n White) = show n ++ "."