binoculars-ng/src/Hkl/Binoculars/Projections.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleContexts      #-}
   3 {-# LANGUAGE GADTs                 #-}
   4 {-# LANGUAGE OverloadedStrings     #-}
   5 {-
   6     Copyright  : Copyright (C) 2014-2024 Synchrotron SOLEIL
   7                                          L'Orme des Merisiers Saint-Aubin
   8                                          BP 48 91192 GIF-sur-YVETTE CEDEX
   9     License    : GPL3+
  10
  11     Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
  12     Stability  : Experimental
  13     Portability: GHC only (not tested)
  14 -}
  15 module Hkl.Binoculars.Projections
  16   ( Space(..)
  17   , cmd
  18   , newSpace
  19   , saveCube
  20   , withMaybeLimits
  21   , withMaybeMask
  22   , withMaybeSampleAxis
  23   , withNPixels
  24   , withPixelsDims
  25   , withResolutions
  26   , withSampleAxis
  27   ) where
  28
  29 import           Control.Monad              (zipWithM)
  30 import           Control.Monad.Catch        (MonadThrow)
  31 import           Control.Monad.IO.Class     (MonadIO (liftIO))
  32 import           Control.Monad.Logger       (MonadLogger, logDebugN)
  33 import           Control.Monad.Trans.Reader (ReaderT, runReaderT)
  34 import           Data.ByteString            (useAsCString)
  35 import           Data.Text.Encoding         (encodeUtf8)
  36 import           Foreign.C.String           (CString, withCString)
  37 import           Foreign.C.Types            (CBool, CSize (..))
  38 import           Foreign.ForeignPtr         (ForeignPtr, newForeignPtr,
  39                                              withForeignPtr)
  40 import           Foreign.Marshal.Alloc      (alloca)
  41 import           Foreign.Marshal.Array      (withArrayLen)
  42 import           Foreign.Ptr                (Ptr, nullPtr)
  43 import           Foreign.Storable           (poke)
  44 import           GHC.Exts                   (IsList (..))
  45
  46 import           Prelude                    hiding (drop)
  47
  48 import           Hkl.Binoculars.Config
  49 import           Hkl.C
  50 import           Hkl.Detector
  51 import           Hkl.Orphan                 ()
  52 import           Hkl.Repa
  53 import           Hkl.Utils                  hiding (withCString)
  54
  55
  56 cmd :: (HasIniConfig a, ToIni (Config a), MonadLogger m, MonadThrow m, MonadIO m)
  57     => ReaderT (Config a) m () -> Maybe FilePath -> Args a -> m ()
  58 cmd action mf args
  59   = do
  60   content <- liftIO $ readConfig mf
  61   capabilities <- liftIO getCapabilities
  62   let econf = getConfig content args capabilities
  63   case econf of
  64     Right conf -> do
  65       logDebugN "config red from the config file"
  66       logDebugN $ serializeConfig conf
  67       runReaderT action conf
  68     Left e      -> logErrorNSH e
  69
  70
  71 --  Common
  72
  73 withNPixels :: Detector a DIM2 -> (CSize -> IO r) -> IO r
  74 withNPixels d f = f (toEnum . size . shape $ d)
  75
  76 withPixelsDims :: Array F DIM3 Double -> (Int -> Ptr CSize -> IO r) -> IO r
  77 withPixelsDims p = withArrayLen (map toEnum $ listOfShape . extent $ p)
  78
  79 saveCube :: Shape sh => FilePath -> String -> [Cube sh] -> IO ()
  80 saveCube o conf rs = do
  81   let c = mconcat rs
  82   case c of
  83     (Cube fp) ->
  84       withCString o $ \fn ->
  85       withCString conf $ \config ->
  86       withForeignPtr fp $ \p ->
  87             c'hkl_binoculars_cube_save_hdf5 fn config p
  88     EmptyCube -> return ()
  89
  90 newLimits :: Limits -> Double -> IO (ForeignPtr C'HklBinocularsAxisLimits)
  91 newLimits (Limits mmin mmax) res =
  92     alloca $ \imin' ->
  93         alloca $ \imax' -> do
  94           imin'' <- case mmin of
  95                     Nothing -> pure nullPtr
  96                     (Just d) -> do
  97                               poke imin' (round (d / res))
  98                               pure imin'
  99           imax'' <- case mmax of
 100                     Nothing -> pure nullPtr
 101                     (Just d) -> do
 102                               poke imax' (round (d / res))
 103                               pure imax'
 104           newForeignPtr p'hkl_binoculars_axis_limits_free
 105                         =<< c'hkl_binoculars_axis_limits_new imin'' imax''
 106
 107 withMaybeLimits :: Shape sh
 108                 => Maybe (RLimits sh)
 109                 -> Resolutions sh
 110                 -> (Int -> Ptr (Ptr C'HklBinocularsAxisLimits) -> IO r)
 111                 -> IO r
 112 withMaybeLimits mls rs f = do
 113   case mls of
 114     Nothing   -> f 0 nullPtr
 115     (Just ls) -> do
 116       ptrs <- zipWithM newLimits (toList ls) (toList rs)
 117       withForeignPtrs ptrs $ \pts -> withArrayLen pts f
 118
 119 withMaybeMask :: Maybe Mask -> (Ptr CBool -> IO r) -> IO r
 120 withMaybeMask mm f = case mm of
 121                        Nothing  -> f nullPtr
 122                        (Just m) -> withForeignPtr (toForeignPtr m) $ \ptr -> f ptr
 123
 124 withMaybeSampleAxis :: Maybe SampleAxis -> (CString -> IO r) -> IO r
 125 withMaybeSampleAxis Nothing f  = f nullPtr
 126 withMaybeSampleAxis (Just a) f = withSampleAxis a f
 127
 128 withResolutions :: Shape sh => Resolutions sh -> (Int -> Ptr Double -> IO r) -> IO r
 129 withResolutions = withArrayLen . toList
 130
 131 withSampleAxis :: SampleAxis -> (CString -> IO r) -> IO r
 132 withSampleAxis (SampleAxis t) =  useAsCString (encodeUtf8 t)
 133
 134 -----------
 135 -- Space --
 136 -----------
 137
 138 newtype Space sh = Space (ForeignPtr C'HklBinocularsSpace)
 139   deriving Show
 140
 141 newSpace' :: Ptr C'HklBinocularsSpace -> IO (Space sh)
 142 newSpace' p = Space <$> newForeignPtr p'hkl_binoculars_space_free p
 143
 144 newSpace :: (Shape sh1, Shape sh) => Detector a sh1 -> Int -> IO (Space sh)
 145 newSpace d n = do
 146   let nPixels = toEnum . size . shape $ d
 147   let nDims = toEnum n
 148   newSpace' =<< c'hkl_binoculars_space_new nPixels nDims