contrib/haskell/src/Hkl/C.hsc

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE CPP #-}
   4
   5 module Hkl.C
   6        ( compute
   7        , computePipe
   8        , solve
   9        , solveTraj
  10        , solveTrajPipe
  11        , module X
  12        ) where
  13
  14 import Prelude hiding (min, max)
  15
  16 import Control.Monad (forever)
  17 import Control.Monad.Trans.State.Strict
  18 import Foreign ( ForeignPtr
  19                , FunPtr
  20                , Ptr
  21                , nullPtr
  22                , newForeignPtr
  23                , withForeignPtr
  24                , peekArray
  25                , withArray)
  26 import Foreign.C ( CInt(..), CSize(..), CString
  27                  , withCString)
  28 import Foreign.Storable
  29
  30 import Pipes (Pipe, await, lift, yield)
  31
  32 import Hkl.C.DArray as X
  33 import Hkl.C.Detector as X
  34 import Hkl.C.Engine as X
  35 import Hkl.C.Geometry as X
  36 import Hkl.C.GeometryList as X
  37 import Hkl.C.Lattice as X
  38 import Hkl.C.Sample as X
  39 import Hkl.Detector
  40 import Hkl.Types
  41
  42 #include "hkl.h"
  43
  44 -- private types
  45
  46 data HklEngineList
  47
  48 -- Engine
  49
  50 solve' :: Ptr HklEngine -> Engine -> IO (ForeignPtr HklGeometryList)
  51 solve' engine (Engine _ ps _) = do
  52   let positions = [v | (Parameter _ v _) <- ps]
  53   let n = toEnum (length positions)
  54   withArray positions $ \values ->
  55       c_hkl_engine_pseudo_axis_values_set engine values n unit nullPtr
  56       >>= newForeignPtr c_hkl_geometry_list_free
  57
  58 solve :: Geometry -> Detector a -> Sample b -> Engine -> IO [Geometry]
  59 solve g@(Geometry f _ _ _) d s e@(Engine name _ _) = do
  60   withSample s $ \sample ->
  61       withDetector d $ \detector ->
  62           withGeometry g $ \geometry ->
  63               withEngineList f $ \engines ->
  64                   withCString name $ \cname -> do
  65                   c_hkl_engine_list_init engines geometry detector sample
  66                   engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
  67                   solve' engine e >>= peekHklGeometryList
  68
  69 solveTraj :: Geometry -> Detector a -> Sample b -> [Engine] -> IO [Geometry]
  70 solveTraj g@(Geometry f _ _ _) d s es = do
  71   let name = engineName (head es)
  72   withSample s $ \sample ->
  73       withDetector d $ \detector ->
  74           withGeometry g $ \geometry ->
  75               withEngineList f $ \engines ->
  76                 withCString name $ \cname -> do
  77                   c_hkl_engine_list_init engines geometry detector sample
  78                   engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
  79                   mapM (\e -> solve' engine e >>= getSolution0) es
  80
  81 -- Pipe
  82
  83 data Diffractometer = Diffractometer { difEngineList :: (ForeignPtr HklEngineList)
  84                                      , difGeometry :: (ForeignPtr Geometry)
  85                                      , difDetector :: (ForeignPtr HklDetector)
  86                                      , difSample :: (ForeignPtr HklSample)
  87                                      }
  88                     deriving (Show)
  89
  90 withDiffractometer :: Diffractometer -> (Ptr HklEngineList -> IO b) -> IO b
  91 withDiffractometer d fun = do
  92   let f_engines = difEngineList d
  93   withForeignPtr f_engines fun
  94
  95 newDiffractometer :: Geometry -> Detector a -> Sample b -> IO Diffractometer
  96 newDiffractometer g@(Geometry f _ _ _) d s = do
  97   f_engines <- newEngineList f
  98   f_geometry <- newGeometry g
  99   f_detector <- newDetector d
 100   f_sample <- newSample s
 101   withForeignPtr f_sample $ \sample ->
 102     withForeignPtr f_detector $ \detector ->
 103     withForeignPtr f_geometry $ \geometry ->
 104     withForeignPtr f_engines $ \engines -> do
 105       c_hkl_engine_list_init engines geometry detector sample
 106       return $ Diffractometer { difEngineList = f_engines
 107                               , difGeometry = f_geometry
 108                               , difDetector = f_detector
 109                               , difSample = f_sample
 110                               }
 111
 112 computePipe :: Detector a -> Sample b -> Pipe Geometry [Engine] IO ()
 113 computePipe d s = forever $ do
 114   g <- await
 115   e <- lift $ compute g d s
 116   yield e
 117
 118 solveTrajPipe :: Geometry -> Detector a -> Sample b -> Pipe Engine Geometry IO ()
 119 solveTrajPipe g d s = do
 120   dif <- lift $ newDiffractometer g d s
 121   solveTrajPipe' dif
 122
 123 solveTrajPipe' :: Diffractometer -> Pipe Engine Geometry IO ()
 124 solveTrajPipe' dif = flip evalStateT dif $ forever $ do
 125     -- Inside here we are using `StateT Diffractometer (Pipe Engine Geometry IO ()) r`
 126     e <- lift await
 127     dif_ <- get
 128     let name = engineName e
 129     solutions <- lift . lift $ withDiffractometer dif_ $ \engines ->
 130      withCString name $ \cname -> do
 131        engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr
 132        solve' engine e >>= getSolution0
 133     put dif_
 134     lift $ yield solutions
 135
 136 foreign import ccall unsafe "hkl.h hkl_engine_list_engine_get_by_name"
 137   c_hkl_engine_list_engine_get_by_name :: Ptr HklEngineList --engine list
 138                                        -> CString -- engine name
 139                                        -> Ptr () --  gerror need to deal about this
 140                                        -> IO (Ptr HklEngine) -- the returned HklEngine
 141
 142 foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_values_set"
 143   c_hkl_engine_pseudo_axis_values_set :: Ptr HklEngine
 144                                       -> Ptr Double --values
 145                                       -> CSize -- n_values
 146                                       -> CInt -- unit_type
 147                                       -> Ptr () --  GError **error
 148                                       -> IO (Ptr HklGeometryList)
 149
 150 foreign import ccall unsafe "hkl.h &hkl_geometry_list_free"
 151   c_hkl_geometry_list_free :: FunPtr (Ptr HklGeometryList -> IO ())
 152
 153 -- EngineList
 154
 155 withEngineList :: Factory -> (Ptr HklEngineList -> IO b) -> IO b
 156 withEngineList f func = do
 157   fptr <- newEngineList f
 158   withForeignPtr fptr func
 159
 160 newEngineList :: Factory -> IO (ForeignPtr HklEngineList)
 161 newEngineList f = newFactory f
 162                   >>= c_hkl_factory_create_new_engine_list
 163                   >>= newForeignPtr c_hkl_engine_list_free
 164
 165 foreign import ccall unsafe "hkl.h hkl_factory_create_new_engine_list"
 166   c_hkl_factory_create_new_engine_list:: Ptr HklFactory -> IO (Ptr HklEngineList)
 167
 168 foreign import ccall unsafe "hkl.h &hkl_engine_list_free"
 169   c_hkl_engine_list_free :: FunPtr (Ptr HklEngineList -> IO ())
 170
 171 engineListEnginesGet :: Ptr HklEngineList -> IO [Engine]
 172 engineListEnginesGet e = do
 173   pdarray <- c_hkl_engine_list_engines_get e
 174   n <- (#{peek darray_engine, size} pdarray) :: IO CSize
 175   engines <- #{peek darray_engine ,item} pdarray :: IO (Ptr (Ptr HklEngine))
 176   enginess <- peekArray (fromEnum n) engines
 177   mapM peekEngine enginess
 178
 179 foreign import ccall unsafe "hkl.h hkl_engine_list_engines_get"
 180   c_hkl_engine_list_engines_get:: Ptr HklEngineList -> IO (Ptr ())
 181
 182 compute :: Geometry -> Detector a -> Sample b -> IO [Engine]
 183 compute g@(Geometry f _ _ _) d s = do
 184   withSample s $ \sample ->
 185       withDetector d $ \detector ->
 186           withGeometry g $ \geometry ->
 187               withEngineList f $ \engines -> do
 188                     c_hkl_engine_list_init engines geometry detector sample
 189                     c_hkl_engine_list_get engines
 190                     engineListEnginesGet engines
 191
 192 foreign import ccall unsafe "hkl.h hkl_engine_list_init"
 193   c_hkl_engine_list_init:: Ptr HklEngineList -> Ptr Geometry -> Ptr HklDetector -> Ptr HklSample -> IO ()
 194
 195 foreign import ccall unsafe "hkl.h hkl_engine_list_get"
 196   c_hkl_engine_list_get:: Ptr HklEngineList -> IO ()