binoculars-ng/src/Hkl/Binoculars/Config/Sample.hs

   1 {-# LANGUAGE DataKinds             #-}
   2 {-# LANGUAGE DeriveAnyClass        #-}
   3 {-# LANGUAGE DeriveGeneric         #-}
   4 {-# LANGUAGE FlexibleContexts      #-}
   5 {-# LANGUAGE FlexibleInstances     #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE OverloadedStrings     #-}
   8 {-# LANGUAGE RankNTypes            #-}
   9 {-# LANGUAGE RecordWildCards       #-}
  10 {-# LANGUAGE ScopedTypeVariables   #-}
  11 {-# LANGUAGE TypeFamilies          #-}
  12
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14
  15 {-
  16     Copyright  : Copyright (C) 2014-2024 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.Config.Sample
  27     ( Args(..)
  28     , Config(..)
  29     , default'DataSourcePath'Sample
  30     , guess'DataSourcePath'Sample
  31     , overload'DataSourcePath'Sample
  32     ) where
  33
  34 import           Data.Aeson                   (FromJSON, ToJSON)
  35 import           Data.HashMap.Lazy            (fromList)
  36 import           Data.Ini                     (Ini (..))
  37 import           GHC.Generics                 (Generic)
  38
  39 import           Hkl.Binoculars.Config
  40 import           Hkl.Binoculars.Config.Common
  41 import           Hkl.DataSource
  42 import           Hkl.H5
  43 import           Hkl.Lattice
  44 import           Hkl.Parameter
  45 import           Hkl.Sample
  46
  47 ----------------
  48 -- DataSource --
  49 ----------------
  50
  51 instance DataSource Sample where
  52   data DataSourcePath Sample
  53     = DataSourcePath'Sample
  54       (DataSourcePath Double) -- a
  55       (DataSourcePath Double) -- b
  56       (DataSourcePath Double) -- c
  57       (DataSourcePath Degree) -- alpha
  58       (DataSourcePath Degree) -- beta
  59       (DataSourcePath Degree) -- gamma
  60       (DataSourcePath Degree) -- ux
  61       (DataSourcePath Degree) -- uy
  62       (DataSourcePath Degree) -- uz
  63     | DataSourcePath'Sample'Or (DataSourcePath Sample) (DataSourcePath Sample)
  64     deriving (FromJSON, Generic, Show, ToJSON)
  65
  66   data DataSourceAcq Sample
  67     = DataSourceAcq'Sample
  68       (DataSourceAcq Double)
  69       (DataSourceAcq Double)
  70       (DataSourceAcq Double)
  71       (DataSourceAcq Degree)
  72       (DataSourceAcq Degree)
  73       (DataSourceAcq Degree)
  74       (DataSourceAcq Degree)
  75       (DataSourceAcq Degree)
  76       (DataSourceAcq Degree)
  77
  78   withDataSourceP f (DataSourcePath'Sample a b c alpha beta gamma ux uy uz) g =
  79     withDataSourceP f a $ \a' ->
  80     withDataSourceP f b $ \b' ->
  81     withDataSourceP f c $ \c' ->
  82     withDataSourceP f alpha $ \alpha' ->
  83     withDataSourceP f beta $ \beta' ->
  84     withDataSourceP f gamma $ \gamma' ->
  85     withDataSourceP f ux $ \ux' ->
  86     withDataSourceP f uy $ \uy' ->
  87     withDataSourceP f uz $ \uz' -> g (DataSourceAcq'Sample a' b' c' alpha' beta' gamma' ux' uy' uz')
  88   withDataSourceP f (DataSourcePath'Sample'Or l r) g = withDataSourcePOr f l r g
  89
  90 instance Is0DStreamable (DataSourceAcq Sample) Sample where
  91   extract0DStreamValue (DataSourceAcq'Sample a b c alpha beta gamma ux uy uz) =
  92     Sample "test"
  93     <$> (Triclinic
  94          <$> extract0DStreamValue a
  95          <*> extract0DStreamValue b
  96          <*> extract0DStreamValue c
  97          <*> extract0DStreamValue alpha
  98          <*> extract0DStreamValue beta
  99          <*> extract0DStreamValue gamma)
 100     <*> (Parameter "ux"
 101          <$> extract0DStreamValue ux
 102          <*> pure (Range 0 0))
 103     <*> (Parameter "uy"
 104          <$> extract0DStreamValue uy
 105          <*> pure (Range 0 0))
 106     <*> (Parameter "uz"
 107          <$> extract0DStreamValue uz
 108          <*> pure (Range 0 0))
 109
 110 default'DataSourcePath'Sample :: DataSourcePath Sample
 111 default'DataSourcePath'Sample = DataSourcePath'Sample
 112   (DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/A"))
 113   (DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/B"))
 114   (DataSourcePath'Double(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/C"))
 115   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Alpha"))
 116   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Beta"))
 117   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Gamma"))
 118   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Ux"))
 119   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Uy"))
 120   (DataSourcePath'Degree(hdf5p $ grouppat 0 $ datasetp "SIXS/I14-C-CX2__EX__DIFF-UHV__#1/Uz"))
 121
 122
 123 overload'DataSourcePath'Sample :: Config Sample
 124                                -> DataSourcePath Sample
 125                                -> DataSourcePath Sample
 126 overload'DataSourcePath'Sample (BinocularsConfig'Sample ma mb mc malpha mbeta mgamma mux muy muz) (DataSourcePath'Sample pa pb pc palpha pbeta pgamma pux puy puz)
 127   = DataSourcePath'Sample
 128     (maybe pa DataSourcePath'Double'Const ma)
 129     (maybe pb DataSourcePath'Double'Const mb)
 130     (maybe pc DataSourcePath'Double'Const mc)
 131     (maybe palpha DataSourcePath'Degree'Const malpha)
 132     (maybe pbeta DataSourcePath'Degree'Const mbeta)
 133     (maybe pgamma DataSourcePath'Degree'Const mgamma)
 134     (maybe pux DataSourcePath'Degree'Const mux)
 135     (maybe puy DataSourcePath'Degree'Const muy)
 136     (maybe puz DataSourcePath'Degree'Const muz)
 137 overload'DataSourcePath'Sample c (DataSourcePath'Sample'Or l r)
 138   = DataSourcePath'Sample'Or
 139     (overload'DataSourcePath'Sample c l)
 140     (overload'DataSourcePath'Sample c r)
 141
 142 guess'DataSourcePath'Sample :: Config Common
 143                            -> Config Sample
 144                            -> DataSourcePath Sample
 145 guess'DataSourcePath'Sample common sample =
 146   do let inputType = binocularsConfig'Common'InputType common
 147      let samplePath' beamline device =
 148            DataSourcePath'Sample
 149            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "A"))
 150            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "B"))
 151            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "C"))
 152            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "alpha"))
 153            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "beta"))
 154            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "gamma"))
 155            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Ux"))
 156            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Uy"))
 157            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Uz"))
 158      let sampleMarsPath beamline device =
 159            DataSourcePath'Sample
 160            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "a"))
 161            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "b"))
 162            (DataSourcePath'Double(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "c"))
 163            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "alpha"))
 164            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "beta"))
 165            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "gamma"))
 166            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_x"))
 167            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_y"))
 168            (DataSourcePath'Degree(hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_z"))
 169      let cristalSamplePath = samplePath' "NOBEAMLINE" "NOBEAMLINE"
 170      let diffabsSamplePath = samplePath' "DIFFABS" undefined
 171      let marsSamplePath = sampleMarsPath "MARS" "d03-1-cx2__ex__dif-cm_#1"
 172      let medHSamplePath = samplePath' "SIXS" "i14-c-cx1-ex-cm-med.h"
 173      let medVSamplePath = samplePath' "SIXS" "i14-c-cx1-ex-cm-med.v"
 174      let uhvSamplePath  = samplePath' "SIXS" "I14-C-CX2__EX__DIFF-UHV__#1"
 175                           `DataSourcePath'Sample'Or`
 176                           samplePath' "SIXS" "i14-c-cx2-ex-cm-uhv"
 177
 178      let samplePath = case inputType of
 179                         CristalK6C        -> cristalSamplePath
 180                         DiffabsCirpad     -> diffabsSamplePath
 181                         MarsFlyscan       -> marsSamplePath
 182                         MarsSbs           -> marsSamplePath
 183                         SixsFlyMedH       -> medHSamplePath
 184                         SixsFlyMedHGisaxs -> medHSamplePath
 185                         SixsFlyMedV       -> medVSamplePath
 186                         SixsFlyMedVGisaxs -> medVSamplePath
 187                         SixsFlyUhv        -> uhvSamplePath
 188                         SixsFlyUhvGisaxs  -> uhvSamplePath
 189                         SixsSbsMedH       -> medHSamplePath
 190                         SixsSbsMedHGisaxs -> medHSamplePath
 191                         SixsSbsMedV       -> medVSamplePath
 192                         SixsSbsMedVGisaxs -> medVSamplePath
 193                         SixsSbsUhv        -> uhvSamplePath
 194                         SixsSbsUhvGisaxs  -> uhvSamplePath
 195
 196      overload'DataSourcePath'Sample sample samplePath
 197
 198 ------------
 199 -- Config --
 200 ------------
 201
 202 instance HasIniConfig Sample where
 203
 204     data Config Sample
 205         = BinocularsConfig'Sample
 206           { binocularsConfig'Sample'A     :: Maybe Double
 207           , binocularsConfig'Sample'B     :: Maybe Double
 208           , binocularsConfig'Sample'C     :: Maybe Double
 209           , binocularsConfig'Sample'Alpha :: Maybe Degree
 210           , binocularsConfig'Sample'Beta  :: Maybe Degree
 211           , binocularsConfig'Sample'Gamma :: Maybe Degree
 212           , binocularsConfig'Sample'Ux    :: Maybe Degree
 213           , binocularsConfig'Sample'Uy    :: Maybe Degree
 214           , binocularsConfig'Sample'Uz    :: Maybe Degree
 215           } deriving (Eq, Show, Generic)
 216
 217     data Args Sample
 218         = Args'Sample
 219
 220     defaultConfig
 221         = BinocularsConfig'Sample
 222           { binocularsConfig'Sample'A = Nothing
 223           , binocularsConfig'Sample'B = Nothing
 224           , binocularsConfig'Sample'C = Nothing
 225           , binocularsConfig'Sample'Alpha = Nothing
 226           , binocularsConfig'Sample'Beta = Nothing
 227           , binocularsConfig'Sample'Gamma = Nothing
 228           , binocularsConfig'Sample'Ux = Nothing
 229           , binocularsConfig'Sample'Uy = Nothing
 230           , binocularsConfig'Sample'Uz = Nothing
 231           }
 232
 233     toIni c = Ini { iniSections = fromList [ ("input", elemFMbDef "a" binocularsConfig'Sample'A c defaultConfig
 234                                                      [ "`a` parameter of the sample lattice (same unit than the wavelength)."
 235                                                      , ""
 236                                                      , "This parameter with the 5 others, `b`, `c`, `alpha`, `beta` and `gamma`"
 237                                                      , "can be set in order to overwrite the values from the data file."
 238                                                      , ""
 239                                                      , " `<not set>` - read `a` from the data file."
 240                                                      , " `a`         - override `a` with this value."
 241                                                      ]
 242                                                      <> elemFMbDef "b" binocularsConfig'Sample'B c defaultConfig
 243                                                      [ "`b` parameter of the sample lattice (same unit than the wavelength)."
 244                                                      , ""
 245                                                      , "This parameter with the 5 others, `a`, `c`, `alpha`, `beta` and `gamma`"
 246                                                      , "can be set in order to overwrite the values from the data file."
 247                                                      , ""
 248                                                      , " `<not set>` - read `b` from the data file."
 249                                                      , " `b`         - override `b` with this value."
 250                                                      ]
 251                                                      <> elemFMbDef "c" binocularsConfig'Sample'C c defaultConfig
 252                                                      [ "`c` parameter of the sample lattice (same unit than the wavelength)."
 253                                                      , ""
 254                                                      , "This parameter with the 5 others, `a`, `b`, `alpha`, `beta` and `gamma`"
 255                                                      , "can be set in order to overwrite the values from the data file."
 256                                                      , ""
 257                                                      , " `<not set>` - read `c` from the data file."
 258                                                      , " `c`         - override `c` with this value."
 259                                                      ]
 260                                                      <> elemFMbDef "alpha" binocularsConfig'Sample'Alpha c defaultConfig
 261                                                      [ "`alpha` parameter of the sample lattice (Degree)."
 262                                                      , ""
 263                                                      , "This parameter with the 5 others, `a`, `b`, `c`, `beta` and `gamma`"
 264                                                      , "can be set in order to overwrite the values from the data file."
 265                                                      , ""
 266                                                      , " `<not set>` - read `alpha` from the data file."
 267                                                      , " `alpha`     - override `alpha` with this value."
 268                                                      ]
 269                                                      <> elemFMbDef "beta" binocularsConfig'Sample'Beta c defaultConfig
 270                                                      [ "`beta` parameter of the sample lattice (Degree)."
 271                                                      , ""
 272                                                      , "This parameter with the 5 others, `a`, `b`, `c`, `alpha`, and `gamma`"
 273                                                      , "can be set in order to overwrite the values from the data file."
 274                                                      , ""
 275                                                      , " `<not set>` - read `beta` from the data file."
 276                                                      , " `beta`      - override `beta` with this value."
 277                                                      ]
 278                                                      <> elemFMbDef "gamma" binocularsConfig'Sample'Gamma c defaultConfig
 279                                                      [ "`gamma` parameter of the sample lattice (Degree)."
 280                                                      , ""
 281                                                      , "This parameter with the 5 others, `a`, `b`, `c`, `alpha` and `beta`"
 282                                                      , "can be set in order to overwrite the values from the data file."
 283                                                      , ""
 284                                                      , " `<not set>` - read `gamma` from the data file."
 285                                                      , " `gamma`     - override `gamma` with this value."
 286                                                      ]
 287                                                      <> elemFMbDef "ux" binocularsConfig'Sample'Ux c defaultConfig
 288                                                      [ "`ux` rotation of the sample around the x axis"
 289                                                      , ""
 290                                                      , "`ux`, `uy`, `uz` are the eulerian angles, which define"
 291                                                      , "the orientation of the sample lattice, relatively to"
 292                                                      , "the sample holder."
 293                                                      , ""
 294                                                      , "the rotation is computed like this:"
 295                                                      , ""
 296                                                      , "Ux * Uy * Uz"
 297                                                      , ""
 298                                                      , " `<not set>` - read `ux` from the data file."
 299                                                      , " `ux`        - override `ux` with this value."
 300                                                      ]
 301                                                      <> elemFMbDef "uy" binocularsConfig'Sample'Uy c defaultConfig
 302                                                      [ "`uy` rotation of the sample around the y axis"
 303                                                      , ""
 304                                                      , "`ux`, `uy`, `uz` are the eulerian angles, which define"
 305                                                      , "the orientation of the sample lattice, relatively to"
 306                                                      , "the sample holder."
 307                                                      , ""
 308                                                      , "the rotation is computed like this:"
 309                                                      , ""
 310                                                      , "Ux * Uy * Uz"
 311                                                      , ""
 312                                                      , " `<not set>` - read `uy` from the data file."
 313                                                      , " `uy`        - override `uy` with this value."
 314                                                      ]
 315                                                      <> elemFMbDef "uz" binocularsConfig'Sample'Uz c defaultConfig
 316                                                      [ "`uz` rotation of the sample around the z axis"
 317                                                      , ""
 318                                                      , "`ux`, `uy`, `uz` are the eulerian angles, which define"
 319                                                      , "the orientation of the sample lattice, relatively to"
 320                                                      , "the sample holder."
 321                                                      , ""
 322                                                      , "the rotation is computed like this:"
 323                                                      , ""
 324                                                      , "Ux * Uy * Uz"
 325                                                      , ""
 326                                                      , " `<not set>` - read `uz` from the data file."
 327                                                      , " `uz`        - override `uz` with this value."
 328                                                      ]
 329                                            )
 330                                          ]
 331                 , iniGlobals = []
 332                 }
 333
 334     getConfig (ConfigContent cfg) _ _
 335         = do binocularsConfig'Sample'A <- parseMb cfg "input" "a"
 336              binocularsConfig'Sample'B <- parseMb cfg "input" "b"
 337              binocularsConfig'Sample'C <- parseMb cfg "input" "c"
 338              binocularsConfig'Sample'Alpha <- parseMb cfg "input" "alpha"
 339              binocularsConfig'Sample'Beta <- parseMb cfg "input" "beta"
 340              binocularsConfig'Sample'Gamma <- parseMb cfg "input" "gamma"
 341              binocularsConfig'Sample'Ux <- parseMb cfg "input" "ux"
 342              binocularsConfig'Sample'Uy <- parseMb cfg "input" "uy"
 343              binocularsConfig'Sample'Uz <- parseMb cfg "input" "uz"
 344              pure BinocularsConfig'Sample{..}