ghc/tests/programs/andy_cherry/Main.lhs

   1 > module Main (main) where
   2
   3 > import GenUtils
   4 > import DataTypes
   5 > import Parser
   6 > import Interp
   7 > import PrintTEX
   8
   9 > import System -- 1.3 (partain)
  10 > import Char -- 1.3
  11
  12 > --fakeArgs = "game001.txt"
  13 > --fakeArgs = "pca2.pgn"
  14 > --fakeArgs = "silly.pgn"
  15 > --fakeArgs = "small.pgn"
  16 > --fakeArgs = "sicil.pgn"
  17 > --fakeArgs = "badgame.pgn"
  18 > --fakeArgs = "mycgames.pgn"
  19 > fakeArgs = "rab.pgn"
  20
  21 > version = "0.3"
  22
  23
  24 > main = do
  25 >       args <- getArgs
  26 >       let (style,fn,filename) = interpArgs args
  27 >       file <- readFile filename
  28 >       std_in <- getContents
  29 >       let games = pgnParser fn file   -- parse relavent pgn games
  30 >       putStr (prog style std_in games)
  31
  32 >{- OLD 1.2:
  33 > main =
  34 >       getArgs         abort                           $ \ args ->
  35 >       --let args = (words "-d tex analgames.pgn") in
  36 >       let (style,fn,filename) = interpArgs args in
  37 >       readFile filename abort                         $ \ file ->
  38 >       readChan stdin abort                            $ \ std_in ->
  39 >       let games = pgnParser fn file   -- parse relavent pgn games
  40 >       in
  41 >       appendChan stdout (prog style std_in games) abort done
  42 >-}
  43
  44 > interpArgs :: [String] -> (OutputStyle,Int -> Bool,String)
  45 > --interpArgs [] = (ViewGame,const True,fakeArgs)
  46 > interpArgs [] = interpArgs (words "-d pgn analgames.pgn")
  47 > interpArgs files = interpArgs' OutputPGN (const True) files
  48
  49 > interpArgs' style fn ("-d":"pgn":xs)    = interpArgs' OutputPGN    fn xs
  50 > interpArgs' style fn ("-d":"rawpgn":xs) = interpArgs' OutputRawPGN fn xs
  51 > interpArgs' style fn ("-d":"play":xs)   = interpArgs' ViewGame     fn xs
  52 > interpArgs' style fn ("-d":"parser":xs) = interpArgs' OutputParser fn xs
  53 > interpArgs' style fn ("-d":"tex":xs)    = interpArgs' OutputTEX    fn xs
  54 > interpArgs' style fn ("-d":"head":xs)   = interpArgs' OutputHeader fn xs
  55 > interpArgs' style fn ("-g":range:xs)
  56 >       = interpArgs' style (changeFn (parse range)) xs
  57 >    where
  58 >       changeFn (Digit n:Line:Digit m:r) x = moreChangeFn r x || x >= n && x <= m
  59 >       changeFn (Line:Digit m:r) x = moreChangeFn r x || x <= m
  60 >       changeFn (Digit n:Line:r) x = moreChangeFn r x || x >= n
  61 >       changeFn (Digit n:r) x = moreChangeFn r x || x == n
  62 >       changeFn _ _ = rangeError
  63 >       moreChangeFn [] = const False
  64 >       moreChangeFn (Comma:r) = changeFn r
  65 >       moreChangeFn _ = rangeError
  66 >       parse xs@(n:_)
  67 >               | isDigit n = case span isDigit xs of
  68 >                               (dig,rest) -> Digit (read dig) : parse rest
  69 >       parse ('-':r) = Line : parse r
  70 >       parse (',':r) = Comma : parse r
  71 >       parse [] = []
  72 >       parse _ = rangeError
  73 >       rangeError = error ("incorrect -g option (" ++ range ++ ")\n")
  74
  75 > interpArgs' style fn [file] = (style,fn,file)
  76 > interpArgs' style fn args = error ("bad args: " ++ unwords args)
  77
  78 > data Tok
  79 >       = Digit Int             -- n
  80 >       | Line                  -- -
  81 >       | Comma                 -- ,
  82
  83 > data OutputStyle
  84
  85 >       = OutputPGN             -- pgn
  86 >       | OutputRawPGN          -- rawpgn
  87 >       | OutputHeader          -- header
  88 >       | ViewGame              -- play
  89 >       | ViewGameEmacs         -- emacs
  90 >       | TwoColumn             -- 2col
  91 >       | TestGames             -- test
  92 >       | OutputTEX
  93
  94 Finally the debug options.
  95
  96 >       | OutputParser  -- simply dump out the string read in.
  97 >       | CmpGen        -- cmp 2nd and 3rd generations of output
  98
  99 The *main* program.
 100
 101 > prog  :: OutputStyle          -- style of action
 102 >       -> String               -- stdin (for interactive bits)
 103 >       -> [AbsGame]            -- input games
 104 >       -> String               -- result
 105 > prog OutputPGN _
 106 >               = pgnPrinter True       -- print out game(s)
 107 >               . map runInterp         -- interprete all games
 108 > prog OutputRawPGN _
 109 >               = pgnPrinter False      -- print out game(s)
 110 >               . map runInterp         -- interprete all games
 111 > prog OutputHeader _
 112 >               = pgnHeadPrinter        -- print out game(s) headers
 113 >               . map runInterp         -- interprete all games
 114 > prog OutputTEX _
 115 >               = texPrinter            -- print out game(s)
 116 >               . map runInterp         -- interprete all games
 117 > prog ViewGame std_in
 118 >               = interactViewer std_in -- print out game(s)
 119 >               . runInterp             -- interprete the game
 120 >               . head                  -- should check for only *one* object
 121 > prog OutputParser _
 122 >               = userFormat
 123
 124 %------------------------------------------------------------------------------
 125
 126 Printing the pgn file.
 127
 128 1) if White, *always* print number,
 129 2) is After comment / variation, print number, ie 2. Nf4 ( <stuff> ) 2... Rh8
 130
 131
 132 > type PrintState = (Bool,MoveNumber)
 133
 134 > pgnPrinter :: Bool -> [RealGame] -> String
 135 > pgnPrinter detail = unlines . concat . map printGame
 136 >   where
 137 >       printMoveNumber :: Bool -> MoveNumber -> String
 138 >       printMoveNumber False (MoveNumber _ Black) = ""
 139 >       printMoveNumber _     mvnum = userFormat mvnum ++ " "
 140
 141 >       printQuantums :: PrintState -> [Quantum] -> [String]
 142 >       printQuantums ps = concat . fst . mapAccumL printQuantum ps
 143
 144 >       printQuantum :: PrintState -> Quantum -> ([String],PrintState)
 145 >       printQuantum (pnt,mv) (QuantumMove move ch an brd) =
 146 >               ([printMoveNumber pnt mv ++ move ++ ch],(False,incMove mv))
 147 >       printQuantum (pnt,mv) (QuantumNAG i) =
 148 >               if detail
 149 >               then (["$" ++ show i],(False,mv))
 150 >               else ([],(False,mv))
 151 >       printQuantum (pnt,mv) (QuantumComment comms) =
 152 >               if detail
 153 >               then ("{" : comms ++ ["}"],(True,mv))
 154 >               else ([],(False,mv))
 155 >       printQuantum (pnt,mv) (QuantumAnalysis anal) =
 156 >               if detail
 157 >               then ("(" : printQuantums (True,decMove mv) anal ++ [")"],
 158 >                       (True,mv))
 159 >               else ([],(False,mv))
 160 >       printQuantum (pnt,mv) (QuantumResult str) = ([str],(True,mv))
 161 >       printQuantum _ _ = error "PANIC: strange Quantum"
 162
 163 >       printGame :: RealGame -> [String]
 164 >       printGame (Game tags qu) =
 165 >               [ userFormat tag | tag <- tags] ++
 166 >               formatText 75 (printQuantums (False,initMoveNumber) qu)
 167
 168 %------------------------------------------------------------------------------
 169
 170 > printHeadGame :: RealGame -> [String]
 171 > printHeadGame (Game tags qu) = [
 172 >       rjustify 4 gameno ++ " " ++
 173 >       take 20 (rjustify 20 white) ++ " - " ++
 174 >       take 20 (ljustify 20 black) ++ " " ++
 175 >       take 26 (ljustify 28 site) ++ " " ++ result ]
 176 >   where
 177 >       (date,site,game_no,res,white,black,opening) = getHeaderInfo tags
 178 >       gameno = case game_no of
 179 >                 Nothing -> ""
 180 >                 Just n -> show n
 181 >       result = userFormat res
 182
 183 > pgnHeadPrinter :: [RealGame] -> String
 184 > pgnHeadPrinter = unlines . concat . map printHeadGame
 185
 186 %------------------------------------------------------------------------
 187
 188 This gives an interactive playback of a game.
 189
 190 > interactViewer :: String -> RealGame -> String
 191 > interactViewer stdin (Game tags qu) = replayQ qu (lines stdin)
 192
 193 > replayQ (QuantumMove _ _ _ brd:rest) std_in
 194 >       = "\027[H" ++ userFormat brd ++ waitQ rest std_in
 195 > replayQ (_:rest) std_in = replayQ rest std_in
 196 > replayQ [] _ = []
 197
 198 > waitQ game std_in = ">>" ++
 199 >    (case std_in of
 200 >       [] -> ""
 201 >       (q:qs) -> replayQ game qs)
 202
 203