2 {-# LANGUAGE MultiWayIf #-}
3 {-# LANGUAGE StandaloneDeriving #-}
6 Copyright : Copyright (C) 2014-2024 Synchrotron SOLEIL
7 L'Orme des Merisiers Saint-Aubin
8 BP 48 91192 GIF-sur-YVETTE CEDEX
11 Maintainer : Picca Frédéric-Emmanuel <picca@synchrotron-soleil.fr>
12 Stability : Experimental
13 Portability: GHC only (not tested)
15 module Hkl
.Binoculars
.Common
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
)
35 import Hkl
.Binoculars
.Config
36 import Hkl
.Binoculars
.Projections
37 import Hkl
.C
.Binoculars
42 data Chunk n a
= Chunk
!a
!n
!n
43 deriving instance (Show n
, Show a
) => Show (Chunk n a
)
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
49 {-# SPECIALIZE cclip :: Int -> Int -> Chunk Int FilePath -> Chunk Int FilePath #-}
51 clength
:: Num n
=> Chunk n a
-> n
52 clength
(Chunk _ l h
) = h
- l
+ 1
53 {-# SPECIALIZE clength :: Chunk Int FilePath -> Int #-}
55 cweight
:: Num n
=> Chunk n a
-> n
56 cweight
(Chunk _ l h
) = h
- l
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
)
61 chunk
:: (Num n
, Ord n
) => n
-> [Chunk n a
] -> [[Chunk n a
]]
62 chunk target
= go target target
64 go
:: (Num n
, Ord n
) => n
-> n
-> [Chunk n a
] -> [[Chunk n a
]]
66 go tgt gap
[x
] = golast tgt gap x
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
)
73 cons1 x cs
= (x
: Prelude
.head cs
) : tail cs
76 if |
0 == gap
-> [[x
]]
77 | cweight x
<= gap
-> [[x
]]
78 |
(x1
, x2
) <- csplit x gap
-> [x1
] : golast tgt tgt x2
80 {-# SPECIALIZE chunk :: Int -> [Chunk Int FilePath] -> [[Chunk Int FilePath]] #-}
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
89 data DataFrameSpace sh
= DataFrameSpace Image
(Space sh
) Attenuation
94 {-# INLINE mkCube' #-}
95 mkCube
' :: Shape sh
=> [DataFrameSpace sh
] -> IO (Cube sh
)
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
'
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
111 type Template
= String
113 data InputFn
= InputFn
FilePath
114 | InputFn
'Range Template
Int Int
115 | InputFn
'List
[Path Abs File
]
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
127 (\r -> f r
>> readIORef r
)