--- a/hedgewars/uLandTemplates.pas Sat Oct 13 18:32:41 2018 +0200
+++ b/hedgewars/uLandTemplates.pas Sat Oct 13 22:38:51 2018 +0200
@@ -1805,7 +1805,6 @@
(x:1005; y: 805; w: 0; h: 0)
);
-
const Template46Points: array[0..19] of TSDL_Rect =
(
(x: 800; y: 1424; w: 1; h: 1),
--- a/tools/pas2c/Pas2C.hs Sat Oct 13 18:32:41 2018 +0200
+++ b/tools/pas2c/Pas2C.hs Sat Oct 13 22:38:51 2018 +0200
@@ -186,6 +186,7 @@
toCFiles _ _ (_, Redo _) = return ()
toCFiles outputPath ns pu@(fileName, _) = do
hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
+ --let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p
toCFiles' pu
where
toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
--- a/tools/pas2c/PascalUnitSyntaxTree.hs Sat Oct 13 18:32:41 2018 +0200
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs Sat Oct 13 22:38:51 2018 +0200
@@ -5,20 +5,20 @@
| Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
| System [TypeVarDeclaration]
| Redo [TypeVarDeclaration]
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Interface = Interface Uses TypesAndVars
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Implementation = Implementation Uses TypesAndVars
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Identifier = Identifier String BaseType
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data TypesAndVars = TypesAndVars [TypeVarDeclaration]
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
| VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
| FunctionDeclaration Identifier Bool Bool Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
| OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data TypeDecl = SimpleType Identifier
| RangeType Range
| Sequence [Identifier]
@@ -32,17 +32,17 @@
| DeriveType InitExpression
| VoidType
| VarParamType TypeDecl -- this is a hack
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Range = Range Identifier
| RangeFromTo InitExpression InitExpression
| RangeInfinite
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Initialize = Initialize String
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Finalize = Finalize String
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Uses = Uses [Identifier]
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Phrase = ProcCall Reference [Expression]
| IfThenElse Expression Phrase (Maybe Phrase)
| WhileCycle Expression Phrase
@@ -54,7 +54,7 @@
| Assignment Reference Expression
| BuiltInFunctionCall [Expression] Reference
| NOP
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Expression = Expression String
| BuiltInFunCall [Expression] Reference
| PrefixOp String Expression
@@ -70,7 +70,7 @@
| Reference Reference
| SetExpression [Identifier]
| Null
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data Reference = ArrayElement [Expression] Reference
| FunCall [Expression] Reference
| TypeCast Identifier Expression
@@ -79,7 +79,7 @@
| RecordField Reference Reference
| Address Reference
| RefExpression Expression
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data InitExpression = InitBinOp String InitExpression InitExpression
| InitPrefixOp String InitExpression
| InitReference Identifier
@@ -97,7 +97,7 @@
| InitNull
| InitRange Range
| InitTypeCast Identifier InitExpression
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
data BaseType = BTUnknown
| BTChar
@@ -116,4 +116,4 @@
| BTVoid
| BTUnit
| BTVarParam BaseType
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/landTemplatesUnit2yaml.hs Sat Oct 13 22:38:51 2018 +0200
@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Monad
+import Data.Maybe
+import qualified Data.Yaml as YAML
+import Data.Yaml ((.=))
+import Data.List
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as Text
+
+import PascalUnitSyntaxTree
+
+
+fixName :: String -> String
+fixName "MaxHedgeHogs" = "max_hedgehogs"
+fixName"canFlip" = "can_flip"
+fixName"canInvert" = "can_invert"
+fixName"canMirror" = "can_mirror"
+fixName"TemplateWidth" = "width"
+fixName"TemplateHeight" = "height"
+fixName"RandPassesCount" = "rand_passes"
+fixName"BezierizeCount" = "bezie_passes"
+fixName"hasGirders" = "put_girders"
+fixName"isNegative" = "is_negative"
+fixName a = a
+
+instance YAML.ToJSON InitExpression where
+ toJSON (InitArray ar) = YAML.toJSON ar
+ toJSON (InitRecord ar) = YAML.object $ map (\(Identifier i _, iref) -> Text.pack (fixName i) .= iref) $ filter isRelevant ar
+ where
+ isRelevant (Identifier i _, _) | i `elem` ["BasePoints", "FillPoints", "BasePointsCount", "FillPointsCount"] = False
+ isRelevant _ = True
+ toJSON (InitTypeCast {}) = YAML.object []
+ toJSON (BuiltInFunction {}) = YAML.object []
+ toJSON (InitNumber n) = YAML.toJSON (read n :: Int)
+ toJSON (InitReference (Identifier "true" _)) = YAML.toJSON True
+ toJSON (InitReference (Identifier "false" _)) = YAML.toJSON False
+ toJSON a = error $ show a
+
+instance YAML.ToJSON Identifier where
+ toJSON (Identifier i _) = YAML.toJSON i
+
+data Template = Template InitExpression ([InitExpression], InitExpression)
+ deriving Show
+
+instance YAML.ToJSON Template where
+ toJSON (Template (InitRecord ri) (points, fpoints)) = YAML.toJSON $ InitRecord $ ri ++ [(Identifier "outline_points" BTUnknown, InitArray points), (Identifier "fill_points" BTUnknown, fpoints)]
+
+takeLast i = reverse . take i . reverse
+
+extractDeclarations :: PascalUnit -> [TypeVarDeclaration]
+extractDeclarations (Unit (Identifier "uLandTemplates" _) (Interface _ (TypesAndVars decls)) _ _ _) = decls
+extractDeclarations _ = error "Unexpected file structure"
+
+extractTemplatePoints :: Int -> [TypeVarDeclaration] -> ([InitExpression], InitExpression)
+extractTemplatePoints templateNumber decls = (breakNTPX . head . catMaybes $ map (toTemplatePointInit "Points") decls, head . catMaybes $ map (toTemplatePointInit "FPoints") decls)
+ where
+ toTemplatePointInit suffix (VarDeclaration False False ([Identifier i _], _) ie)
+ | (i == "Template" ++ show templateNumber ++ suffix) = ie
+ | otherwise = Nothing
+ toTemplatePointInit _ _ = Nothing
+
+ breakNTPX :: InitExpression -> [InitExpression]
+ breakNTPX (InitArray ia) = map (InitArray . filter (not . isNtpx)) $ groupBy (\a _ -> not $ isNtpx a) ia
+ breakNTPX a = error $ show a
+ isNtpx :: InitExpression -> Bool
+ isNtpx (InitRecord ((Identifier "x" _, InitReference (Identifier "NTPX" _)):_)) = True
+ isNtpx _ = False
+
+extractTemplates :: [TypeVarDeclaration] -> [Template]
+extractTemplates decls = map toFull $ zip (head . catMaybes $ map toTemplateInit decls) [0..]
+ where
+ toTemplateInit (VarDeclaration False False ([Identifier "EdgeTemplates" _], _) (Just (InitArray ia))) = Just ia
+ toTemplateInit _ = Nothing
+
+ toFull (ie, num) = let ps = extractTemplatePoints num decls in if "NTPX" `isInfixOf` show ps then error $ show num ++ " " ++ show ps else Template ie ps
+
+convert :: PascalUnit -> B.ByteString
+convert pu = YAML.encode . extractTemplates . extractDeclarations $ pu
+
+main = do
+ f <- liftM read $ readFile "uLandTemplates.dump"
+ B.putStrLn $ convert f