hets/FreeCAD/Translator.hs

	Translator.hs revision 544c60683756b3ad5869a2e19bdb3d285eba16c6
{- |
Module      :  $Header$
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 mbel = findChild objListQName mbel

objList:: Element -> [Element]
objList mbel= findChildren objQName (fromJust (objListEl mbel))

firstThree :: String -> String
firstThree s = take 3 s

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 [Char]
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