contrib/haskell/src/Hkl/Binoculars/Projections/QCustom.hs

   1 {-# LANGUAGE DataKinds             #-}
   2 {-# LANGUAGE DeriveAnyClass        #-}
   3 {-# LANGUAGE DeriveGeneric         #-}
   4 {-# LANGUAGE FlexibleContexts      #-}
   5 {-# LANGUAGE FlexibleInstances     #-}
   6 {-# LANGUAGE LambdaCase            #-}
   7 {-# LANGUAGE MultiParamTypeClasses #-}
   8 {-# LANGUAGE OverloadedStrings     #-}
   9 {-# LANGUAGE RankNTypes            #-}
  10 {-# LANGUAGE ScopedTypeVariables   #-}
  11 {-# LANGUAGE TypeFamilies          #-}
  12
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14 {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-splices #-}
  15 {-
  16     Copyright  : Copyright (C) 2014-2023 Synchrotron SOLEIL
  17                                          L'Orme des Merisiers Saint-Aubin
  18                                          BP 48 91192 GIF-sur-YVETTE CEDEX
  19     License    : GPL3+
  20
  21     Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
  22     Stability  : Experimental
  23     Portability: GHC only (not tested)
  24 -}
  25
  26 module Hkl.Binoculars.Projections.QCustom
  27     ( Args(..)
  28     , Config(..)
  29     , DataFrameQCustom(..)
  30     , DataSourcePath(..)
  31     , FramesP(..)
  32     , default'DataSourcePath'DataFrameQCustom
  33     , guess'DataSourcePath'DataFrameQCustom
  34     , newQCustom
  35     , overload'DataSourcePath'DataFrameQCustom
  36     , processQCustom
  37     , updateQCustom
  38     ) where
  39
  40 import           Control.Applicative               ((<|>))
  41 import           Control.Concurrent.Async          (mapConcurrently)
  42 import           Control.Monad.Catch               (MonadThrow)
  43 import           Control.Monad.IO.Class            (MonadIO (liftIO))
  44 import           Control.Monad.Logger              (MonadLogger, logDebugN,
  45                                                     logInfoN)
  46 import           Control.Monad.Reader              (MonadReader, ask, forM_,
  47                                                     forever)
  48 import           Data.Aeson                        (FromJSON, ToJSON,
  49                                                     eitherDecode', encode)
  50 import           Data.Array.Repa                   (Array)
  51 import           Data.Array.Repa.Index             (DIM2, DIM3)
  52 import           Data.Array.Repa.Repr.ForeignPtr   (F, toForeignPtr)
  53 import           Data.ByteString.Lazy              (fromStrict, toStrict)
  54 import           Data.HashMap.Lazy                 (fromList)
  55 import           Data.Ini                          (Ini (..))
  56 import           Data.Ini.Config.Bidir             (FieldValue (..))
  57 import           Data.Maybe                        (fromJust, fromMaybe)
  58 import           Data.Text                         (pack, unpack)
  59 import           Data.Text.Encoding                (decodeUtf8, encodeUtf8)
  60 import           Data.Text.IO                      (putStr)
  61 import           Data.Vector.Storable.Mutable      (unsafeWith)
  62 import           Foreign.C.Types                   (CDouble (..))
  63 import           Foreign.ForeignPtr                (ForeignPtr, withForeignPtr)
  64 import           GHC.Generics                      (Generic)
  65 import           Generic.Random                    (genericArbitraryU)
  66 import           Numeric.Units.Dimensional.Prelude (Angle, degree, radian, (*~),
  67                                                     (/~))
  68 import           Path                              (Abs, Dir, Path)
  69 import           Pipes                             (await, each, runEffect,
  70                                                     yield, (>->))
  71 import           Pipes.Prelude                     (filter, map, tee, toListM)
  72 import           Pipes.Safe                        (runSafeT)
  73 import           Test.QuickCheck                   (Arbitrary (..))
  74 import           Text.Printf                       (printf)
  75
  76 import           Hkl.Binoculars.Common
  77 import           Hkl.Binoculars.Config
  78 import           Hkl.Binoculars.Config.Common
  79 import           Hkl.Binoculars.Pipes
  80 import           Hkl.Binoculars.Projections
  81 import           Hkl.C.Binoculars
  82 import           Hkl.C.Hkl
  83 import           Hkl.DataSource
  84 import           Hkl.Detector
  85 import           Hkl.Geometry
  86 import           Hkl.H5
  87 import           Hkl.Image
  88 import           Hkl.Orphan                        ()
  89 import           Hkl.Pipes
  90 import           Hkl.Types
  91 import           Hkl.Utils
  92
  93 -----------------------
  94 -- QCustom Projection --
  95 -----------------------
  96
  97 -- Cursor
  98
  99 data DataFrameQCustom
 100     = DataFrameQCustom
 101       Attenuation -- attenuation
 102       (ForeignPtr C'HklGeometry) -- geometry
 103       Image -- image
 104       Timestamp -- timestamp in double
 105     deriving Show
 106
 107 instance DataSource DataFrameQCustom where
 108   data DataSourcePath DataFrameQCustom
 109     = DataSourcePath'DataFrameQCustom
 110       (DataSourcePath Attenuation)
 111       (DataSourcePath Geometry)
 112       (DataSourcePath Image)
 113       (DataSourcePath Timestamp)
 114     deriving (Generic, Show, FromJSON, ToJSON)
 115
 116   data DataSourceAcq DataFrameQCustom
 117     = DataSourceAcq'DataFrameQCustom
 118       (DataSourceAcq Attenuation)
 119       (DataSourceAcq Geometry)
 120       (DataSourceAcq Image)
 121       (DataSourceAcq Timestamp)
 122
 123   withDataSourceP f (DataSourcePath'DataFrameQCustom a g i idx) gg =
 124     withDataSourceP f a $ \a' ->
 125     withDataSourceP f g $ \g' ->
 126     withDataSourceP f i $ \i' ->
 127     withDataSourceP f idx $ \idx' -> gg (DataSourceAcq'DataFrameQCustom a' g' i' idx')
 128
 129 instance Is1DStreamable (DataSourceAcq DataFrameQCustom) DataFrameQCustom where
 130     extract1DStreamValue (DataSourceAcq'DataFrameQCustom att geom img idx) i =
 131       DataFrameQCustom
 132       <$> extract1DStreamValue att i
 133       <*> extract1DStreamValue geom i
 134       <*> extract1DStreamValue img i
 135       <*> extract1DStreamValue idx i
 136
 137 instance Arbitrary (DataSourcePath DataFrameQCustom) where
 138   arbitrary = DataSourcePath'DataFrameQCustom <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 139
 140 default'DataSourcePath'DataFrameQCustom :: DataSourcePath DataFrameQCustom
 141 default'DataSourcePath'DataFrameQCustom
 142   = DataSourcePath'DataFrameQCustom
 143     (DataSourcePath'Attenuation
 144       (DataSourcePath'Float (hdf5p $ grouppat 0 $ datasetp "scan_data/attenuation"))
 145       2 0 Nothing)
 146     (DataSourcePath'Geometry
 147       (Geometry'Factory Uhv)
 148       (DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "SIXS/Monochromator/wavelength"))
 149       [ DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/UHV_MU")
 150       , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/UHV_OMEGA")
 151       , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/UHV_DELTA")
 152       , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/UHV_GAMMA")
 153       ])
 154     (DataSourcePath'Image
 155       (hdf5p $ grouppat 0 $ datasetp "scan_data/xpad_image")
 156       defaultDetector)
 157     (DataSourcePath'Timestamp(hdf5p $ grouppat 0 $ datasetp "scan_data/epoch"))
 158
 159 instance HasFieldComment (DataSourcePath DataFrameQCustom) where
 160   fieldComment _ = [ "`datapath` internal value used to find the data in the data file."
 161                    , ""
 162                    , "This value is for expert only."
 163                    , ""
 164                    , "default value: <not set>"
 165                    ]
 166
 167 instance HasFieldValue (DataSourcePath DataFrameQCustom) where
 168   fieldvalue = FieldValue
 169                { fvParse = eitherDecode' . fromStrict . encodeUtf8
 170                , fvEmit = decodeUtf8 . toStrict . encode
 171                }
 172
 173 ------------
 174 -- Config --
 175 ------------
 176
 177 data instance Config 'QCustomProjection
 178   = BinocularsConfig'QCustom
 179     { binocularsConfig'QCustom'Common :: BinocularsConfig'Common
 180     , binocularsConfig'QCustom'HklBinocularsSurfaceOrientationEnum     :: HklBinocularsSurfaceOrientationEnum
 181     , binocularsConfig'QCustom'ProjectionType         :: ProjectionType
 182     , binocularsConfig'QCustom'ProjectionResolution   :: Resolutions DIM3
 183     , binocularsConfig'QCustom'ProjectionLimits       :: Maybe (RLimits DIM3)
 184     , binocularsConfig'QCustom'DataPath               :: DataSourcePath DataFrameQCustom
 185     , binocularsConfig'QCustom'SubProjection          :: Maybe HklBinocularsQCustomSubProjectionEnum
 186     , binocularsConfig'QCustom'Uqx                    :: Degree
 187     , binocularsConfig'QCustom'Uqy                    :: Degree
 188     , binocularsConfig'QCustom'Uqz                    :: Degree
 189     , binocularsConfig'QCustom'SampleAxis             :: Maybe SampleAxis
 190     } deriving (Show, Generic)
 191
 192 instance Arbitrary (Config 'QCustomProjection) where
 193   arbitrary = genericArbitraryU
 194
 195 newtype instance Args 'QCustomProjection = Args'QCustomProjection (Maybe ConfigRange)
 196
 197 default'BinocularsConfig'QCustom :: Config 'QCustomProjection
 198 default'BinocularsConfig'QCustom
 199   = BinocularsConfig'QCustom
 200     { binocularsConfig'QCustom'Common = default'BinocularsConfig'Common
 201     , binocularsConfig'QCustom'HklBinocularsSurfaceOrientationEnum = HklBinocularsSurfaceOrientationEnum'Vertical
 202     , binocularsConfig'QCustom'ProjectionType = QCustomProjection
 203     , binocularsConfig'QCustom'ProjectionResolution = Resolutions3 0.01 0.01 0.01
 204     , binocularsConfig'QCustom'ProjectionLimits  = Nothing
 205     , binocularsConfig'QCustom'DataPath = default'DataSourcePath'DataFrameQCustom
 206     , binocularsConfig'QCustom'SubProjection = Just HklBinocularsQCustomSubProjectionEnum'QxQyQz
 207     , binocularsConfig'QCustom'Uqx = Degree (0.0 *~ degree)
 208     , binocularsConfig'QCustom'Uqy = Degree (0.0 *~ degree)
 209     , binocularsConfig'QCustom'Uqz = Degree (0.0 *~ degree)
 210     , binocularsConfig'QCustom'SampleAxis = Nothing
 211     }
 212
 213
 214 instance HasIniConfig 'QCustomProjection where
 215
 216   getConfig content@(ConfigContent cfg) (Args'QCustomProjection mr) capabilities = do
 217     common <- parse'BinocularsConfig'Common cfg mr capabilities
 218     projectiontype <- parseFDef cfg "projection" "type" (binocularsConfig'QCustom'ProjectionType default'BinocularsConfig'QCustom)
 219
 220     let msubprojection' = parseMbDef cfg "projection" "subprojection" (binocularsConfig'QCustom'SubProjection default'BinocularsConfig'QCustom)
 221     let msubprojection = case projectiontype of
 222                            QIndexProjection -> Just HklBinocularsQCustomSubProjectionEnum'QTimestamp
 223                            QparQperProjection -> Just HklBinocularsQCustomSubProjectionEnum'QparQper
 224                            QxQyQzProjection -> Just HklBinocularsQCustomSubProjectionEnum'QxQyQz
 225                            AnglesProjection -> msubprojection'
 226                            Angles2Projection -> msubprojection'
 227                            HklProjection -> msubprojection'
 228                            QCustomProjection -> msubprojection'
 229                            RealSpaceProjection -> Just HklBinocularsQCustomSubProjectionEnum'XYZ
 230                            PixelsProjection -> Just HklBinocularsQCustomSubProjectionEnum'YZTimestamp
 231                            TestProjection -> msubprojection'
 232
 233     let errorMissingSampleAxis = case msubprojection of
 234                                    Nothing -> Nothing
 235                                    Just sub -> case sub of
 236                                                 HklBinocularsQCustomSubProjectionEnum'QxQyQz -> Nothing
 237                                                 HklBinocularsQCustomSubProjectionEnum'QTthTimestamp -> Nothing
 238                                                 HklBinocularsQCustomSubProjectionEnum'QTimestamp -> Nothing
 239                                                 HklBinocularsQCustomSubProjectionEnum'QparQperTimestamp -> Nothing
 240                                                 HklBinocularsQCustomSubProjectionEnum'QparQper -> Nothing
 241                                                 HklBinocularsQCustomSubProjectionEnum'QPhiQx -> Nothing
 242                                                 HklBinocularsQCustomSubProjectionEnum'QPhiQy -> Nothing
 243                                                 HklBinocularsQCustomSubProjectionEnum'QPhiQz -> Nothing
 244                                                 HklBinocularsQCustomSubProjectionEnum'QStereo -> Nothing
 245                                                 HklBinocularsQCustomSubProjectionEnum'DeltalabGammalabSampleaxis -> error "expect a valid  [projection] 'sampleaxis' key"
 246                                                 HklBinocularsQCustomSubProjectionEnum'XYZ -> Nothing
 247                                                 HklBinocularsQCustomSubProjectionEnum'YZTimestamp -> Nothing
 248                                                 HklBinocularsQCustomSubProjectionEnum'QQparQper -> Nothing
 249                                                 HklBinocularsQCustomSubProjectionEnum'QparsQperTimestamp -> Nothing
 250                                                 HklBinocularsQCustomSubProjectionEnum'QparQperSampleaxis -> error "expect a valid [projection] 'sampleaxis' key"
 251                                                 HklBinocularsQCustomSubProjectionEnum'QSampleaxisTth -> error "expect a valid [projection] 'sampleaxis' key"
 252                                                 HklBinocularsQCustomSubProjectionEnum'QSampleaxisTimestamp -> error "expect a valid [projection] 'sampleaxis' key"
 253                                                 HklBinocularsQCustomSubProjectionEnum'QxQyTimestamp -> Nothing
 254                                                 HklBinocularsQCustomSubProjectionEnum'QxQzTimestamp -> Nothing
 255                                                 HklBinocularsQCustomSubProjectionEnum'QyQzTimestamp -> Nothing
 256
 257
 258     BinocularsConfig'QCustom
 259       common
 260       <$> parseFDef cfg "input" "surface_orientation" (binocularsConfig'QCustom'HklBinocularsSurfaceOrientationEnum default'BinocularsConfig'QCustom)
 261       <*> pure projectiontype
 262       <*> parseFDef cfg "projection" "resolution" (binocularsConfig'QCustom'ProjectionResolution default'BinocularsConfig'QCustom)
 263       <*> parseMb cfg "projection" "limits"
 264       <*> pure (eitherF (const $ guess'DataSourcePath'DataFrameQCustom common msubprojection content) (parse' cfg "input" "datapath")
 265                 (\case
 266                     Nothing -> guess'DataSourcePath'DataFrameQCustom common msubprojection content
 267                     Just d ->  overload'DataSourcePath'DataFrameQCustom common msubprojection d))
 268       <*> pure msubprojection
 269       <*> parseFDef cfg "projection" "uqx" (binocularsConfig'QCustom'Uqx default'BinocularsConfig'QCustom)
 270       <*> parseFDef cfg "projection" "uqy" (binocularsConfig'QCustom'Uqy default'BinocularsConfig'QCustom)
 271       <*> parseFDef cfg "projection" "uqz" (binocularsConfig'QCustom'Uqz default'BinocularsConfig'QCustom)
 272       <*> pure (eitherF (const $ errorMissingSampleAxis) (parse' cfg "projection" "sampleaxis")
 273                 (\case
 274                     Nothing -> errorMissingSampleAxis
 275                     Just d  -> Just d
 276                 ))
 277
 278 instance ToIni (Config 'QCustomProjection) where
 279
 280   toIni c = toIni (binocularsConfig'QCustom'Common c)
 281             `mergeIni`
 282             Ini { iniSections = fromList [ ("input",    elemFDef' "surface_orientation" binocularsConfig'QCustom'HklBinocularsSurfaceOrientationEnum c default'BinocularsConfig'QCustom
 283                                                      <> elemFDef' "datapath" binocularsConfig'QCustom'DataPath c default'BinocularsConfig'QCustom
 284                                            )
 285                                          , ("projection",    elemFDef' "type" binocularsConfig'QCustom'ProjectionType c default'BinocularsConfig'QCustom
 286                                                           <> elemFDef' "resolution" binocularsConfig'QCustom'ProjectionResolution c default'BinocularsConfig'QCustom
 287                                                           <> elemFMbDef' "limits" binocularsConfig'QCustom'ProjectionLimits c default'BinocularsConfig'QCustom
 288                                                           <> elemFMbDef' "subprojection" binocularsConfig'QCustom'SubProjection c default'BinocularsConfig'QCustom
 289                                                           <> elemFDef "uqx" binocularsConfig'QCustom'Uqx c default'BinocularsConfig'QCustom
 290                                                           [ "rotation around the x-axis of the sample in the surface basis system -- degree"
 291                                                           , ""
 292                                                           , "in this basis, the x-axis is colinear to the surface of the sample along the x-rays."
 293                                                           , ""
 294                                                           , " `<not set>` - use the default value `0.0`"
 295                                                           , " `a value`   - use this value"
 296                                                           ]
 297                                                           <> elemFDef "uqy" binocularsConfig'QCustom'Uqy c default'BinocularsConfig'QCustom
 298                                                           [ "rotation around the y-axis of the sample in the surface basis system -- degree"
 299                                                           , ""
 300                                                           , "in this basis, the y-axis is colinear to the surface of the sample and"
 301                                                           , "forme a directe basis with x-axis and z-axis."
 302                                                           , ""
 303                                                           , "examples:"
 304                                                           , "  - all motors set to zero and a vertical surface - y-axis along -z (labo basis)"
 305                                                           , "  - all motors set to zero and an horizontal surcafe - y-axis along y (labo basis)"
 306                                                           , ""
 307                                                           , " `<not set>` - use the default value `0.0`"
 308                                                           , " `a value`   - use this value"
 309                                                           ]
 310                                                           <> elemFDef "uqz" binocularsConfig'QCustom'Uqz c default'BinocularsConfig'QCustom
 311                                                           [ "rotation around the z-axis of the sample in the surface basis system -- degree"
 312                                                           , ""
 313                                                           , "in this basis, the z-axis is perpendicular to the surface of the sample."
 314                                                           , ""
 315                                                           , "examples:"
 316                                                           , "  - all motors set to zero and a vertical surface - z-axis along y (labo basis)"
 317                                                           , "  - all motors set to zero and an horizontal surcafe - z-axis along z (labo basis)"
 318                                                           , ""
 319                                                           , ""
 320                                                           , " `<not set>` - use the default value `0.0`"
 321                                                           , " `a value`   - use this value"
 322                                                           ]
 323                                                           <> elemFMbDef "sampleaxis" binocularsConfig'QCustom'SampleAxis c default'BinocularsConfig'QCustom
 324                                                           [ "the name of the sample axis expected by some subprojections."
 325                                                           , ""
 326                                                           , " `<not set>` - for all subprojections which does not expect a value."
 327                                                           , " `a value`   - use this value for the subprojection expecting this axis."
 328                                                           ]
 329                                            )]
 330
 331                 , iniGlobals = []
 332                 }
 333
 334 ------------------
 335 -- Input Path's --
 336 ------------------
 337
 338 mkAttenuation :: Maybe Double -> DataSourcePath Attenuation -> DataSourcePath Attenuation
 339 mkAttenuation ma att =
 340     case ma of
 341       Nothing -> case att of
 342                   DataSourcePath'NoAttenuation     -> DataSourcePath'NoAttenuation
 343                   DataSourcePath'Attenuation{} ->  DataSourcePath'NoAttenuation
 344                            -- logWarnN "The current configuration extract the attenuation from the data files."
 345                            -- logWarnN "You forgot to provide the attenuation coefficient in the config file."
 346                            -- logWarnN "I continue without attenuation correction"
 347                            -- logWarnN "Add attenuation_coefficient=<something> under the [input] section, to fix this"
 348                            -- return DataSourcePath'NoAttenuation
 349                   applyed@DataSourcePath'ApplyedAttenuationFactor{} -> applyed
 350       (Just coef) -> case att of
 351                       DataSourcePath'NoAttenuation           -> DataSourcePath'NoAttenuation
 352                       (DataSourcePath'Attenuation p o _ m) -> DataSourcePath'Attenuation p o coef m
 353                       (DataSourcePath'ApplyedAttenuationFactor _) -> undefined
 354
 355 mkDetector'Sixs'Fly :: Detector Hkl DIM2 -> DataSourcePath Image
 356 mkDetector'Sixs'Fly det@(Detector2D d _ _)
 357   = case d of
 358       HklBinocularsDetectorEnum'ImxpadS140 ->
 359         DataSourcePath'Image
 360         (hdf5p $ grouppat 0 (datasetp "scan_data/xpad_image"
 361                               `H5Or`
 362                               datasetp "scan_data/xpad_s140_image"))
 363         det
 364       HklBinocularsDetectorEnum'XpadFlatCorrected -> undefined
 365       HklBinocularsDetectorEnum'ImxpadS70 ->
 366         DataSourcePath'Image
 367         (hdf5p $ grouppat 0 $ datasetp "scan_data/xpad_s70_image")
 368         det
 369       HklBinocularsDetectorEnum'DectrisEiger1M ->
 370         DataSourcePath'Image
 371         (hdf5p $ grouppat 0 $ datasetp "scan_data/eiger_image")
 372         det
 373       HklBinocularsDetectorEnum'Ufxc ->
 374         DataSourcePath'Image
 375         (hdf5p $ grouppat 0 $ datasetp "scan_data/ufxc_sixs_image")
 376         det
 377       HklBinocularsDetectorEnum'Merlin -> undefined
 378       HklBinocularsDetectorEnum'MerlinMedipix3rxQuad -> undefined
 379
 380 mkDetector'Sixs'Sbs :: Detector Hkl DIM2 -> DataSourcePath Image
 381 mkDetector'Sixs'Sbs det@(Detector2D d _ _)
 382   = case d of
 383       HklBinocularsDetectorEnum'ImxpadS140 ->
 384         DataSourcePath'Image
 385         (hdf5p (datasetpattr ("long_name", "i14-c-c00/dt/xpad.s140/image")
 386                 `H5Or`
 387                 datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image")))
 388         det
 389       HklBinocularsDetectorEnum'XpadFlatCorrected -> undefined
 390       HklBinocularsDetectorEnum'ImxpadS70 ->
 391         DataSourcePath'Image
 392         (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.s70/image"))
 393         det
 394       HklBinocularsDetectorEnum'DectrisEiger1M ->
 395         DataSourcePath'Image
 396         (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/eiger.1/image"))
 397         det
 398       HklBinocularsDetectorEnum'Ufxc -> undefined
 399       HklBinocularsDetectorEnum'Merlin -> undefined
 400       HklBinocularsDetectorEnum'MerlinMedipix3rxQuad -> undefined
 401
 402 overloadAttenuationPath :: Maybe Double -> Maybe Float -> DataSourcePath Attenuation -> DataSourcePath Attenuation
 403 overloadAttenuationPath ma m' (DataSourcePath'Attenuation p o a m)
 404   = DataSourcePath'Attenuation p o (fromMaybe a ma) (m' <|> m)
 405 overloadAttenuationPath _ _ ap@DataSourcePath'ApplyedAttenuationFactor{} = ap
 406 overloadAttenuationPath _ _ ap@DataSourcePath'NoAttenuation = ap
 407
 408 overloadTimestampPath :: Maybe HklBinocularsQCustomSubProjectionEnum -> DataSourcePath Timestamp -> DataSourcePath Timestamp
 409 overloadTimestampPath msub idx =
 410   case msub of
 411     Nothing -> DataSourcePath'Timestamp'NoTimestamp
 412     (Just sub) -> case sub of
 413                    HklBinocularsQCustomSubProjectionEnum'QxQyQz -> DataSourcePath'Timestamp'NoTimestamp
 414                    HklBinocularsQCustomSubProjectionEnum'QTthTimestamp -> idx
 415                    HklBinocularsQCustomSubProjectionEnum'QTimestamp -> idx
 416                    HklBinocularsQCustomSubProjectionEnum'QparQperTimestamp -> idx
 417                    HklBinocularsQCustomSubProjectionEnum'QparQper -> DataSourcePath'Timestamp'NoTimestamp
 418                    HklBinocularsQCustomSubProjectionEnum'QPhiQx -> DataSourcePath'Timestamp'NoTimestamp
 419                    HklBinocularsQCustomSubProjectionEnum'QPhiQy -> DataSourcePath'Timestamp'NoTimestamp
 420                    HklBinocularsQCustomSubProjectionEnum'QPhiQz -> DataSourcePath'Timestamp'NoTimestamp
 421                    HklBinocularsQCustomSubProjectionEnum'QStereo -> DataSourcePath'Timestamp'NoTimestamp
 422                    HklBinocularsQCustomSubProjectionEnum'DeltalabGammalabSampleaxis -> DataSourcePath'Timestamp'NoTimestamp
 423                    HklBinocularsQCustomSubProjectionEnum'XYZ -> DataSourcePath'Timestamp'NoTimestamp
 424                    HklBinocularsQCustomSubProjectionEnum'YZTimestamp -> idx
 425                    HklBinocularsQCustomSubProjectionEnum'QQparQper -> DataSourcePath'Timestamp'NoTimestamp
 426                    HklBinocularsQCustomSubProjectionEnum'QparsQperTimestamp -> idx
 427                    HklBinocularsQCustomSubProjectionEnum'QparQperSampleaxis -> DataSourcePath'Timestamp'NoTimestamp
 428                    HklBinocularsQCustomSubProjectionEnum'QSampleaxisTth -> DataSourcePath'Timestamp'NoTimestamp
 429                    HklBinocularsQCustomSubProjectionEnum'QSampleaxisTimestamp -> idx
 430                    HklBinocularsQCustomSubProjectionEnum'QxQyTimestamp -> idx
 431                    HklBinocularsQCustomSubProjectionEnum'QxQzTimestamp -> idx
 432                    HklBinocularsQCustomSubProjectionEnum'QyQzTimestamp -> idx
 433
 434 overloadWaveLength :: Maybe Double -> DataSourcePath Double -> DataSourcePath Double
 435 overloadWaveLength ma wp = maybe wp DataSourcePath'Double'Const ma
 436
 437 overloadGeometryPath ::  Maybe Double -> DataSourcePath Geometry -> DataSourcePath Geometry
 438 overloadGeometryPath mw (DataSourcePath'Geometry g wp as) = DataSourcePath'Geometry g (overloadWaveLength mw wp) as
 439 overloadGeometryPath mw (DataSourcePath'Geometry'Fix wp) = DataSourcePath'Geometry'Fix (overloadWaveLength mw wp)
 440
 441
 442 overloadImagePath :: Detector Hkl DIM2 -> DataSourcePath Image -> DataSourcePath Image
 443 overloadImagePath det (DataSourcePath'Image p _) = DataSourcePath'Image p det
 444
 445 overload'DataSourcePath'DataFrameQCustom :: BinocularsConfig'Common
 446                                          -> Maybe HklBinocularsQCustomSubProjectionEnum
 447                                          -> DataSourcePath DataFrameQCustom
 448                                          -> DataSourcePath DataFrameQCustom
 449 overload'DataSourcePath'DataFrameQCustom common msub (DataSourcePath'DataFrameQCustom attenuationPath' geometryPath imagePath indexP)
 450   = let mAttCoef = binocularsConfig'Common'AttenuationCoefficient common
 451         mMaxAtt = binocularsConfig'Common'AttenuationMax common
 452         mWavelength = binocularsConfig'Common'Wavelength common
 453         detector =  binocularsConfig'Common'Detector common
 454
 455         newAttenuationPath = overloadAttenuationPath mAttCoef mMaxAtt attenuationPath'
 456         newGeometryPath = overloadGeometryPath mWavelength geometryPath
 457         newImagePath = overloadImagePath detector imagePath
 458         newTimestampPath = overloadTimestampPath msub indexP
 459     in
 460       DataSourcePath'DataFrameQCustom newAttenuationPath newGeometryPath newImagePath newTimestampPath
 461
 462
 463 guess'DataSourcePath'DataFrameQCustom :: BinocularsConfig'Common
 464                                       -> Maybe HklBinocularsQCustomSubProjectionEnum
 465                                       -> ConfigContent
 466                                       -> DataSourcePath DataFrameQCustom
 467 guess'DataSourcePath'DataFrameQCustom common msub cfg =
 468     do
 469       let inputtype = binocularsConfig'Common'InputType common
 470       let mAttenuationCoefficient = binocularsConfig'Common'AttenuationCoefficient common
 471       let detector =  binocularsConfig'Common'Detector common
 472       let mAttenuationMax = binocularsConfig'Common'AttenuationMax common
 473       let mAttenuationShift = binocularsConfig'Common'AttenuationShift common
 474       let mWavelength = binocularsConfig'Common'Wavelength common
 475
 476       -- attenuation
 477       let dataSourcePath'Attenuation'Sixs :: DataSourcePath Attenuation
 478           dataSourcePath'Attenuation'Sixs =
 479             DataSourcePath'Attenuation
 480             (DataSourcePath'Float (hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "attenuation"
 481                                                                             `H5Or`
 482                                                                             datasetp "attenuation_old")))
 483             (fromMaybe 2 mAttenuationShift) 0 mAttenuationMax
 484
 485       let dataSourcePath'Attenuation'SixsSBS :: DataSourcePath Attenuation
 486           dataSourcePath'Attenuation'SixsSBS =
 487             DataSourcePath'Attenuation
 488             (DataSourcePath'Float (hdf5p (datasetpattr ("long_name", "i14-c-c00/ex/roic/att")
 489                                           `H5Or`
 490                                           datasetpattr ("long_name", "i14-c-c00/ex/roic-s140/att")
 491                                           `H5Or`
 492                                           datasetpattr ("long_name", "i14-c-c00/ex/roic-s140/att_old")
 493                                           `H5Or`
 494                                           datasetpattr ("long_name", "i14-c-c00/ex/roic-s70/att")
 495                                           `H5Or`
 496                                           datasetpattr ("long_name", "i14-c-c00/ex/roic-s70/att_old"))))
 497             (fromMaybe 0 mAttenuationShift) 0 mAttenuationMax
 498
 499       -- timestamp
 500       let mkTimeStamp'Sbs :: Maybe HklBinocularsQCustomSubProjectionEnum -> DataSourcePath Timestamp
 501           mkTimeStamp'Sbs msub'
 502             = overloadTimestampPath msub' (DataSourcePath'Timestamp(hdf5p $ grouppat 0 $ datasetp "scan_data/sensors_timestamps"))
 503
 504       let mkTimeStamp'Fly :: Maybe HklBinocularsQCustomSubProjectionEnum -> DataSourcePath Timestamp
 505           mkTimeStamp'Fly msub'
 506             = overloadTimestampPath msub' (DataSourcePath'Timestamp(hdf5p $ grouppat 0 $ datasetp "scan_data/epoch"))
 507
 508       -- wavelength
 509       let dataSourcePath'WaveLength'Sixs ::  DataSourcePath Double
 510           dataSourcePath'WaveLength'Sixs
 511             = DataSourcePath'Double (hdf5p $ grouppat 0 (datasetp "SIXS/Monochromator/wavelength"
 512                                                          `H5Or`
 513                                                          datasetp "SIXS/i14-c-c02-op-mono/lambda"))
 514
 515       -- geometry
 516       let sixs'eix
 517             = DataSourcePath'Double'Ini cfg "geometry.values" "eix"
 518               `DataSourcePath'Double'Or`
 519               DataSourcePath'Double(hdf5p (grouppat 0 $ datasetp "scan_data/eix")
 520                                     `H5Or`
 521                                     hdf5p (grouppat 0 $ groupp "scan_data" $ datasetpattr ("long_name", "i14-c-cx1/dt/tab-mt_tx.1/position"))
 522                                     `H5Or`
 523                                     hdf5p (grouppat 0 $ groupp "scan_data" $ datasetpattr ("long_name", "i14-c-cx2/dt/tab-mt_tx.1/position"))
 524                                     `H5Or`
 525                                     hdf5p (grouppat 0 $ datasetp "SIXS/i14-c-cx1-dt-det_tx.1/position_pre"))
 526       let sixs'eiz
 527             = DataSourcePath'Double'Ini cfg "geometry.values" "eiz"
 528               `DataSourcePath'Double'Or`
 529               DataSourcePath'Double(hdf5p (grouppat 0 $ datasetp "scan_data/eiz")
 530                                     `H5Or`
 531                                     hdf5p (grouppat 0 $ groupp "scan_data" $ datasetpattr ("long_name", "i14-c-cx1/dt/tab-mt_tz.1/position"))
 532                                     `H5Or`
 533                                     hdf5p (grouppat 0 $ groupp "scan_data" $ datasetpattr ("long_name", "i14-c-cx2/dt/tab-mt_tz.1/position"))
 534                                     `H5Or`
 535                                     hdf5p (grouppat 0 $ datasetp "SIXS/i14-c-cx1-dt-det_tz.1/position_pre"))
 536
 537       let sixs'Uhv'Mu
 538             = DataSourcePath'Double'Ini cfg "geometry.values" "mu"
 539               `DataSourcePath'Double'Or`
 540               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "mu"
 541                                                                              `H5Or`
 542                                                                              datasetpattr ("long_name", "i14-c-cx2/ex/uhv-dif-group/mu")
 543                                                                              `H5Or`
 544                                                                              datasetp "UHV_MU"
 545                                                                              `H5Or`
 546                                                                              datasetp "mu_xps"))
 547       let sixs'Uhv'Omega
 548             = DataSourcePath'Double'Ini cfg "geometry.values" "omega"
 549               `DataSourcePath'Double'Or`
 550               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "omega"
 551                                                                              `H5Or`
 552                                                                              datasetp "UHV_OMEGA"
 553                                                                              `H5Or`
 554                                                                              datasetpattr ("long_name", "i14-c-cx2/ex/uhv-dif-group/omega")
 555                                                                              `H5Or`
 556                                                                              datasetp "omega_xps"))
 557       let sixs'Uhv'Delta
 558             = DataSourcePath'Double'Ini cfg "geometry.values" "delta"
 559               `DataSourcePath'Double'Or`
 560               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "delta"
 561                                                                              `H5Or`
 562                                                                              datasetp "UHV_DELTA"
 563                                                                              `H5Or`
 564                                                                              datasetpattr ("long_name", "i14-c-cx2/ex/uhv-dif-group/delta")
 565                                                                              `H5Or`
 566                                                                              datasetp "delta_xps"))
 567
 568       let sixs'Uhv'Gamma
 569             = DataSourcePath'Double'Ini cfg "geometry.values" "gamma"
 570               `DataSourcePath'Double'Or`
 571               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "gamma"
 572                                                                              `H5Or`
 573                                                                              datasetp "UHV_GAMMA"
 574                                                                              `H5Or`
 575                                                                              datasetpattr ("long_name", "i14-c-cx2/ex/uhv-dif-group/gamma")
 576                                                                              `H5Or`
 577                                                                              datasetp "gamma_xps"))
 578
 579       let dataSourcePath'Geometry'Sixs'Uhv :: DataSourcePath Geometry
 580           dataSourcePath'Geometry'Sixs'Uhv
 581             = DataSourcePath'Geometry
 582               (Geometry'Factory Uhv)
 583               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 584               [sixs'Uhv'Mu, sixs'Uhv'Omega, sixs'Uhv'Delta, sixs'Uhv'Gamma]
 585
 586       let dataSourcePath'Geometry'Sixs'UhvGisaxs :: DataSourcePath Geometry
 587           dataSourcePath'Geometry'Sixs'UhvGisaxs
 588             = DataSourcePath'Geometry
 589               sixsUhvGisaxs
 590               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 591               [ sixs'Uhv'Mu, sixs'Uhv'Omega, sixs'eix, sixs'eiz ]
 592
 593       let sixs'Med'Beta
 594             = DataSourcePath'Double'Ini cfg "geometry.values" "beta"
 595               `DataSourcePath'Double'Or`
 596               DataSourcePath'Double(hdf5p $ grouppat 0 (groupp "scan_data" (datasetp "beta"
 597                                                                             `H5Or`
 598                                                                             datasetpattr ("long_name", "i14-c-cx1/ex/diff-med-tpp/pitch"))
 599                                                         `H5Or`
 600                                                         datasetp "SIXS/i14-c-cx1-ex-diff-med-tpp/TPP/Orientation/pitch"))
 601       let sixs'MedH'Mu
 602             = DataSourcePath'Double'Ini cfg "geometry.values" "mu"
 603               `DataSourcePath'Double'Or`
 604               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "mu"
 605                                                                              `H5Or`
 606                                                                               datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/mu")))
 607       let sixs'MedV'Mu
 608             = DataSourcePath'Double'Ini cfg "geometry.values" "mu"
 609               `DataSourcePath'Double'Or`
 610               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "mu"
 611                                                                              `H5Or`
 612                                                                               datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/mu")))
 613       let sixs'MedV'Omega
 614             = DataSourcePath'Double'Ini cfg "geometry.values" "omega"
 615               `DataSourcePath'Double'Or`
 616               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "omega"
 617                                                                              `H5Or`
 618                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/omega")))
 619       let sixs'MedH'Gamma
 620             = DataSourcePath'Double'Ini cfg "geometry.values" "gamma"
 621               `DataSourcePath'Double'Or`
 622               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "gamma"
 623                                                                              `H5Or`
 624                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/gamma")))
 625       let sixs'MedV'Gamma
 626             = DataSourcePath'Double'Ini cfg "geometry.values" "gamma"
 627               `DataSourcePath'Double'Or`
 628               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "gamma"
 629                                                                              `H5Or`
 630                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/gamma")))
 631       let sixs'MedH'Delta
 632             = DataSourcePath'Double'Ini cfg "geometry.values" "delta"
 633               `DataSourcePath'Double'Or`
 634               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "delta"
 635                                                                              `H5Or`
 636                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/delta")))
 637
 638       let sixs'MedV'Delta
 639             = DataSourcePath'Double'Ini cfg "geometry.values" "delta"
 640               `DataSourcePath'Double'Or`
 641               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "delta"
 642                                                                              `H5Or`
 643                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/delta")))
 644
 645       let sixs'MedV'Etaa
 646             = DataSourcePath'Double'Ini cfg "geometry.values" "etaa"
 647               `DataSourcePath'Double'Or`
 648               DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp "scan_data" (datasetp "etaa"
 649                                                                              `H5Or`
 650                                                                              datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/etaa")))
 651
 652
 653       let dataSourcePath'Geometry'Sixs'MedH ::  DataSourcePath Geometry
 654           dataSourcePath'Geometry'Sixs'MedH
 655             = DataSourcePath'Geometry
 656               (Geometry'Factory MedH)
 657               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 658               [ sixs'Med'Beta, sixs'MedH'Mu, sixs'MedH'Gamma, sixs'MedH'Delta ]
 659
 660       let dataSourcePath'Geometry'Sixs'MedHGisaxs ::  DataSourcePath Geometry
 661           dataSourcePath'Geometry'Sixs'MedHGisaxs
 662             = DataSourcePath'Geometry
 663               sixsMedHGisaxs
 664               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 665               [ sixs'Med'Beta, sixs'MedH'Mu, sixs'eix, sixs'eiz ]
 666
 667       let dataSourcePath'Geometry'Sixs'MedV :: DataSourcePath Geometry
 668           dataSourcePath'Geometry'Sixs'MedV
 669             = DataSourcePath'Geometry
 670               (Geometry'Factory MedV)
 671               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 672               [ sixs'Med'Beta, sixs'MedV'Mu, sixs'MedV'Omega, sixs'MedV'Gamma, sixs'MedV'Delta, sixs'MedV'Etaa ]
 673
 674       let dataSourcePath'Geometry'Sixs'MedVGisaxs :: DataSourcePath Geometry
 675           dataSourcePath'Geometry'Sixs'MedVGisaxs
 676             = DataSourcePath'Geometry
 677               sixsMedVGisaxs
 678               (overloadWaveLength mWavelength dataSourcePath'WaveLength'Sixs)
 679               [ sixs'Med'Beta, sixs'MedV'Mu, sixs'MedV'Omega, sixs'eix, sixs'eiz ]
 680
 681       let dataSourcePath'DataFrameQCustom'Sixs'Fly :: DataSourcePath Geometry -> DataSourcePath DataFrameQCustom
 682           dataSourcePath'DataFrameQCustom'Sixs'Fly g
 683             = DataSourcePath'DataFrameQCustom
 684               (mkAttenuation mAttenuationCoefficient dataSourcePath'Attenuation'Sixs)
 685               g
 686               (mkDetector'Sixs'Fly detector)
 687               (mkTimeStamp'Fly msub)
 688
 689       let dataSourcePath'DataFrameQCustom'Sixs'Sbs :: DataSourcePath Geometry -> DataSourcePath DataFrameQCustom
 690           dataSourcePath'DataFrameQCustom'Sixs'Sbs g
 691             = DataSourcePath'DataFrameQCustom
 692               (mkAttenuation mAttenuationCoefficient dataSourcePath'Attenuation'SixsSBS)
 693               g
 694               (mkDetector'Sixs'Sbs detector)
 695               (mkTimeStamp'Sbs msub)
 696
 697       case inputtype of
 698          CristalK6C -> DataSourcePath'DataFrameQCustom
 699                       (mkAttenuation mAttenuationCoefficient  DataSourcePath'NoAttenuation)
 700                       (DataSourcePath'Geometry
 701                         (Geometry'Factory K6c)
 702                         (overloadWaveLength mWavelength (DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Monochromator/lambda")))
 703                         [ DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Diffractometer/i06-c-c07-ex-dif-mu/position")
 704                         , DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Diffractometer/i06-c-c07-ex-dif-komega/position")
 705                         , DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Diffractometer/i06-c-c07-ex-dif-kappa/position")
 706                         , DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "scan_data/actuator_1_1")
 707                         , DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Diffractometer/i06-c-c07-ex-dif-gamma/position")
 708                         , DataSourcePath'Double (hdf5p $ grouppat 0 $ datasetp "CRISTAL/Diffractometer/i06-c-c07-ex-dif-delta/position")
 709                         ]
 710                       )
 711                       (DataSourcePath'Image
 712                         (hdf5p $ grouppat 0 $ datasetp "scan_data/data_05")
 713                         detector)
 714                       (mkTimeStamp'Sbs msub)
 715          MarsFlyscan -> DataSourcePath'DataFrameQCustom
 716                        (mkAttenuation mAttenuationCoefficient (DataSourcePath'ApplyedAttenuationFactor
 717                                                                (DataSourcePath'Float (hdf5p $ grouppat 0 $ datasetp "scan_data/applied_att"))))
 718                        (DataSourcePath'Geometry
 719                          (Geometry'Factory Mars)
 720                          (overloadWaveLength mWavelength (DataSourcePath'Double'Const 1.537591))
 721                          [ DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/omega")
 722                          , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/chi")
 723                          , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/phi")
 724                          , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/tth")
 725                          ])
 726                        (DataSourcePath'Image
 727                          (hdf5p $ grouppat 0 (datasetp "scan_data/merlin_image"
 728                                               `H5Or`
 729                                               datasetp "scan_data/merlin_quad_image"))
 730                          detector)
 731                        (mkTimeStamp'Fly msub)
 732          MarsSbs -> DataSourcePath'DataFrameQCustom
 733                    (mkAttenuation mAttenuationCoefficient DataSourcePath'NoAttenuation)
 734                    (DataSourcePath'Geometry
 735                      (Geometry'Factory Mars)
 736                      (overloadWaveLength mWavelength (DataSourcePath'Double'Const 1.537591))
 737                      [ DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/omega")
 738                      , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/chi")
 739                      , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/phi")
 740                      , DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "scan_data/tth")
 741                      ])
 742                    (DataSourcePath'Image
 743                     (hdf5p $ datasetpattr ("long_name", "d03-1-c00/dt/merlin-quad/image"))
 744                     detector)
 745                    (mkTimeStamp'Sbs msub)
 746          SixsFlyMedH -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'MedH
 747          SixsFlyMedHGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'MedHGisaxs
 748          SixsFlyMedV -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'MedV
 749          SixsFlyMedVGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'MedVGisaxs
 750          SixsFlyUhv -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'Uhv
 751          SixsFlyUhvGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Fly dataSourcePath'Geometry'Sixs'UhvGisaxs
 752          SixsSbsMedH -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'MedH
 753          SixsSbsMedHGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'MedHGisaxs
 754          SixsSbsMedV -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'MedV
 755          SixsSbsMedVGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'MedVGisaxs
 756          SixsSbsUhv -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'Uhv
 757          SixsSbsUhvGisaxs -> dataSourcePath'DataFrameQCustom'Sixs'Sbs dataSourcePath'Geometry'Sixs'UhvGisaxs
 758
 759
 760 {-# INLINE spaceQCustom #-}
 761 spaceQCustom :: Detector a DIM2
 762              -> Array F DIM3 Double
 763              -> Resolutions DIM3
 764              -> Maybe Mask
 765              -> HklBinocularsSurfaceOrientationEnum
 766              -> Maybe (RLimits DIM3)
 767              -> HklBinocularsQCustomSubProjectionEnum
 768              -> Angle Double -> Angle Double -> Angle Double
 769              -> Maybe SampleAxis
 770              -> Bool
 771              -> Space DIM3
 772              -> DataFrameQCustom
 773              -> IO (DataFrameSpace DIM3)
 774 spaceQCustom det pixels rs mmask' surf mlimits subprojection uqx uqy uqz mSampleAxis doPolarizationCorrection space@(Space fSpace) (DataFrameQCustom att g img index) =
 775   withNPixels det $ \nPixels ->
 776   withForeignPtr g $ \geometry ->
 777   withForeignPtr (toForeignPtr pixels) $ \pix ->
 778   withResolutions rs $ \nr r ->
 779   withPixelsDims pixels $ \ndim dims ->
 780   withMaybeMask mmask' $ \ mask'' ->
 781   withMaybeLimits mlimits rs $ \nlimits limits ->
 782   withMaybeSampleAxis mSampleAxis $ \sampleAxis ->
 783   withForeignPtr fSpace $ \pSpace -> do
 784   case img of
 785     (ImageInt32 arr) -> unsafeWith arr $ \i -> do
 786       {-# SCC "hkl_binoculars_space_qcustom_int32_t" #-} c'hkl_binoculars_space_qcustom_int32_t pSpace geometry i nPixels (CDouble . unAttenuation $ att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) limits (toEnum nlimits) (CDouble . unTimestamp $ index) (toEnum . fromEnum $ subprojection) (CDouble (uqx /~ radian)) (CDouble (uqy /~ radian)) (CDouble (uqz /~ radian)) sampleAxis (toEnum . fromEnum $ doPolarizationCorrection)
 787     (ImageWord16 arr) -> unsafeWith arr $ \i -> do
 788       {-# SCC "hkl_binoculars_space_qcustom_uint16_t" #-} c'hkl_binoculars_space_qcustom_uint16_t pSpace geometry i nPixels (CDouble . unAttenuation $ att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) limits (toEnum nlimits) (CDouble . unTimestamp $ index) (toEnum . fromEnum $ subprojection) (CDouble (uqx /~ radian)) (CDouble (uqy /~ radian)) (CDouble (uqz /~ radian)) sampleAxis (toEnum . fromEnum $ doPolarizationCorrection)
 789     (ImageWord32 arr) -> unsafeWith arr $ \i -> do
 790       {-# SCC "hkl_binoculars_space_qcustom_uint32_t" #-} c'hkl_binoculars_space_qcustom_uint32_t pSpace geometry i nPixels (CDouble . unAttenuation $ att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) limits (toEnum nlimits) (CDouble . unTimestamp $ index) (toEnum . fromEnum $ subprojection) (CDouble (uqx /~ radian)) (CDouble (uqy /~ radian)) (CDouble (uqz /~ radian)) sampleAxis (toEnum . fromEnum $ doPolarizationCorrection)
 791
 792   return (DataFrameSpace img space att)
 793
 794 ----------
 795 -- Pipe --
 796 ----------
 797
 798 processQCustomP :: (MonadIO m, MonadLogger m, MonadReader (Config 'QCustomProjection) m, MonadThrow m)
 799                 => m ()
 800 processQCustomP = do
 801   (conf :: Config 'QCustomProjection) <- ask
 802
 803   -- directly from the common config
 804   let common = binocularsConfig'QCustom'Common conf
 805   let overwrite = binocularsConfig'Common'Overwrite common
 806   let det = binocularsConfig'Common'Detector common
 807   let (NCores cap) =  binocularsConfig'Common'NCores common
 808   let destination = binocularsConfig'Common'Destination common
 809   let centralPixel' = binocularsConfig'Common'Centralpixel common
 810   let (Meter sampleDetectorDistance) = binocularsConfig'Common'Sdd common
 811   let (Degree detrot) = binocularsConfig'Common'Detrot common
 812   let mImageSumMax = binocularsConfig'Common'ImageSumMax common
 813   let inputRange = binocularsConfig'Common'InputRange common
 814   let nexusDir = binocularsConfig'Common'Nexusdir common
 815   let tmpl = binocularsConfig'Common'Tmpl common
 816   let maskMatrix = binocularsConfig'Common'Maskmatrix common
 817   let mSkipFirstPoints = binocularsConfig'Common'SkipFirstPoints common
 818   let mSkipLastPoints = binocularsConfig'Common'SkipLastPoints common
 819   let doPolarizationCorrection = binocularsConfig'Common'PolarizationCorrection common
 820
 821   -- directly from the specific config
 822   let mlimits = binocularsConfig'QCustom'ProjectionLimits conf
 823   let res = binocularsConfig'QCustom'ProjectionResolution conf
 824   let surfaceOrientation = binocularsConfig'QCustom'HklBinocularsSurfaceOrientationEnum conf
 825   let datapaths = binocularsConfig'QCustom'DataPath conf
 826   let subprojection = fromJust (binocularsConfig'QCustom'SubProjection conf) -- should not be Maybe
 827   let projectionType = binocularsConfig'QCustom'ProjectionType conf
 828   let (Degree uqx) = binocularsConfig'QCustom'Uqx conf
 829   let (Degree uqy) = binocularsConfig'QCustom'Uqy conf
 830   let (Degree uqz) = binocularsConfig'QCustom'Uqz conf
 831   let mSampleAxis = binocularsConfig'QCustom'SampleAxis conf
 832
 833   -- built from the config
 834   output' <- liftIO $ destination' projectionType (Just subprojection) inputRange mlimits destination overwrite
 835   filenames <- InputFn'List <$> files nexusDir (Just inputRange) tmpl
 836   mask' <- getMask maskMatrix det
 837   pixels <- liftIO $ getPixelsCoordinates det centralPixel' sampleDetectorDistance detrot NoNormalisation
 838
 839   -- compute the jobs
 840
 841   let fns = concatMap (replicate 1) (toList filenames)
 842   chunks <- liftIO $ runSafeT $ toListM $ each fns >-> chunkP mSkipFirstPoints mSkipLastPoints datapaths
 843   let ntot = sum (Prelude.map clength chunks)
 844   let jobs = chunk (quot ntot cap) chunks
 845
 846   -- log parameters
 847
 848   logDebugNSH filenames
 849   logDebugNSH datapaths
 850   logDebugNSH chunks
 851   logDebugNSH ntot
 852   logDebugNSH jobs
 853   logDebugN "start gessing final cube size"
 854
 855   -- guess the final cube dimensions (To optimize, do not create the cube, just extract the shape)
 856
 857   guessed <- liftIO $ withCubeAccumulator EmptyCube $ \c ->
 858     runSafeT $ runEffect $
 859     each chunks
 860     >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f, quot (f + t) 4, quot (f + t) 4 * 2, quot (f + t) 4 * 3, t]))
 861     >-> framesP datapaths
 862     >-> project det 3 (spaceQCustom det pixels res mask' surfaceOrientation mlimits subprojection uqx uqy uqz mSampleAxis doPolarizationCorrection)
 863     >-> accumulateP c
 864
 865   logDebugN "stop gessing final cube size"
 866
 867   -- do the final projection
 868
 869   logInfoN $ pack $ printf "let's do a QCustom projection of %d %s image(s) on %d core(s)" ntot (show det) cap
 870
 871   liftIO $ withProgressBar ntot $ \pb -> do
 872     r' <- mapConcurrently (\job -> withCubeAccumulator guessed $ \c ->
 873                              runSafeT $ runEffect $
 874                              each job
 875                              >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f..t]))
 876                              >-> framesP datapaths
 877                              >-> Pipes.Prelude.filter (\(DataFrameQCustom _ _ img _) -> filterSumImage mImageSumMax img)
 878                              >-> project det 3 (spaceQCustom det pixels res mask' surfaceOrientation mlimits subprojection uqx uqy uqz mSampleAxis doPolarizationCorrection)
 879                              >-> tee (accumulateP c)
 880                              >-> progress pb
 881                          ) jobs
 882     saveCube output' (unpack . serializeConfig $ conf) r'
 883
 884
 885 instance ChunkP (DataSourcePath DataFrameQCustom) where
 886     chunkP mSkipFirst mSkipLast (DataSourcePath'DataFrameQCustom ma _ (DataSourcePath'Image i _) _) =
 887       skipMalformed $ forever $ do
 888       fp <- await
 889       withFileP (openFile' fp) $ \f ->
 890         withHdf5PathP f i $ \i' -> do
 891         (_, ss) <- liftIO $ datasetShape i'
 892         case head ss of
 893           (Just n) -> yield $ let (Chunk _ from to) = cclip (fromMaybe 0 mSkipFirst) (fromMaybe 0 mSkipLast) (Chunk fp 0 (fromIntegral n - 1))
 894                              in case ma of
 895                                   DataSourcePath'NoAttenuation -> Chunk fp from to
 896                                   (DataSourcePath'Attenuation _ off _ _) -> Chunk fp from (to - off)
 897                                   (DataSourcePath'ApplyedAttenuationFactor _) -> Chunk fp from to
 898           Nothing  -> error "can not extract length"
 899
 900 instance FramesP (DataSourcePath DataFrameQCustom) DataFrameQCustom where
 901     framesP p =
 902         skipMalformed $ forever $ do
 903           (fn, js) <- await
 904           withFileP (openFile' fn) $ \f ->
 905             withDataSourceP f p $ \ g ->
 906             forM_ js (tryYield . extract1DStreamValue g)
 907
 908 ---------
 909 -- Cmd --
 910 ---------
 911
 912 processQCustom :: (MonadLogger m, MonadThrow m, MonadIO m) => Maybe FilePath -> Maybe ConfigRange -> m ()
 913 processQCustom mf mr = cmd processQCustomP mf (Args'QCustomProjection mr)
 914
 915 newQCustom :: (MonadIO m, MonadLogger m, MonadThrow m)
 916            => Path Abs Dir -> m ()
 917 newQCustom cwd = do
 918   let conf = default'BinocularsConfig'QCustom
 919              { binocularsConfig'QCustom'Common = default'BinocularsConfig'Common
 920                                                  { binocularsConfig'Common'Nexusdir = Just cwd }
 921              }
 922   liftIO $ Data.Text.IO.putStr $ serializeConfig conf
 923
 924 updateQCustom :: (MonadIO m, MonadLogger m, MonadThrow m)
 925               => Maybe FilePath -> Maybe ConfigRange -> m ()
 926 updateQCustom mf mr = cmd (pure ()) mf (Args'QCustomProjection mr)