1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
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)
|
