From f0bc3b65da908d6cc7978ff48b4935e48f4c09f3 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Picca=20Fr=C3=A9d=C3=A9ric-Emmanuel?= Date: Sun, 14 Feb 2016 09:24:17 +0100 Subject: [PATCH] [contrib] add the solve method. --- contrib/haskell/hkl.cabal | 2 + contrib/haskell/src/Hkl/C.hsc | 125 +++++++++++++++++++++++++++++++++--------- contrib/haskell/src/ghkl.hs | 9 +++ 3 files changed, 109 insertions(+), 27 deletions(-) diff --git a/contrib/haskell/hkl.cabal b/contrib/haskell/hkl.cabal index 0f2286bf..40a8cf25 100644 --- a/contrib/haskell/hkl.cabal +++ b/contrib/haskell/hkl.cabal @@ -52,6 +52,7 @@ executable ghkl build-depends: base >=4.6 && <4.9 , containers >=0.5 && <0.6 , dimensional >= 0.10 + , monad-loops >= 0.4.2 other-modules: Hkl, Hkl.Types, Hkl.C hs-source-dirs: src default-language: Haskell2010 @@ -72,6 +73,7 @@ library build-depends: base >=4.6 && <4.9 , containers >=0.5 && <0.6 , dimensional >= 0.10 + , monad-loops >= 0.4.2 -- Directories containing source files. hs-source-dirs: src diff --git a/contrib/haskell/src/Hkl/C.hsc b/contrib/haskell/src/Hkl/C.hsc index 2a139ea3..f591d530 100644 --- a/contrib/haskell/src/Hkl/C.hsc +++ b/contrib/haskell/src/Hkl/C.hsc @@ -5,9 +5,11 @@ module Hkl.C ( compute , factories , newSample + , solve ) where import Control.Monad +import Control.Monad.Loops (unfoldrM) import Data.Map.Strict as Map import Numeric.Units.Dimensional.Prelude ( meter, degree, radian, nano , (*~), (/~)) @@ -24,6 +26,8 @@ data HklDetector data HklEngine data HklEngineList data HklGeometry +data HklGeometryList +data HklGeometryListItem data HklLattice data HklParameter data HklSample @@ -53,6 +57,46 @@ darrayStringLen p = do n <- (#{peek darray_string, size} p) :: IO CSize return n +-- Engine + +solve :: Factory -> Geometry -> Detector -> Sample -> Engine -> IO [Geometry] +solve f g d s (Engine name vs (Mode mode ps)) = do + f_sample <- newSample s + f_detector <- newDetector d + f_geometry <- newGeometry f g + f_engines <- newEngineList f + withForeignPtr f_sample $ \sample -> + withForeignPtr f_detector $ \detector -> + withForeignPtr f_geometry $ \geometry -> + withForeignPtr f_engines $ \engines -> do + c_hkl_engine_list_init engines geometry detector sample + withCString name $ \cname -> do + engine <- c_hkl_engine_list_engine_get_by_name engines cname nullPtr + n <- c_hkl_engine_pseudo_axis_names_get engine >>= darrayStringLen + let positions = [v | (Parameter _ v _) <- vs] + withArray positions $ \values -> + (c_hkl_engine_pseudo_axis_values_set engine values n unit nullPtr) + >>= newForeignPtr c_hkl_geometry_list_free + >>= peekHklGeometryList + + +foreign import ccall unsafe "hkl.h hkl_engine_list_engine_get_by_name" + c_hkl_engine_list_engine_get_by_name :: Ptr HklEngineList --engine list + -> CString -- engine name + -> Ptr () -- gerror need to deal about this + -> IO (Ptr HklEngine) -- the returned HklEngine + +foreign import ccall unsafe "hkl.h hkl_engine_pseudo_axis_values_set" + c_hkl_engine_pseudo_axis_values_set :: Ptr HklEngine + -> Ptr Double --values + -> CSize -- n_values + -> CInt -- unit_type + -> Ptr () -- GError **error + -> IO (Ptr HklGeometryList) + +foreign import ccall unsafe "hkl.h &hkl_geometry_list_free" + c_hkl_geometry_list_free :: FunPtr (Ptr HklGeometryList -> IO ()) + -- Factory factories :: IO (Map String Factory) @@ -101,6 +145,30 @@ foreign import ccall unsafe "hkl.h &hkl_sample_free" -- Geometry +peekGeometry :: Ptr HklGeometry -> IO (Geometry) +peekGeometry gp = do + (CDouble w) <- c_hkl_geometry_wavelength_get gp unit + darray <- c_hkl_geometry_axis_names_get gp + n <- darrayStringLen darray + let nn = fromEnum n + allocaArray nn $ \values -> do + c_hkl_geometry_axis_values_get gp values n unit + vs <- peekArray nn values + return $ Geometry (Source (w *~ nano meter)) vs + +foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_get" + c_hkl_geometry_wavelength_get :: Ptr HklGeometry -- geometry + -> CInt -- unit + -> IO CDouble -- wavelength + + +foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_get" + c_hkl_geometry_axis_values_get :: Ptr HklGeometry -- geometry + -> Ptr Double -- axis values + -> CSize -- size of axis values + -> CInt -- unit + -> IO () -- IO CInt but for now do not deal with the errors + newGeometry :: Factory -> Geometry -> IO (ForeignPtr HklGeometry) newGeometry (Factory f) (Geometry (Source lw) vs) = do let wavelength = CDouble (lw /~ nano meter) @@ -141,17 +209,6 @@ foreign import ccall unsafe "hkl.h hkl_geometry_name_get" c_hkl_geometry_name_get :: Ptr HklGeometry -> IO CString -geometryWavelengthGet :: ForeignPtr HklGeometry -> IO Double -geometryWavelengthGet g = - withForeignPtr g $ \gp -> do - (CDouble d) <- c_hkl_geometry_wavelength_get gp unit - return d - -foreign import ccall unsafe "hkl.h hkl_geometry_wavelength_get" - c_hkl_geometry_wavelength_get :: Ptr HklGeometry -- geometry - -> CInt -- unit - -> IO CDouble -- wavelength - geometryAxisNamesGet' :: ForeignPtr HklGeometry -> IO [CString] geometryAxisNamesGet' g = withForeignPtr g (c_hkl_geometry_axis_names_get >=> peekDArrayString) @@ -174,22 +231,36 @@ foreign import ccall unsafe "hkl.h hkl_geometry_axis_get" geometryAxesGet :: ForeignPtr HklGeometry -> IO [Parameter] geometryAxesGet g = geometryAxisNamesGet' g >>= mapM (geometryAxisGet g) -geometryAxisValuesGet :: ForeignPtr HklGeometry -> IO [Double] -geometryAxisValuesGet g = - withForeignPtr g $ \gp -> do - darray <- c_hkl_geometry_axis_names_get gp - n <- darrayStringLen darray - let nn = fromEnum n - allocaArray nn $ \values -> do - c_hkl_geometry_axis_values_get gp values n unit - peekArray nn values - -foreign import ccall unsafe "hkl.h hkl_geometry_axis_values_get" - c_hkl_geometry_axis_values_get :: Ptr HklGeometry -- geometry - -> Ptr Double -- axis values - -> CSize -- size of axis values - -> CInt -- unit - -> IO () -- IO CInt but for now do not deal with the errors +-- HklGeometryList + +peekItems :: Ptr HklGeometryList -> IO [Ptr HklGeometryListItem] +peekItems l = c_hkl_geometry_list_items_first_get l >>= unfoldrM go + where + go e + | e == nullPtr = return Nothing + | otherwise = do + next <- c_hkl_geometry_list_items_next_get l e + return (Just (e, next)) + +peekHklGeometryList :: ForeignPtr HklGeometryList -> IO [Geometry] +peekHklGeometryList l = withForeignPtr l $ \ls -> do + items <- peekItems ls + mapM extract items + where + extract it = c_hkl_geometry_list_item_geometry_get it >>= peekGeometry + +foreign import ccall unsafe "hkl.h hkl_geometry_list_items_first_get" + c_hkl_geometry_list_items_first_get :: Ptr HklGeometryList + -> IO (Ptr HklGeometryListItem) + +foreign import ccall unsafe "hkl.h hkl_geometry_list_items_next_get" + c_hkl_geometry_list_items_next_get :: Ptr HklGeometryList + -> Ptr HklGeometryListItem + -> IO (Ptr HklGeometryListItem) + +foreign import ccall unsafe "hkl.h hkl_geometry_list_item_geometry_get" + c_hkl_geometry_list_item_geometry_get :: Ptr HklGeometryListItem + -> IO (Ptr HklGeometry) -- Detector diff --git a/contrib/haskell/src/ghkl.hs b/contrib/haskell/src/ghkl.hs index 45ce5e91..a30c24c7 100644 --- a/contrib/haskell/src/ghkl.hs +++ b/contrib/haskell/src/ghkl.hs @@ -25,6 +25,15 @@ main' = do -- compute the pseudo axes values pseudoAxes <- compute factory geometry detector sample print pseudoAxes + + -- solve the pseudo axis problem + let engine = Engine "hkl" [ Parameter "h" 0.0 (Range (-1.0) 1.0) + , Parameter "k" 0.0 (Range (-1.0) 1.0) + , Parameter "l" 1.0 (Range (-1.0) 1.0) + ] + (Mode "bissector_vertical" []) + solutions <- solve factory geometry detector sample engine + print solutions return () main :: IO () -- 2.11.4.GIT