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

   1 {-# LANGUAGE GADTs              #-}
   2 {-# LANGUAGE MultiWayIf         #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4
   5 {-
   6     Copyright  : Copyright (C) 2014-2024 Synchrotron SOLEIL
   7                                          L'Orme des Merisiers Saint-Aubin
   8                                          BP 48 91192 GIF-sur-YVETTE CEDEX
   9     License    : GPL3+
  10
  11     Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
  12     Stability  : Experimental
  13     Portability: GHC only (not tested)
  14 -}
  15 module Hkl.Binoculars.Common
  16   ( Chunk(..)
  17   , DataFrameSpace(..)
  18   , InputFn(..)
  19   , addSpace
  20   , chunk
  21   , cclip
  22   , clength
  23   , mkCube'
  24   , toList
  25   , withCubeAccumulator
  26   ) where
  27
  28 import           Control.Exception          (bracket)
  29 import           Data.IORef                 (IORef, newIORef, readIORef)
  30 import           Foreign.ForeignPtr         (withForeignPtr)
  31 import           Foreign.Marshal.Array      (withArrayLen)
  32 import           Path                       (Abs, File, Path, fromAbsFile)
  33 import           Text.Printf                (printf)
  34
  35 import           Hkl.Binoculars.Config
  36 import           Hkl.Binoculars.Projections
  37 import           Hkl.C.Binoculars
  38 import           Hkl.Image
  39 import           Hkl.Orphan                 ()
  40 import           Hkl.Repa
  41
  42 data Chunk n a = Chunk !a !n !n
  43 deriving instance (Show n, Show a) => Show (Chunk n a)
  44
  45 cclip :: (Num n, Ord n) => n -> n -> Chunk n a -> Chunk n a
  46 cclip skipL skipH (Chunk a l h) = let nl = if l + skipL > h then l else l + skipL
  47                                       nh = if h - skipH < l then h else h - skipH
  48                                   in Chunk a nl nh
  49 {-# SPECIALIZE cclip :: Int -> Int -> Chunk Int FilePath -> Chunk Int FilePath #-}
  50
  51 clength :: Num n => Chunk n a -> n
  52 clength (Chunk _ l h) = h - l + 1
  53 {-# SPECIALIZE clength :: Chunk Int FilePath -> Int  #-}
  54
  55 cweight :: Num n => Chunk n a -> n
  56 cweight (Chunk _ l h) = h - l
  57
  58 csplit :: Num n => Chunk n a -> n -> (Chunk n a, Chunk n a)
  59 csplit (Chunk a l h) n = (Chunk a l (l + n), Chunk a (l+n) h)
  60
  61 chunk :: (Num n, Ord n) => n -> [Chunk n a] -> [[Chunk n a]]
  62 chunk target = go target target
  63   where
  64     go :: (Num n, Ord n) => n -> n -> [Chunk n a] -> [[Chunk n a]]
  65     go _ _ []          = []
  66     go tgt gap [x]     = golast tgt gap x
  67     go tgt gap ~(x:xs) =
  68       let gap' = gap - cweight x
  69       in if | gap' > 0                 -> cons1 x $ go tgt gap' xs
  70             | gap' == 0                -> [x] : go tgt tgt xs
  71             | (x1, x2) <- csplit x gap -> [x1] : go tgt tgt (x2 : xs)
  72
  73     cons1 x cs = (x : Prelude.head cs) : tail cs
  74
  75     golast tgt gap x =
  76       if | 0 == gap                 -> [[x]]
  77          | cweight x <= gap         -> [[x]]
  78          | (x1, x2) <- csplit x gap -> [x1] : golast tgt tgt x2
  79
  80 {-# SPECIALIZE chunk :: Int -> [Chunk Int FilePath] -> [[Chunk Int FilePath]]  #-}
  81
  82 toList :: InputFn -> [FilePath]
  83 toList (InputFn f)              = [f]
  84 toList (InputFn'Range tmpl f t) = [printf tmpl i | i <- [f..t]]
  85 toList (InputFn'List fs)        = map fromAbsFile fs
  86
  87 --  DataFrameSpace
  88
  89 data DataFrameSpace sh = DataFrameSpace Image (Space sh) Attenuation
  90   deriving Show
  91
  92 --  Create the Cube
  93
  94 {-# INLINE mkCube' #-}
  95 mkCube' :: Shape sh => [DataFrameSpace sh] -> IO (Cube sh)
  96 mkCube' dfs = do
  97   let spaces = [fp | (DataFrameSpace _ (Space fp) _) <- dfs]
  98   withForeignPtrs spaces $ \pspaces ->
  99     withArrayLen pspaces $ \nSpaces' spaces' ->
 100     newCube =<< {-# SCC "hkl_binoculars_cube_new'" #-} c'hkl_binoculars_cube_new (toEnum nSpaces') spaces'
 101
 102 {-# INLINE addSpace #-}
 103 addSpace :: Shape sh => DataFrameSpace sh -> Cube sh -> IO (Cube sh)
 104 addSpace df EmptyCube = mkCube' [df]
 105 addSpace (DataFrameSpace _ (Space fs) _) (Cube fp) =
 106   withForeignPtr fs $ \spacePtr ->
 107   withForeignPtr fp $ \cPtr -> do
 108   {-# SCC "hkl_binoculars_cube_add_space" #-} c'hkl_binoculars_cube_add_space cPtr spacePtr
 109   return $ Cube fp
 110
 111 type Template = String
 112
 113 data InputFn = InputFn FilePath
 114              | InputFn'Range Template Int Int
 115              | InputFn'List [Path Abs File]
 116   deriving Show
 117
 118 withCubeAccumulator :: Shape sh => Cube sh -> (IORef (Cube sh)  -> IO ()) -> IO (Cube sh)
 119 withCubeAccumulator c f = bracket
 120   (newIORef =<< newCube =<< (case c of
 121                                EmptyCube -> c'hkl_binoculars_cube_new_empty
 122                                (Cube fp) -> withForeignPtr fp $ \p ->
 123                                  c'hkl_binoculars_cube_new_empty_from_cube p
 124                             )
 125   )
 126   pure
 127   (\r -> f r >> readIORef r)
 128
 129 -- Projections