94 , cmd1 "ROOM~DEL" SS |
94 , cmd1 "ROOM~DEL" SS |
95 , cmd1 "ROOMS" $ Many [SS] |
95 , cmd1 "ROOMS" $ Many [SS] |
96 , cmd "KICKED" [] |
96 , cmd "KICKED" [] |
97 , cmd "RUN_GAME" [] |
97 , cmd "RUN_GAME" [] |
98 , cmd "ROUND_FINISHED" [] |
98 , cmd "ROUND_FINISHED" [] |
|
99 , cmd1 "ADD_TEAM" $ Many [SS] |
|
100 , cmd1 "REMOVE_TEAM" SS |
|
101 , cmd1 "CFG~MAP" SS |
|
102 , cmd1 "CFG~SEED" SS |
|
103 , cmd1 "CFG~THEME" SS |
|
104 , cmd1 "CFG~TEMPLATE" IntP |
|
105 , cmd1 "CFG~MAPGEN" IntP |
|
106 , cmd1 "CFG~FEATURE_SIZE" IntP |
|
107 , cmd1 "CFG~MAZE_SIZE" IntP |
|
108 , cmd1 "CFG~SCRIPT" SS |
|
109 , cmd1 "CFG~DRAWNMAP" LS |
|
110 , cmd2 "CFG~AMMO" SS LS |
|
111 , cmd1 "FULLMAPCONFIG" $ Many [LS] |
99 ] |
112 ] |
100 |
113 |
101 hasMany = any isMany |
114 hasMany = any isMany |
102 isMany (Many _) = True |
115 isMany (Many _) = True |
103 isMany _ = False |
116 isMany _ = False |
127 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
140 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
128 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
141 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
129 maybeMerge c [] = PTPrefix [c] [] |
142 maybeMerge c [] = PTPrefix [c] [] |
130 cmdLeaf ([(c, hwc:assocs1)], assocs2) |
143 cmdLeaf ([(c, hwc:assocs1)], assocs2) |
131 | null assocs1 = PTPrefix [c] [hwc] : map buildsub assocs2 |
144 | null assocs1 = PTPrefix [c] [hwc] : map buildsub assocs2 |
132 | otherwise = error "not supported" --[buildsub (c, assocs1)] ++ [PTPrefix [] [hwc]] ++ map buildsub assocs2 |
145 | otherwise = [buildsub (c, assocs1)] ++ [PTPrefix [] [hwc]] ++ map buildsub assocs2 |
133 |
146 |
134 dumpTree = vcat . map dt |
147 dumpTree = vcat . map dt |
135 where |
148 where |
136 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
149 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
137 dt _ = empty |
150 dt _ = empty |
138 |
151 |
139 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
152 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [l, s]--[grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
140 where |
153 where |
141 maybeQuotes "$" = text "#0" |
154 maybeQuotes "$" = text "#0" |
142 maybeQuotes "~" = text "#10" |
155 maybeQuotes "~" = text "#10" |
143 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
156 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
144 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
157 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
152 handlerTypes = map cmdParams2handlerType $ reverse sortedCmdDescriptions |
165 handlerTypes = map cmdParams2handlerType $ reverse sortedCmdDescriptions |
153 sortedCmdDescriptions = sort commandsDescription |
166 sortedCmdDescriptions = sort commandsDescription |
154 fixedNames = map fixName handlers |
167 fixedNames = map fixName handlers |
155 bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes |
168 bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes |
156 handlerBody n = text "procedure " <> text n <> semi |
169 handlerBody n = text "procedure " <> text n <> semi |
157 $+$ text "begin" |
170 $+$ text "begin" |
158 $+$ text "end" <> semi |
171 $+$ text "end" <> semi |
159 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi |
172 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi |
160 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
173 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
161 realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions |
174 realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions |
162 realHandlersArray = text "const handlers: array[TCmdType] of PHandler = " |
175 realHandlersArray = text "const handlers: array[TCmdType] of PHandler = " |
163 <> parens (hsep . punctuate comma . concatMap (rhentry "@handler_") $ sortedCmdDescriptions) <> semi |
176 <> parens (hsep . punctuate comma . concatMap (map ((<>) (text "PHandler") . parens) . rhentry "@handler_") $ sortedCmdDescriptions) <> semi |
164 |
177 |
165 rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
178 rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
166 $+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi |
179 $+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi |
167 , emptyBody] else empty |
180 , emptyBody] else empty |
168 where |
181 where |
169 emptyBody = text "begin" $+$ text "end" <> semi |
182 emptyBody = text "begin" $+$ text "end" <> semi |
170 |
183 |
171 rhentry prefix cmd@(Command n p) = map ((<>) (text "PHandler") . parens) $ (text . (++) prefix . fixName . cmdName $ cmd) |
184 rhentry prefix cmd@(Command n p) = (text . (++) prefix . fixName . cmdName $ cmd) |
172 : if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else [] |
185 : if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else [] |
173 |
186 |
174 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
187 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
175 where |
188 where |
176 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
189 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |