contrib/haskell/src/Hkl/C/Geometry.hsc

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 {-# LANGUAGE GADTs #-}
   5
   6 module Hkl.C.Geometry
   7        ( Geometry(..)
   8        , Factory(..)
   9        , HklDetector
  10        , HklFactory
  11        , HklMatrix
  12        , HklQuaternion
  13        , factoryFromString
  14        , newFactory
  15        , newGeometry
  16        , withGeometry
  17        ) where
  18
  19 import Prelude hiding (min, max)
  20
  21 import Numeric.LinearAlgebra
  22 import Foreign ( ForeignPtr
  23                , FunPtr
  24                , Ptr
  25                , nullPtr
  26                , newForeignPtr
  27                , withForeignPtr)
  28 import Foreign.C (CInt(..), CDouble(..), CSize(..), CString,
  29                  peekCString, withCString)
  30 import Foreign.Storable
  31
  32 import Numeric.Units.Dimensional.Prelude ( meter, nano
  33                                          , (*~), (/~))
  34
  35 import qualified Data.Vector.Storable as V
  36 import qualified Data.Vector.Storable.Mutable as MV
  37
  38 import Hkl.Types
  39 import Hkl.C.DArray
  40
  41 #include "hkl.h"
  42
  43 -- | Factory
  44
  45 data Factory = K6c | Uhv | MedH | MedV | SoleilSiriusKappa
  46
  47 instance Show Factory where
  48   show K6c = "K6C"
  49   show Uhv = "ZAXIS"
  50   show MedH = "todo"
  51   show MedV = "todo"
  52   show SoleilSiriusKappa = "SOLEIL SIRIUS KAPPA"
  53
  54 factoryFromString :: String -> Factory
  55 factoryFromString s
  56   | s == "K6C"  = K6c
  57   | s == "ZAXIS" = Uhv
  58   | s == "todo" = MedH
  59   | s == "todo" = MedV
  60   | s == "SOLEIL SIRIUS KAPPA" = SoleilSiriusKappa
  61   | otherwise   = error $ "unknown diffractometer type:" ++ s
  62
  63 -- | Geometry
  64
  65 data Geometry = Geometry
  66                 Factory -- ^ the type of diffractometer
  67                 Source -- ^ source
  68                 (Vector Double) -- ^ axes position
  69                 (Maybe [Parameter]) -- ^ axes configuration
  70               deriving (Show)
  71
  72
  73 -- private types
  74
  75 data HklDetector
  76 data HklFactory
  77 data HklMatrix
  78 data HklQuaternion
  79
  80 #if __GLASGOW_HASKELL__ <= 710
  81 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
  82 #endif
  83
  84 -- Factory
  85
  86 newFactory :: Factory -> IO (Ptr HklFactory)
  87 newFactory f = withCString (show f) $ \cname -> c_hkl_factory_get_by_name cname nullPtr
  88
  89 foreign import ccall unsafe "hkl.h hkl_factory_get_by_name"
  90   c_hkl_factory_get_by_name :: CString  -- ^ name
  91                             -> Ptr () -- ^ GError (null for now)
  92                             -> IO (Ptr HklFactory)
  93 -- Geometry
  94
  95 peekSource :: Ptr Geometry -> IO (Source)
  96 peekSource ptr = do
  97     (CDouble w) <- c_hkl_geometry_wavelength_get ptr unit
  98     return (Source (w *~ nano meter))
  99
 100 foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_set"
 101   c_hkl_geometry_wavelength_set :: Ptr Geometry -- geometry
 102                                 -> CDouble -- wavelength
 103                                 -> CInt -- unit
 104                                 -> Ptr () -- *gerror
 105                                 -> IO () -- IO CInt but for now do not deal with the errors
 106
 107 pokeSource :: Ptr Geometry -> Source -> IO ()
 108 pokeSource ptr (Source lw) = do
 109   let wavelength = CDouble (lw /~ nano meter)
 110   c_hkl_geometry_wavelength_set ptr wavelength unit nullPtr
 111
 112 foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_get"
 113   c_hkl_geometry_wavelength_get :: Ptr Geometry -- geometry
 114                                 -> CInt -- unit
 115                                 -> IO CDouble -- wavelength
 116
 117 peekAxis :: Ptr Geometry -> CString -> IO Parameter
 118 peekAxis ptr s = c_hkl_geometry_axis_get ptr s nullPtr >>= peek
 119
 120 instance Storable Geometry where
 121   alignment _ = #{alignment int}
 122
 123   sizeOf _ = #{size int}
 124
 125   peek ptr = do
 126     f_name <- c_hkl_geometry_name_get ptr >>= peekCString
 127     let factory = factoryFromString f_name
 128
 129     source <- peekSource ptr
 130
 131     (DArray n axis_names) <- peek =<< c_hkl_geometry_axis_names_get ptr
 132     v <- MV.new (fromEnum n)
 133     MV.unsafeWith v $ \values ->
 134       c_hkl_geometry_axis_values_get ptr values n unit
 135     vs <- V.freeze v
 136
 137     ps <- mapM (peekAxis ptr) axis_names
 138
 139     return $ Geometry factory source vs (Just ps)
 140
 141   poke ptr (Geometry _ s vs _) = do
 142     pokeSource ptr s
 143     (DArray n _) <- peek =<< c_hkl_geometry_axis_names_get ptr
 144     V.unsafeWith vs $ \values ->
 145       c_hkl_geometry_axis_values_set ptr values n unit nullPtr
 146
 147 foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_get"
 148   c_hkl_geometry_axis_values_get :: Ptr Geometry -- geometry
 149                                  -> Ptr Double -- axis values
 150                                  -> CSize -- size of axis values
 151                                  -> CInt -- unit
 152                                  -> IO () -- IO CInt but for now do not deal with the errors
 153
 154 foreign import ccall unsafe "hkl.h hkl_geometry_axis_names_get"
 155   c_hkl_geometry_axis_names_get :: Ptr Geometry -- goemetry
 156                                 -> IO (Ptr (DArray CString)) -- darray_string
 157
 158 foreign import ccall unsafe "hkl.h hkl_geometry_axis_get"
 159   c_hkl_geometry_axis_get :: Ptr Geometry -- geometry
 160                           -> CString -- axis name
 161                           -> Ptr () -- gerror
 162                           -> IO (Ptr Parameter) -- parameter or nullPtr
 163
 164 foreign import ccall unsafe "hkl.h hkl_geometry_name_get"
 165   c_hkl_geometry_name_get :: Ptr Geometry -> IO CString
 166
 167 foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_set"
 168   c_hkl_geometry_axis_values_set :: Ptr Geometry -- geometry
 169                                  -> Ptr Double -- axis values
 170                                  -> CSize -- size of axis values
 171                                  -> CInt -- unit
 172                                  -> Ptr () -- gerror
 173                                  -> IO () -- IO CInt but for now do not deal with the errors
 174
 175 withGeometry ::  Geometry -> (Ptr Geometry -> IO b) -> IO b
 176 withGeometry g fun = do
 177   fptr <- newGeometry g
 178   withForeignPtr fptr fun
 179
 180 newGeometry :: Geometry -> IO (ForeignPtr Geometry)
 181 newGeometry g@(Geometry f _ _ _) = do
 182   ptr <- c_hkl_factory_create_new_geometry =<< newFactory f
 183   poke ptr g
 184   newForeignPtr c_hkl_geometry_free ptr
 185
 186 foreign import ccall unsafe "hkl.h hkl_factory_create_new_geometry"
 187   c_hkl_factory_create_new_geometry :: Ptr HklFactory -> IO (Ptr Geometry)
 188
 189 foreign import ccall unsafe "hkl.h &hkl_geometry_free"
 190   c_hkl_geometry_free :: FunPtr (Ptr Geometry -> IO ())