hets/FreeCAD/Translator.hs

{- |
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