{- |
Module : ./FreeCAD/Translator.hs
Description : The main part of the module. Here the parsing, translation of the
input xml is handled, as well as the I/O.
Copyright : (c) Robert Savu and Uni Bremen 2011
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Robert.Savu@dfki.de
Stability : experimental
Portability : portable
Declaration of the abstract datatypes of FreeCAD terms
-}
module FreeCAD.Translator where
import FreeCAD.As
import Text.XML.Light
import Data.Maybe
import Data.Set as Set
import FreeCAD.Brep
import System.Directory
import System.IO
import System.Process
import System.FilePath
import FreeCAD.PrintAs ()
import Control.Monad.Reader (ReaderT (..))
getFreshTempDir :: IO FilePath
getFreshTempDir = do
dir <- getTemporaryDirectory
(fp, _) <- openTempFile dir "hetsfc"
removeFile fp
createDirectory fp
return fp
processFile :: FilePath -> IO Document
processFile fp = do
tempDir <- getFreshTempDir
readProcess "unzip" ["-o", fp, "-d", tempDir] []
xmlInput <- readFile (joinPath [tempDir, "Document.xml"])
let parsed = parseXMLDoc xmlInput
d <- runReaderT (translate' $ fromJust parsed) tempDir
removeDirectoryRecursive tempDir
return d
-- constants used to find the appropriate subtree in the XML file:
objListQName :: QName
objListQName = unqual "ObjectData"
objQName :: QName
objQName = unqual "Object"
objListEl :: Element -> Maybe Element
objListEl = findChild objListQName
objList :: Element -> [Element]
objList mbel = findChildren objQName (fromJust (objListEl mbel))
firstThree :: String -> String
firstThree = take 3
getName :: Element -> String
getName el = fromJust (findAttr (unqual "name") el)
hasName :: String -> Element -> Bool
hasName s el = getName el == s
childByName :: String -> Element -> Element
childByName s el = fromJust (findChild (unqual s) el)
childByNameAttr :: String -> Element -> Element
childByNameAttr s el = fromJust (filterChild (hasName s) el)
-- a Set constant -- TODO: find signature
setBaseObjs :: Set.Set String
setBaseObjs = fromList ["Box", "Sph", "Cyl", "Con", "Tor", "Cir", "Rec"]
isBaseObject :: Element -> Bool
isBaseObject el = member (firstThree (getName el)) setBaseObjs
{- identify (by its name) whether an object is simpe or extended
returns true if it is a base object and false otherwise -}
getObject :: Element -> RIO NamedObject
getObject el | tn == "Box" = mkBaseObject $ getBox elc
| tn == "Sph" = mkBaseObject $ getSph elc
| tn == "Cyl" = mkBaseObject $ getCyl elc
| tn == "Con" = mkBaseObject $ getCon elc
| tn == "Tor" = mkBaseObject $ getTor elc
| tn == "Cir" = mkBaseObject $ getCir elc
| tn == "Rec" = mkRectangle el
| tn == "Lin" = mkLine el -- TODO
| tn == "Cut" = mkObject $ getCut elc
| tn == "Com" = mkObject $ getCom elc
| tn == "Fus" = mkObject $ getFus elc
| tn == "Sec" = mkObject $ getSec elc
| tn == "Ext" = mkObject $ getExt elc
where
tn = firstThree (getName el)
mkObject = return . NamedObject (getName el)
. PlacedObject (findPlacement elc)
mkBaseObject = mkObject . BaseObject
getBox e = Box (findFloat "Height" e) (findFloat "Width" e)
(findFloat "Length" e)
getSph e = Sphere (findFloat "Angle1" e) (findFloat "Angle2" e)
(findFloat "Angle3" e) (findFloat "Radius" e)
getCyl e = Cylinder (findFloat "Angle" e) (findFloat "Height" e)
(findFloat "Radius" e)
getCon e = Cone (findFloat "Angle" e) (findFloat "Radius1" e)
(findFloat "Radius2" elc) (findFloat "Height" e)
getTor e = Torus (findFloat "Angle1" e) (findFloat "Angle2" e)
(findFloat "Angle3" e) (findFloat "Radius1" e)
(findFloat "Radius2" e)
getCir e = Circle (findFloat "StartAngle" e) (findFloat "EndAngle" e)
(findFloat "Radius" e)
getCut e = Cut (findRef "Base" e) (findRef "Tool" e)
getCom e = Common (findRef "Base" e) (findRef "Tool" e)
getSec e = Section (findRef "Base" e) (findRef "Tool" e)
getFus e = Fusion (findRef "Base" e) (findRef "Tool" e)
getExt e = Extrusion (findRef "Base" e) (findPropVec "Dir" e)
elc = child el
getObject _ = error "undefined object"
mkRectangle :: Element -> RIO NamedObject
mkRectangle ef = do
let e = child ef
el2 = childByNameAttr "Shape" e
elx = childByName "Part" el2
(bo, place) <- getBrep (getVal "file" elx, "rectangle")
let obj = BaseObject bo
po = PlacedObject place obj
return $ NamedObject (getVal "name" ef) po
mkLine :: Element -> RIO NamedObject
mkLine ef = do
let e = child ef
el2 = childByNameAttr "Shape" e
elx = childByName "Part" el2
(bo, place) <- getBrep (getVal "file" elx, "line")
let obj = BaseObject bo
po = PlacedObject place obj
return $ NamedObject (getVal "name" ef) po
getVal :: String -> Element -> String
getVal s el = fromJust (findAttr (unqual s) el)
getFloatVal :: Element -> String
getFloatVal el = getVal "value" el2
where
el2 = childByName "Float" el
getPlacementVals :: Element -> (String , String , String , String , String , String
, String)
getPlacementVals el = (m "Px", m "Py", m "Pz", m "Q0", m "Q1", m "Q2", m "Q3")
where
m s = getVal s el2
el2 = childByName "PropertyPlacement" el
getLinkVal :: Element -> String
getLinkVal el = getVal "value" el2
where
el2 = childByName "Link" el
findFloat :: String -> Element -> Double
findFloat s el = read (getFloatVal el2)
where
el2 = childByNameAttr s el
findPlacement :: Element -> FreeCAD.As.Placement
findPlacement el = Placement (Vector3 a b c) (Vector4 d e f g)
where
(sa, sb, sc, sd, se, sf, sg) = getPlacementVals el2
a = read sa
b = read sb
c = read sc
d = read sd
e = read se
f = read sf
g = read sg
el2 = childByNameAttr "Placement" el
findRef :: String -> Element -> FreeCAD.As.ExtendedObject
findRef s el = Ref (getLinkVal el2) where
el2 = childByNameAttr s el
findPropVec :: String -> Element -> FreeCAD.As.Vector3
findPropVec s el = Vector3 valueX valueY valueZ where
el2 = childByNameAttr s el
propVec = fromJust ( findChild ( unqual "PropertyVector" ) el2)
valueX = read $ fromJust $ findAttr (unqual "valueX") propVec
valueY = read $ fromJust $ findAttr (unqual "valueY") propVec
valueZ = read $ fromJust $ findAttr (unqual "valueZ") propVec
child :: Element -> Element
child el = head (elChildren el)
{- Facade function that translates the parsed XML document
into Haskell-FreeCAD datatype -}
translate' :: Element -> RIO Document
translate' baseElement = mapM getObject $ objList baseElement