diff options
Diffstat (limited to 'testsuite/tests/programs/andy_cherry/Main.hs')
| -rw-r--r-- | testsuite/tests/programs/andy_cherry/Main.hs | 204 |
1 files changed, 204 insertions, 0 deletions
diff --git a/testsuite/tests/programs/andy_cherry/Main.hs b/testsuite/tests/programs/andy_cherry/Main.hs new file mode 100644 index 0000000000..aa4274ec59 --- /dev/null +++ b/testsuite/tests/programs/andy_cherry/Main.hs @@ -0,0 +1,204 @@ + + module Main (main) where + + import GenUtils + import DataTypes + import Parser + import Interp + import PrintTEX + + import System.Environment -- 1.3 (partain) + import Data.Char -- 1.3 + + --fakeArgs = "game001.txt" + --fakeArgs = "pca2.pgn" + --fakeArgs = "silly.pgn" + --fakeArgs = "small.pgn" + --fakeArgs = "sicil.pgn" + --fakeArgs = "badgame.pgn" + --fakeArgs = "mycgames.pgn" + fakeArgs = "rab.pgn" + + version = "0.3" + + + main = do + [test_dir] <- getArgs + let (style,fn,filename) = interpArgs (words "-d tex mygames.pgn") + file <- readFile (test_dir ++ "/" ++filename) + std_in <- getContents + let games = pgnParser fn file -- parse relavent pgn games + putStr (prog style std_in games) + +{- OLD 1.2: + main = + getArgs abort $ \ args -> + --let args = (words "-d tex analgames.pgn") in + let (style,fn,filename) = interpArgs args in + readFile filename abort $ \ file -> + readChan stdin abort $ \ std_in -> + let games = pgnParser fn file -- parse relavent pgn games + in + appendChan stdout (prog style std_in games) abort done +-} + + interpArgs :: [String] -> (OutputStyle,Int -> Bool,String) + --interpArgs [] = (ViewGame,const True,fakeArgs) + interpArgs [] = interpArgs (words "-d pgn analgames.pgn") + interpArgs files = interpArgs' OutputPGN (const True) files + + interpArgs' style fn ("-d":"pgn":xs) = interpArgs' OutputPGN fn xs + interpArgs' style fn ("-d":"rawpgn":xs) = interpArgs' OutputRawPGN fn xs + interpArgs' style fn ("-d":"play":xs) = interpArgs' ViewGame fn xs + interpArgs' style fn ("-d":"parser":xs) = interpArgs' OutputParser fn xs + interpArgs' style fn ("-d":"tex":xs) = interpArgs' OutputTEX fn xs + interpArgs' style fn ("-d":"head":xs) = interpArgs' OutputHeader fn xs + interpArgs' style fn ("-g":range:xs) + = interpArgs' style (changeFn (parse range)) xs + where + changeFn (Digit n:Line:Digit m:r) x = moreChangeFn r x || x >= n && x <= m + changeFn (Line:Digit m:r) x = moreChangeFn r x || x <= m + changeFn (Digit n:Line:r) x = moreChangeFn r x || x >= n + changeFn (Digit n:r) x = moreChangeFn r x || x == n + changeFn _ _ = rangeError + moreChangeFn [] = const False + moreChangeFn (Comma:r) = changeFn r + moreChangeFn _ = rangeError + parse xs@(n:_) + | isDigit n = case span isDigit xs of + (dig,rest) -> Digit (read dig) : parse rest + parse ('-':r) = Line : parse r + parse (',':r) = Comma : parse r + parse [] = [] + parse _ = rangeError + rangeError = error ("incorrect -g option (" ++ range ++ ")\n") + + interpArgs' style fn [file] = (style,fn,file) + interpArgs' style fn args = error ("bad args: " ++ unwords args) + + data Tok + = Digit Int -- n + | Line -- - + | Comma -- , + + data OutputStyle + + = OutputPGN -- pgn + | OutputRawPGN -- rawpgn + | OutputHeader -- header + | ViewGame -- play + | ViewGameEmacs -- emacs + | TwoColumn -- 2col + | TestGames -- test + | OutputTEX + + + + | OutputParser -- simply dump out the string read in. + | CmpGen -- cmp 2nd and 3rd generations of output + + + + prog :: OutputStyle -- style of action + -> String -- stdin (for interactive bits) + -> [AbsGame] -- input games + -> String -- result + prog OutputPGN _ + = pgnPrinter True -- print out game(s) + . map runInterp -- interprete all games + prog OutputRawPGN _ + = pgnPrinter False -- print out game(s) + . map runInterp -- interprete all games + prog OutputHeader _ + = pgnHeadPrinter -- print out game(s) headers + . map runInterp -- interprete all games + prog OutputTEX _ + = texPrinter -- print out game(s) + . map runInterp -- interprete all games + prog ViewGame std_in + = interactViewer std_in -- print out game(s) + . runInterp -- interprete the game + . head -- should check for only *one* object + prog OutputParser _ + = userFormat + + + + + + + + + + type PrintState = (Bool,MoveNumber) + + pgnPrinter :: Bool -> [RealGame] -> String + pgnPrinter detail = unlines . concat . map printGame + where + printMoveNumber :: Bool -> MoveNumber -> String + printMoveNumber False (MoveNumber _ Black) = "" + printMoveNumber _ mvnum = userFormat mvnum ++ " " + + printQuantums :: PrintState -> [Quantum] -> [String] + printQuantums ps = concat . fst . mapAccumL printQuantum ps + + printQuantum :: PrintState -> Quantum -> ([String],PrintState) + printQuantum (pnt,mv) (QuantumMove move ch an brd) = + ([printMoveNumber pnt mv ++ move ++ ch],(False,incMove mv)) + printQuantum (pnt,mv) (QuantumNAG i) = + if detail + then (["$" ++ show i],(False,mv)) + else ([],(False,mv)) + printQuantum (pnt,mv) (QuantumComment comms) = + if detail + then ("{" : comms ++ ["}"],(True,mv)) + else ([],(False,mv)) + printQuantum (pnt,mv) (QuantumAnalysis anal) = + if detail + then ("(" : printQuantums (True,decMove mv) anal ++ [")"], + (True,mv)) + else ([],(False,mv)) + printQuantum (pnt,mv) (QuantumResult str) = ([str],(True,mv)) + printQuantum _ _ = error "PANIC: strange Quantum" + + printGame :: RealGame -> [String] + printGame (Game tags qu) = + [ userFormat tag | tag <- tags] ++ + formatText 75 (printQuantums (False,initMoveNumber) qu) + + + + printHeadGame :: RealGame -> [String] + printHeadGame (Game tags qu) = [ + rjustify 4 gameno ++ " " ++ + take 20 (rjustify 20 white) ++ " - " ++ + take 20 (ljustify 20 black) ++ " " ++ + take 26 (ljustify 28 site) ++ " " ++ result ] + where + (date,site,game_no,res,white,black,opening) = getHeaderInfo tags + gameno = case game_no of + Nothing -> "" + Just n -> show n + result = userFormat res + + pgnHeadPrinter :: [RealGame] -> String + pgnHeadPrinter = unlines . concat . map printHeadGame + + + + + + interactViewer :: String -> RealGame -> String + interactViewer stdin (Game tags qu) = replayQ qu (lines stdin) + + replayQ (QuantumMove _ _ _ brd:rest) std_in + = "\027[H" ++ userFormat brd ++ waitQ rest std_in + replayQ (_:rest) std_in = replayQ rest std_in + replayQ [] _ = [] + + waitQ game std_in = ">>" ++ + (case std_in of + [] -> "" + (q:qs) -> replayQ game qs) + + |