one more merge
authornemo
Sun, 14 Oct 2018 09:45:16 -0400
changeset 13918 1d4291eccb5f
parent 13917 ac1801fe51d9 (current diff)
parent 13914 5988e73080a3 (diff)
child 13919 b95074eb8d57
one more merge
--- a/hedgewars/uLandTemplates.pas	Sun Oct 14 09:43:42 2018 -0400
+++ b/hedgewars/uLandTemplates.pas	Sun Oct 14 09:45:16 2018 -0400
@@ -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	Sun Oct 14 09:43:42 2018 -0400
+++ b/tools/pas2c/Pas2C.hs	Sun Oct 14 09:45:16 2018 -0400
@@ -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	Sun Oct 14 09:43:42 2018 -0400
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs	Sun Oct 14 09:45:16 2018 -0400
@@ -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	Sun Oct 14 09:45:16 2018 -0400
@@ -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