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