{- |
Module      :  $FreeCAD$
Description :  Hets(Haskell) end-point of the interface with the OpenCascade
               libraries. It reads the ouput of the C++ program "Brep_Reader"
               and interprets it in order to generate the data for the basic
               FreeCAD terms, which are not properly described in the file
               "Document.xml"
Copyright   :  (c) Robert Savu and Uni Bremen 2011
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Robert.Savu@dfki.de
Stability   :  experimental
Portability :  portable

Haskell layer of the Brep-reader
-}

module FreeCAD.Brep where

import System.Process
import Text.XML.Light
import Data.Maybe
import FreeCAD.As
import FreeCAD.VecTools
import Control.Monad.Reader (ask, ReaderT (..), liftIO)
import System.FilePath

getBrep :: (String, String) -> RIO (BaseObject, Placement)
getBrep :: (String, String) -> RIO (BaseObject, Placement)
getBrep (address :: String
address, "line") =
    ((Vector3, Vector3) -> (BaseObject, Placement))
-> ReaderT String IO (Vector3, Vector3)
-> RIO (BaseObject, Placement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector3, Vector3) -> (BaseObject, Placement)
proc3dLine (ReaderT String IO (Vector3, Vector3)
 -> RIO (BaseObject, Placement))
-> ReaderT String IO (Vector3, Vector3)
-> RIO (BaseObject, Placement)
forall a b. (a -> b) -> a -> b
$ String -> ReaderT String IO (Vector3, Vector3)
get3dLine String
address
getBrep (address :: String
address, "rectangle") =
    ((Vector3, Vector3, Vector3, Vector3) -> (BaseObject, Placement))
-> ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
-> RIO (BaseObject, Placement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector3, Vector3, Vector3, Vector3) -> (BaseObject, Placement)
procRectangle (ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
 -> RIO (BaseObject, Placement))
-> ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
-> RIO (BaseObject, Placement)
forall a b. (a -> b) -> a -> b
$ String -> ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
getRectangle String
address
getBrep (_, _) = String -> RIO (BaseObject, Placement)
forall a. HasCallStack => String -> a
error "getBrep called with wrong arguments"

proc3dLine :: (Vector3, Vector3) -> (BaseObject, Placement)
proc3dLine :: (Vector3, Vector3) -> (BaseObject, Placement)
proc3dLine (a :: Vector3
a, b :: Vector3
b) = (Double -> BaseObject
Line Double
l, Placement
place)
    where
      l :: Double
l = Vector3 -> Vector3 -> Double
distance3 Vector3
a Vector3
b
      pos :: Vector3
pos = Vector3
a
      ox :: Vector3
ox = Double -> Double -> Double -> Vector3
Vector3 1 0 0
      direction :: Vector3
direction = Vector3 -> Vector3 -> Vector3
subtract3 Vector3
b Vector3
a
      rotVec :: Vector3
rotVec = Vector3 -> Vector3 -> Vector3
v3VecProd Vector3
ox Vector3
direction
      rotVecn :: Vector3
rotVecn = if Vector3 -> Double
norm3 Vector3
rotVec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                    Double -> Vector3 -> Vector3
scalarprod3 (1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
rotVec) Vector3
rotVec
                else
                    Double -> Double -> Double -> Vector3
Vector3 1 0 0
      cosAa :: Double
cosAa = Double -> Double
forall a. Floating a => a -> a
cos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ if Vector3 -> Double
norm3 Vector3
rotVec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                  Double -> Double
forall a. Floating a => a -> a
acos (Vector3 -> Vector3 -> Double
v3DotProd Vector3
ox Vector3
direction Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
direction) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2
              else 0
      sinAa :: Double
sinAa = Double -> Double
forall a. Floating a => a -> a
sqrt (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cosAa Double -> Double -> Double
forall a. Floating a => a -> a -> a
** 2)
      quat :: Vector4
quat = Double -> Double -> Double -> Double -> Vector4
Vector4 (Double
sinAa Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
x Vector3
rotVecn) (Double
sinAa Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
y Vector3
rotVecn)
              (Double
sinAa Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
z Vector3
rotVecn) Double
cosAa
      place :: Placement
place = Vector3 -> Vector4 -> Placement
Placement Vector3
pos Vector4
quat

procRectangle :: (Vector3, Vector3, Vector3, Vector3) -> (BaseObject, Placement)
procRectangle :: (Vector3, Vector3, Vector3, Vector3) -> (BaseObject, Placement)
procRectangle (a :: Vector3
a, b :: Vector3
b, c :: Vector3
c, d :: Vector3
d) = (Double -> Double -> BaseObject
Rectangle Double
h Double
l, Placement
place)
    where
      d1 :: Double
d1 = Vector3 -> Vector3 -> Double
distance3 Vector3
a Vector3
b -- \
      d2 :: Double
d2 = Vector3 -> Vector3 -> Double
distance3 Vector3
a Vector3
c -- > values used to compute rectangle's properties
      d3 :: Double
d3 = Vector3 -> Vector3 -> Double
distance3 Vector3
a Vector3
d -- /
      mn :: Double
mn = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
d1 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
d2 Double
d3) -- heigth/small edge value
      mx :: Double
mx = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
d1 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
d2 Double
d3) -- diagonal length
      md :: Double
md | (Double
d1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mn) Bool -> Bool -> Bool
&& (Double
d1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mx) = Double
d1 -- length value
         | (Double
d2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mn) Bool -> Bool -> Bool
&& (Double
d2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mx) = Double
d2
         | (Double
d3 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mn) Bool -> Bool -> Bool
&& (Double
d3 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
mx) = Double
d3
         | Bool
otherwise = 0
      h :: Double
h = Double
mn
      l :: Double
l = Double
md
      hh :: Vector3
hh | Double
mn Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d1 = Vector3
b -- w/o rotation is on the Oy axis
         | Double
mn Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d2 = Vector3
c
         | Double
mn Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d3 = Vector3
d
         | Bool
otherwise = Double -> Double -> Double -> Vector3
Vector3 0 0 0
      hpoint :: Vector3
hpoint = Vector3 -> Vector3 -> Vector3
subtract3 Vector3
hh Vector3
a
      ll :: Vector3
ll | Double
md Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d1 = Vector3
b -- w/o rotation is on the Ox axis
         | Double
md Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d2 = Vector3
c
         | Double
md Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
d3 = Vector3
d
         | Bool
otherwise = Double -> Double -> Double -> Vector3
Vector3 0 0 0
      lpoint :: Vector3
lpoint = Vector3 -> Vector3 -> Vector3
subtract3 Vector3
ll Vector3
a
      {- obtain actual rotation by 2 intermediary rotations, matching points in
      space ( a = 0.0.0; first: hpoint = hpoint'; then: lpoint = lpoint' )
      0.0.0 --> X.Y.Z
      first we rotate with regard to hpoint (and Oy axis) -}
      oy :: Vector3
oy = Double -> Double -> Double -> Vector3
Vector3 0 1 0
      rot1vec :: Vector3
rot1vec = Vector3 -> Vector3 -> Vector3
v3VecProd Vector3
oy Vector3
hpoint -- rotation axis (for q1)
      rot1vecn :: Vector3
rot1vecn = if Vector3 -> Double
norm3 Vector3
rot1vec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                     Double -> Vector3 -> Vector3
scalarprod3 (1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
rot1vec) Vector3
rot1vec -- norm.rot.axis
                 else
                     Double -> Double -> Double -> Vector3
Vector3 1 0 0
      cosAa1 :: Double
cosAa1 = Double -> Double
forall a. Floating a => a -> a
cos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ if Vector3 -> Double
norm3 Vector3
rot1vec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                   Double -> Double
forall a. Floating a => a -> a
acos (Vector3 -> Vector3 -> Double
v3DotProd Vector3
oy Vector3
hpoint Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
hpoint) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2
               else 0
      sinAa1 :: Double
sinAa1 = Double -> Double
forall a. Floating a => a -> a
sqrt (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cosAa1 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** 2)
      quat1 :: Vector4
quat1 = Double -> Double -> Double -> Double -> Vector4
Vector4 (Double
sinAa1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
x Vector3
rot1vecn) (Double
sinAa1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
y Vector3
rot1vecn)
              (Double
sinAa1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
z Vector3
rot1vecn) Double
cosAa1
      tmatrix :: Matrix33
tmatrix = Vector4 -> Matrix33
quat2matrix Vector4
quat1
      l2point :: Vector3
l2point = Matrix33 -> Vector3 -> Vector3
rotate Matrix33
tmatrix (Double -> Double -> Double -> Vector3
Vector3 (Vector3 -> Double
norm3 Vector3
lpoint) 0 0)
      -- then we rotate l2point into lpoint
      rot2vec :: Vector3
rot2vec = Vector3 -> Vector3 -> Vector3
v3VecProd Vector3
l2point Vector3
lpoint
      rot2vecn :: Vector3
rot2vecn = if Vector3 -> Double
norm3 Vector3
rot2vec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                     Double -> Vector3 -> Vector3
scalarprod3 (1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
rot2vec) Vector3
rot2vec
                 else Double -> Double -> Double -> Vector3
Vector3 1 0 0
      cosAa2 :: Double
cosAa2 = Double -> Double
forall a. Floating a => a -> a
cos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ if Vector3 -> Double
norm3 Vector3
rot2vec Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then
                   Double -> Double
forall a. Floating a => a -> a
acos (Vector3 -> Vector3 -> Double
v3DotProd Vector3
l2point Vector3
lpoint Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Vector3 -> Double
norm3 Vector3
lpoint) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2
               else 0
      sinAa2 :: Double
sinAa2 = Double -> Double
forall a. Floating a => a -> a
sqrt (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cosAa2 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** 2)
      quat2 :: Vector4
quat2 = Double -> Double -> Double -> Double -> Vector4
Vector4 (Double
sinAa2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
x Vector3
rot2vecn) (Double
sinAa2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
y Vector3
rot2vecn)
              (Double
sinAa2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Vector3 -> Double
z Vector3
rot2vecn) Double
cosAa2
      quaternion :: Vector4
quaternion = Vector4 -> Vector4 -> Vector4
quatProd Vector4
quat1 Vector4
quat2
      pos :: Vector3
pos = Vector3
a
      place :: Placement
place = Vector3 -> Vector4 -> Placement
Placement Vector3
pos Vector4
quaternion

brepToXmlBinary :: RIO FilePath
brepToXmlBinary :: RIO String
brepToXmlBinary = String -> RIO String
forall (m :: * -> *) a. Monad m => a -> m a
return "brep_to_xml"

getBrepObject :: (String -> a) -> String -> String -> RIO a
getBrepObject :: (String -> a) -> String -> String -> RIO a
getBrepObject parser :: String -> a
parser t :: String
t addr :: String
addr = do
  String
tmpDir <- RIO String
forall r (m :: * -> *). MonadReader r m => m r
ask
  String
binary <- RIO String
brepToXmlBinary
  (String -> a) -> RIO String -> RIO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> a
parser (RIO String -> RIO a) -> RIO String -> RIO a
forall a b. (a -> b) -> a -> b
$ IO String -> RIO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO String) -> IO String -> RIO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
binary [[String] -> String
joinPath [String
tmpDir, String
addr], String
t] ""

get3dLine :: String -> RIO (Vector3, Vector3)
get3dLine :: String -> ReaderT String IO (Vector3, Vector3)
get3dLine = (String -> (Vector3, Vector3))
-> String -> String -> ReaderT String IO (Vector3, Vector3)
forall a. (String -> a) -> String -> String -> RIO a
getBrepObject String -> (Vector3, Vector3)
parseBrepXML2 "line"

getRectangle :: String -> RIO (Vector3, Vector3, Vector3, Vector3)
getRectangle :: String -> ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
getRectangle = (String -> (Vector3, Vector3, Vector3, Vector3))
-> String
-> String
-> ReaderT String IO (Vector3, Vector3, Vector3, Vector3)
forall a. (String -> a) -> String -> String -> RIO a
getBrepObject String -> (Vector3, Vector3, Vector3, Vector3)
parseBrepXML "rectangle"

parseBrepXML :: String -> (Vector3, Vector3, Vector3, Vector3)
parseBrepXML :: String -> (Vector3, Vector3, Vector3, Vector3)
parseBrepXML a :: String
a = Element -> (Vector3, Vector3, Vector3, Vector3)
getData (Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc String
a))

parseBrepXML2 :: String -> (Vector3, Vector3)
parseBrepXML2 :: String -> (Vector3, Vector3)
parseBrepXML2 a :: String
a = Element -> (Vector3, Vector3)
getData2 (Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc String
a))

quadFromList :: [a] -> (a, a, a, a)
quadFromList :: [a] -> (a, a, a, a)
quadFromList ([]) = String -> (a, a, a, a)
forall a. HasCallStack => String -> a
error "quadFromList: List empty"
quadFromList (_ : []) = String -> (a, a, a, a)
forall a. HasCallStack => String -> a
error "quadFromList: List too short"
quadFromList (_ : _ : []) = String -> (a, a, a, a)
forall a. HasCallStack => String -> a
error "quadFromList: List too short"
quadFromList (_ : _ : _ : []) = String -> (a, a, a, a)
forall a. HasCallStack => String -> a
error "quadFromList: List too short"
quadFromList (b :: a
b : c :: a
c : d :: a
d : e :: [a]
e) = (a
b, a
c, a
d, [a] -> a
forall a. [a] -> a
head [a]
e)

doubleFromList :: [a] -> (a, a)
doubleFromList :: [a] -> (a, a)
doubleFromList [] = String -> (a, a)
forall a. HasCallStack => String -> a
error "doubleFromList: List too short"
doubleFromList (_ : []) = String -> (a, a)
forall a. HasCallStack => String -> a
error "quadFromList: List too short"
doubleFromList (b :: a
b : c :: [a]
c) = (a
b, [a] -> a
forall a. [a] -> a
head [a]
c)

getData :: Element -> (Vector3, Vector3, Vector3, Vector3)
getData :: Element -> (Vector3, Vector3, Vector3, Vector3)
getData e :: Element
e = if QName -> String
qName (Element -> QName
elName Element
e) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "rectangle" then
                [Vector3] -> (Vector3, Vector3, Vector3, Vector3)
forall a. [a] -> (a, a, a, a)
quadFromList ((Element -> Vector3) -> [Element] -> [Vector3]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Element -> Vector3
parseVertex (Element -> [Element]
elChildren Element
e))
            else String -> (Vector3, Vector3, Vector3, Vector3)
forall a. HasCallStack => String -> a
error "unsupported object type in the .brp file"

getData2 :: Element -> (Vector3, Vector3)
getData2 :: Element -> (Vector3, Vector3)
getData2 e :: Element
e = if QName -> String
qName (Element -> QName
elName Element
e) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "line" then
                 [Vector3] -> (Vector3, Vector3)
forall a. [a] -> (a, a)
doubleFromList ((Element -> Vector3) -> [Element] -> [Vector3]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Element -> Vector3
parseVertex (Element -> [Element]
elChildren Element
e))
             else String -> (Vector3, Vector3)
forall a. HasCallStack => String -> a
error "unsuported ubject type in the .brp file"

parseVertex :: Element -> Vector3
parseVertex :: Element -> Vector3
parseVertex e :: Element
e = Double -> Double -> Double -> Vector3
Vector3 (String -> Double
forall b. Read b => String -> b
getD "x") (String -> Double
forall b. Read b => String -> b
getD "y") (String -> Double
forall b. Read b => String -> b
getD "z") where
    getD :: String -> b
getD el :: String
el = b -> (String -> b) -> Maybe String -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> b
forall a. HasCallStack => String -> a
error "erroneous input given by c++ module")
               String -> b
forall b. Read b => String -> b
read (QName -> Element -> Maybe String
findAttr (String -> QName
unqual String
el) Element
e)

type Env = FilePath
type RIO a = ReaderT Env IO a