diff -Nru hkl-5.0.0.2816/binoculars/hkl-binoculars.c hkl-5.0.0.2875/binoculars/hkl-binoculars.c --- hkl-5.0.0.2816/binoculars/hkl-binoculars.c 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/binoculars/hkl-binoculars.c 2021-12-08 09:14:21.000000000 +0000 @@ -96,7 +96,7 @@ static inline int hkl_binoculars_axis_contains_axis(const HklBinocularsAxis *self, const HklBinocularsAxis *other) { - return self->imin >= other->imin && self->imax <= other->imax; + return self->imin <= other->imin && self->imax >= other->imax; } static inline void hkl_binoculars_axis_merge(HklBinocularsAxis *self, const HklBinocularsAxis *other) @@ -127,7 +127,7 @@ } static inline int does_not_include(const darray_axis *axes, - const darray_axis *others) + const darray_axis *others) { size_t i; int res = 0; @@ -187,6 +187,12 @@ fprintf(f, "\nmasked pixels: %ld (%f%%)", masked, (double)masked / self->max_items * 100); } +static inline void hkl_binoculars_space_item_fprintf(FILE *f, const HklBinocularsSpaceItem *self) +{ + fprintf(f, "item->indexes(%p) v: %ld %ld %ld, intensity: %d", &self->indexes_0[0], + self->indexes_0[0], self->indexes_0[1], self->indexes_0[2], self->intensity); +} + static inline void space_update_axes(HklBinocularsSpace *space, const char *names[], size_t n_pixels, @@ -215,129 +221,125 @@ } /* the array is pre filled with the pixel coordinates */ -void hkl_binoculars_space_q(HklBinocularsSpace *space, - const HklGeometry *geometry, - const uint16_t *image, - size_t n_pixels, - double weight, - const double *pixels_coordinates, - size_t pixels_coordinates_ndim, - const size_t *pixels_coordinates_dims, - const double *resolutions, - size_t n_resolutions, - const uint8_t *masked) -{ - size_t i, j; - const char * names[] = {"qx", "qy", "qz"}; - - assert(ARRAY_SIZE(names) == darray_size(space->axes)); - assert(ARRAY_SIZE(names) == n_resolutions); - assert(n_pixels == space->max_items); - - const double *q_x = &pixels_coordinates[0 * n_pixels]; - const double *q_y = &pixels_coordinates[1 * n_pixels]; - const double *q_z = &pixels_coordinates[2 * n_pixels]; - - HklSample *sample = hkl_sample_new("test"); - HklDetector *detector = hkl_detector_factory_new(HKL_DETECTOR_TYPE_0D); - const HklQuaternion q = hkl_geometry_detector_rotation_get(geometry, detector); - HklQuaternion qs_1 = hkl_geometry_sample_rotation_get(geometry, sample); - const HklVector ki = hkl_geometry_ki_get(geometry); - double k = hkl_vector_norm2(&ki); - hkl_quaternion_conjugate(&qs_1); - - /* compute the coordinates in the last axis basis and the - * indexes */ - darray_size(space->items) = 0; - - for(i=0;iitems, item); - } - } - - space_update_axes(space, names, n_pixels, resolutions); - - hkl_detector_free(detector); - hkl_sample_free(sample); -} - -/* the array is pre filled with the pixel coordinates */ -void hkl_binoculars_space_hkl(HklBinocularsSpace *space, - const HklGeometry *geometry, - const HklSample *sample, - const uint16_t *image, - size_t n_pixels, - double weight, - const double *pixels_coordinates, - size_t pixels_coordinates_ndim, - const size_t *pixels_coordinates_dims, - const double *resolutions, - size_t n_resolutions, - const uint8_t *masked) -{ - size_t i, j; - const char * names[] = {"H", "K", "L"}; - - assert(ARRAY_SIZE(names) == darray_size(space->axes)); - assert(ARRAY_SIZE(names) == n_resolutions); - assert(n_pixels == space->max_items); - - const double *h = &pixels_coordinates[0 * n_pixels]; - const double *k = &pixels_coordinates[1 * n_pixels]; - const double *l = &pixels_coordinates[2 * n_pixels]; - - HklDetector *detector = hkl_detector_factory_new(HKL_DETECTOR_TYPE_0D); - const HklQuaternion q_d = hkl_geometry_detector_rotation_get(geometry, detector); - HklQuaternion qs = hkl_geometry_sample_rotation_get(geometry, sample); - const HklVector ki = hkl_geometry_ki_get(geometry); - double K = hkl_vector_norm2(&ki); - HklMatrix RUB; - HklMatrix RUB_1; - hkl_quaternion_to_matrix(&qs, &RUB); - hkl_matrix_times_matrix(&RUB, hkl_sample_UB_get(sample)); - hkl_matrix_inv(&RUB, &RUB_1); - - /* compute the coordinates in the last axis basis and the - * indexes */ - darray_size(space->items) = 0; - for(i=0;iitems, item); - } - } +#define HKL_BINOCULARS_SPACE_Q_IMPL(image_t) \ + HKL_BINOCULARS_SPACE_Q_DECL(image_t) \ + { \ + size_t i, j; \ + const char * names[] = {"qx", "qy", "qz"}; \ + \ + assert(ARRAY_SIZE(names) == darray_size(space->axes)); \ + assert(ARRAY_SIZE(names) == n_resolutions); \ + assert(n_pixels == space->max_items); \ + \ + const double *q_x = &pixels_coordinates[0 * n_pixels]; \ + const double *q_y = &pixels_coordinates[1 * n_pixels]; \ + const double *q_z = &pixels_coordinates[2 * n_pixels]; \ + \ + HklSample *sample = hkl_sample_new("test"); \ + HklDetector *detector = hkl_detector_factory_new(HKL_DETECTOR_TYPE_0D); \ + const HklQuaternion q = hkl_geometry_detector_rotation_get(geometry, detector); \ + const HklVector ki = hkl_geometry_ki_get(geometry); \ + double k = hkl_vector_norm2(&ki); \ + HklQuaternion qs_1 = hkl_geometry_sample_rotation_get(geometry, sample); \ + switch(surf){ \ + case HKL_BINOCULARS_SURFACE_ORIENTATION_VERTICAL: \ + { \ + HklQuaternion q_ub = {{0, -1, 0, 0}}; \ + hkl_quaternion_times_quaternion(&qs_1, &q_ub); \ + break; \ + }; \ + case HKL_BINOCULARS_SURFACE_ORIENTATION_HORIZONTAL: \ + case HKL_BINOCULARS_SURFACE_ORIENTATION_NUM_ORIENTATION:\ + break; \ + }; \ + hkl_quaternion_conjugate(&qs_1); \ + \ + darray_size(space->items) = 0; \ + \ + for(i=0;iitems, item); \ + } \ + } \ + \ + space_update_axes(space, names, n_pixels, resolutions); \ + \ + hkl_detector_free(detector); \ + hkl_sample_free(sample); \ + } - space_update_axes(space, names, n_pixels, resolutions); +HKL_BINOCULARS_SPACE_Q_IMPL(int32_t); +HKL_BINOCULARS_SPACE_Q_IMPL(uint16_t); +HKL_BINOCULARS_SPACE_Q_IMPL(uint32_t); + +#define HKL_BINOCULARS_SPACE_HKL_IMPL(image_t) \ + HKL_BINOCULARS_SPACE_HKL_DECL(image_t) \ + { \ + size_t i, j; \ + const char * names[] = {"H", "K", "L"}; \ + \ + assert(ARRAY_SIZE(names) == darray_size(space->axes)); \ + assert(ARRAY_SIZE(names) == n_resolutions); \ + assert(n_pixels == space->max_items); \ + \ + const double *h = &pixels_coordinates[0 * n_pixels]; \ + const double *k = &pixels_coordinates[1 * n_pixels]; \ + const double *l = &pixels_coordinates[2 * n_pixels]; \ + \ + HklDetector *detector = hkl_detector_factory_new(HKL_DETECTOR_TYPE_0D); \ + const HklQuaternion q_d = hkl_geometry_detector_rotation_get(geometry, detector); \ + HklQuaternion qs = hkl_geometry_sample_rotation_get(geometry, sample); \ + const HklVector ki = hkl_geometry_ki_get(geometry); \ + double K = hkl_vector_norm2(&ki); \ + HklMatrix RUB; \ + HklMatrix RUB_1; \ + hkl_quaternion_to_matrix(&qs, &RUB); \ + hkl_matrix_times_matrix(&RUB, hkl_sample_UB_get(sample)); \ + hkl_matrix_inv(&RUB, &RUB_1); \ + \ + darray_size(space->items) = 0; \ + for(i=0;iitems, item); \ + } \ + } \ + \ + space_update_axes(space, names, n_pixels, resolutions); \ + \ + hkl_detector_free(detector); \ + } - /* hkl_binoculars_space_fprintf(stdout, space); */ - hkl_detector_free(detector); -} +HKL_BINOCULARS_SPACE_HKL_IMPL(int32_t); +HKL_BINOCULARS_SPACE_HKL_IMPL(uint16_t); +HKL_BINOCULARS_SPACE_HKL_IMPL(uint32_t); /* Cube */ @@ -508,6 +510,16 @@ return empty_cube(NULL); } +HklBinocularsCube *hkl_binoculars_cube_new_empty_from_cube(const HklBinocularsCube *cube) +{ + HklBinocularsCube *self = empty_cube(&cube->axes); + + /* allocated the final cube */ + calloc_cube(self); + + return self; +} + HklBinocularsCube *hkl_binoculars_cube_new_from_space(const HklBinocularsSpace *space) { HklBinocularsCube *self = empty_cube(&space->axes); @@ -617,13 +629,25 @@ { HklBinocularsCube *cube; +#ifdef DEBUG + fprintf(stdout, "\nENTERING hkl_binoculars_cube_add_space:\n"); + hkl_binoculars_cube_fprintf(stdout, self); + hkl_binoculars_space_fprintf(stdout, space); +#endif if(is_empty(self)){ +#ifdef DEBUG + fprintf(stdout, "\nCreate a new empty cube"); +#endif + cube = hkl_binoculars_cube_new_from_space(space); switch_content(self, cube); hkl_binoculars_cube_free(cube); }else{ /* check the compatibility of the cube and the space. */ if (does_not_include(&self->axes, &space->axes)){ +#ifdef DEBUG + fprintf(stdout, "\nthe Cube does not contain the space, so create a new cube."); +#endif HklBinocularsCube *cube = empty_cube(&self->axes); merge_axes(&cube->axes, &space->axes); /* circonscript */ @@ -637,4 +661,9 @@ } add_space(self, space); } +#ifdef DEBUG + fprintf(stdout, "\n"); + hkl_binoculars_cube_fprintf(stdout, self); + fprintf(stdout, "\nLEAVING hkl_binoculars_cube_add_space:\n"); +#endif } diff -Nru hkl-5.0.0.2816/binoculars/hkl-binoculars-detectors-2d.c hkl-5.0.0.2875/binoculars/hkl-binoculars-detectors-2d.c --- hkl-5.0.0.2816/binoculars/hkl-binoculars-detectors-2d.c 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/binoculars/hkl-binoculars-detectors-2d.c 2021-12-08 09:14:21.000000000 +0000 @@ -113,7 +113,8 @@ (ImXpadS140, struct imxpad_t), (XpadFlatCorrected, struct square_t), (Eiger1M, struct dectris_t), - (Ufxc, struct square_t) + (Ufxc, struct square_t), + (Merlin, struct square_t) ); struct detector_t { @@ -138,6 +139,8 @@ SHAPE(1030, 1065), DECTRIS(1030, 514, 10, 37, 75e-6)), DETECTOR(Ufxc, SHAPE(257, 256), SQUARE(75e-6)), + DETECTOR(Merlin, + SHAPE(256, 256), SQUARE(55e-6)), }; return detectors[n]; } @@ -378,6 +381,23 @@ } } +static inline void normalize_coordinates(double *arr, const struct shape_t shape) +{ + double *x = x_coordinates(arr, shape); + double *y = y_coordinates(arr, shape); + double *z = z_coordinates(arr, shape); + + for(int i=0; i>shape_size(shape); ++i) + { + double n = sqrt(x[i] * x[i] + y[i] * y[i] + z[i] * z[i]); + if (n > -DBL_MAX){ + x[i] = x[i] / n; + y[i] = y[i] / n; + z[i] = z[i] / n; + } + } +} + void hkl_binoculars_detector_2d_sixs_calibration(HklBinocularsDetectorEnum n, double *arr, int width, int height, @@ -394,6 +414,7 @@ translate_coordinates(arr, shape, dx, dy, dz); rotate_coordinates(arr, shape, detrot, 1, 0, 0); + normalize_coordinates(arr, shape); } /*****************************/ @@ -446,6 +467,10 @@ return coordinates_get_square(&detector.shape, square); } + of(Merlin, square){ + return coordinates_get_square(&detector.shape, + square); + } } } @@ -491,6 +516,9 @@ of(Ufxc){ return no_mask(&detector.shape); } + of(Merlin){ + return no_mask(&detector.shape); + } } } diff -Nru hkl-5.0.0.2816/binoculars/hkl-binoculars.h hkl-5.0.0.2875/binoculars/hkl-binoculars.h --- hkl-5.0.0.2816/binoculars/hkl-binoculars.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/binoculars/hkl-binoculars.h 2021-12-08 09:14:21.000000000 +0000 @@ -38,6 +38,7 @@ HKL_BINOCULARS_DETECTOR_IMXPAD_S70, HKL_BINOCULARS_DETECTOR_DECTRIS_EIGER1M, HKL_BINOCULARS_DETECTOR_UFXC, + HKL_BINOCULARS_DETECTOR_MERLIN, /* Add new your detectors here */ HKL_BINOCULARS_DETECTOR_NUM_DETECTORS, } HklBinocularsDetectorEnum; @@ -107,35 +108,56 @@ darray_HklBinocularsSpaceItem items; }; +typedef enum _HklBinocularsSurfaceOrientationEnum +{ + HKL_BINOCULARS_SURFACE_ORIENTATION_VERTICAL = 0, + HKL_BINOCULARS_SURFACE_ORIENTATION_HORIZONTAL, + /* Add new your detectors here */ + HKL_BINOCULARS_SURFACE_ORIENTATION_NUM_ORIENTATION, +} HklBinocularsSurfaceOrientationEnum; + + HKLAPI extern HklBinocularsSpace *hkl_binoculars_space_new(size_t n_indexes_0, size_t n_axes); HKLAPI extern void hkl_binoculars_space_free(HklBinocularsSpace *self); -HKLAPI extern void hkl_binoculars_space_q(HklBinocularsSpace *self, - const HklGeometry *geometry, - const uint16_t *image, - size_t n_pixels, - double weight, - const double *pixels_coordinates, - size_t pixels_coordinates_ndim, - const size_t *pixels_coordinates_dims, - const double *resolutions, - size_t n_resolutions, - const uint8_t *mask); - -HKLAPI extern void hkl_binoculars_space_hkl(HklBinocularsSpace *self, - const HklGeometry *geometry, - const HklSample *sample, - const uint16_t *image, - size_t n_pixels, - double weight, - const double *pixels_coordinates, - size_t pixels_coordinates_ndim, - const size_t *pixels_coordinates_dims, - const double *resolutions, - size_t n_resolutions, - const uint8_t *mask); +#define HKL_BINOCULARS_SPACE_Q_DECL(image_t) \ + void hkl_binoculars_space_q_ ## image_t (HklBinocularsSpace *space, \ + const HklGeometry *geometry, \ + const image_t *image, \ + size_t n_pixels, \ + double weight, \ + const double *pixels_coordinates, \ + size_t pixels_coordinates_ndim, \ + const size_t *pixels_coordinates_dims, \ + const double *resolutions, \ + size_t n_resolutions, \ + const uint8_t *masked, \ + HklBinocularsSurfaceOrientationEnum surf) + +HKLAPI extern HKL_BINOCULARS_SPACE_Q_DECL(int32_t); +HKLAPI extern HKL_BINOCULARS_SPACE_Q_DECL(uint16_t); +HKLAPI extern HKL_BINOCULARS_SPACE_Q_DECL(uint32_t); + + +#define HKL_BINOCULARS_SPACE_HKL_DECL(image_t)\ + void hkl_binoculars_space_hkl_ ## image_t (HklBinocularsSpace *space,\ + const HklGeometry *geometry, \ + const HklSample *sample, \ + const image_t *image, \ + size_t n_pixels, \ + double weight, \ + const double *pixels_coordinates, \ + size_t pixels_coordinates_ndim, \ + const size_t *pixels_coordinates_dims, \ + const double *resolutions, \ + size_t n_resolutions, \ + const uint8_t *masked) + +HKLAPI extern HKL_BINOCULARS_SPACE_HKL_DECL(int32_t); +HKLAPI extern HKL_BINOCULARS_SPACE_HKL_DECL(uint16_t); +HKLAPI extern HKL_BINOCULARS_SPACE_HKL_DECL(uint32_t); /********/ /* Cube */ @@ -157,6 +179,8 @@ HKLAPI extern HklBinocularsCube *hkl_binoculars_cube_new_empty(void); +HKLAPI extern HklBinocularsCube *hkl_binoculars_cube_new_empty_from_cube(const HklBinocularsCube *src); + HKLAPI extern HklBinocularsCube *hkl_binoculars_cube_new_copy(const HklBinocularsCube *src); HKLAPI extern HklBinocularsCube *hkl_binoculars_cube_new_from_space(const HklBinocularsSpace *space); diff -Nru hkl-5.0.0.2816/contrib/haskell/app/Binoculars.hs hkl-5.0.0.2875/contrib/haskell/app/Binoculars.hs --- hkl-5.0.0.2816/contrib/haskell/app/Binoculars.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/app/Binoculars.hs 2021-12-08 09:14:21.000000000 +0000 @@ -28,7 +28,7 @@ import Hkl.Binoculars -data Options = Process (Maybe FilePath) (Maybe (ConfigRange Int)) +data Options = Process (Maybe FilePath) (Maybe ConfigRange) | CfgNew (Maybe FilePath) | CfgUpdate FilePath deriving Show diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_mars_ruche_rel_flyscan.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_mars_ruche_rel_flyscan.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_mars_ruche_rel_flyscan.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_mars_ruche_rel_flyscan.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,27 @@ +[dispatcher] +# ncores = +destination = scan_{first}-{last}.hdf5 +overwrite = false +[input] +type = mars:flyscan +nexusdir = /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/commissioning_RSM3D_CX2/ +inputtmpl = %04d +inputrange = 125-127 +detector = Merlin +centralpixel = 0,0 +sdd = 1.0 +# detrot = +# attenuation_coefficient = +# maskmatrix = +# a = +# b = +# c = +# alpha = +# beta = +# gamma = +# ux = +# uy = +# uz = +[projection] +type = hkl +resolution = 0.0005 diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,50 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = m1018_32h_Qxyz_labelHKL_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:flyscanuhv2 # refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche/sixs-soleil/com-sixs/2021/Run4/Arthur_UHV/Al2O3_m1018 + +a=6.2831853 +b=6.2831853 +c=6.2831853 +alpha=90 +beta=90 +gamma=90 +ux=-90.92 +uy=-9.93 +uz=22.7 + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 284, 163 # x,y +sdd = 1.154 # sample to detector distance (m) +detrot = 90.0 +#attenuation_coefficient = 1.8 +maskmatrix = /nfs/ruche/sixs-soleil/com-sixs/2021/Run4/Arthur_UHV/mask_nxs00002_20210928_13h21.npy +## choose PROJECTION plus resolution +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.005, 0.005, 0.01 +#resolution = 0.008, 0.008, 0.01 # or just give 1 number for all dimensions +#limits = [-3.53:-1.68,-0.59:0.68,0.98:1.06] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_int32.cfg hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_int32.cfg --- hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_int32.cfg 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_int32.cfg 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,43 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = scan_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:FlyMedH# refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche/sixs-soleil/com-sixs/2021/Run4/20210628_Torrelles/align/ + + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 277, 94 # x,y +sdd = 1.19206 # sample to detector distance (m) +detrot = 90.0 +attenuation_coefficient = 2.273 +maskmatrix = /nfs/ruche/sixs-soleil/com-sixs/2021/Run4/20210628_Torrelles/align1/mask_nxs01559_20211008_18h00.npy +## choose PROJECTION plus resolution +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + + + +resolution = 0.005 +#resolution = 0.008, 0.008, 0.01 # or just give 1 number for all dimensions +#limits = [-3.53:-1.68,-0.59:0.68,0.98:1.06] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_ruche_mars_flyscan.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_ruche_mars_flyscan.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_ruche_mars_flyscan.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_ruche_mars_flyscan.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,26 @@ +[dispatcher] +# ncores = +destination = scan_{first}-{last}.hdf5 +overwrite = false +[input] +type = mars:flyscan +nexusdir = /nfs/ruche/mars-soleil/com-mars/2021_Run5/commissioning_RSM3D_CX2/ +inputrange = 125-127 +detector = Merlin +centralpixel = 0,0 +sdd = 1.0 +# detrot = +# attenuation_coefficient = +# maskmatrix = +# a = +# b = +# c = +# alpha = +# beta = +# gamma = +# ux = +# uy = +# uz = +[projection] +type = hkl +resolution = 0.005 diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_ruche_uhv_big.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_ruche_uhv_big.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_ord05133_ruche_uhv_big.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_ord05133_ruche_uhv_big.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,56 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = GaPd2_Sn4_Qxyz_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:flyscanuhv2 # refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche/sixs-soleil/com-sixs/2021/Run5/20210079_Emilie/GaPd2_210_Sn4 +inputrange=132-185 + +#a=6.2831853 +#b=6.2831853 +#c=6.2831853 +#alpha=90 +#beta=90 +#gamma=90 +#ux=-90.2 +#uy=0.8 +#uz=-4.2 + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 287, 163 # x,y +sdd = 1.162 # sample to detector distance (m) +detrot = 90.0 +attenuation_coefficient = 1.744 +maskmatrix = /nfs/ruche/sixs-soleil/com-sixs/2021/Run5/20210079_Emilie/GaPd2_210_Sn4/binoculars/mask_nxs00134_20211111_17h04.npy +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.02, 0.02, 0.02 +#resolution = 0.002, 0.002, 0.004 # or just give 1 number for all dimensions +#limits = [0.7:1,-1.6:-1.3,:] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh + + +# expected +# qx -5.46 5.46 547 +# qy -5.46 5.46 547 +# qz -0.04 1.46 76 \ No newline at end of file diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_110_m1018_32h_Qxyz_Vhkl.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_110_m1018_32h_Qxyz_Vhkl.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_110_m1018_32h_Qxyz_Vhkl.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_110_m1018_32h_Qxyz_Vhkl.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,50 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = m1018_32h_Qxyz_labelHKL_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:flyscanuhv2 # refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run4/Arthur_UHV/Al2O3_m1018 + +a=6.2831853 +b=6.2831853 +c=6.2831853 +alpha=90 +beta=90 +gamma=90 +ux=-90.92 +uy=-9.93 +uz=22.7 + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 284, 163 # x,y +sdd = 1.154 # sample to detector distance (m) +detrot = 90.0 +#attenuation_coefficient = 1.8 +maskmatrix = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run4/Arthur_UHV/mask_nxs00002_20210928_13h21.npy +## choose PROJECTION plus resolution +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.005, 0.005, 0.01 +#resolution = 0.008, 0.008, 0.01 # or just give 1 number for all dimensions +#limits = [-3.53:-1.68,-0.59:0.68,0.98:1.06] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_flymedv_2.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_flymedv_2.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_flymedv_2.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_flymedv_2.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,41 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = scan_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:FlyMedV # refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run4/20200372_Sanna/SDC_044/ +inputrange=835 + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 276, 96 # x,y +sdd = 1.180 # sample to detector distance (m) +detrot = 90.0 +attenuation_coefficient = 2.43 +maskmatrix = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run4/20200372_Sanna/SDC_017/mask_nxs00037_20211013_14h24.npy +## choose PROJECTION plus resolution +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.002, 0.002, 0.002 +#resolution = 0.008, 0.008, 0.01 # or just give 1 number for all dimensions +#limits = [-3.53:-1.68,-0.59:0.68,0.98:1.06] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_flymedv_3.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_flymedv_3.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_flymedv_3.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_flymedv_3.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,42 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = scan_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:FlyMedV # refers to class Sixs in BINoculars/backends/sixs.py +inputrange 698-736 + +nexusdir = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run5/20210636_Foulquier/ + + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 275, 96 # x,y +sdd = 1.115 # sample to detector distance (m) +detrot = 90.0 +attenuation_coefficient = 2.43 +maskmatrix = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run5/20210636_Foulquier/mask_nxs00045_20211124_09h40.npy +## choose PROJECTION plus resolution +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.03, 0.03, 0.008 +#resolution = 0.0008, 0.0008, 0.001 # or just give 1 number for all dimensions +#limits = [-3.53:-1.68,-0.59:0.68,0.98:1.06] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_uhv.ini hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_uhv.ini --- hkl-5.0.0.2816/contrib/haskell/data/test/config_sixs_ruche_uhv.ini 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/config_sixs_ruche_uhv.ini 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,56 @@ +### the DISPATCHER is responsible for job management +[dispatcher] +type = local # run local +#type = singlecore # run local +ncores = 16 # optionally, specify number of cores (autodetect by default) + +# specificy destination file using scan numbers +destination = GaPd2_Sn4_Qxyz_{first}-{last}.hdf5 +overwrite = false + +### choose an appropriate INPUT class and specify custom options +[input]## +type = sixs:flyscanuhv2 # refers to class Sixs in BINoculars/backends/sixs.py + +nexusdir = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run5/20210079_Emilie/GaPd2_210_Sn4 +inputrange=132-185 + +#a=6.2831853 +#b=6.2831853 +#c=6.2831853 +#alpha=90 +#beta=90 +#gamma=90 +#ux=-90.2 +#uy=0.8 +#uz=-4.2 + +## approximate number of images per job, only useful when running on the oar cluster +target_weight = 100 + +# technical data for this particular input class +centralpixel = 287, 163 # x,y +sdd = 1.162 # sample to detector distance (m) +detrot = 90.0 +attenuation_coefficient = 1.744 +maskmatrix = /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run5/20210079_Emilie/GaPd2_210_Sn4/binoculars/mask_nxs00134_20211111_17h04.npy +## projections: realspace, pixels, hklprojection, hkprojection, qxqyqzprojection, qparqperprojection +[projection] + +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:hklprojection # refers to HKProjection in BINoculars/backends/sixs.py +type = sixs:qxqyqzprojection # refers to HKProjection in BINoculars/backends/sixs.py +#type = sixs:qparqperprojection # refers to HKProjection in BINoculars/backends/sixs.py + +resolution = 0.02, 0.02, 0.02 +#resolution = 0.002, 0.002, 0.004 # or just give 1 number for all dimensions +#limits = [0.7:1,-1.6:-1.3,:] + +#omega_offset = 0 +#source /usr/local/applications/diffractions/binoculars/v0.0.1/env.sh + + +# expected +# qx -5.46 5.46 547 +# qy -5.46 5.46 547 +# qz -0.04 1.46 76 \ No newline at end of file diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/Makefile hkl-5.0.0.2875/contrib/haskell/data/test/Makefile --- hkl-5.0.0.2816/contrib/haskell/data/test/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/Makefile 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,49 @@ +mars: +# cd ../..; /usr/bin/time -v cabal run binoculars-ng -- +RTS -N5 -RTS process data/test/config_mars_ruche_rel_flyscan.ini + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 173 + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 153 + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 132 + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 105 + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 78 + cd ../..; cabal run binoculars-ng -- process /nfs/ruche-mars/mars-soleil/com-mars/2021_Run5/20191020/binoculars/config_qxqyqz.ini 75 + +ord05133: +# cd ../..; cabal run binoculars-ng -- process /nfs/ruche/sixs-soleil/com-sixs/2021/Run4/20210628_Torrelles/binoculars/config2.txt 1303 +# cd ../..; /usr/bin/time -v cabal run binoculars-ng -- process data/test/config_ord05133_int32.cfg 1303-1312 +# valgrind --tool=massif /home/picca/src/repo.or.cz/hkl/contrib/haskell/dist-newstyle/build/x86_64-linux/ghc-8.8.4/hkl-0.1.0.0/x/binoculars-ng/build/binoculars-ng/binoculars-ng process config_ord05133_flymedh.ini 1303-1312 +# valgrind --tool=helgrind /home/picca/src/repo.or.cz/hkl/contrib/haskell/dist-newstyle/build/x86_64-linux/ghc-8.8.4/hkl-0.1.0.0/x/binoculars-ng/build/binoculars-ng/binoculars-ng process config_ord05133_int32.cfg 1303-1306 +# cd ../..; cabal run binoculars-ng -- process /nfs/ruche-sixs/sixs-soleil/com-sixs/2021/Run4/Arthur_UHV/binoculars/config210_m1018_32h_Qxyz_Vhkl.txt 134-160 +# cd ../..; cabal run binoculars-ng -- process data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini 272-285,289-316 +# cd ../..; cabal run binoculars-ng -- process data/test/config_ord05133_110_m1018_32h_Qxyz_Vhkl.ini 272-273 +# /usr/bin/time /tmp/binoculars-ng +RTS -N4 -- process ~/src/repo.or.cz/hkl/contrib/haskell/data/test/config_ord05133_flymedh.ini 1303-1312 +# /usr/bin/time /tmp/binoculars-ng-prof +RTS -N4 -- process ~/src/repo.or.cz/hkl/contrib/haskell/data/test/config_ord05133_flymedh.ini 1303-1312 +# cd ../..; cabal run binoculars-ng -- process data/test/config_ord05133_flymedh.ini 1303-1312 +# cd ../..; /usr/bin/time -v cabal run binoculars-ng -- process data/test/config_ord05133_ruche_mars_flyscan.ini +# cd ../..; /usr/bin/time -v cabal run binoculars-ng -- +RTS -N -RTS process data/test/config_ord05133_ruche_uhv_big.in + cd ../..; /usr/bin/time -v cabal run binoculars-ng -- +RTS -N -RTS process data/test/config_ord05133_ruche_flymedv_3.ini + +sixs: + #cd ../..; gdb --args ~picca/src/repo.or.cz/hkl/contrib/haskell/dist-newstyle/build/x86_64-linux/ghc-8.8.4/hkl-0.1.0.0/x/binoculars-ng/build/binoculars-ng/binoculars-ng process data/test/config_sixs_ruche_uhv.ini + cd ../..; /usr/bin/time -v cabal run binoculars-ng -- +RTS -N4 -RTS process data/test/config_sixs_ruche_uhv.ini + #cd ../..; /usr/bin/time -v cabal run binoculars-ng -- +RTS -N4 -RTS process data/test/config_sixs_ruche_flymedv_2.ini + +ssd: +# cd ../..; /usr/bin/time -v cabal run binoculars-ng -- process data/test/config_ssd_cristal.ini + cd /home/picca/tests-datas/binoculars/sixs/int32/ && ~picca/src/repo.or.cz/hkl/contrib/haskell/dist-newstyle/build/x86_64-linux/ghc-8.8.4/hkl-0.1.0.0/x/binoculars-ng/build/binoculars-ng/binoculars-ng process config.cfg + +#binoculars process config_m1018_32h_Qxyz.txt 173-187- 190-195 +#binoculars process config_m1018_32h_Qxyz.txt 217-224 +#binoculars process config_m1018_32h_HKL.txt 103-132 +#binoculars process config_m1018_32h_HKL.txt 173-187 190-195 +#binoculars process config_m1018_32h_HKL.txt 228-257 +#binoculars process config110tige1_m1018_32h_Qxyz_Vhkl.txt 173-187 190-195 +#binoculars process config110tige2_m1018_32h_Qxyz_Vhkl.txt 40-53 55-68 71-100 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 103-132 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 134 137 140 143 146 149 152 155 158 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 259 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 262-269 +#binoculars process config_m1018_32h_Qxyz_Vhkl.txt 105-106 129 131 +#binoculars process config_m1018_32h_Qxyz.txt 105-106 129 131 +#binoculars process configV2_m1018_32h_Qxyz_Vhkl.txt 45-48 62-63 67-68 +#binoculars process config_m1018_32h_HKL.txt 33-36 +.PHONI: mars ord05133 ssd sixs diff -Nru hkl-5.0.0.2816/contrib/haskell/data/test/test.sh hkl-5.0.0.2875/contrib/haskell/data/test/test.sh --- hkl-5.0.0.2816/contrib/haskell/data/test/test.sh 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/data/test/test.sh 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,16 @@ +binoculars-ng process config_ord05133_110_m1018_32h_Qxyz_Vhkl.txt 272-285 289-316 +#binoculars process config_m1018_32h_Qxyz.txt 173-187- 190-195 +#binoculars process config_m1018_32h_Qxyz.txt 217-224 +#binoculars process config_m1018_32h_HKL.txt 103-132 +#binoculars process config_m1018_32h_HKL.txt 173-187 190-195 +#binoculars process config_m1018_32h_HKL.txt 228-257 +#binoculars process config110tige1_m1018_32h_Qxyz_Vhkl.txt 173-187 190-195 +#binoculars process config110tige2_m1018_32h_Qxyz_Vhkl.txt 40-53 55-68 71-100 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 103-132 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 134 137 140 143 146 149 152 155 158 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 259 +#binoculars process config210_m1018_32h_Qxyz_Vhkl.txt 262-269 +#binoculars process config_m1018_32h_Qxyz_Vhkl.txt 105-106 129 131 +#binoculars process config_m1018_32h_Qxyz.txt 105-106 129 131 +#binoculars process configV2_m1018_32h_Qxyz_Vhkl.txt 45-48 62-63 67-68 +#binoculars process config_m1018_32h_HKL.txt 33-36 diff -Nru hkl-5.0.0.2816/contrib/haskell/debian/control hkl-5.0.0.2875/contrib/haskell/debian/control --- hkl-5.0.0.2816/contrib/haskell/debian/control 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/debian/control 2021-12-08 09:14:21.000000000 +0000 @@ -7,20 +7,10 @@ cdbs, ghc, ghc-prof, - libghc-glob-dev (>= 0.7.5), - libghc-glob-prof (>= 0.7.5), - libghc-juicypixels-dev (>= 3.1.7), - libghc-juicypixels-prof (>= 3.1.7), - libghc-aeson-dev (>= 0.8), - libghc-aeson-prof (>= 0.8), libghc-async-dev, libghc-async-prof, libghc-attoparsec-dev, libghc-attoparsec-prof, - libghc-bytestring-to-vector-dev, - libghc-bytestring-to-vector-prof, - libghc-conduit-dev, - libghc-conduit-prof, libghc-config-ini-dev, libghc-config-ini-prof, libghc-dimensional-dev (>= 0.10), @@ -31,8 +21,6 @@ libghc-exceptions-prof, libghc-extra-dev, libghc-extra-prof, - libghc-fgl-dev, - libghc-fgl-prof, libghc-hdf5-dev, libghc-hdf5-prof, libghc-hmatrix-dev (>= 0.17), @@ -41,20 +29,10 @@ libghc-hmatrix-gsl-prof (>= 0.17), libghc-lens-dev, libghc-lens-prof, - libghc-lifted-async-dev, - libghc-lifted-async-prof, - libghc-lifted-base-dev, - libghc-lifted-base-prof, - libghc-mmorph-dev (>= 1.0.3), - libghc-mmorph-prof (>= 1.0.3), - libghc-monad-control-dev, - libghc-monad-control-prof, libghc-monad-logger-dev, libghc-monad-logger-prof, libghc-monad-loops-dev (>= 0.4.2), libghc-monad-loops-prof (>= 0.4.2), - libghc-monads-tf-dev, - libghc-monads-tf-prof, libghc-path-dev, libghc-path-prof, libghc-path-io-dev, @@ -63,16 +41,10 @@ libghc-pipes-prof (>= 4.1.2), libghc-pipes-safe-dev (>= 2.2.0), libghc-pipes-safe-prof (>= 2.2.0), - libghc-puremd5-dev (>= 2.0), - libghc-puremd5-prof (>= 2.0), libghc-repa-dev, libghc-repa-prof, - libghc-safe-dev, - libghc-safe-prof, libghc-terminal-progress-bar-dev, libghc-terminal-progress-bar-prof, - libghc-transformers-base-dev, - libghc-transformers-base-prof, libghc-vector-dev (>= 0.10.0.1), libghc-vector-prof (>= 0.10.0.1), libhkl-dev, @@ -81,39 +53,25 @@ libghc-hspec-dev, libghc-hspec-prof, Build-Depends-Indep: ghc-doc, - libghc-glob-doc, - libghc-juicypixels-doc, - libghc-aeson-doc, libghc-async-doc, libghc-attoparsec-doc, - libghc-bytestring-to-vector-doc, - libghc-conduit-doc, libghc-config-ini-doc, libghc-dimensional-doc, libghc-errors-doc, libghc-exceptions-doc, libghc-extra-doc, - libghc-fgl-doc, libghc-hdf5-doc, libghc-hmatrix-doc, libghc-hmatrix-gsl-doc, libghc-lens-doc, - libghc-lifted-async-doc, - libghc-lifted-base-doc, - libghc-mmorph-doc, - libghc-monad-control-doc, libghc-monad-logger-doc, libghc-monad-loops-doc, - libghc-monads-tf-doc, libghc-path-doc, libghc-path-io-doc, libghc-pipes-doc, libghc-pipes-safe-doc, - libghc-puremd5-doc, libghc-repa-doc, - libghc-safe-doc, libghc-terminal-progress-bar-doc, - libghc-transformers-base-doc, libghc-vector-doc, Standards-Version: 4.5.0 X-Description: WARNING: No synopsis available for package hkl-0.1.0.0 diff -Nru hkl-5.0.0.2816/contrib/haskell/hkl.cabal hkl-5.0.0.2875/contrib/haskell/hkl.cabal --- hkl-5.0.0.2816/contrib/haskell/hkl.cabal 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/hkl.cabal 2021-12-08 09:14:21.000000000 +0000 @@ -94,6 +94,7 @@ ghc-options: -ddump-to-file ghc-options: -ddump-simpl ghc-options: -ddump-stg + ghc-options: "-with-rtsopts=-N" if flag(useHklDev) pkgconfig-depends: gobject-2.0 @@ -101,11 +102,12 @@ ghc-options: "-optl-Wl,--whole-archive,../../hkl/.libs/libhkl.a,--no-whole-archive" ghc-options: "-optl-Wl,--whole-archive,../../binoculars/libhkl-binoculars.a,--no-whole-archive" + ghc-prof-options: -fprof-auto "-with-rtsopts=-N -p -s -h -i0.1" + library exposed-modules: Hkl , Hkl.Binoculars , Hkl.Binoculars.Common - -- , Hkl.Binoculars.Conduit , Hkl.Binoculars.Config , Hkl.Binoculars.Pipes , Hkl.Binoculars.Projections @@ -120,51 +122,17 @@ , Hkl.C.GeometryList , Hkl.C.Lattice , Hkl.C.Sample - , Hkl.Conduit - , Hkl.DataSource , Hkl.Detector - , Hkl.Edf , Hkl.Engine - , Hkl.Flat , Hkl.H5 + , Hkl.Image , Hkl.Lattice , Hkl.MyMatrix - , Hkl.Nxs , Hkl.Orphan - , Hkl.Projects - , Hkl.Projects.D2AM - , Hkl.Projects.D2AM.XRD - , Hkl.Projects.Diffabs - , Hkl.Projects.Diffabs.Charlier - , Hkl.Projects.Diffabs.Hamon - , Hkl.Projects.Diffabs.Hercules - , Hkl.Projects.Diffabs.IRDRx - , Hkl.Projects.Diffabs.Laure - , Hkl.Projects.Diffabs.Melle - , Hkl.Projects.Diffabs.Martinetto - , Hkl.Projects.Mars - , Hkl.Projects.Mars.Romeden - , Hkl.Projects.Mars.Schlegel , Hkl.Pipes - , Hkl.PyFAI - , Hkl.PyFAI.AzimuthalIntegrator - , Hkl.PyFAI.Calib - , Hkl.PyFAI.Calibrant - , Hkl.PyFAI.Detector - , Hkl.PyFAI.Poni - , Hkl.PyFAI.PoniExt - , Hkl.PyFAI.Npt - , Hkl.Python - , Hkl.Script - , Hkl.Tiff , Hkl.Types , Hkl.Types.Parameter , Hkl.Utils - , Hkl.Xrd - , Hkl.Xrd.Calibration - , Hkl.Xrd.Mesh - , Hkl.Xrd.OneD - , Hkl.Xrd.ZeroD other-modules: Paths_hkl other-extensions: CPP , ForeignFunctionInterface @@ -173,50 +141,32 @@ , FlexibleInstances , FlexibleContexts , RecordWildCards - build-depends: aeson >=0.8 - , async + build-depends: async , attoparsec , base >= 4.6 , bytestring >= 0.10.0.2 - , bytestring-to-vector - , conduit , config-ini - , containers >= 0.5 && < 0.7 , dimensional >= 0.10 , directory >= 1.3.0 , errors , exceptions , extra , filepath >= 1.3.0 - , fgl - , Glob >= 0.7.5 , hdf5 , hmatrix >= 0.17 , hmatrix-gsl >= 0.17 - , JuicyPixels >= 3.1.7 , lens - , lifted-async - , lifted-base - , mmorph >= 1.0.3 - , monad-control , monad-logger , monad-loops >= 0.4.2 - , monads-tf + , mtl , path , path-io , pipes >= 4.1.2 , pipes-safe >= 2.2.0 - , process >= 1.1 , repa - , pureMD5 >= 2.0 - , stm - , safe - , template-haskell >=2.8 , terminal-progress-bar , text , transformers >= 0.3 - , transformers-base - , unix >= 2.6.0.0 , vector >= 0.10.0.1 hs-source-dirs: src default-language: Haskell2010 @@ -244,15 +194,25 @@ ghc-options: -ddump-stg test-suite hkl-test - type: exitcode-stdio-1.0 - main-is: Spec.hs + default-language: Haskell2010 hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N -K1k + build-depends: attoparsec build-depends: base >= 4.6 - , config-ini - , hkl - , hspec - , text + build-depends: config-ini + build-depends: hkl + build-depends: hspec + build-depends: text + + if flag(useHklDev) + pkgconfig-depends: gobject-2.0 + ghc-options: -pgml gcc "-optl-Wl,--allow-multiple-definition" + ghc-options: "-optl-Wl,--whole-archive,../../hkl/.libs/libhkl.a,--no-whole-archive" + ghc-options: "-optl-Wl,--whole-archive,../../binoculars/libhkl-binoculars.a,--no-whole-archive" + + ghc-options: -threaded + ghc-options: -rtsopts=all + ghc-options: -with-rtsopts=-K1k + main-is: Spec.hs other-modules: BinocularsSpec - , Paths_hkl - default-language: Haskell2010 + other-modules: Paths_hkl + type: exitcode-stdio-1.0 diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Common.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Common.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Common.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Common.hs 2021-12-08 09:14:21.000000000 +0000 @@ -14,12 +14,12 @@ -} module Hkl.Binoculars.Common ( Chunk(..) - , InputFn(..) , DataFrameSpace(..) + , InputFn(..) , addSpace , chunk + , clength , mkCube' - , mkJobs' , toList , withCubeAccumulator ) where @@ -27,7 +27,6 @@ import Control.Exception (bracket) import Data.Array.Repa (Shape) import Data.IORef (IORef, newIORef, readIORef) -import Data.Word (Word16) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Marshal.Array (withArrayLen) import Foreign.Ptr (Ptr) @@ -36,11 +35,16 @@ import Text.Printf (printf) import Hkl.C.Binoculars +import Hkl.Image import Hkl.Orphan () data Chunk n a = Chunk !a !n !n deriving instance (Show n, Show a) => Show (Chunk n a) +clength :: Num n => Chunk n a -> n +clength (Chunk _ l h) = h - l + 1 +{-# SPECIALIZE clength :: Chunk Int FilePath -> Int #-} + cweight :: Num n => Chunk n a -> n cweight (Chunk _ l h) = h - l @@ -55,7 +59,7 @@ go tgt gap [x] = golast tgt gap x go tgt gap ~(x:xs) = let gap' = gap - cweight x - in if | gap' > 0 -> cons1 x $ go tgt gap' xs + in if | gap' > 0 -> cons1 x $ go tgt gap' xs | gap' == 0 -> [x] : go tgt tgt xs | (x1, x2) <- csplit x gap -> [x1] : go tgt tgt (x2 : xs) @@ -72,12 +76,9 @@ toList (InputRange tmpl f t) = [printf tmpl i | i <- [f..t]] toList (InputList fs) = map fromAbsFile fs -mkJobs' :: Int -> [FilePath] -> [Int] -> [[Chunk Int FilePath]] -mkJobs' n fns ts = chunk n [Chunk f 0 t | (f, t) <- zip fns ts] - -- DataFrameSpace -data DataFrameSpace sh = DataFrameSpace (ForeignPtr Word16) (Space sh) Double +data DataFrameSpace sh = DataFrameSpace Image (Space sh) Double deriving Show -- Create the Cube @@ -97,7 +98,7 @@ peek =<< {-# SCC "hkl_binoculars_cube_new'" #-} hkl_binoculars_cube_new' (toEnum nSpaces') spaces' {-# INLINE addSpace #-} -addSpace :: Shape sh => DataFrameSpace sh -> (Cube' sh) -> IO (ForeignPtr (Cube' sh)) +addSpace :: Shape sh => DataFrameSpace sh -> Cube' sh -> IO (ForeignPtr (Cube' sh)) addSpace df EmptyCube' = do (Cube' fp) <- mkCube' [df] return fp @@ -114,7 +115,13 @@ | InputList [Path Abs File] deriving Show -withCubeAccumulator :: Shape sh => (IORef (Cube' sh) -> IO ()) -> IO (Cube' sh) -withCubeAccumulator f = bracket (newIORef =<< peek =<< hkl_binoculars_cube_new_empty') pure (\r -> f r >> readIORef r) +withCubeAccumulator :: Shape sh => Cube' sh -> (IORef (Cube' sh) -> IO ()) -> IO (Cube' sh) +withCubeAccumulator c f = bracket + (newIORef =<< peek =<< case c of + EmptyCube' -> hkl_binoculars_cube_new_empty' + (Cube' fp) -> withForeignPtr fp $ \p -> hkl_binoculars_cube_new_empty_from_cube' p + ) + pure + (\r -> f r >> readIORef r) -- Projections diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Config.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Config.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Config.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Config.hs 2021-12-08 09:14:21.000000000 +0000 @@ -19,8 +19,10 @@ ( BinocularsConfig(..) , ConfigRange(..) , DestinationTmpl(..) + , InputRange(..) , InputType(..) , ProjectionType(..) + , SurfaceOrientation(..) , configRangeP , combineWithCmdLineArgs , destination' @@ -35,6 +37,7 @@ ) where +import Control.Applicative (many, (<|>)) import Control.Lens (makeLenses, (^.)) import Control.Monad.Catch (Exception, MonadThrow, throwM) @@ -42,11 +45,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger) import Data.Array.Repa.Index (DIM2) -#if MIN_VERSION_extra(1, 6, 14) -import Data.Either.Extra (mapLeft, mapRight) -#endif import Data.Attoparsec.Text (Parser, char, decimal, - sepBy) + parseOnly, satisfy, sepBy) +import Data.Either.Extra (mapLeft, mapRight) import Data.Ini.Config.Bidir (FieldValue (..), IniSpec, bool, field, getIniValue, ini, listWithSeparator, @@ -58,7 +59,8 @@ import Data.Text (Text, breakOn, drop, findIndex, length, lines, pack, replace, strip, take, - takeWhile, unlines, unpack) + takeWhile, toLower, unlines, + unpack, unwords) import Data.Text.IO (putStr, readFile) import Data.Typeable (Typeable) import GHC.Exts (IsList) @@ -74,37 +76,16 @@ import Prelude hiding (drop, length, lines, putStr, readFile, take, - takeWhile, unlines) + takeWhile, unlines, unwords) import Hkl.Detector import Hkl.Types import Paths_hkl -#if MIN_VERSION_extra(1, 6, 14) -#else --- for buster - --- The 'mapLeft' function takes a function and applies it to an Either value --- iff the value takes the form @'Left' _@. --- --- > mapLeft show (Left 1) == Left "1" --- > mapLeft show (Right True) == Right True -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f = either (Left . f) Right - --- The 'mapRight' function takes a function and applies it to an Either value --- iff the value takes the form @'Right' _@. --- --- > mapRight show (Left 1) == Left 1 --- > mapRight show (Right True) == Right "True" -mapRight :: (b -> c) -> Either a b -> Either a c -mapRight = fmap -#endif - data HklBinocularsConfigException = NoFilesInTheGivenDirectory (Path Abs Dir) | NoDataFilesInTheGivenDirectory (Path Abs Dir) - | NoFilesInRangeInTheGivenDirectory (Path Abs Dir) (ConfigRange Int) + | NoFilesInRangeInTheGivenDirectory (Path Abs Dir) ConfigRange | ResolutionNotCompatibleWithProjectionNbOfCoordinates [Double] Int deriving (Show) instance Exception HklBinocularsConfigException @@ -113,7 +94,11 @@ DestinationTmpl { unDestinationTmpl :: Text } deriving (Eq, Show) +newtype InputTmpl = InputTmpl { unInputTmpl :: Text } + deriving (Eq, Show) + data InputType = CristalK6C + | MarsFlyscan | SixsFlyMedH | SixsFlyMedV | SixsFlyMedVEiger @@ -127,9 +112,25 @@ | SixsSbsMedVFixDetector deriving (Eq, Show) -newtype ConfigRange a = ConfigRange [a] +data InputRange = InputRangeSingle Int + | InputRangeFromTo Int Int + deriving (Eq, Show) + +newtype ConfigRange = ConfigRange [InputRange] deriving (Eq, Show, IsList) +data SurfaceOrientation = SurfaceOrientationVertical + | SurfaceOrientationHorizontal + deriving (Eq, Show) + +instance Enum SurfaceOrientation where + fromEnum SurfaceOrientationVertical = 0 + fromEnum SurfaceOrientationHorizontal = 1 + + toEnum 0 = SurfaceOrientationVertical + toEnum 1 = SurfaceOrientationHorizontal + toEnum unmatched = error ("Key.toEnum: Cannot match " ++ show unmatched) + data ProjectionType = QxQyQzProjection | HklProjection deriving (Eq, Show) @@ -140,12 +141,14 @@ , _binocularsDispatcherOverwrite :: Bool , _binocularsInputItype :: InputType , _binocularsInputNexusdir :: Maybe (Path Abs Dir) - , _binocularsInputInputRange :: Maybe (ConfigRange Int) + , _binocularsInputTmpl :: Maybe InputTmpl + , _binocularsInputInputRange :: Maybe ConfigRange , _binocularsInputDetector :: Maybe (Detector Hkl DIM2) , _binocularsInputCentralpixel :: (Int, Int) , _binocularsInputSdd :: Length Double , _binocularsInputDetrot :: Maybe (Angle Double) , _binocularsInputAttenuationCoefficient :: Maybe Double + , _binocularsInputSurfaceOrientation :: Maybe SurfaceOrientation , _binocularsInputMaskmatrix :: Maybe Text , _binocularsInputA :: Maybe (Length Double) , _binocularsInputB :: Maybe (Length Double) @@ -156,6 +159,7 @@ , _binocularsInputUx :: Maybe (Angle Double) , _binocularsInputUy :: Maybe (Angle Double) , _binocularsInputUz :: Maybe (Angle Double) + , _binocularsInputWavelength :: Maybe (Length Double) , _binocularsProjectionPtype :: ProjectionType , _binocularsProjectionResolution :: [Double] } deriving (Eq, Show) @@ -169,12 +173,14 @@ , _binocularsDispatcherOverwrite = False , _binocularsInputItype = SixsFlyScanUhv , _binocularsInputNexusdir = Nothing + , _binocularsInputTmpl = Nothing , _binocularsInputInputRange = Nothing , _binocularsInputDetector = Nothing , _binocularsInputCentralpixel = (0, 0) , _binocularsInputSdd = 1 *~ meter , _binocularsInputDetrot = Nothing , _binocularsInputAttenuationCoefficient = Nothing + , _binocularsInputSurfaceOrientation = Just SurfaceOrientationVertical , _binocularsInputMaskmatrix = Nothing , _binocularsInputA = Nothing , _binocularsInputB = Nothing @@ -185,6 +191,7 @@ , _binocularsInputUx = Nothing , _binocularsInputUy = Nothing , _binocularsInputUz = Nothing + , _binocularsInputWavelength = Nothing , _binocularsProjectionPtype = QxQyQzProjection , _binocularsProjectionResolution = [0.01, 0.01, 0.01] } @@ -207,6 +214,15 @@ emit :: DestinationTmpl -> Text emit (DestinationTmpl t) = t +inputTmpl :: FieldValue InputTmpl +inputTmpl = FieldValue { fvParse = parse, fvEmit = emit } + where + parse :: Text -> Either String InputTmpl + parse = Right . InputTmpl . uncomment + + emit :: InputTmpl -> Text + emit (InputTmpl t) = t + binocularsConfigSpec :: IniSpec BinocularsConfig () binocularsConfigSpec = do section "dispatcher" $ do @@ -216,12 +232,14 @@ section "input" $ do binocularsInputItype .= field "type" inputType binocularsInputNexusdir .=? field "nexusdir" pathAbsDir + binocularsInputTmpl .=? field "inputtmpl" inputTmpl binocularsInputInputRange .=? field "inputrange" configRange binocularsInputDetector .=? field "detector" detector binocularsInputCentralpixel .= field "centralpixel" centralPixel binocularsInputSdd .= field "sdd" (numberUnit meter) binocularsInputDetrot .=? field "detrot" (numberUnit degree) binocularsInputAttenuationCoefficient .=? field "attenuation_coefficient" number' + binocularsInputSurfaceOrientation .=? field "surface_orientation" surfaceOrientation binocularsInputMaskmatrix .=? field "maskmatrix" text binocularsInputA .=? field "a" (numberUnit angstrom) binocularsInputB .=? field "b" (numberUnit angstrom) @@ -232,6 +250,7 @@ binocularsInputUx .=? field "ux" (numberUnit degree) binocularsInputUy .=? field "uy" (numberUnit degree) binocularsInputUz .=? field "uz" (numberUnit degree) + binocularsInputWavelength .=? field "wavelength" (numberUnit angstrom) section "projection" $ do binocularsProjectionPtype .= field "type" projectionType binocularsProjectionResolution .= field "resolution" (listWithSeparator "," number') @@ -241,7 +260,7 @@ where parse :: Text -> Either String InputType parse t - | t == emit SixsFlyMedH = Right SixsFlyMedH + | toLower t == emit SixsFlyMedH = Right SixsFlyMedH | t == emit SixsFlyMedV = Right SixsFlyMedV | t == emit SixsFlyMedVEiger = Right SixsFlyMedVEiger | t == emit SixsFlyMedVS70 = Right SixsFlyMedVS70 @@ -253,6 +272,7 @@ | t == emit SixsSbsMedV = Right SixsSbsMedV | t == emit SixsSbsMedVFixDetector = Right SixsSbsMedVFixDetector | t == emit CristalK6C = Right CristalK6C + | t == emit MarsFlyscan = Right MarsFlyscan | otherwise = Left ("Unsupported \"" ++ unpack t ++ "\" input format") emit :: InputType -> Text @@ -268,6 +288,21 @@ emit SixsSbsMedV = "sixs:sbsmedv" emit SixsSbsMedVFixDetector = "sixs:sbsmedvfixdetector" emit CristalK6C = "cristal:k6c" + emit MarsFlyscan = "mars:flyscan" + +surfaceOrientation :: FieldValue SurfaceOrientation +surfaceOrientation = FieldValue { fvParse = parse . strip . uncomment, fvEmit = emit } + where + parse :: Text -> Either String SurfaceOrientation + parse t + | t == emit SurfaceOrientationVertical = Right SurfaceOrientationVertical + | t == emit SurfaceOrientationHorizontal = Right SurfaceOrientationHorizontal + | otherwise = Left ("Unsupported " ++ unpack t ++ " surface orientation (vertical or horizontal)") + + emit :: SurfaceOrientation -> Text + emit SurfaceOrientationVertical = "vertical" + emit SurfaceOrientationHorizontal = "horizontal" + projectionType :: FieldValue ProjectionType projectionType = FieldValue { fvParse = parse . strip . uncomment, fvEmit = emit } @@ -290,11 +325,36 @@ , fvEmit = pack . fromAbsDir } -configRange :: (Num a, Read a, Show a, Typeable a) => FieldValue (ConfigRange a) -configRange = listWithSeparator "-" number' -configRangeP :: Integral a => Parser (ConfigRange a) -configRangeP = ConfigRange <$> (decimal `sepBy` char '-') +inputRangeP :: Parser InputRange +inputRangeP = inputRangeFromToP <|> inputRangeP' + where + inputRangeFromToP :: Parser InputRange + inputRangeFromToP = InputRangeFromTo + <$> decimal <* char '-' + <*> decimal + + inputRangeP' :: Parser InputRange + inputRangeP' = InputRangeSingle <$> decimal + +configRange :: FieldValue ConfigRange +configRange = FieldValue {fvParse = parse, fvEmit = emit } + where + parse :: Text -> Either String ConfigRange + parse = parseOnly configRangeP + + emit :: ConfigRange -> Text + emit (ConfigRange is) = unwords $ map (pack . showInputRange) is + + showInputRange :: InputRange -> String + showInputRange (InputRangeSingle f) = printf "%d" f + showInputRange (InputRangeFromTo f t) = printf "%d-%d" f t + +configRangeP :: Parser ConfigRange +configRangeP = ConfigRange <$> (inputRangeP `sepBy` many (satisfy isSep)) + where + isSep :: Char -> Bool + isSep c = c == ' ' || c == ',' detector :: FieldValue (Detector Hkl DIM2) detector = FieldValue @@ -341,44 +401,56 @@ then throwM (NoDataFilesInTheGivenDirectory dir) else case c ^. binocularsInputInputRange of Just r -> do - let fs'' = filter (isInConfigRange r) fs' + let tmpl = maybe "%05d" (unpack . unInputTmpl) (c ^. binocularsInputTmpl) + let fs'' = filter (isInConfigRange tmpl r) fs' if null fs'' then throwM (NoFilesInRangeInTheGivenDirectory dir r) else return fs'' Nothing -> return fs' where isHdf5 :: Path Abs File -> Bool --- debian bulleyes (signature changed ???) -#if MIN_VERSION_path(0, 7, 0) - isHdf5 p = case ((fileExtension p) :: Maybe [Char]) of + isHdf5 p = case (fileExtension p :: Maybe [Char]) of Nothing -> False (Just ext) -> ext `elem` [".h5", ".nxs"] --- debian buster -#else - isHdf5 p = case (fileExtension p) of - "" -> False - ext -> ext `elem` [".h5", ".nxs"] -#endif - matchIndex :: Path Abs File -> Int -> Bool - matchIndex p n = printf "%04d" n `isInfixOf` toFilePath p - - isInConfigRange :: ConfigRange Int -> Path Abs File -> Bool - isInConfigRange (ConfigRange []) _ = True - isInConfigRange (ConfigRange [from]) p = any (matchIndex p) [from] - isInConfigRange (ConfigRange [from, to]) p = any (matchIndex p) [from..to] - isInConfigRange (ConfigRange (from:to:_)) p = any (matchIndex p) [from..to] + + matchIndex :: Path Abs File -> String -> Int -> Bool + matchIndex p tmpl n = printf tmpl n `isInfixOf` toFilePath p + + isInInputRange :: Path Abs File -> String -> InputRange -> Bool + isInInputRange p tmpl (InputRangeSingle i) = any (matchIndex p tmpl) [i] + isInInputRange p tmpl (InputRangeFromTo from to) = any (matchIndex p tmpl) [from..to] + + isInConfigRange :: String -> ConfigRange -> Path Abs File -> Bool + isInConfigRange _ (ConfigRange []) _ = True + isInConfigRange tmpl (ConfigRange rs) p = any (isInInputRange p tmpl) rs + replace' :: Int -> Int -> DestinationTmpl -> FilePath replace' f t = unpack . replace "{last}" (pack . show $ t) . replace "{first}" (pack . show $ f) . unDestinationTmpl -destination' :: ConfigRange Int -> DestinationTmpl -> FilePath -destination' (ConfigRange []) = replace' 0 0 -destination' (ConfigRange [from]) = replace' from from -destination' (ConfigRange [from, to]) = replace' from to -destination' (ConfigRange (from:to:_)) = replace' from to +destination' :: ConfigRange -> DestinationTmpl -> FilePath +destination' (ConfigRange rs) = replace' from to + where + (from,to) = hull rs + + froms :: [Int] + froms = [ case r of + (InputRangeSingle f) -> f + (InputRangeFromTo f _) -> f + | r <- rs] + + tos :: [Int] + tos = [ case r of + (InputRangeSingle f) -> f + (InputRangeFromTo _ t) -> t + | r <- rs] + + hull :: [InputRange] -> (Int, Int) + hull [] = (0, 0) + hull _ = (minimum froms, maximum tos) -combineWithCmdLineArgs :: BinocularsConfig -> Maybe (ConfigRange Int) -> BinocularsConfig +combineWithCmdLineArgs :: BinocularsConfig -> Maybe ConfigRange -> BinocularsConfig combineWithCmdLineArgs c mr = case mr of Nothing -> c (Just _) -> c{_binocularsInputInputRange = mr} @@ -430,8 +502,8 @@ getResolution :: MonadThrow m => BinocularsConfig -> Int -> m [Double] getResolution c n | Data.List.length res == 1 = return $ replicate n (head res) - | Data.List.length res == n = return $ res - | otherwise = throwM $ (ResolutionNotCompatibleWithProjectionNbOfCoordinates res) n + | Data.List.length res == n = return res + | otherwise = throwM $ ResolutionNotCompatibleWithProjectionNbOfCoordinates res n where res = _binocularsProjectionResolution c diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Pipes.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Pipes.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Pipes.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Pipes.hs 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,8 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright : Copyright (C) 2014-2021 Synchrotron SOLEIL @@ -15,30 +17,31 @@ module Hkl.Binoculars.Pipes ( Chunk(..) - , DataFrameSpace(..) - , LenP(..) - , mkJobs - , mkInputHkl - , mkInputQxQyQz - , processHkl - , processQxQyQz + , processHklP + , processQxQyQzP ) where import Bindings.HDF5.Core (Location) +import Bindings.HDF5.Dataset (getDatasetType) +import Bindings.HDF5.Datatype (getTypeSize, nativeTypeOf, + typeIDsEqual) import Control.Concurrent.Async (mapConcurrently) import Control.Exception (throwIO) import Control.Monad (forM_, forever) import Control.Monad.Catch (MonadThrow, tryJust) +import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (MonadLogger) +import Control.Monad.Logger (MonadLogger, logInfo) +import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans.Cont (cont, runCont) import Data.Array.Repa (Shape, size) import Data.Array.Repa.Index (DIM1, DIM2) import Data.IORef (IORef, readIORef) +import Data.Int (Int32) import Data.Maybe (fromMaybe) +import Data.Text (pack) import Data.Vector.Storable (fromList) -import Data.Word (Word16) -import Foreign.ForeignPtr (ForeignPtr) +import Data.Word (Word16, Word32) import GHC.Base (returnIO) import GHC.Conc (getNumCapabilities) import GHC.Float (float2Double) @@ -48,17 +51,18 @@ import Pipes (Consumer, Pipe, Proxy, await, each, runEffect, yield, (>->)) -import Pipes.Prelude (tee, toListM) -import Pipes.Safe (MonadSafe, SafeT, - SomeException, bracket, - catchP, displayException, - runSafeP, runSafeT) +import Pipes.Prelude (map, mapM, tee, toListM) +import Pipes.Safe (MonadSafe, SomeException, + bracket, catchP, + displayException, runSafeP, + runSafeT) import System.ProgressBar (Progress (..), ProgressBar, Style (..), defStyle, elapsedTime, incProgress, newProgressBar, renderDuration, updateProgress) +import Text.Printf (printf) import Prelude hiding (filter) @@ -69,29 +73,15 @@ import Hkl.C.Geometry import Hkl.Detector import Hkl.H5 hiding (File) +import Hkl.Image import Hkl.Pipes import Hkl.Types --- LenP - -class LenP a where - lenP :: a -> Pipe FilePath Int (SafeT IO) () - - --- Jobs - -mkJobs :: LenP a => InputFn -> a -> IO ([[Chunk Int FilePath]], ProgressBar ()) -mkJobs fn h5d = do - let fns = concatMap (replicate 1) (toList fn) - ns <- runSafeT $ toListM $ each fns >-> lenP h5d - c' <- getNumCapabilities - let ntot = sum ns - c = if c' >= 2 then c' - 1 else c' - pb <- newProgressBar defStyle{ stylePostfix=elapsedTime renderDuration } - 10 (Progress 0 ntot ()) - return $ (mkJobs' (quot ntot c) fns ns, pb) +-- ChunkP +class ChunkP a where + chunkP :: MonadSafe m => a -> Pipe FilePath (Chunk Int FilePath) m () -- Project @@ -104,12 +94,11 @@ -> Int -> (Space sh -> b -> IO (DataFrameSpace sh)) -> Pipe b (DataFrameSpace sh) m () -project d n f = withSpace d n $ \s -> forever $ do - df <- await - yield =<< liftIO (f s df) +project d n f = withSpace d n $ \s -> Pipes.Prelude.mapM (liftIO . f s) -skipMalformed :: MonadSafe m => - Proxy a' a b' b m r + +skipMalformed :: MonadSafe m + => Proxy a' a b' b m r -> Proxy a' a b' b m r skipMalformed p = loop where @@ -119,100 +108,138 @@ -- QxQyQz -class LenP a => FramesQxQyQzP a where - framesQxQyQzP :: a -> Detector b DIM2 -> Pipe (Chunk Int FilePath) DataFrameQxQyQz (SafeT IO) () +class ChunkP a => FramesQxQyQzP a where + framesQxQyQzP :: MonadSafe m + => a -> Detector b DIM2 -> Pipe (FilePath, [Int]) DataFrameQxQyQz m () + +class (FramesQxQyQzP a, Show a) => ProcessQxQyQzP a where + processQxQyQzP :: (MonadIO m, MonadLogger m, MonadReader BinocularsConfig m, MonadThrow m) + => m a -> m () + processQxQyQzP mkPaths = do + conf <- ask + let det = fromMaybe defaultDetector (_binocularsInputDetector conf) + let output' = case _binocularsInputInputRange conf of + Just r -> destination' r (_binocularsDispatcherDestination conf) + Nothing -> destination' (ConfigRange []) (_binocularsDispatcherDestination conf) + let centralPixel' = _binocularsInputCentralpixel conf + let sampleDetectorDistance = _binocularsInputSdd conf + let detrot = fromMaybe (0 *~ degree) ( _binocularsInputDetrot conf) + let surfaceOrientation = fromMaybe SurfaceOrientationVertical (_binocularsInputSurfaceOrientation conf) + + h5d <- mkPaths + filenames <- InputList <$> files conf + pixels <- liftIO $ getPixelsCoordinates det centralPixel' sampleDetectorDistance detrot + res <- getResolution conf 3 + mask' <- getMask conf det + + -- compute the jobs + + let fns = concatMap (replicate 1) (toList filenames) + chunks <- liftIO $ runSafeT $ toListM $ each fns >-> chunkP h5d + cap' <- liftIO $ getNumCapabilities + let ntot = sum (Prelude.map clength chunks) + let cap = if cap' >= 2 then cap' - 1 else cap' + let jobs = chunk (quot ntot cap) chunks + + -- guess the final cube dimensions (To optimize, do not create the cube, just extract the shape) + + guessed <- liftIO $ withCubeAccumulator EmptyCube' $ \c -> + runSafeT $ runEffect $ + each chunks + >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f, (quot (f + t) 4), (quot (f + t) 4) * 2, (quot (f + t) 4) * 3, t])) + >-> framesQxQyQzP h5d det + >-> project det 3 (spaceQxQyQz det pixels res mask' surfaceOrientation) + >-> accumulateP c + + liftIO $ Prelude.print guessed + + -- do the final projection + + $(logInfo) (pack $ printf "let's do a QxQyQz projection of %d %s image(s) on %d core(s)" ntot (show det) cap) + + pb <- liftIO $ newProgressBar defStyle{ stylePostfix=elapsedTime renderDuration } 10 (Progress 0 ntot ()) + + r' <- liftIO $ mapConcurrently (\job -> withCubeAccumulator guessed $ \c -> + runSafeT $ runEffect $ + each job + >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f..t])) + >-> framesQxQyQzP h5d det + -- >-> filter (\(DataFrameQxQyQz _ _ _ ma) -> isJust ma) + >-> project det 3 (spaceQxQyQz det pixels res mask' surfaceOrientation) + >-> tee (accumulateP c) + >-> progress pb + ) jobs + liftIO $ saveCube output' r' -mkJobsQxQyQz :: LenP a => InputQxQyQz a -> IO ([[Chunk Int FilePath]], ProgressBar ()) -mkJobsQxQyQz (InputQxQyQz _ fn h5d _ _ _ _ _ _) = mkJobs fn h5d + liftIO $ updateProgress pb $ \p@(Progress _ t _) -> p{progressDone=t} -mkInputQxQyQz :: (MonadIO m, MonadLogger m, MonadThrow m, FramesQxQyQzP a) - => BinocularsConfig - -> (BinocularsConfig -> m a) - -> m (InputQxQyQz a) -mkInputQxQyQz c f = do - fs <- files c - let d = fromMaybe defaultDetector (_binocularsInputDetector c) - mask' <- getMask c d - res <- getResolution c 3 - h5dpath' <- f c - pure $ InputQxQyQz { detector = d - , filename = InputList fs - , h5dpath = h5dpath' - , output = case _binocularsInputInputRange c of - Just r -> destination' r (_binocularsDispatcherDestination c) - Nothing -> destination' (ConfigRange []) (_binocularsDispatcherDestination c) - , resolutions = res - , centralPixel = _binocularsInputCentralpixel c - , sdd' = _binocularsInputSdd c - , detrot' = fromMaybe (0 *~ degree) ( _binocularsInputDetrot c) - , mask = mask' - } - -processQxQyQz :: FramesQxQyQzP a => InputQxQyQz a -> IO () -processQxQyQz input@(InputQxQyQz det _ h5d o res cen d r mask') = do - pixels <- getPixelsCoordinates det cen d r - (jobs, pb) <- mkJobsQxQyQz input - r' <- mapConcurrently (\job -> withCubeAccumulator $ \c -> - runSafeT $ runEffect $ - each job - >-> framesQxQyQzP h5d det - -- >-> filter (\(DataFrameQxQyQz _ _ _ ma) -> isJust ma) - >-> project det 3 (spaceQxQyQz det pixels res mask') - >-> tee (accumulateP c) - >-> progress pb - ) jobs - saveCube o r' +instance ProcessQxQyQzP QxQyQzPath -- Hkl -class LenP a => FramesHklP a where - framesHklP :: a -> Detector b DIM2 -> Pipe (Chunk Int FilePath) (DataFrameHkl b) (SafeT IO) () - -mkJobsHkl :: LenP a => InputHkl a -> IO ([[Chunk Int FilePath]], ProgressBar ()) -mkJobsHkl (InputHkl _ fn h5d _ _ _ _ _ _ _) = mkJobs fn h5d +class ChunkP a => FramesHklP a where + framesHklP :: MonadSafe m + => a -> Detector b DIM2 -> Pipe (FilePath, [Int]) (DataFrameHkl b) m () + + +class (FramesHklP a, Show a) => ProcessHklP a where + processHklP :: (MonadIO m, MonadLogger m, MonadReader BinocularsConfig m, MonadThrow m) + => m a -> m () + processHklP mkPaths = do + conf <- ask + let det = fromMaybe defaultDetector (_binocularsInputDetector conf) + let output' = case _binocularsInputInputRange conf of + Just r -> destination' r (_binocularsDispatcherDestination conf) + Nothing -> destination' (ConfigRange []) (_binocularsDispatcherDestination conf) + let centralPixel' = _binocularsInputCentralpixel conf + let sampleDetectorDistance = _binocularsInputSdd conf + let detrot = fromMaybe (0 *~ degree) ( _binocularsInputDetrot conf) + + filenames <- InputList <$> files conf + mask' <- getMask conf det + res <- getResolution conf 3 + h5d <- mkPaths + pixels <- liftIO $ getPixelsCoordinates det centralPixel' sampleDetectorDistance detrot + + let fns = concatMap (replicate 1) (toList filenames) + chunks <- liftIO $ runSafeT $ toListM $ each fns >-> chunkP h5d + cap' <- liftIO $ getNumCapabilities + let ntot = sum (Prelude.map clength chunks) + let cap = if cap' >= 2 then cap' - 1 else cap' + let jobs = chunk (quot ntot cap) chunks + + -- guess the final cube dimensions (To optimize, do not create the cube, just extract the shape) + + guessed <- liftIO $ withCubeAccumulator EmptyCube' $ \c -> + runSafeT $ runEffect $ + each chunks + >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f, (quot (f + t) 4), (quot (f + t) 4) * 2, (quot (f + t) 4) * 3, t])) + >-> framesHklP h5d det + >-> project det 3 (spaceHkl conf det pixels res mask') + >-> accumulateP c + + liftIO $ Prelude.print guessed + + $(logInfo) (pack $ printf "let's do an Hkl projection of %d %s image(s) on %d core(s)" ntot (show det) cap) + + pb <- liftIO $ newProgressBar defStyle{ stylePostfix=elapsedTime renderDuration } 10 (Progress 0 ntot ()) + + r' <- liftIO $ mapConcurrently (\job -> withCubeAccumulator guessed $ \c -> + runEffect $ runSafeP $ + each job + >-> Pipes.Prelude.map (\(Chunk fn f t) -> (fn, [f..t])) + -- >-> tee Pipes.Prelude.print + >-> framesHklP h5d det + -- >-> filter (\(DataFrameHkl (DataFrameQxQyQz _ _ _ ma) _) -> isJust ma) + >-> project det 3 (spaceHkl conf det pixels res mask') + >-> tee (accumulateP c) + >-> progress pb + ) jobs + liftIO $ saveCube output' r' -mkInputHkl :: (FramesHklP a, MonadIO m, MonadThrow m) - => BinocularsConfig - -> (BinocularsConfig -> m a) - -> m (InputHkl a) -mkInputHkl c f = do - fs <- files c - let d = fromMaybe defaultDetector (_binocularsInputDetector c) - mask' <- getMask c d - res <- getResolution c 3 - h5dpath' <- f c - pure $ InputHkl - { detector = d - , filename = InputList fs - , h5dpath = h5dpath' - , output = destination' - (fromMaybe (ConfigRange []) (_binocularsInputInputRange c)) - (_binocularsDispatcherDestination c) - , resolutions = res - , centralPixel = _binocularsInputCentralpixel c - , sdd' = _binocularsInputSdd c - , detrot' = fromMaybe (0 *~ degree) (_binocularsInputDetrot c) - , config = c - , mask = mask' - } - -processHkl :: FramesHklP a => InputHkl a -> IO () -processHkl input@(InputHkl det _ h5d o res cen d r config' mask') = do - pixels <- getPixelsCoordinates det cen d r - (jobs, pb) <- mkJobsHkl input - r' <- mapConcurrently (\job -> withCubeAccumulator $ \c -> - runEffect $ runSafeP $ - each job - -- >-> tee Pipes.Prelude.print - >-> framesHklP h5d det - -- >-> filter (\(DataFrameHkl (DataFrameQxQyQz _ _ _ ma) _) -> isJust ma) - >-> project det 3 (spaceHkl config' det pixels res mask') - >-> tee (accumulateP c) - >-> progress pb - ) jobs - saveCube o r' + liftIO $ updateProgress pb $ \p@(Progress _ t _) -> p{progressDone=t} - updateProgress pb $ \p@(Progress _ t _) -> p{progressDone=t} +instance ProcessHklP HklPath -- Create the Cube @@ -221,24 +248,33 @@ forever $ do s <- await liftIO $ addSpace s =<< readIORef ref -progress :: (MonadIO m, Shape sh) => ProgressBar s -> Consumer (DataFrameSpace sh) m () +progress :: MonadIO m => ProgressBar s -> Consumer a m () progress p = forever $ do _ <- await liftIO $ p `incProgress` 1 -- Instances -withDetectorPathP :: (MonadSafe m, Location l) => l -> Detector a DIM2 -> DetectorPath -> ((Int -> IO (ForeignPtr Word16)) -> m r) -> m r +condM :: (Monad m) => [(m Bool, m a)] -> m a +condM [] = undefined +condM ((p, v):ls) = ifM p v (condM ls) + +withDetectorPathP :: (MonadSafe m, Location l) => l -> Detector a DIM2 -> DetectorPath -> ((Int -> IO Image) -> m r) -> m r withDetectorPathP f det (DetectorPath p) g = do - let n = (size . shape $ det) * 2 -- hardcoded size - withBytes n $ \buf -> - withHdf5PathP f p $ \p' -> g (getArrayInBuffer buf det p') + withHdf5PathP f p $ \p' -> do + t <- liftIO $ getDatasetType p' + s <- liftIO $ getTypeSize t + let n = (size . shape $ det) * fromEnum s + condM [ ((liftIO $ typeIDsEqual t (nativeTypeOf (undefined :: Int32))), (withBytes n $ \buf -> g (\i -> ImageInt32 <$> getArrayInBuffer buf det p' i))) + , ((liftIO $ typeIDsEqual t (nativeTypeOf (undefined :: Word16))), (withBytes n $ \buf -> g (\i -> ImageWord16 <$> getArrayInBuffer buf det p' i))) + , ((liftIO $ typeIDsEqual t (nativeTypeOf (undefined :: Word32))), (withBytes n $ \buf -> g (\i -> ImageWord32 <$> getArrayInBuffer buf det p' i))) + ] nest :: [(r -> a) -> a] -> ([r] -> a) -> a nest xs = runCont (Prelude.mapM cont xs) withAxesPathP :: (MonadSafe m, Location l) => l -> [Hdf5Path DIM1 Double] -> ([Dataset] -> m a) -> m a -withAxesPathP f dpaths = nest (map (withHdf5PathP f) dpaths) +withAxesPathP f dpaths = nest (Prelude.map (withHdf5PathP f) dpaths) withGeometryPathP :: (MonadSafe m, Location l) => l -> GeometryPath -> ((Int -> IO Geometry) -> m r) -> m r withGeometryPathP f (GeometryPathCristalK6C w m ko ka kp g d) gg = @@ -267,8 +303,16 @@ gg (const $ Geometry Fixe <$> (Source <$> getValueWithUnit w' 0 angstrom) - <*> (fromList <$> pure []) + <*> pure (fromList []) <*> pure Nothing) +withGeometryPathP f (GeometryPathMars as) gg = + withAxesPathP f as $ \as' -> + gg (\j -> Geometry Mars + <$> (Source <$> (return $ 1.537591 *~ angstrom)) + <*> (fromList <$> do + vs <- Prelude.mapM (`get_position` j) as' + return (0.0 : vs)) + <*> pure Nothing) withGeometryPathP f (GeometryPathMedH w as) gg = withHdf5PathP f w $ \w' -> withAxesPathP f as $ \as' -> @@ -302,14 +346,16 @@ -> ((Int -> IO Double) -> m r) -> m r withAttenuationPathP f matt g = - case matt of - NoAttenuation -> g (const $ returnIO 1) - (AttenuationPath p offset coef) -> - withHdf5PathP f p $ \p' -> g (\j -> do - v <- get_position p' (j + offset) - if v == badAttenuation - then throwIO (WrongAttenuation "file" (j + offset) (float2Double v)) - else return (coef ** float2Double v)) + case matt of + NoAttenuation -> g (const $ returnIO 1) + (AttenuationPath p offset coef) -> + withHdf5PathP f p $ \p' -> g (\j -> do + v <- get_position p' (j + offset) + if v == badAttenuation + then throwIO (WrongAttenuation "file" (j + offset) (float2Double v)) + else return (coef ** float2Double v)) + (ApplyedAttenuationFactorPath p) -> + withHdf5PathP f p $ \p' -> g (\j -> get_position p' j) withQxQyQzPath :: (MonadSafe m, Location l) => l @@ -329,20 +375,22 @@ -- FramesQxQyQzP -instance LenP QxQyQzPath where - lenP (QxQyQzPath ma (DetectorPath i) _) = - skipMalformed $ forever $ do - fp <- await - withFileP (openH5 fp) $ \f -> - withHdf5PathP f i $ \i' -> do - (_, ss) <- liftIO $ datasetShape i' - case head ss of - (Just n) -> yield $ fromIntegral n - case ma of - NoAttenuation -> 0 - (AttenuationPath _ off _) -> off - Nothing -> error "can not extract length" +instance ChunkP QxQyQzPath where + chunkP (QxQyQzPath ma (DetectorPath i) _) = + skipMalformed $ forever $ do + fp <- await + withFileP (openH5 fp) $ \f -> + withHdf5PathP f i $ \i' -> do + (_, ss) <- liftIO $ datasetShape i' + case head ss of + (Just n) -> yield $ case ma of + NoAttenuation -> Chunk fp 0 (fromIntegral n - 1) + (AttenuationPath _ off _) -> Chunk fp 0 (fromIntegral n - 1 - off) + (ApplyedAttenuationFactorPath _) -> Chunk fp 0 (fromIntegral n -1) + Nothing -> error "can not extract length" -tryYield :: IO r -> Proxy x' x () r (SafeT IO) () +tryYield :: MonadSafe m + => IO r -> Proxy x' x () r m () tryYield io = do edf <- liftIO $ tryJust selectHklBinocularsException io case edf of @@ -355,10 +403,10 @@ instance FramesQxQyQzP QxQyQzPath where framesQxQyQzP p det = skipMalformed $ forever $ do - (Chunk fp from to) <- await - withFileP (openH5 fp) $ \f -> + (fn, js) <- await + withFileP (openH5 fn) $ \f -> withQxQyQzPath f det p $ \getDataFrameQxQyQz -> - forM_ [from..to-1] (\j -> tryYield (getDataFrameQxQyQz j)) + forM_ js (tryYield . getDataFrameQxQyQz) -- FramesHklP @@ -397,16 +445,16 @@ <*> pure (Range 0 0))) withSamplePathP _ (SamplePath2 s) g = g (return s) -instance LenP HklPath where - lenP (HklPath p _) = lenP p +instance ChunkP HklPath where + chunkP (HklPath p _) = chunkP p instance FramesHklP HklPath where framesHklP (HklPath qp samp) det = skipMalformed $ forever $ do - (Chunk fp from to) <- await + (fp, js) <- await withFileP (openH5 fp) $ \f -> withQxQyQzPath f det qp $ \getDataFrameQxQyQz -> withSamplePathP f samp $ \getSample -> - forM_ [from..to-1] (\j -> tryYield ( DataFrameHkl - <$> getDataFrameQxQyQz j - <*> getSample - )) + forM_ js (\j -> tryYield ( DataFrameHkl + <$> getDataFrameQxQyQz j + <*> getSample + )) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Projections.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Projections.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Projections.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Projections.hs 2021-12-08 09:14:21.000000000 +0000 @@ -19,8 +19,6 @@ , GeometryPath(..) , HklPath(..) , HklBinocularsException(..) - , InputHkl(..) - , InputQxQyQz(..) , QxQyQzPath(..) , SamplePath(..) , badAttenuation @@ -29,22 +27,21 @@ , spaceQxQyQz ) where -import Control.Exception (Exception) -import Data.Array.Repa (Array, extent, listOfShape, - size) -import Data.Array.Repa.Index (DIM1, DIM2, DIM3, Z) -import Data.Array.Repa.Repr.ForeignPtr (F, toForeignPtr) -import Data.Text (Text) -import Data.Typeable (typeOf) -import Data.Word (Word16) -import Foreign.C.Types (CBool, CDouble (..), - CSize (..)) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Marshal.Array (withArrayLen) -import Foreign.Ptr (Ptr, nullPtr) -import Numeric.Units.Dimensional.Prelude (Angle, Length) +import Control.Exception (Exception) +import Data.Array.Repa (Array, extent, listOfShape, + size) +import Data.Array.Repa.Index (DIM1, DIM2, DIM3, Z) +import Data.Array.Repa.Repr.ForeignPtr (F, toForeignPtr) +import Data.Text (Text) +import Data.Typeable (typeOf) +import Data.Word (Word16) +import Foreign.C.Types (CBool, CDouble (..), + CSize (..)) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Array (withArrayLen) +import Foreign.Ptr (Ptr, nullPtr) -import Prelude hiding (drop, mapM) +import Prelude hiding (drop, mapM) import Hkl.Binoculars.Common import Hkl.Binoculars.Config @@ -52,8 +49,9 @@ import Hkl.C.Geometry import Hkl.C.Sample import Hkl.Detector -import Hkl.H5 hiding (File) -import Hkl.Orphan () +import Hkl.H5 hiding (File) +import Hkl.Image +import Hkl.Orphan () import Hkl.Types -- Common @@ -90,6 +88,8 @@ , geometryPathDelta :: Hdf5Path DIM1 Double } | GeometryPathFix { geometryPathWavelength :: Hdf5Path Z Double } + | GeometryPathMars { geometryPathAxes :: [Hdf5Path DIM1 Double] + } | GeometryPathMedH { geometryPathWavelength :: Hdf5Path Z Double , geometryPathAxes :: [Hdf5Path DIM1 Double] } @@ -118,6 +118,7 @@ , attenuationOffset :: Int , attenuationCoefficient :: Double } + | ApplyedAttenuationFactorPath { attenuationPath :: Hdf5Path DIM1 Float } | NoAttenuation deriving Show @@ -133,40 +134,33 @@ type Resolutions = [Double] -data InputQxQyQz a = - InputQxQyQz { detector :: Detector Hkl DIM2 - , filename :: InputFn - , h5dpath :: a - , output :: FilePath - , resolutions :: [Double] - , centralPixel :: (Int, Int) -- x, y - , sdd' :: Length Double -- sample to detector distance - , detrot' :: Angle Double - , mask :: Maybe Mask - } - deriving Show - data DataFrameQxQyQz = DataFrameQxQyQz Int -- n Double -- attenuation Geometry -- geometry - (ForeignPtr Word16) -- image + Image -- image deriving Show {-# INLINE spaceQxQyQz #-} -spaceQxQyQz :: Detector a DIM2 -> Array F DIM3 Double -> Resolutions -> Maybe Mask -> Space DIM3 -> DataFrameQxQyQz -> IO (DataFrameSpace DIM3) -spaceQxQyQz det pixels rs mmask' space (DataFrameQxQyQz _ att g img) = +spaceQxQyQz :: Detector a DIM2 -> Array F DIM3 Double -> Resolutions -> Maybe Mask -> SurfaceOrientation -> Space DIM3 -> DataFrameQxQyQz -> IO (DataFrameSpace DIM3) +spaceQxQyQz det pixels rs mmask' surf space (DataFrameQxQyQz _ att g img) = withNPixels det $ \nPixels -> - withGeometry g $ \geometry -> - withForeignPtr (toForeignPtr pixels) $ \pix -> - withArrayLen rs $ \nr r -> - withPixelsDims pixels $ \ndim dims -> - withMaybeMask mmask' $ \ mask'' -> - withForeignPtr img $ \i -> - withForeignPtr (spaceHklPointer space) $ \pSpace -> do - {-# SCC "hkl_binoculars_space_q" #-} hkl_binoculars_space_q pSpace geometry i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' - return (DataFrameSpace img space att) + withGeometry g $ \geometry -> + withForeignPtr (toForeignPtr pixels) $ \pix -> + withArrayLen rs $ \nr r -> + withPixelsDims pixels $ \ndim dims -> + withMaybeMask mmask' $ \ mask'' -> + withForeignPtr (spaceHklPointer space) $ \pSpace -> do + case img of + (ImageInt32 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_q_int32_t" #-} hkl_binoculars_space_q_int32_t pSpace geometry i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) + (ImageWord16 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_q_uint16_t" #-} hkl_binoculars_space_q_uint16_t pSpace geometry i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) + (ImageWord32 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_q_uint32_t" #-} hkl_binoculars_space_q_uint32_t pSpace geometry i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' (toEnum $ fromEnum surf) + + return (DataFrameSpace img space att) -- SamplePath @@ -189,20 +183,6 @@ data HklPath = HklPath QxQyQzPath SamplePath deriving Show -data InputHkl a = - InputHkl { detector :: Detector Hkl DIM2 - , filename :: InputFn - , h5dpath :: a - , output :: FilePath - , resolutions :: [Double] - , centralPixel :: (Int, Int) -- x, y - , sdd' :: Length Double -- sample to detector distance - , detrot' :: Angle Double - , config :: BinocularsConfig - , mask :: Maybe Mask - } - deriving Show - data DataFrameHkl a = DataFrameHkl DataFrameQxQyQz (Sample Triclinic) deriving Show @@ -212,13 +192,18 @@ spaceHkl config' det pixels rs mmask' space (DataFrameHkl (DataFrameQxQyQz _ att g img) samp) = do let sample' = overloadSampleWithConfig config' samp withNPixels det $ \nPixels -> - withGeometry g $ \geometry -> - withSample sample' $ \sample -> - withForeignPtr (toForeignPtr pixels) $ \pix -> - withArrayLen rs $ \nr r -> - withMaybeMask mmask' $ \ mask'' -> - withPixelsDims pixels $ \ndim dims -> - withForeignPtr img $ \i -> - withForeignPtr (spaceHklPointer space) $ \pSpace -> do - {-# SCC "hkl_binoculars_space_hkl" #-} hkl_binoculars_space_hkl pSpace geometry sample i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' - return (DataFrameSpace img space att) + withGeometry g $ \geometry -> + withSample sample' $ \sample -> + withForeignPtr (toForeignPtr pixels) $ \pix -> + withArrayLen rs $ \nr r -> + withMaybeMask mmask' $ \ mask'' -> + withPixelsDims pixels $ \ndim dims -> + withForeignPtr (spaceHklPointer space) $ \pSpace -> do + case img of + (ImageInt32 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_hkl_int32_t" #-} hkl_binoculars_space_hkl_int32_t pSpace geometry sample i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' + (ImageWord16 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_hkl_uint16_t" #-} hkl_binoculars_space_hkl_uint16_t pSpace geometry sample i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' + (ImageWord32 fp) -> withForeignPtr fp $ \i -> do + {-# SCC "hkl_binoculars_space_hkl_uint32_t" #-} hkl_binoculars_space_hkl_uint32_t pSpace geometry sample i nPixels (CDouble att) pix (toEnum ndim) dims r (toEnum nr) mask'' + return (DataFrameSpace img space att) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Sixs.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Sixs.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Binoculars/Sixs.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Binoculars/Sixs.hs 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} + {- Copyright : Copyright (C) 2014-2021 Synchrotron SOLEIL L'Orme des Merisiers Saint-Aubin @@ -17,8 +19,9 @@ import Control.Monad.Catch (Exception, MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logDebugSH, - logErrorSH, logInfo, logWarn, - logWarnN) + logErrorSH, logWarn, logWarnN) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans.Reader (runReaderT) import Data.Text (Text) import Hkl.Binoculars.Config @@ -44,214 +47,254 @@ logWarnN ("I continue without attenuation correction" :: Text) logWarnN ("Add attenuation_coefficient= under the [input] section, to fix this" :: Text) return NoAttenuation + applyed@ApplyedAttenuationFactorPath{} -> return applyed (Just coef) -> return $ case att of NoAttenuation -> NoAttenuation (AttenuationPath p o _) -> AttenuationPath p o coef + (ApplyedAttenuationFactorPath _) -> undefined -h5dpathQxQyQz :: (MonadLogger m, MonadThrow m) => BinocularsConfig -> m QxQyQzPath -h5dpathQxQyQz c = case _binocularsInputItype c of - CristalK6C -> QxQyQzPath - <$> mkAttenuation c NoAttenuation - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "data_05")) -- medipix - <*> pure (GeometryPathCristalK6C - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Monochromator" $ datasetp "lambda") - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-mu" $ datasetp "position") - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-komega" $ datasetp "position") - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-kappa" $ datasetp "position") - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "actuator_1_1") - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-gamma" $ datasetp "position") - (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-delta" $ datasetp "position")) - SixsFlyMedH -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) - <*> pure (GeometryPathMedH - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "pitch" -- should be optional - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - ]) - SixsFlyMedV -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) - <*> pure (GeometryPathMedV - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ -- hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" it was not saved in the file - hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" - ]) - SixsFlyMedVEiger -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eiger_image")) - <*> pure (GeometryPathMedVEiger - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" -- maybe nothing - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" - ] - ((hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eix") - `H5Or` - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-dt-det_tx.1" $ datasetp "position_pre")) - ((hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eiz") - `H5Or` - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-dt-det_tz.1" $ datasetp "position_pre"))) - SixsFlyMedVS70 -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_s70_image")) - <*> pure (GeometryPathMedV - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" - ]) - SixsFlyScanUhv -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) - <*> pure (GeometryPathUhv - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_MU" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_OMEGA" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_DELTA" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_GAMMA" - ]) - SixsFlyScanUhv2 -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) + +h5dpathQxQyQz :: (MonadLogger m, MonadReader BinocularsConfig m, MonadThrow m) + => m QxQyQzPath +h5dpathQxQyQz = + do c <- ask + case _binocularsInputItype c of + CristalK6C -> QxQyQzPath + <$> mkAttenuation c NoAttenuation <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) - <*> pure (GeometryPathUhv - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - ]) - SixsFlyScanUhvUfxc -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") - 2 0) - <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "ufxc_sixs_image")) - <*> pure (GeometryPathUhv - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") - [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" - , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" - ]) - SixsSbsFixedDetector -> QxQyQzPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "data_05")) -- medipix + <*> pure (GeometryPathCristalK6C + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Monochromator" $ datasetp "lambda") + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-mu" $ datasetp "position") + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-komega" $ datasetp "position") + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-kappa" $ datasetp "position") + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "actuator_1_1") + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-gamma" $ datasetp "position") + (hdf5p $ grouppat 0 $ groupp "CRISTAL" $ groupp "Diffractometer" $ groupp "i06-c-c07-ex-dif-delta" $ datasetp "position")) + MarsFlyscan -> QxQyQzPath + <$> mkAttenuation c (ApplyedAttenuationFactorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "applied_att")) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "merlin_image")) + <*> pure (GeometryPathMars + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "chi" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "phi" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "tth" + ]) + SixsFlyMedH -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (H5Or + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image") + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_s140_image"))) + <*> pure (GeometryPathMedH + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" -- should be optional + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + ]) + SixsFlyMedV -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) + <*> pure (GeometryPathMedV + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ -- hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" it was not saved in the file + hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" + ]) + SixsFlyMedVEiger -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eiger_image")) + <*> pure (GeometryPathMedVEiger + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" -- maybe nothing + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" + ] + ((hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eix") + `H5Or` + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-dt-det_tx.1" $ datasetp "position_pre")) + ((hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "eiz") + `H5Or` + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-dt-det_tz.1" $ datasetp "position_pre"))) + SixsFlyMedVS70 -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_s70_image")) + <*> pure (GeometryPathMedV + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "beta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "etaa" + ]) + SixsFlyScanUhv -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image")) + <*> pure (GeometryPathUhv + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_MU" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_OMEGA" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_DELTA" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "UHV_GAMMA" + ]) + SixsFlyScanUhv2 -> QxQyQzPath <$> mkAttenuation c (AttenuationPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") 2 0) <*> pure (DetectorPath - (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "data_11")) - <*> pure (GeometryPathFix - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda")) - SixsSbsMedH -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) - 0 0) - <*> pure (DetectorPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image"))) - <*> pure (GeometryPathMedH - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/diff-med-tpp/pitch") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/mu") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/gamma") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/delta") - ]) - SixsSbsMedV -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) - 0 0) - <*> pure (DetectorPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image"))) - <*> pure (GeometryPathMedV - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-ex-diff-med-tpp" $ groupp "TPP" $ groupp "Orientation" $ datasetp "pitch" - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/mu") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/omega") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/gamma") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/delta") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/etaa") - ]) - SixsSbsMedVFixDetector -> QxQyQzPath - <$> mkAttenuation c (AttenuationPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) - 0 0) - <*> pure (DetectorPath - (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/eiger.1/image"))) - <*> pure (GeometryPathMedV - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") - [ hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-ex-diff-med-tpp" $ groupp "TPP" $ groupp "Orientation" $ datasetp "pitch" - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/mu") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/omega") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/gamma") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/delta") - , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/etaa") - ]) + (H5Or + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_image") + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "xpad_s140_image"))) + <*> pure (GeometryPathUhv + (H5Or + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda")) + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + ]) + SixsFlyScanUhvUfxc -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "attenuation") + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "ufxc_sixs_image")) + <*> pure (GeometryPathUhv + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "Monochromator" $ datasetp "wavelength") + [ hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "mu" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "omega" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "delta" + , hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "gamma" + ]) + SixsSbsFixedDetector -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) + 2 0) + <*> pure (DetectorPath + (hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetp "data_11")) + <*> pure (GeometryPathFix + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda")) + SixsSbsMedH -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) + 0 0) + <*> pure (DetectorPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image"))) + <*> pure (GeometryPathMedH + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/diff-med-tpp/pitch") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/mu") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/gamma") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-h-dif-group.1/delta") + ]) + SixsSbsMedV -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) + 0 0) + <*> pure (DetectorPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image"))) + <*> pure (GeometryPathMedV + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-ex-diff-med-tpp" $ groupp "TPP" $ groupp "Orientation" $ datasetp "pitch" + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/mu") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/omega") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/gamma") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/delta") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/etaa") + ]) + SixsSbsMedVFixDetector -> QxQyQzPath + <$> mkAttenuation c (AttenuationPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/ex/roic/att")) + 0 0) + <*> pure (DetectorPath + (hdf5p $ datasetpattr ("long_name", "i14-c-c00/dt/eiger.1/image"))) + <*> pure (GeometryPathMedV + (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-c02-op-mono" $ datasetp "lambda") + [ hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp "i14-c-cx1-ex-diff-med-tpp" $ groupp "TPP" $ groupp "Orientation" $ datasetp "pitch" + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/mu") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/omega") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/gamma") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/delta") + , hdf5p $ datasetpattr ("long_name", "i14-c-cx1/ex/med-v-dif-group.1/etaa") + ]) -- FramesHklP -h5dpathHkl :: (MonadLogger m, MonadThrow m) => BinocularsConfig -> m HklPath -h5dpathHkl c = do - let sixsSample device = SamplePath - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "A") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "B") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "C") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "alpha") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "beta") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "gamma") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "Ux") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "Uy") - (hdf5p $ grouppat 0 $ groupp "SIXS" $ groupp device $ datasetp "Uz") - let uhvSamplePath = sixsSample "I14-C-CX2__EX__DIFF-UHV__#1" - let cmMedHSamplePath = sixsSample "i14-c-cx2-ex-cm-med.h" -- TODO check - let cmMedVSamplePath = sixsSample "i14-c-cx1-ex-cm-med.v" - qxqyqz <- h5dpathQxQyQz c - case _binocularsInputItype c of - SixsFlyMedH -> return $ HklPath qxqyqz cmMedHSamplePath - SixsFlyMedV -> return $ HklPath qxqyqz cmMedVSamplePath - SixsFlyMedVEiger -> return $ HklPath qxqyqz cmMedVSamplePath - SixsFlyMedVS70 -> return $ HklPath qxqyqz cmMedVSamplePath - SixsFlyScanUhv -> return $ HklPath qxqyqz uhvSamplePath - SixsFlyScanUhv2 -> return $ HklPath qxqyqz uhvSamplePath - SixsFlyScanUhvUfxc -> return $ HklPath qxqyqz uhvSamplePath - SixsSbsFixedDetector -> undefined -- TODO this must not be possible. - SixsSbsMedH -> return $ HklPath qxqyqz cmMedHSamplePath - SixsSbsMedV -> return $ HklPath qxqyqz cmMedVSamplePath - SixsSbsMedVFixDetector -> return $ HklPath qxqyqz cmMedVSamplePath - CristalK6C -> do - let ms = sampleConfig c - case ms of - (Just s) -> return (HklPath qxqyqz (SamplePath2 s)) - Nothing -> throwM (MissingSampleParameters c) +h5dpathHkl :: (MonadLogger m, MonadReader BinocularsConfig m, MonadThrow m) + => m HklPath +h5dpathHkl = + do c <- ask + let samplePath beamline device = + SamplePath + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "A") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "B") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "C") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "alpha") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "beta") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "gamma") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Ux") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Uy") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "Uz") + let sampleMarsPath beamline device = + SamplePath + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "a") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "b") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "c") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "alpha") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "beta") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "gamma") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_x") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_y") + (hdf5p $ grouppat 0 $ groupp beamline $ groupp device $ datasetp "u_z") + let marsSamplePath = sampleMarsPath "MARS" "d03-1-cx2__ex__dif-cm_#1" + let medHSamplePath = samplePath "SIXS" "i14-c-cx1-ex-cm-med.h" + let medVSamplePath = samplePath "SIXS" "i14-c-cx1-ex-cm-med.v" + let uhvSamplePath = samplePath "SIXS" "I14-C-CX2__EX__DIFF-UHV__#1" + let uhvSamplePath2 = samplePath "SIXS" "i14-c-cx2-ex-diff-uhv" + qxqyqz <- h5dpathQxQyQz + case _binocularsInputItype c of + CristalK6C -> do + let ms = sampleConfig c + case ms of + (Just s) -> return (HklPath qxqyqz (SamplePath2 s)) + Nothing -> throwM (MissingSampleParameters c) + MarsFlyscan -> return $ HklPath qxqyqz marsSamplePath + SixsFlyMedH -> return $ HklPath qxqyqz medHSamplePath + SixsFlyMedV -> return $ HklPath qxqyqz medVSamplePath + SixsFlyMedVEiger -> return $ HklPath qxqyqz medVSamplePath + SixsFlyMedVS70 -> return $ HklPath qxqyqz medVSamplePath + SixsFlyScanUhv -> return $ HklPath qxqyqz uhvSamplePath + SixsFlyScanUhv2 -> return $ HklPath qxqyqz uhvSamplePath2 + SixsFlyScanUhvUfxc -> return $ HklPath qxqyqz uhvSamplePath + SixsSbsFixedDetector -> undefined -- TODO this must not be possible. + SixsSbsMedH -> return $ HklPath qxqyqz medHSamplePath + SixsSbsMedV -> return $ HklPath qxqyqz medVSamplePath + SixsSbsMedVFixDetector -> return $ HklPath qxqyqz medVSamplePath -- SixsSbsMedV -> HklPath -- hdf5p $ grouppat 0 $ groupp "scan_data" $ datasetpattr ("long_name", "i14-c-c00/dt/xpad.1/image") -- xpad @@ -267,22 +310,20 @@ -- medVSamplePath -- -- "attenuation": DatasetPathWithAttribute("long_name", b"i14-c-c00/ex/roic/att"), -- -- "timestamp": HItem("sensors_timestamps", True), -process :: (MonadLogger m, MonadThrow m, MonadIO m) => Maybe FilePath -> Maybe (ConfigRange Int) -> m () + +process' :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader BinocularsConfig m) + => m () +process' = do + c <- ask + $(logDebugSH) c + case _binocularsProjectionPtype c of + QxQyQzProjection -> processQxQyQzP h5dpathQxQyQz + HklProjection -> processHklP h5dpathHkl + +process :: (MonadLogger m, MonadThrow m, MonadIO m) => Maybe FilePath -> Maybe (ConfigRange) -> m () process mf mr = do conf <- liftIO $ getConfig mf + $(logDebugSH) conf case conf of - Right conf' -> do - let c = combineWithCmdLineArgs conf' mr - $(logDebugSH) c - case _binocularsProjectionPtype c of - QxQyQzProjection -> do - i <- mkInputQxQyQz c h5dpathQxQyQz - $(logDebugSH) i - $(logInfo) "let's do a QxQyQz projection" - liftIO $ processQxQyQz i - HklProjection -> do - i <- mkInputHkl c h5dpathHkl - $(logDebugSH) i - $(logInfo) "let's do an Hkl projection" - liftIO $ processHkl i - Left e -> $(logErrorSH) e + Right conf' -> runReaderT process' (combineWithCmdLineArgs conf' mr) + Left e -> $(logErrorSH) e diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/C/Binoculars.hsc hkl-5.0.0.2875/contrib/haskell/src/Hkl/C/Binoculars.hsc --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/C/Binoculars.hsc 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/C/Binoculars.hsc 2021-12-08 09:14:21.000000000 +0000 @@ -20,16 +20,20 @@ -} module Hkl.C.Binoculars - ( Cube(..) + ( Cube , Cube'(..) , Space(..) - , hkl_binoculars_cube_new , hkl_binoculars_cube_new' , hkl_binoculars_cube_new_empty' + , hkl_binoculars_cube_new_empty_from_cube' , hkl_binoculars_cube_new_from_space , hkl_binoculars_cube_add_space - , hkl_binoculars_space_q - , hkl_binoculars_space_hkl + , hkl_binoculars_space_hkl_int32_t + , hkl_binoculars_space_hkl_uint16_t + , hkl_binoculars_space_hkl_uint32_t + , hkl_binoculars_space_q_int32_t + , hkl_binoculars_space_q_uint16_t + , hkl_binoculars_space_q_uint32_t , newSpace , toCube ) where @@ -37,12 +41,13 @@ import Data.Array.Repa.Repr.ForeignPtr (Array, F, fromForeignPtr) import Data.Array.Repa (DIM1, DIM3, Shape, shapeOfList, ix1, size) import Data.ByteString.Char8 (ByteString, packCString) -import Data.Word (Word16) -import Foreign.C.Types (CBool, CDouble(..), CSize(..), CUInt(..), CPtrdiff) +import Data.Int (Int32) +import Data.Word (Word16, Word32) +import Foreign.C.Types (CBool, CDouble(..), CInt(..), CSize(..), CUInt(..), CPtrdiff) import Foreign.Marshal.Alloc (finalizerFree) -import Foreign.Marshal.Array (allocaArray, peekArray) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) -import Foreign.Ptr (FunPtr, Ptr, plusPtr) +import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, mallocForeignPtrArray, withForeignPtr) +import Foreign.Ptr (FunPtr, Ptr, plusPtr, castPtr) import Foreign.Storable (Storable (..)) import System.IO.Unsafe (unsafePerformIO) @@ -133,32 +138,25 @@ foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_new_empty" \ hkl_binoculars_cube_new_empty' :: IO (Ptr (Cube' sh)) +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_new_empty_from_cube" \ +hkl_binoculars_cube_new_empty_from_cube' :: Ptr (Cube' sh) -> IO (Ptr (Cube' sh)) + -- Cube data Cube sh = Cube { cubePhotons :: (Array F sh CUInt) , cubeContributions :: (Array F sh CUInt) , cubeAxes :: [Axis] - , cubeHklPointer :: (ForeignPtr (Cube sh)) - } + } | EmptyCube deriving Show -instance Shape sh => Semigroup (Cube sh) where - (<>) EmptyCube EmptyCube = EmptyCube - (<>) EmptyCube b = b - (<>) a EmptyCube = a - (<>) (Cube _ _ _ fpa) (Cube _ _ _ fpb) = unsafePerformIO $ do - withForeignPtr fpa $ \pa -> - withForeignPtr fpb $ \pb -> - peek =<< {-# SCC "hkl_binoculars_cube_new_merge" #-} hkl_binoculars_cube_new_merge pa pb - -foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_new_merge" \ -hkl_binoculars_cube_new_merge :: Ptr (Cube sh) - -> Ptr (Cube sh) - -> IO (Ptr (Cube sh)) - -instance Shape sh => Monoid (Cube sh) where - mempty = EmptyCube +extractArray :: Storable a => IO (Ptr a) -> Int -> IO (ForeignPtr a) +extractArray io n = do + fp <- mallocForeignPtrArray n + withForeignPtr fp $ \to -> do + from <- io + copyArray to from n + return fp instance Shape sh => Storable (Cube sh) where alignment _ = #{alignment HklBinocularsCube} @@ -172,18 +170,11 @@ hkl_binoculars_cube_dims ptr n dims' dims <- peekArray (fromEnum n) dims' let sh = shapeOfList (reverse (map fromEnum dims)) - fpPhotons <- newForeignPtr_ =<< (#{peek HklBinocularsCube, photons} ptr) - fpContributions <- newForeignPtr_ =<< (#{peek HklBinocularsCube, contributions} ptr) + let nbElem = size sh + fpPhotons <- extractArray (#{peek HklBinocularsCube, photons} ptr) nbElem + fpContributions <- extractArray (#{peek HklBinocularsCube, contributions} ptr) nbElem axes <- peekArray (fromEnum n) =<< (#{peek darray_axis, item} paxes) - fp <- newForeignPtr hkl_binoculars_cube_free ptr - return $ Cube (fromForeignPtr sh fpPhotons) (fromForeignPtr sh fpContributions) axes fp - -foreign import ccall unsafe "hkl-binoculars.h &hkl_binoculars_cube_free" hkl_binoculars_cube_free :: FunPtr (Ptr (Cube sh) -> IO ()) - -foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_new" \ -hkl_binoculars_cube_new :: CSize -- number of Space - -> Ptr (Ptr (Space sh)) -- spaces - -> IO (Ptr (Cube sh)) + return $ Cube (fromForeignPtr sh fpPhotons) (fromForeignPtr sh fpContributions) axes foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_dims" \ hkl_binoculars_cube_dims :: Ptr (Cube sh) @@ -192,21 +183,16 @@ -> IO () instance Shape sh => ToHdf5 (Cube sh) where - toHdf5 (Cube p c axes _) = group "binoculars" - [ group "axes" [dataset (name axis) (arr axis) | axis <- axes] - , dataset "counts" p - , dataset "contributions" c - ] + toHdf5 (Cube p c axes) = group "binoculars" + [ group "axes" [dataset (name axis) (arr axis) | axis <- axes] + , dataset "counts" p + , dataset "contributions" c + ] toHdf5 EmptyCube = empty toCube :: Shape sh => Cube' sh -> IO (Cube sh) toCube EmptyCube' = pure EmptyCube -toCube (Cube' fp') = withForeignPtr fp' $ \p -> do - peek =<< hkl_binoculars_cube_new_copy p - -foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_cube_new_copy" \ -hkl_binoculars_cube_new_copy :: Ptr (Cube' sh) -- src - -> IO (Ptr (Cube sh)) +toCube (Cube' fp') = withForeignPtr fp' (peek . castPtr) -- Space @@ -233,31 +219,50 @@ foreign import ccall unsafe "hkl-binoculars.h &hkl_binoculars_space_free" hkl_binoculars_space_free :: FunPtr (Ptr (Space sh) -> IO ()) -foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_q" \ -hkl_binoculars_space_q :: Ptr (Space DIM3) -- HklBinocularsSpace *self - -> Ptr Geometry -- const HklGeometry *geometry - -> Ptr Word16 -- const uint16_t *image - -> CSize -- size_t n_pixels - -> CDouble -- double weight - -> Ptr Double -- const double *pixels_coordinates - -> CSize -- int32_t pixels_coordinates_ndim - -> Ptr CSize -- const int32_t *pixels_coordinates_dims - -> Ptr Double -- const double *resolutions - -> CSize -- size_t n_resolutions - -> Ptr CBool -- const uint8_t *mask - -> IO () - -foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_hkl" \ -hkl_binoculars_space_hkl :: Ptr (Space DIM3) -- HklBinocularsSpace *self - -> Ptr Geometry -- const HklGeometry *geometry - -> Ptr HklSample -- const HklSample *sample - -> Ptr Word16 -- const uint16_t *image - -> CSize -- size_t n_pixels - -> CDouble -- double weight - -> Ptr Double -- const double *pixels_coordinates - -> CSize -- size_t pixels_coordinates_ndim - -> Ptr CSize -- const int32_t *pixels_coordinates_dims - -> Ptr Double -- const double *resolutions - -> CSize -- size_t n_resolutions - -> Ptr CBool -- const uint8_t *mask - -> IO () +type C'ProjectionTypeQ t = Ptr (Space DIM3) -- HklBinocularsSpace *self + -> Ptr Geometry -- const HklGeometry *geometry + -> Ptr t -- const uint16_t *image + -> CSize -- size_t n_pixels + -> CDouble -- double weight + -> Ptr Double -- const double *pixels_coordinates + -> CSize -- int32_t pixels_coordinates_ndim + -> Ptr CSize -- const int32_t *pixels_coordinates_dims + -> Ptr Double -- const double *resolutions + -> CSize -- size_t n_resolutions + -> Ptr CBool -- const uint8_t *mask + -> CInt -- surface orientation + -> IO () + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_q_int32_t" \ +hkl_binoculars_space_q_int32_t :: C'ProjectionTypeQ Int32 + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_q_uint16_t" \ +hkl_binoculars_space_q_uint16_t :: C'ProjectionTypeQ Word16 + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_q_uint32_t" \ +hkl_binoculars_space_q_uint32_t :: C'ProjectionTypeQ Word32 + + +type C'ProjectionTypeHkl t = Ptr (Space DIM3) -- HklBinocularsSpace *self + -> Ptr Geometry -- const HklGeometry *geometry + -> Ptr HklSample -- const HklSample *sample + -> Ptr t -- const *image + -> CSize -- size_t n_pixels + -> CDouble -- double weight + -> Ptr Double -- const double *pixels_coordinates + -> CSize -- size_t pixels_coordinates_ndim + -> Ptr CSize -- const int32_t *pixels_coordinates_dims + -> Ptr Double -- const double *resolutions + -> CSize -- size_t n_resolutions + -> Ptr CBool -- const uint8_t *mask + -> IO () + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_hkl_int32_t" \ +hkl_binoculars_space_hkl_int32_t :: C'ProjectionTypeHkl Int32 + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_hkl_uint16_t" \ +hkl_binoculars_space_hkl_uint16_t :: C'ProjectionTypeHkl Word16 + + +foreign import ccall unsafe "hkl-binoculars.h hkl_binoculars_space_hkl_uint32_t" \ +hkl_binoculars_space_hkl_uint32_t :: C'ProjectionTypeHkl Word32 diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/C/Geometry.hsc hkl-5.0.0.2875/contrib/haskell/src/Hkl/C/Geometry.hsc --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/C/Geometry.hsc 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/C/Geometry.hsc 2021-12-08 09:14:21.000000000 +0000 @@ -41,13 +41,14 @@ -- Factory -data Factory = K6c | Fixe | Uhv | MedH | MedV | SoleilSiriusKappa +data Factory = K6c | Fixe | Uhv | Mars | MedH | MedV | SoleilSiriusKappa instance Show Factory where show K6c = "K6C" show Fixe = undefined show Uhv = "ZAXIS" - show MedH = undefined + show Mars = "SOLEIL MARS" + show MedH = "SOLEIL SIXS MED1+2" show MedV = "SOLEIL SIXS MED2+3" show SoleilSiriusKappa = "SOLEIL SIRIUS KAPPA" @@ -56,6 +57,7 @@ | s == "K6C" = K6c | s == undefined = Fixe | s == "ZAXIS" = Uhv + | s == "SOLEIL MARS" = Mars | s == undefined = MedH | s == "SOLEIL SIXS MED2+3" = MedV | s == "SOLEIL SIRIUS KAPPA" = SoleilSiriusKappa diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Conduit.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Conduit.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Conduit.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Conduit.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Hkl.Conduit - ( withBytesC - , withFileC - , withDatasetC - , withDataspaceC - , withHdf5PathC - ) - where - -import Bindings.HDF5.Core (Location) -import Bindings.HDF5.Dataspace (Dataspace, closeDataspace) -import Bindings.HDF5.Group (Group, closeGroup, openGroup) -import Conduit (ConduitT, MonadResource, bracketP) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, - mallocForeignPtrBytes) - -import Hkl.H5 - --- Deal with hdf5 object in a safe way - -bracket' :: MonadResource m => (a -> IO ()) -> IO a -> (a -> ConduitT i o m r) -> ConduitT i o m r -bracket' r a = bracketP (liftIO a) (liftIO . r) - -withBytesC :: MonadResource m => Int -> (ForeignPtr a -> ConduitT i o m r) -> ConduitT i o m r -withBytesC n = bracket' finalizeForeignPtr (mallocForeignPtrBytes n) - -withFileC :: MonadResource m => IO File -> (File -> ConduitT i o m r) -> ConduitT i o m r -withFileC = bracket' closeFile - -withGroupC :: MonadResource m => IO Group -> (Group -> ConduitT i o m r) -> ConduitT i o m r -withGroupC = bracket' closeGroup - -withGroupAtC :: (Location l, MonadResource m) => l -> Int -> (Group -> ConduitT i o m r) -> ConduitT i o m r -withGroupAtC l i f = do - es <- liftIO $ nxEntries' l - withGroupC (openGroup l (es !! i) Nothing) f - -withDatasetC :: MonadResource m => IO Dataset -> (Dataset -> ConduitT i o m r) -> ConduitT i o m r -withDatasetC = bracket' closeDataset - -withDataspaceC :: MonadResource m => IO Dataspace -> (Dataspace -> ConduitT i o m r) -> ConduitT i o m r -withDataspaceC = bracket' closeDataspace - -withHdf5PathC :: (Location l, MonadResource m) => l -> Hdf5Path sh e -> (Dataset -> ConduitT i o m r) -> ConduitT i o m r -withHdf5PathC l (H5RootPath subpath) f = withHdf5PathC l subpath f -withHdf5PathC l (H5GroupPath n subpath) f = withGroupC (openGroup l n Nothing) $ \g -> withHdf5PathC g subpath f -withHdf5PathC l (H5GroupAtPath i subpath) f = withGroupAtC l i $ \g -> withHdf5PathC g subpath f -withHdf5PathC l (H5DatasetPath n) f = withDatasetC (openDataset l n Nothing) f --- withHdf5PathC l (H5DatasetPathAttr (a, c)) f = withDatasetC (findDatasetAttr l a c) f diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/DataSource.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/DataSource.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/DataSource.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/DataSource.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Hkl.DataSource ( ExtendDims(..) - , DataItem(..) - , DataSource(..) - , atIndex' - , openDataSource - , closeDataSource - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif - -import Control.Monad.Trans.Maybe (MaybeT) -import Data.Array.Repa (Shape) -import Data.ByteString.Char8 (pack) -import Data.Vector.Storable (Vector, any, singleton) -import Pipes (lift) -import Prelude hiding (any) - -import Hkl.H5 - -data ExtendDims = ExtendDims | StrictDims deriving (Show) - -data DataItem a where - DataItemH5 :: H5Path -> ExtendDims -> DataItem H5 - DataItemConst :: Double -> DataItem Double -deriving instance Show (DataItem a) - -data DataSource a where - DataSourceH5 :: DataItem H5 -> Dataset -> DataSource H5 - DataSourceConst :: Double -> DataSource Double - -openDataSource :: File -> DataItem a -> IO (DataSource a) -openDataSource hid di@(DataItemH5 name _) = DataSourceH5 di - <$> openDataset hid (pack name) Nothing -openDataSource _ (DataItemConst v) = return $ DataSourceConst v - -closeDataSource :: DataSource a -> IO () -closeDataSource (DataSourceH5 _ d) = closeDataset d -closeDataSource (DataSourceConst _) = return () - -atIndex' :: Shape sh => DataSource a -> sh -> MaybeT IO (Vector Double) -atIndex' (DataSourceH5 _ a ) b = lift $ do - v <- get_position_new a b - if any isNaN v then fail "File contains Nan" else return v -atIndex' (DataSourceConst v) _ = lift $ return $ singleton v diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Detector.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Detector.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Detector.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Detector.hs 2021-12-08 09:14:21.000000000 +0000 @@ -14,7 +14,6 @@ , PyFAI , SomeDetector(..) , ZeroD - , coordinates , defaultDetector , getDetectorMask , getDetectorDefaultMask @@ -29,12 +28,11 @@ throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Array.Repa (Array, Shape) -import Data.Array.Repa.Index ((:.) (..), DIM0, DIM2, DIM3, - Z (..), ix2, ix3) +import Data.Array.Repa.Index (DIM0, DIM2, DIM3, Z (..), + ix2, ix3, (:.) (..)) import Data.Array.Repa.Repr.ForeignPtr (F, fromForeignPtr) import Data.List (find, sort) import Data.Text (Text, pack, unpack, unwords) -import Data.Vector.Storable (Vector, fromList) import Foreign.C.String (CString, peekCString, withCString) import Foreign.C.Types (CBool, CDouble (..), @@ -48,8 +46,6 @@ import Numeric.Units.Dimensional.Prelude (Angle, Length, meter, radian, (/~)) -import Hkl.PyFAI.Npt (NptPoint (NptPoint)) - data HklDetectorException = MaskShapeNotcompatible Text | NoDefaultMask deriving (Show) @@ -129,62 +125,6 @@ -- Xpad Family -type Gap = Double -type Width = Int -type Index = Int - --- an xpad line is like this (pixel size, index) --- s 0 | s 1 | s 2 | ... | 5/2 s (w - 1) || 5/2 s w | s (w + 1) | ... -xpadLine :: Width -> Index -> Double -xpadLine w i' - | i' == 0 = s / 2 - | i' == 1 = s * 3 / 2 - | idx == 0 = s * (fromIntegral i' + 3 * fromIntegral c - 1 / 4) - | idx <= (w - 2) = s * (fromIntegral i' + 3 * fromIntegral c + 1 / 2) - | idx == (w - 1) = s * (fromIntegral i' + 3 * fromIntegral c + 5 / 4) - | otherwise = error $ "wront coordinates" ++ show i' - where - s = 130e-6 - (c, idx) = divMod i' w - -xpadLineWithGap :: Width -> Gap -> Index -> Double -xpadLineWithGap w g i' = s / 2 + (s * fromIntegral i') + g * fromIntegral (div i' w) - where - s = 130e-6 - -interp :: (Int -> Double) -> Double -> Double -interp f p - | p0 == p1 = f p0 - | otherwise = (p - fromIntegral p0) * (f p1 - f p0) + f p0 - where - p0 :: Int - p0 = floor p - - p1 :: Int - p1 = ceiling p - --- compute the coordinated at a given point - -coordinates :: Detector a sh -> NptPoint -> Vector Double -coordinates ZeroD (NptPoint 0 0) = fromList [0, 0, 0] -coordinates ZeroD _ = error "No coordinates in a ZeroD detector" - -coordinates ImXpadS140 (NptPoint x y) = - fromList [ interp (xpadLine 120) y - , interp (xpadLine 80) x - , 0 - ] - -coordinates Xpad32 (NptPoint x y) = - fromList [ interp (xpadLineWithGap 120 3.57e-3) y - , interp (xpadLine 80) x - , 0] - -coordinates XpadFlatCorrected (NptPoint x y) = - fromList [ y * 130e-6 - , x * 130e-6 - , 0] - getPixelsCoordinates :: Detector Hkl DIM2 -> (Int, Int) -> Length Double -> Angle Double -> IO (Array F DIM3 Double) getPixelsCoordinates (Detector2D n _ sh) (ix0, iy0) sdd detrot = do parr <- hkl_binoculars_detector_2d_coordinates_get n diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Edf.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Edf.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Edf.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Edf.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Edf - ( Edf(..) - , ExtractEdf(..) - , edfP - , edfFromFile - ) where - -import Data.Attoparsec.Text ( Parser - , () - , anyChar - , double - , many1 - , manyTill - , parseOnly - , skipSpace - , string - , takeTill - , try - ) -import Data.ByteString.Char8 (readFile, split) -import Data.Text (Text, words) -import Data.Text.Encoding (decodeUtf8) -import Numeric.Units.Dimensional.Prelude (Length, (*~), nano, meter) - -data Edf = Edf { edf'Lambda :: Length Double - , edf'Motors :: [(Text, Double)] - } - deriving (Show) - -class ExtractEdf a where - extractEdf ∷ a → IO () - - -edfLambdaP :: Parser (Length Double) -edfLambdaP = do - _ <- manyTill anyChar (try $ string "Lambda = ") - value <- double - pure $ value *~ nano meter - -edfMotorsP :: Parser [(Text, Double)] -edfMotorsP = do - _ <- manyTill anyChar (try $ string "motor_pos = ") - vs <- many1 (skipSpace *> double) - _ <- manyTill anyChar (try $ string "motor_mne = ") - ns <- takeTill (== ';') - return $ zip (Data.Text.words ns) vs - -edfP :: Parser Edf -edfP = Edf - <$> edfLambdaP - <*> edfMotorsP - "edfP" - -edfFromFile :: FilePath -> IO Edf -edfFromFile filename = do - content <- Data.ByteString.Char8.readFile filename - let header = head (split '}' content) - return $ case parseOnly edfP (decodeUtf8 header) of - Left _ -> error $ "Can not parse the " ++ filename ++ " edf file" - Right a -> a diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Flat.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Flat.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Flat.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Flat.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Flat - ( Flat(..) - , Npy - , computeFlat - ) - where - -import Data.Text (pack, unlines) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath.Posix (replaceExtension) - -import Hkl.DataSource (DataItem (DataItemH5)) -import Hkl.Nxs (DataFrameH5Path (XrdFlatH5Path), - Nxs (Nxs), XrdFlat) -import Hkl.Python (PyVal, toPyVal) -import Hkl.Script (Py2, Script (Py2Script), run) - -data Npy - -data Flat a where - FlatNpy ∷ FilePath → Flat Npy -deriving instance Show (Flat a) - -scriptPy2Flat ∷ [Nxs XrdFlat] → FilePath → Script Py2 -scriptPy2Flat ns output = Py2Script (script, scriptName) - where - script = Data.Text.unlines $ - map pack ["#!/bin/env python" - , "" - , "import numpy" - , "from h5py import File" - , "" - , "NEXUSFILES = " ++ toPyVal nxs' - , "IMAGEPATHS = " ++ toPyVal hpaths - , "OUTPUT = " ++ toPyVal output - , "" - , "flat = None" - , "n = None" - , "with File(NEXUSFILES[0], mode='r') as f:" - , " imgs = f[IMAGEPATHS[0]]" - , " flat = numpy.sum(imgs[:], axis=0)" - , " n = imgs.shape[0]" - , "for idx, (nxs, h5path) in enumerate(zip(NEXUSFILES[1:], IMAGEPATHS[1:])):" - , " with File(nxs, mode='r') as f:" - , " imgs = f[h5path]" - , " flat += numpy.sum(imgs[:], axis=0)" - , " n += imgs.shape[0]" - , "numpy.save(OUTPUT, flat.astype('f') / n)" - ] - nxs' ∷ [String] - nxs' = [f | (Nxs f _) ← ns] - - hpaths ∷ [String] - hpaths = [h | (Nxs _ (XrdFlatH5Path (DataItemH5 h _))) ← ns] - - scriptName ∷ FilePath - scriptName = output `replaceExtension` "py" - -computeFlat ∷ [Nxs XrdFlat] → FilePath → IO (Flat Npy) -computeFlat ns o = do - -- create the python script. - let script = scriptPy2Flat ns o - -- execute this script. - ExitSuccess ← run script False - -- return the filepath of the generated file. - return (FlatNpy o) - -instance PyVal (Flat a) where - toPyVal (FlatNpy v) = "numpy.load(" ++ show v ++ ")" diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/H5.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/H5.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/H5.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/H5.hs 2021-12-08 09:14:21.000000000 +0000 @@ -21,8 +21,6 @@ , closeDataset , closeFile , getArrayInBuffer - , get_image - , get_image' , get_position , get_position_new , get_ub @@ -30,7 +28,7 @@ , datasetShape , nxEntries , nxEntries' - , openDataset + , openDataset' , openDatasetWithAttr , openH5 , set_image @@ -65,7 +63,8 @@ iterOrderCode) import Bindings.HDF5.Dataset (Dataset, closeDataset, createDataset, - getDatasetSpace, openDataset, + getDatasetSpace, + getDatasetType, openDataset, readDataset, readDatasetInto, writeDataset) import Bindings.HDF5.Dataspace (Dataspace, @@ -76,6 +75,7 @@ getSimpleDataspaceExtentNDims, getSimpleDataspaceExtentNPoints, selectHyperslab, selectNone) +import Bindings.HDF5.Datatype (getTypeClass, getTypeSize) import Bindings.HDF5.Datatype.Internal (NativeType, hdfTypeOf1, nativeTypeOf) import Bindings.HDF5.Error (withErrorCheck_) @@ -88,6 +88,7 @@ import Bindings.HDF5.Object (ObjectId, ObjectType (..), closeObject, getObjectType, openObject) +import Bindings.HDF5.PropertyList.DAPL (DAPL) import Bindings.HDF5.PropertyList.DXPL (DXPL) import Bindings.HDF5.Raw (H5L_info_t, HErr_t (HErr_t), HId_t (HId_t), h5d_read, @@ -98,21 +99,18 @@ import Data.Array.Repa (Array, Shape, extent, linearIndex, listOfShape, size) -import Data.Array.Repa.Repr.ForeignPtr (F, fromForeignPtr, - toForeignPtr) +import Data.Array.Repa.Repr.ForeignPtr (F, toForeignPtr) import Data.ByteString.Char8 (ByteString, pack, packCString, unpack) import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Vector.Storable (Storable, Vector, freeze, head, unsafeFromForeignPtr0) -import Data.Vector.Storable.Mutable (MVector (..), new, replicate) +import Data.Vector.Storable.Mutable (new) import Data.Word (Word16) import Foreign.C.String (CString) import Foreign.C.Types (CInt (CInt)) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, - withForeignPtr) -import Foreign.Marshal.Alloc (finalizerFree, mallocBytes) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr) import Foreign.Ptr.Conventions (In (In), InOut (InOut), @@ -159,27 +157,7 @@ castToVector :: (Shape sh, Storable e) => Array F sh e -> Vector e castToVector arr = unsafeFromForeignPtr0 (toForeignPtr arr) (size . extent $ arr) -get_image :: Shape sh => Detector a sh -> Dataset -> Int -> IO (Array F sh Word16) -get_image det d n = withDataspace (getDatasetSpace d) $ \dataspace -> do - let s = shape det - h = (HSize (fromIntegral n), Nothing, HSize 1, Nothing) : shapeAsRangeToHyperslab s - selectHyperslab dataspace Set h - withDataspace (createDataspaceFromShape s) $ \memspace -> do - data_out@(MVector _ fp) <- Data.Vector.Storable.Mutable.replicate (size s) (0 :: Word16) - readDatasetInto d (Just memspace) (Just dataspace) Nothing data_out - return $ fromForeignPtr s fp - -get_image' :: Shape sh => Detector a sh -> Dataset -> Int -> IO (ForeignPtr Word16) -get_image' det d n = withDataspace (getDatasetSpace d) $ \dataspace -> do - let s = shape det - h = (HSize (fromIntegral n), Nothing, HSize 1, Nothing) : shapeAsRangeToHyperslab s - selectHyperslab dataspace Set h - withDataspace (createDataspaceFromShape s) $ \memspace -> do - p <- mallocBytes (size s * 2) - readDatasetInto' d (Just memspace) (Just dataspace) Nothing p - newForeignPtr finalizerFree p - -getArrayInBuffer :: Shape sh => ForeignPtr Word16 -> Detector a sh -> Dataset -> Int -> IO (ForeignPtr Word16) +getArrayInBuffer :: (NativeType t, Shape sh) => ForeignPtr t -> Detector a sh -> Dataset -> Int -> IO (ForeignPtr t) getArrayInBuffer fbuf det d n = withDataspace (getDatasetSpace d) $ \dataspace -> do let s = shape det h = (HSize (fromIntegral n), Nothing, HSize 1, Nothing) : shapeAsRangeToHyperslab s @@ -267,6 +245,18 @@ -- DataSet +openDataset' :: Location l => l -> ByteString -> Maybe DAPL -> IO Dataset +openDataset' loc n ml = do + ds <- openDataset loc n ml + s <- getDatasetSpace ds + np <- getSimpleDataspaceExtentNPoints s + e <- getSimpleDataspaceExtent s + t <- getDatasetType ds + c <- getTypeClass t + es <- getTypeSize t + -- print (n, c, es, np, e) + return ds + withDataset :: IO Dataset -> (Dataset -> IO r) -> IO r withDataset a = bracket a closeDataset @@ -336,16 +326,16 @@ case t of DatasetObj -> do exist <- doesAttributeExist obj attr - case exist of - True -> withAttribute (openAttribute obj attr) $ \a -> do + if exist + then withAttribute (openAttribute obj attr) $ \a -> do c <- readAttributeStringASCII a - case c == value of - True -> do - ds <- openDataset g n Nothing - modifyIORef' state $ \_ -> (Just ds) + if c == value + then do + ds <- openDataset' g n Nothing + modifyIORef' state $ const (Just ds) return $ HErr_t 1 - False -> return $ HErr_t 0 - False -> return $ HErr_t 0 + else return $ HErr_t 0 + else return $ HErr_t 0 _ -> return $ HErr_t 0 fromMaybeM (throwIO $ CanNotFindDatasetWithAttributContent attr value) (readIORef state) @@ -413,9 +403,9 @@ withHdf5Path' loc (H5RootPath subpath) f = withHdf5Path' loc subpath f withHdf5Path' loc (H5GroupPath n subpath) f = withGroup (openGroup loc n Nothing) $ \g -> withHdf5Path' g subpath f withHdf5Path' loc (H5GroupAtPath i subpath) f = withGroupAt loc i $ \g -> withHdf5Path' g subpath f -withHdf5Path' loc (H5DatasetPath n) f = withDataset (openDataset loc n Nothing) f +withHdf5Path' loc (H5DatasetPath n) f = withDataset (openDataset' loc n Nothing) f withHdf5Path' loc (H5DatasetPathAttr (a, c)) f = withDataset (openDatasetWithAttr loc a c) f -withHdf5Path' loc (H5Or l r) f = (withHdf5Path' loc l f) <|> (withHdf5Path' loc r f) +withHdf5Path' loc (H5Or l r) f = withHdf5Path' loc l f <|> withHdf5Path' loc r f withHdf5Path :: FilePath -> Hdf5Path sh e -> (Dataset -> IO r) -> IO r withHdf5Path fn path f = withH5File fn $ \fn' -> withHdf5Path' fn' path f diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Image.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Image.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Image.hs 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Image.hs 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,14 @@ +{-# LANGUAGE UnicodeSyntax #-} + +module Hkl.Image + ( Image(..) ) + where + +import Data.Int (Int32) +import Data.Word (Word16, Word32) +import Foreign.ForeignPtr (ForeignPtr) + +data Image = ImageInt32 (ForeignPtr Int32) + | ImageWord16 (ForeignPtr Word16) + | ImageWord32 (ForeignPtr Word32) + deriving Show diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Nxs.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Nxs.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Nxs.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Nxs.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,237 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Nxs - ( DataFrameH5(..) - , DataFrameH5Path(..) - , NxEntry - , Nxs(..) - , PoniGenerator - , XrdFlat - , XrdOneD - , XrdMesh - , XrdZeroD - , mkNxs - , withDataFrameH5 - , withDataSource - ) where - -import Bindings.HDF5.Dataset ( readDataset - , getDatasetSpace ) -import Bindings.HDF5.Dataspace ( getSimpleDataspaceExtent ) -import Codec.Picture ( DynamicImage( ImageY16 ) - , Image ( Image ) - ) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), pure) -#endif -import Control.Exception.Base (bracket) -import Control.Monad.IO.Class (liftIO) -import Pipes.Safe ( MonadSafe, bracket ) - -import Hkl.DataSource ( DataItem - , DataSource ( DataSourceH5 ) - , closeDataSource - , openDataSource - ) -import Hkl.H5 ( File, H5 - , closeFile - , openH5 - ) -import Hkl.PyFAI ( Pose, PoniExt ) -import Hkl.Tiff ( ToTiff - , toTiff - ) - -type NxEntry = String - --- to remove an put directly into OneD -type PoniGenerator = Pose -> Int -> IO PoniExt - -data XrdFlat -data XrdOneD -data XrdMesh -data XrdZeroD - -data DataFrameH5Path a where - XrdFlatH5Path ∷ DataItem H5 -- image - → DataFrameH5Path XrdFlat - XrdOneDH5Path ∷ DataItem H5 -- image - → DataItem H5 -- gamma - → DataItem H5 -- delta - → DataItem H5 -- wavelength - → DataFrameH5Path XrdOneD - XrdMeshH5Path ∷ DataItem H5 -- Image - → DataItem H5 -- meshx - → DataItem H5 -- meshy - → DataItem H5 -- gamma - → DataItem H5 -- delta - → DataItem H5 -- wavelength - → DataFrameH5Path XrdMesh - XrdMeshFlyH5Path ∷ DataItem H5 -- Image - → DataItem H5 -- meshx - → DataItem H5 -- meshy - → DataItem Double -- gamma - → DataItem Double -- delta - → DataItem Double -- wavelength - → DataFrameH5Path XrdMesh - XrdZeroDH5Path ∷ DataItem H5 -- image - → DataItem Double -- wavelength - → DataFrameH5Path XrdZeroD -- used to integrate one static image - -deriving instance Show (DataFrameH5Path a) - -data Nxs a where - Nxs ∷ FilePath → DataFrameH5Path a → Nxs a - -deriving instance Show (Nxs a) - -data DataFrameH5 a where - XrdFlatH5 ∷ Nxs XrdFlat -- Nexus Source file - → File -- h5file handler - → DataSource H5 --images - → DataFrameH5 XrdFlat - DataFrameH5 ∷ Nxs XrdOneD -- Nexus file - → File -- h5file handler - → DataSource H5 -- gamma - → DataSource H5 -- delta - → DataSource H5 -- wavelength - → PoniGenerator -- ponie generator - → DataFrameH5 XrdOneD - XrdMeshH5 ∷ Nxs XrdMesh -- NexusFile Source File - → File -- h5file handler - → DataSource H5 -- image - → DataSource H5 -- meshx - → DataSource H5 -- meshy - → DataSource H5 -- gamma - → DataSource H5 -- delta - → DataSource H5 -- wavelength - → DataFrameH5 XrdMesh - XrdMeshFlyH5 ∷ Nxs XrdMesh -- NexusFile Source File - → File -- h5file handler - → DataSource H5 -- image - → DataSource H5 -- meshx - → DataSource H5 -- meshy - → DataSource Double -- gamma - → DataSource Double -- delta - → DataSource Double -- wavelength - → DataFrameH5 XrdMesh - XrdZeroDH5 ∷ Nxs XrdZeroD -- NexusFile Source File - → File -- h5file handler - → DataSource H5 -- image - → DataSource Double -- wavelength - → DataFrameH5 XrdZeroD - -mkNxs ∷ FilePath → NxEntry → (NxEntry → DataFrameH5Path a) → Nxs a -mkNxs f e h = Nxs f (h e) - --- Instanciate a DataFrameH5 from a DataFrameH5Path --- acquire and release the resources - -after ∷ DataFrameH5 a → IO () -after (XrdFlatH5 _ f i) = do - closeDataSource i - closeFile f -after (DataFrameH5 _ f g d w _) = do - closeDataSource g - closeDataSource d - closeDataSource w - closeFile f -after (XrdMeshH5 _ f i x y g d w) = do - closeDataSource i - closeDataSource x - closeDataSource y - closeDataSource g - closeDataSource d - closeDataSource w - closeFile f -after (XrdMeshFlyH5 _ f i x y g d w) = do - closeDataSource i - closeDataSource x - closeDataSource y - closeDataSource g - closeDataSource d - closeDataSource w - closeFile f -after (XrdZeroDH5 _ f i w) = do - closeDataSource i - closeDataSource w - closeFile f - -before :: Nxs a → IO (DataFrameH5 a) -before nxs'@(Nxs f (XrdFlatH5Path i)) = do - h ← openH5 f - XrdFlatH5 - <$> return nxs' - <*> return h - <*> openDataSource h i --- before nxs'@(Nxs f (XrdOneDH5Path i g d w)) = do --- h ← openH5 f --- DataFrameH5 --- <$> return nxs' --- <*> return h --- <*> openDataSource h g --- <*> openDataSource h d --- <*> openDataSource h w --- <*> return gen -before nxs'@(Nxs f (XrdMeshH5Path i x y g d w)) = do - h ← openH5 f - XrdMeshH5 - <$> return nxs' - <*> return h - <*> openDataSource h i - <*> openDataSource h x - <*> openDataSource h y - <*> openDataSource h g - <*> openDataSource h d - <*> openDataSource h w -before nxs'@(Nxs f (XrdMeshFlyH5Path i x y g d w))= do - h ← openH5 f - XrdMeshFlyH5 - <$> return nxs' - <*> return h - <*> openDataSource h i - <*> openDataSource h x - <*> openDataSource h y - <*> openDataSource h g - <*> openDataSource h d - <*> openDataSource h w -before nxs'@(Nxs f (XrdZeroDH5Path i w)) = do - h ← openH5 f - XrdZeroDH5 - <$> return nxs' - <*> return h - <*> openDataSource h i - <*> openDataSource h w - -withDataSource :: Nxs a -> (DataFrameH5 a -> IO r) -> IO r -withDataSource s = Control.Exception.Base.bracket (before s) after - --- Pipe - -withDataFrameH5 :: (MonadSafe m) => Nxs XrdOneD -> PoniGenerator -> (DataFrameH5 XrdOneD -> m r) -> m r -withDataFrameH5 nxs'@(Nxs f (XrdOneDH5Path _ g d w)) gen = Pipes.Safe.bracket (liftIO before') (liftIO . after) - where - -- before :: File -> DataFrameH5Path -> m DataFrameH5 - before' :: IO (DataFrameH5 XrdOneD) - before' = do - h ← openH5 f - DataFrameH5 - <$> return nxs' - <*> return h - <*> openDataSource h g - <*> openDataSource h d - <*> openDataSource h w - <*> return gen - -instance ToTiff (Nxs XrdFlat) where - toTiff n = withDataSource n $ - \(XrdFlatH5 _ _ (DataSourceH5 _ i)) → do - ([w, h], _) ← getSimpleDataspaceExtent =<< getDatasetSpace i - ImageY16 <$> ( Image - <$> pure (fromIntegral w) - <*> pure (fromIntegral h) - <*> readDataset i Nothing Nothing ) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Pipes.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Pipes.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Pipes.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Pipes.hs 2021-12-08 09:14:21.000000000 +0000 @@ -49,6 +49,6 @@ withHdf5PathP loc (H5RootPath subpath) f = withHdf5PathP loc subpath f withHdf5PathP loc (H5GroupPath n subpath) f = withGroupP (openGroup loc n Nothing) $ \g -> withHdf5PathP g subpath f withHdf5PathP loc (H5GroupAtPath i subpath) f = withGroupAtP loc i $ \g -> withHdf5PathP g subpath f -withHdf5PathP loc (H5DatasetPath n) f = withDatasetP (openDataset loc n Nothing) f +withHdf5PathP loc (H5DatasetPath n) f = withDatasetP (openDataset' loc n Nothing) f withHdf5PathP loc (H5DatasetPathAttr (a, c)) f = withDatasetP (openDatasetWithAttr loc a c) f -withHdf5PathP loc (H5Or l r) f = (withHdf5PathP loc l f) `catchAll` \_ -> (withHdf5PathP loc r f) +withHdf5PathP loc (H5Or l r) f = withHdf5PathP loc l f `catchAll` const (withHdf5PathP loc r f) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/D2AM/XRD.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/D2AM/XRD.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/D2AM/XRD.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/D2AM/XRD.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,106 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.Projects.D2AM.XRD - ( d2am ) where - -import Data.Array.Repa (DIM1, ix1) --- import Data.Char (toUpper) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl.Detector -import Hkl.MyMatrix -import Hkl.PyFAI -import Hkl.Xrd - --- Samples - -project :: FilePath -project = "/home/experiences/instrumentation/picca/data/d2am" --- project = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/" - -published :: FilePath -published = project "published-data" - -sampleRef :: XRDRef -sampleRef = XRDRef "reference" - (published "calibration") - (XrdRefEdf - (project "16Dec08D5_0268-rsz.edf") - (project "16Dec08D5_0268-rsz.poni") - ) - -sampleCalibration :: XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "calibration" -- TODO pourquoi ce output - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - - idxs :: [Int] - idxs = [268, 271, 285, 295] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryEdf - { xrdCalibrationEntryEdf'Edf = project printf "16Dec08D5_%04d-rsz.edf" idx - , xrdCalibrationEntryEdf'NptPath = project printf "16Dec08D5_%04d-rsz.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - -bins :: DIM1 -bins = ix1 1000 - -multibins :: DIM1 -multibins = ix1 10000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 5000) - -skipedFrames :: [Int] -skipedFrames = [] - -lab6 :: XRDSample -lab6 = XRDSample "test" - (published "test") - [XrdNxs bins multibins threshold skipedFrames entries] - where - idxs :: [Int] - idxs = [268, 271, 285, 295] - - entry :: Int -> FilePath - entry idx = project printf "16Dec08D5_%04d-rsz.edf" idx - - entries :: XrdSource - entries = XrdSourceEdf [entry idx | idx <- idxs] - --- Main - -d2am :: IO () -d2am = do - let samples = [lab6] - - p <- getPoniExtRef sampleRef - - -- let poniextref = setPose (Hkl.PyFAI.PoniExt.flip p) (MyMatrix HklB (ident 3)) - let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - - -- full calibration - poniextref' <- calibrate sampleCalibration poniextref - - print poniextref - print poniextref' - - -- integrate each step of the scan - let params = XrdOneDParams poniextref' Nothing Csr -- waiting for PyFAI to manage method in multi geometry - integrateMulti params samples - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/D2AM.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/D2AM.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/D2AM.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/D2AM.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -module Hkl.Projects.D2AM (module X) where - -import Hkl.Projects.D2AM.XRD as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Charlier.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Charlier.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Charlier.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Charlier.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,165 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.Projects.Diffabs.Charlier - ( charlier ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl - ---  TODO --- ⋅ gerer le dummy correctement en focntion du type de données des images uint32, int16 --- ∘ couper la fin du spectre qui nous embète. --- Samples - -project :: FilePath -project = "/nfs/ruche-diffabs/diffabs-users/20151386/" - -published :: FilePath -published = project "published-data" "xrd" - --- Calibration part - -project' :: FilePath -project' = "/nfs/ruche-diffabs/diffabs-users/99160066/" - -published':: FilePath -published' = project' "published-data" - -h5path' :: NxEntry -> DataFrameH5Path XrdOneD -h5path' nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_53" - gamma = "d13-1-cx1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleCalibration :: XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published' "calibration" - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - idxs :: [Int] - idxs = [3, 6, 9, 15, 18, 21, 24, 27, 30, 33, 36, 39, 43] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (published' "calibration" "XRD18keV_26.nxs") "scan_26" h5path' - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published' "calibration" printf "XRD18keV_26.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - - -sampleRef :: XRDRef -sampleRef = XRDRef "reference" - (published' "calibration") - (XrdRefNxs - (mkNxs (published' "calibration" "XRD18keV_26.nxs") "scan_26" h5path') - 6 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - ) - -bins :: DIM1 -bins = ix1 8000 - -multibins :: DIM1 -multibins = ix1 25000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 1200) - -h5path :: NxEntry -> DataFrameH5Path XrdMesh -h5path nxentry = XrdMeshH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry meshx) StrictDims) - (DataItemH5 (nxentry meshy) StrictDims) - (DataItemH5 (nxentry beamline gamma) StrictDims) - (DataItemH5 (nxentry beamline delta) StrictDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_53" - meshx = "scan_data/actuator_1_1" - meshy = "scan_data/actuator_2_1" - gamma = "d13-1-cx1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "d13-1-cx1__EX__DIF.1-DELTA__#1/raw_value" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -charlemagne :: XrdMeshSample -charlemagne = XrdMeshSample "Charlemagne" - (published "Charlemagne") - [ XrdMesh bins multibins threshold (XrdMeshSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_31.nxs") "scan_31" h5path - , mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_32.nxs") "scan_32" h5path - , mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_33.nxs") "scan_33" h5path - ] - ] - -charlesLeChauve :: XrdMeshSample -charlesLeChauve = XrdMeshSample "Charles le Chauve" - (published "Charles le Chauve") - [ XrdMesh bins multibins threshold (XrdMeshSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-24" "XRD18keV_34.nxs") "scan_34" h5path ] - ] - -louisLePieux :: XrdMeshSample -louisLePieux = XrdMeshSample "Louis le Pieux" - (published "Louis Le Pieux") - [ XrdMesh bins multibins threshold (XrdMeshSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-24" "XRD18keV_35.nxs") "scan_35" h5path - , mkNxs (project "2016" "Run2" "2016-03-24" "XRD18keV_36.nxs") "scan_36" h5path - , mkNxs (project "2016" "Run2" "2016-03-24" "XRD18keV_37.nxs") "scan_37" h5path - ] - ] - --- Main - -charlier :: IO () -charlier = do - let samples = [ charlemagne, charlesLeChauve, louisLePieux] - -- let samples = [ louisLePieux ] - -- # need to run f30 by itself because of a segfault in the hkl library - -- for now f30 whcih is an incomplet scan stop the script so put it at the end. - -- let samples = [f30, ceo2] - -- let samples = [ceo2] - let mflat = Nothing - let method = CsrOcl - - p <- getPoniExtRef sampleRef - - -- flip the ref poni in order to fit the reality - -- let poniextref = p - let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - -- let poniextref = setPose (Hkl.PyFAI.PoniExt.flip p) (MyMatrix HklB (ident 3)) - - -- full calibration - poniextref' <- calibrate sampleCalibration poniextref - -- print p - print poniextref - print poniextref' - - -- integrate each step of the scan - integrateMesh (XrdMeshParams poniextref' mflat method) samples - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Hamon.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Hamon.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Hamon.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Hamon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.Projects.Diffabs.Hamon - ( hamon ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl - --- TODO --- take into account a non-centered sample. --- find a way to use integrateMulti with a small amount of memory. --- better mask for each detector. - --- Samples - -project :: FilePath -project = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/" - -published :: FilePath -published = project "2016" "Run4B" "OutilsMetallo_CarolineHamon" - -sampleRef :: XRDRef -sampleRef = XRDRef "reference" - (published "xrd" "calibration") - (XrdRefNxs - (mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path') - 33 - ) - -h5path' :: NxEntry -> DataFrameH5Path XrdOneD -h5path' nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_02" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleCalibration :: XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "xrd" "calibration" -- TODO pourquoi ce output - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - - idxs :: [Int] - idxs = [5, 33, 100, 246, 300, 436] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path' - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published "xrd" "calibration" printf "IHR_30.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - - -bins :: DIM1 -bins = ix1 1000 - -multibins :: DIM1 -multibins = ix1 10000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 5000) - -skipedFrames :: [Int] -skipedFrames = [] - -ceo2 :: XRDSample -ceo2 = XRDSample "CeO2" - (published "xrd" "CeO2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run4" "2016-09-07" "IHR_29.nxs") "scan_29" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_56.nxs") "scan_56" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_58.nxs") "scan_58" h5path' - ] - ] - --- Main - -hamon :: IO () -hamon = do - -- pre-calibrate (extract from nexus to edf in order to do the - -- calibration) - extractEdf sampleCalibration - - p <- getPoniExtRef sampleRef - - let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - - -- full calibration - poniextref' <- calibrate sampleCalibration poniextref - - print poniextref - print poniextref' - - -- Integrate the flyscan mesh - -- 4.680504680504681e-3 per images (2*60+18) / 29484 this contain - -- read/write and computation - -- integrateMesh (XrdMeshParams poniextref' mflat method) [fly] - - -- set the integration parameters - let mflat = Nothing - let aiMethod = Csr - let params = XrdOneDParams poniextref' mflat aiMethod - - -- integrate each step of the scan - integrate params [ceo2] - - -- this code doesn not work because there is not enought memory on - -- the computer. - -- integrateMulti params [ceo2] - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Hercules.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Hercules.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Hercules.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Hercules.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,169 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Projects.Diffabs.Hercules - ( hercules ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.Units.Dimensional.Prelude (centi, degree, meter, (*~)) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (lookup, readFile, - writeFile) - -import Hkl - --- Samples - -project ∷ FilePath -project = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/" - -published ∷ FilePath -published = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/2017/Run2B/TPHercules" - --- Calibration part - -mkNxs' ∷ FilePath → Int → (NxEntry → DataFrameH5Path a ) → Nxs a -mkNxs' d idx = mkNxs f' e - where - f ∷ FilePath → Int → (FilePath, NxEntry) - f d' i' = (d' printf "scan_%d.nxs" i', printf "scan_%d" i') - - (f', e) = f d idx - -h5path ∷ NxEntry → DataFrameH5Path XrdOneD -h5path nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_03" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleRef ∷ XRDRef -sampleRef = XRDRef "reference" - (published "calibration") - (XrdRefNxs - (mkNxs' (project "2017" "Run2" "2017-03-21") 91 h5path) - 15 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - ) - -sampleCalibration ∷ XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "calibration" - , xrdCalibrationDetector = ImXpadS140 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - idxs ∷ [Int] - idxs = [15, 16, 17, 18, 19] - - entry ∷ Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs' (project "2017" "Run2" "2017-03-21") 91 h5path - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published "calibration" printf "scan_91.nxs_%02d.npt" idx - } - - entries ∷ [XRDCalibrationEntry] - entries = map entry idxs - --- Data treatment - -bins ∷ DIM1 -bins = ix1 3000 - -multibins ∷ DIM1 -multibins = ix1 25000 - -threshold ∷ Maybe Threshold -threshold = Just (Threshold 800) - -skipedFrames ∷ [Int] -skipedFrames = [] - --- Flat - --- flat ∷ [Nxs XrdFlat] --- flat = [mkNxs' (project "2017" "Run1" "2017-02-15") idx h5path | idx ← [57, 60 ∷ Int]] -- skip 58 59 for now (problème de droits d'accès) --- where --- h5path :: NxEntry -> DataFrameH5Path XrdFlat --- h5path nxentry = XrdFlatH5Path (DataItemH5 (nxentry "scan_data/data_02") StrictDims) - --- Scan en delta - -mkXRDSample ∷ String → [(FilePath, [Int])] -> XRDSample -mkXRDSample n ps = XRDSample n - (published "xrd" n) - [ XrdNxs bins multibins threshold skipedFrames n' | n' ← concatMap nxs''' ps ] - where - nxs''' ∷ (FilePath, [Int]) → [XrdSource] - nxs''' (p, idxs) = [XrdSourceNxs (mkNxs' p idx h5path) | idx ← idxs] - - -samples :: [XRDSample] -samples = map (uncurry mkXRDSample) - [ ("CeO2", [ (project "2017" "Run2" "2017-03-21", [91 :: Int]) ]) - , ("zgso4_room", [ (project "2017" "Run2" "2017-03-21", [96 :: Int]) ]) - , ("zgso4_450C", [ (project "2017" "Run2" "2017-03-21", [192 :: Int]) ]) - , ("zgso4_heating", [ (project "2017" "Run2" "2017-03-21", [100..190 :: Int]) ]) - , ("zgso4_cooling", [ (project "2017" "Run2" "2017-03-21", [199..214 :: Int]) ]) - ] - --- Main - -hercules ∷ IO () -hercules = do - - -- pre-calibrate (extract from nexus to edf in order to do the - -- calibration) - extractEdf sampleCalibration - - -- compute the flat - -- flat' ← computeFlat flat (published "flat" "flat.npy") - - -- get a first ref poniExt - p ← getPoniExtRef sampleRef - -- set the initial position of the poni (pyFAI calibration is not - -- accurate with only one ring) - let poniextref = set p - (63 *~ centi meter) -- distance - (0 *~ meter) -- poni1 - (0 *~ meter) -- poni2 - (0 *~ degree) -- rot1 - (0 *~ degree) -- rot2 - (0 *~ degree) -- rot3 - print poniextref - - -- full calibration - poniextref' ← calibrate sampleCalibration poniextref - print poniextref' - - -- set the integration parameters - let mflat = Nothing - let aiMethod = Csr - let params = XrdOneDParams poniextref' mflat aiMethod - - -- -- integrate scan with multi geometry - -- -- splitPixel (the only available now) → 17m47.825s - integrateMulti params samples - - -- -- Integrate each image of the scans - -- -- Lut → 21.52 minutes - -- -- Csr → 21.9 minutes - -- integrate params samples - - -- -- substrack the air from all samples - -- substract params air samples - -- substractMulti params air samples - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/IRDRx.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/IRDRx.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/IRDRx.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/IRDRx.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.Projects.Diffabs.IRDRx - ( irdrx ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl - --- Samples - -project :: FilePath -project = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/" - -published :: FilePath -published = project "2016" "Run5B" "irdrx" - -sampleRef :: XRDRef -sampleRef = XRDRef "reference" - (published "calibration") - (XrdRefNxs - (mkNxs (project "2016" "Run5" "2016-11-09" "scan_39.nxs") "scan_39" h5path') - 10 - ) - -h5path' :: NxEntry -> DataFrameH5Path XrdOneD -h5path' nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_05" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/data_03" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleCalibration :: XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "calibration" -- TODO pourquoi ce output - , xrdCalibrationDetector = ImXpadS140 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - - idxs :: [Int] - idxs = [0, 1, 10, 30] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (project "2016" "Run5" "2016-11-09" "scan_39.nxs") "scan_39" h5path' - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published "calibration" printf "scan_39.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - - -bins :: DIM1 -bins = ix1 1000 - -multibins :: DIM1 -multibins = ix1 10000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 5000) - -skipedFrames :: [Int] -skipedFrames = [] - -lab6 :: XRDSample -lab6 = XRDSample "LaB6" - (published "LaB6") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run5" "2016-11-09" "scan_39.nxs") "scan_39" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_40.nxs") "scan_40" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_41.nxs") "scan_41" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_42.nxs") "scan_42" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_43.nxs") "scan_43" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_44.nxs") "scan_44" h5path' - , mkNxs (project "2016" "Run5" "2016-11-09" "scan_45.nxs") "scan_45" h5path' - ] - ] - - - --- meshSample :: String --- meshSample :: project "2016" Run5 "2016-11-fly" "scan5 "*" --- h5path nxentry = exptest_01368 --- scan_data, sxpos szpos xpad_image 12x273 x 10 (fichiers) --- delta = -6.2 --- gamma = 0.0 --- nrj 18.2 keV -fly :: XrdMeshSample -fly = XrdMeshSample "scan5" - (published "scan5") - [ XrdMesh bins multibins threshold - ( XrdMeshSourceNxsFly [mkNxs (project "2016" "Run5" "2016-11-fly" "scan5" printf "flyscan_%05d.nxs" n) "exptest_01368" h5path | - n <- [7087, 7088, 7089, 7090, 7091, 7092, 7093, 7094, 7095] :: [Int] - ] - ) - ] - where - h5path :: NxEntry -> DataFrameH5Path XrdMesh - h5path nxentry = XrdMeshFlyH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry meshx) StrictDims) - (DataItemH5 (nxentry meshy) StrictDims) - (DataItemConst gamma) - (DataItemConst delta) - (DataItemConst wavelength) - - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/xpad_image" - meshx = "scan_data/sxpos" - meshy = "scan_data/szpos" - gamma = 0.0 / 180.0 * 3.14159 - delta = -6.2 / 180.0 * 3.14159 - wavelength = 1.54 -- TODO vérifier - --- Main - -irdrx :: IO () -irdrx = do - let mflat = Nothing - let method = CsrOcl - - p <- getPoniExtRef sampleRef - - let poniextref = move (Hkl.flip p) (Pose (MyMatrix HklB (ident 3))) - - -- full calibration - poniextref' <- calibrate sampleCalibration poniextref - - print poniextref' - - -- Integrate the flyscan mesh - -- 4.680504680504681e-3 per images (2*60+18) / 29484 this contain - -- read/write and computation - integrateMesh (XrdMeshParams poniextref' mflat method) [fly] - - -- integrate each step of the scan - -- _ <- mapConcurrently (integrate poniextref') [lab6] - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Laure.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Laure.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Laure.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Laure.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Projects.Diffabs.Laure - ( laure ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (lookup, readFile, writeFile) - -import Hkl - --- TODO --- Livre 45 p159 --- simplify with the list of nxs using list comprehension. --- add the flyscan mesh --- add possibility to sum a bunch of pixel coordinates from a mesh. on a mask - --- Samples - -project ∷ FilePath -project = "/nfs/ruche-diffabs/diffabs-users/20160370/" - -published ∷ FilePath -published = project "published-data" - -h5path ∷ NxEntry → DataFrameH5Path XrdOneD -h5path nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_02" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -mkNxs' ∷ FilePath → Int → (NxEntry → DataFrameH5Path a ) → Nxs a -mkNxs' d idx = mkNxs f' e - where - f ∷ FilePath → Int → (FilePath, NxEntry) - f d' i' = (d' printf "scan_%d.nxs" i', printf "scan_%d" (i' - 1)) - - (f', e) = f d idx - --- Calibration part - -sampleRef ∷ XRDRef -sampleRef = XRDRef "reference" - (published "calibration") - (XrdRefNxs - (mkNxs' (published "calibration") 45 h5path) - 10 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - ) - -sampleCalibration ∷ XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "calibration" - , xrdCalibrationDetector = ImXpadS140 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - idxs ∷ [Int] - idxs = [00, 01, 02, 03, 04, 09, 10, 11, 12, 14, 15, 18, 19, 22, 23, 26, 29, 33, 38, 42, 49, 53] - - entry ∷ Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs' (published "calibration") 45 h5path - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published "calibration" printf "scan_45.nxs_%02d.npt" idx - } - - entries ∷ [XRDCalibrationEntry] - entries = map entry idxs - --- Data treatment - -bins ∷ DIM1 -bins = ix1 3000 - -multibins ∷ DIM1 -multibins = ix1 25000 - -threshold ∷ Maybe Threshold -threshold = Just (Threshold 800) - -skipedFrames ∷ [Int] -skipedFrames = [4] - --- Flat - -flat ∷ [Nxs XrdFlat] -flat = [mkNxs' (project "2017" "Run1" "2017-02-15") idx h5path' | idx ← [57, 60 ∷ Int]] -- skip 58 59 for now (problème de droits d'accès) - where - h5path' :: NxEntry -> DataFrameH5Path XrdFlat - h5path' nxentry = XrdFlatH5Path (DataItemH5 (nxentry "scan_data/data_02") StrictDims) - --- Scan en delta - -mkXRDSample ∷ String → [(FilePath, [Int])] -> XRDSample -mkXRDSample n ps = XRDSample n - (published "xrd" n) - [ XrdNxs bins multibins threshold skipedFrames n' | n' ← concatMap nxs''' ps ] - where - nxs''' ∷ (FilePath, [Int]) → [XrdSource] - nxs''' (p, idxs) = [XrdSourceNxs (mkNxs' p idx h5path) | idx ← idxs] - - -air ∷ XRDSample -air = mkXRDSample "air" [ (project "2017" "Run1" "2017-02-17", [198 :: Int]) ] - -samples :: [XRDSample] -samples = air : map (uncurry mkXRDSample) - [ ("CeO2", [ (project "2017" "Run1" "2017-02-15", [45 :: Int]) ]) - , ("kapton", [ (project "2017" "Run1" "2017-02-17", [197 :: Int]) ]) - , ("chlorite", [ (project "2017" "Run1" "2017-02-15", [53 :: Int]) ]) - , ("dMnO2", [ (project "2017" "Run1" "2017-02-16", [135 :: Int]) ]) - , ("bulk_L2", [ (project "2017" "Shutdown1-2" "2017-02-19", [315..316 :: Int]) ]) - , ("L1-H_3", [ (project "2017" "Run1" "2017-02-15", concat [ [62..63 :: Int] - , [65..70 :: Int] - , [74, 75 :: Int] - ]) - , (project "2017" "Run1" "2017-02-16", [76..89 :: Int]) - ]) - , ("L1-H_4", [ (project "2017" "Run1" "2017-02-15", [71..73 :: Int]) - , (project "2017" "Run1" "2017-02-16", concat [ [90..94 :: Int] - , [96..103 :: Int] - , [119..127 :: Int] - ]) - ]) - , ("L1-H_5", [ (project "2017" "Run1" "2017-02-16", [104..118 :: Int]) ]) - , ("L1-Patine_1", [ (project "2017" "Run1" "2017-02-16", [136..151 :: Int]) - , (project "2017" "Run1" "2017-02-17", [152..184 :: Int] ++ [186 :: Int]) - ]) - , ("L1-Patine_2", [ (project "2017" "Run1" "2017-02-17", [187..196 :: Int]) ]) - , ("L2-H_1", [ (project "2017" "Run1" "2017-02-17", [199..213 :: Int]) ]) - , ("L2-H_2", [ (project "2017" "Run1" "2017-02-17", [214..220 :: Int]) - , (project "2017" "Run1" "2017-02-18", [221..228 :: Int] ++ [259..262 :: Int]) - ]) - , ("L2-H_3", [ (project "2017" "Run1" "2017-02-18", [229..248 :: Int]) ]) - , ("L2-PatineFoncee", [ (project "2017" "Run1" "2017-02-18", [249..258 :: Int]) ]) - , ("L2-PatineFonceeNew", [ (project "2017" "Run1" "2017-02-18", [263, 264, 266, 267 :: Int] ++ [269..273 :: Int]) ]) - , ("L2-patineLabo_1", [ (project "2017" "Shutdown1-2" "2017-02-19", [295..313 :: Int]) ]) - , ("L2-PatineClaire_1", [ (project "2017" "Shutdown1-2" "2017-02-19", [317..324 :: Int]) - , (project "2017" "Shutdown1-2" "2017-02-20", [325..356 :: Int]) - ]) - , ("L3-patine_1", [ (project "2017" "Run1" "2017-02-19", [274..293 :: Int]) - , (project "2017" "Shutdown1-2" "2017-02-19", [294, 295 :: Int]) - ]) - ] - --- Main - -laure ∷ IO () -laure = do - - -- compute the flat - flat' ← computeFlat flat (published "flat" "flat.npy") - - -- get a first ref poniExt - p ← getPoniExtRef sampleRef - -- flip the ref poni in order to fit the reality - -- let poniextref = p - let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - -- let poniextref = setPose (Hkl.PyFAI.PoniExt.flip p) (MyMatrix HklB (ident 3)) - print poniextref - - -- full calibration - poniextref' ← calibrate sampleCalibration poniextref - print poniextref' - - -- set the integration parameters - let mflat = Just flat' - let aiMethod = Csr - let params = XrdOneDParams poniextref' mflat aiMethod - - -- integrate scan with multi geometry - -- splitPixel (the only available now) → 17m47.825s - integrateMulti params samples - - -- Integrate each image of the scans - -- Lut → 21.52 minutes - -- Csr → 21.9 minutes - integrate params samples - - -- substrack the air from all samples - substract params air samples - substractMulti params air samples - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Martinetto.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Martinetto.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Martinetto.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Martinetto.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,295 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.Projects.Diffabs.Martinetto - ( martinetto - , martinetto' - ) where - -import Data.Array.Repa (DIM1, ix1) -import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl - --- Samples - -project :: FilePath -project = "/nfs/ruche-diffabs/diffabs-users/99160066/" - -published :: FilePath -published = project "published-data" - -h5path' :: NxEntry -> DataFrameH5Path XrdOneD -h5path' nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_53" - gamma = "d13-1-cx1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleCalibration :: XRDCalibration PyFAI -sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published "calibration" - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - - idxs :: [Int] - idxs = [3, 6, 9, 15, 18, 21, 24, 27, 30, 33, 36, 39, 43] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (published "calibration" "XRD18keV_26.nxs") "scan_26" h5path' - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published "calibration" printf "XRD18keV_26.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - - -sampleRef :: XRDRef -sampleRef = XRDRef "reference" - (published "calibration") - (XrdRefNxs - (mkNxs (published "calibration" "XRD18keV_26.nxs") "scan_26" h5path') - 6 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - ) - -h5path :: NxEntry -> DataFrameH5Path XrdOneD -h5path nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_58" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -bins :: DIM1 -bins = ix1 8000 - -multibins :: DIM1 -multibins = ix1 25000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 800) - -skipedFrames :: [Int] -skipedFrames = [] - -ceo2 :: XRDSample -ceo2 = XRDSample "CeO2" - (published "CeO2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (published "calibration" "XRD18keV_26.nxs") "scan_26" h5path' ] - ] - -n27t2 :: XRDSample -n27t2 = XRDSample "N27T2" - (published "N27T2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "N27T2_14.nxs") "scan_14" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "N27T2_17.nxs") "scan_17" h5path - ] - ] - -r23 :: XRDSample -r23 = XRDSample "R23" - (published "R23") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "R23_6.nxs") "scan_6" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "R23_12.nxs") "scan_12" h5path - ] - ] - -r18 :: XRDSample -r18 = XRDSample "R18" - (published "R18") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "R18_20.nxs") "scan_20" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "R18_24.nxs") "scan_24" h5path - ] - ] - -a3 :: XRDSample -a3 = XRDSample "A3" - (published "A3") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "A3_13.nxs") "scan_13" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "A3_14.nxs") "scan_14" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "A3_15.nxs") "scan_15" h5path - ] - ] - -a2 :: XRDSample -a2 = XRDSample "A2" - (published "A2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "A2_14.nxs") "scan_14" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "A2_17.nxs") "scan_17" h5path - ] - ] - -a26 :: XRDSample -a26 = XRDSample "A26" - (published "A26") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-26" "A26_50.nxs") "scan_50" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_51.nxs") "scan_51" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_52.nxs") "scan_52" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_53.nxs") "scan_53" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_54.nxs") "scan_54" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_55.nxs") "scan_55" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_56.nxs") "scan_56" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_57.nxs") "scan_57" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_58.nxs") "scan_58" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "A26_59.nxs") "scan_59" h5path - ] - ] - -d2 :: XRDSample -d2 = XRDSample "D2" - (published "D2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "D2_16.nxs") "scan_16" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "D2_17.nxs") "scan_17" h5path - ] - ] - -d3 :: XRDSample -d3 = XRDSample "D3" - (published "D3") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "D3_14.nxs") "scan_14" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "D3_15.nxs") "scan_15" h5path - ] - ] - -f30 :: XRDSample -f30 = XRDSample "F30" - (published "F30") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-26" "F30_11.nxs") "scan_11" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "F30_12.nxs") "scan_12" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "F30_13.nxs") "scan_13" h5path - ] - ] - -r11 :: XRDSample -r11 = XRDSample "R11" - (published "R11") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "R11_5.nxs") "scan_5" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "R11_6.nxs") "scan_6" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "R11_7.nxs") "scan_7" h5path - ] - ] - -d16 :: XRDSample -d16 = XRDSample "D16" - (published "D16") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "D16_12.nxs") "scan_12" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "D16_15.nxs") "scan_15" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "D16_17.nxs") "scan_17" h5path - ] - ] - -k9a2 :: XRDSample -k9a2 = XRDSample "K9A2" - (published "K9A2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "K9A2_1_31.nxs") "scan_31" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "K9A2_1_32.nxs") "scan_32" h5path - ] - ] - -r34n1 :: XRDSample -r34n1 = XRDSample "R34N1" - (published "R34N1") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-27" "R34N1_28.nxs") "scan_28" h5path - , mkNxs (project "2016" "Run2" "2016-03-27" "R34N1_37.nxs") "scan_37" h5path - ] - ] - -r35n1 :: XRDSample -r35n1 = XRDSample "R35N1" - (published "R35N1") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-26" "R35N1_25.nxs") "scan_19" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "R35N1_26.nxs") "scan_20" h5path - , mkNxs (project "2016" "Run2" "2016-03-26" "R35N1_27.nxs") "scan_21" h5path - ] - ] - --- meshSample :: String --- meshSample = project "2016" "Run2" "2016-03-28" "MELLE_29.nxs" --- scan_29 scan_data actuator_1_1 actuator_2_1 data_58 (images) - --- Main - -martinetto :: IO () -martinetto = do - -- lire le ou les ponis de référence ainsi que leur géométrie - -- associée. - - -- let samples = [ceo2, a2, a3, a26, d2, d3, d16, f30, k9a2, n27t2, r11, r18, r23, r34n1, r35n1] - let samples = [ceo2] - - p <- getPoniExtRef sampleRef - - -- flip the ref poni in order to fit the reality - -- let poniextref = Hkl.PyFAI.PoniExt.flip p - let poniextref = p - -- integrate each step of the scan - let params = XrdOneDParams poniextref Nothing Lut - integrate params samples - - -- plot de la figure. (script python ou autre ?) - return () - -martinetto' :: IO () -martinetto' = do - let samples = [ceo2, a2, a3, a26, d2, d3, d16, f30, k9a2, n27t2, r11, r18, r23, r34n1, r35n1] - let mflat = Nothing - - p <- getPoniExtRef sampleRef - - -- flip the ref poni in order to fit the reality - -- let poniextref = p - let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - -- let poniextref = setPose (Hkl.PyFAI.PoniExt.flip p) (MyMatrix HklB (ident 3)) - - -- full calibration - poniextref' <- calibrate sampleCalibration poniextref - -- print p - print poniextref - print poniextref' - - -- integrate each step of the scan - integrateMulti (XrdOneDParams poniextref' mflat Csr) samples - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Melle.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Melle.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs/Melle.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs/Melle.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,439 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Projects.Diffabs.Melle - ( melle ) where - --- import Control.Concurrent (setNumCapabilities) --- import Control.Concurrent.Async (mapConcurrently) -import Data.Array.Repa (DIM1, ix1) --- import Data.Char (toUpper) --- import Numeric.LinearAlgebra (ident) -import System.FilePath (()) -import Text.Printf (printf) - --- import Prelude hiding (concat, lookup, readFile, writeFile) - -import Hkl - -published ∷ FilePath -published = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/Reguer/USERSexperiences/melle" - --- TODO - --- MELLE / VIALAS --- Session 1 MACRO - 16-17 février 2016 (Logbook n° 42 p 169) --- Session 2 MICRO KB --28 mars 2016 (Logbook 42 + Logbook 43 p3) --- Session 3 MICRO pinhole - 22-24 juillet 2016 (Logbook 44 p33) --- Session 4 MACRO - septembre 2016 (Logbook 44 p63) - --- Session 1 - --- macrofaisceau --- 16keV --- Λ = 0,775 --- detection : XPAD S140 / image = data 54 --- sample : ω = 5 et χ = 70 - --- calibration = beam direct - --- - 3 MESH pour 3 positions du détecteur de diffraction (delta = -4, 3, 10), - --- macro python: --- for i in range (10): --- myx = -12+i*0,5 --- mv(samplex, myx) --- ascan(sampley, -8, 12, 100, 10) - --- scan_26 à 55.nxs --- diffabs-soleil/com-diffabs/2016/Run1/2016-02-16 ou 02-17 - --- 2THETA = 1 DELTA SCAN --- scan_56 = ascan(delta, -4, 70, 18, 3) --- scan_58 = ascan(delta, -4, 70, 18, 3) - - --- Session 2 - --- microbeam --- 18keV, ?= 0,6888Å --- detection : XPAD 3.2 / image = data 58 --- sample : ? = 5° et ? = 80°. --- calibration CeO2 --- data dans le dossier du proposal de Philippe Charlier 2015 1386 --- voir aussi script Martinetto proposal IHR 99160066 --- scan_25 = ascan(delta, -14.5, 60.5, 75, 0.5) --- scan_26 = ascan(delta, -14, 60, 75, 1) --- scan_27 = ascan(delta, -14, 60, 46, 1) - --- MESH : MELLE_29.nxs --- dossier: diffabs-soleil/com-diffabs/2016/Run2/2016-03-28 - --- calibration - -project2 :: FilePath -project2 = "/nfs/ruche-diffabs/diffabs-users/99160066/" - -published2:: FilePath -published2 = project2 "published-data" - -h5path2 :: NxEntry -> DataFrameH5Path XrdOneD -h5path2 nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_53" - gamma = "d13-1-cx1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - -sampleCalibration2 :: XRDCalibration PyFAI -sampleCalibration2 = XRDCalibration { xrdCalibrationName = "calibration2" - , xrdCalibrationOutputDir = published "calibration2" - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - idxs :: [Int] - idxs = [3, 6, 9, 15, 18, 21, 24, 27, 30, 33, 36, 39, 43] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (published2 "calibration" "XRD18keV_26.nxs") "scan_26" h5path2 - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published2 "calibration" printf "XRD18keV_26.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - -sampleRef2 :: XRDRef -sampleRef2 = XRDRef "reference" - (published2 "calibration") - (XrdRefNxs - (mkNxs (published2 "calibration" "XRD18keV_26.nxs") "scan_26" h5path2) - 6 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - ) - -bins :: DIM1 -bins = ix1 8000 - -multibins :: DIM1 -multibins = ix1 25000 - -threshold :: Maybe Threshold -threshold = Just (Threshold 800) - -skipedFrames :: [Int] -skipedFrames = [] - -melleScan :: XRDSample -melleScan = XRDSample "CeO2" - (published "xrd" "session2" "oned") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_25.nxs") "scan_25" h5path2 - , mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_26.nxs") "scan_26" h5path2 - , mkNxs (project "2016" "Run2" "2016-03-23" "XRD18keV_27.nxs") "scan_27" h5path2 - ] - ] - where - project ∷ FilePath - project = "/nfs/ruche-diffabs/diffabs-users/20151386/" - - -melleMesh :: XrdMeshSample -melleMesh = XrdMeshSample "MELLE_29" - (published "xrd" "session2" "mesh") - [ XrdMesh bins multibins threshold (XrdMeshSourceNxs n) | n <- - [ mkNxs (project2' "2016" "Run2" "2016-03-28" "MELLE_29.nxs") "scan_29" h5path2' - ] - ] - where - project2' :: FilePath - project2' = "/nfs/ruche-diffabs/diffabs-users/99160066/" - - h5path2' :: NxEntry -> DataFrameH5Path XrdMesh - h5path2' nxentry = - XrdMeshH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry meshX) StrictDims) - (DataItemH5 (nxentry meshY) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry beamline delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_58" - meshX = "scan_data/actuator_1_1" - meshY = "scan_data/actuator_2_1" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "D13-1-CX1__EX__DIF.1-DELTA__#1/raw_value" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - - -session2 :: IO () -session2 = do - -- compute the ref poni - p ← getPoniExtRef sampleRef2 - poniextref <- calibrate sampleCalibration2 p - - -- integrate the mesh - let mflat = Nothing - integrateMesh (XrdMeshParams poniextref mflat CsrOcl) [melleMesh] - - -- integrate the scan parts - let params = XrdOneDParams poniextref mflat Csr - integrate params [melleScan] - integrateMulti params [melleScan] - - return () - --- session 4 --- macro --- 18keV, ?= 0,6888Å --- detection : XPAD 3.2 - -session4 ∷ IO () -session4 = do - -- calibration - p ← getPoniExtRef sampleRef - poniextref <- calibrate sampleCalibration p - --- calibration : CeO2 --- On peut utiliser la calib de IHR_30, mais il faut prendre en compte le décentrage. --- IHR_56 --- IHR_58 --- sont deux autres possibilité de calibration. --- diffabs-soleil\com-diffabs\2016\Run4\2016-09-07 - - -- set the integration parameters - let mflat = Nothing - let params = XrdOneDParams poniextref mflat Csr - - -- integrate each step of the scan - integrate params [ceo2] - --- 1 seul "MESH"(20, 49) à partir d'une serie 2THETA --- IHR_63 à 95 --- diffabs-soleil\com-diffabs\2016\Run4\2016-09-07 --- IHR_96 à 190 --- diffabs-soleil\com-diffabs\2016\Run4\2016-09-08 --- obtenu via la macro suivante. --- for i in range(20): --- myx = -11 + i --- mv(txs, myx) # exhantillon à 45 degree donc ce double déplacement correspond au vrai x --- mv(tys, myx) --- for j in range(29): --- myy = 12 + j --- mv(tabV, myy) --- ascan(δ, -13.6, 30, 109, 5) - - return () - - where - - project :: FilePath - project = "/nfs/ruche-diffabs/diffabs-soleil/com-diffabs/" - - published' :: FilePath - published' = project "2016" "Run4B" "OutilsMetallo_CarolineHamon" - - sampleRef :: XRDRef - sampleRef = XRDRef "reference" - (published' "xrd" "calibration") - (XrdRefNxs - (mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path') - 33 - ) - - h5path' :: NxEntry -> DataFrameH5Path XrdOneD - h5path' nxentry = - XrdOneDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemH5 (nxentry beamline gamma) ExtendDims) - (DataItemH5 (nxentry delta) ExtendDims) - (DataItemH5 (nxentry beamline wavelength) StrictDims) - where - beamline :: String - beamline = beamlineUpper Diffabs - - image = "scan_data/data_02" - gamma = "D13-1-CX1__EX__DIF.1-GAMMA__#1/raw_value" - delta = "scan_data/actuator_1_1" - wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - - sampleCalibration :: XRDCalibration PyFAI - sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" - , xrdCalibrationOutputDir = published' "xrd" "calibration" -- TODO pourquoi ce output - , xrdCalibrationDetector = Xpad32 - , xrdCalibrationCalibrant = CeO2 - , xrdCalibrationEntries = entries - } - where - - idxs :: [Int] - idxs = [5, 33, 100, 246, 300, 436] - - entry :: Int -> XRDCalibrationEntry - entry idx = XRDCalibrationEntryNxs - { xrdCalibrationEntryNxs'Nxs = mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path' - , xrdCalibrationEntryNxs'Idx = idx - , xrdCalibrationEntryNxs'NptPath = published' "xrd" "calibration" printf "IHR_30.nxs_%02d.npt" idx - } - - entries :: [XRDCalibrationEntry] - entries = [ entry idx | idx <- idxs] - - bins :: DIM1 - bins = ix1 1000 - - multibins :: DIM1 - multibins = ix1 10000 - - threshold :: Maybe Threshold - threshold = Just (Threshold 5000) - - skipedFrames :: [Int] - skipedFrames = [] - - ceo2 :: XRDSample - ceo2 = XRDSample "CeO2" - (published "session4" "xrd" "CeO2") - [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- - [ mkNxs (project "2016" "Run4" "2016-09-07" "IHR_29.nxs") "scan_29" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_56.nxs") "scan_56" h5path' - , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_58.nxs") "scan_58" h5path' - ] - ] - --- * session 5 --- micro --- 18.05keV --- detection XPAD S140 - --- calibration CeO2 --- gam = 9 phi = 170 --- 18p1kev_71 --- gam = 9 phi = 175 --- 18p1kev_73 --- gam = 0 phi = 205 --- 18p1kev_74 --- gam = 0.3 phi = 205 --- 18p1kev_75 --- ruche-diffabs\diffabs-users\99170085\2017\Run3\2017-05-14 - --- FLAT (à verifier si suffisant) (faire la somme des trois fichiers) --- 18p1kev_82 --- 18p1kev_83 --- 18p1kev_84 --- ruche-diffabs\diffabs-users\99170085\2017\Run3\2017-05-14 - --- FLY -- ???? --- flyscan_16602 --- diffabs-soleil\com-diffabs\2017\Run3\fly_IHRSol - --- 2THETA = 1 DELTA SCAN --- 18p1kev_85 --- 18p1kev_86 --- ruche-diffabs\diffabs-users\99170085\2017\Run3\2017-05-14 - --- Samples - --- published :: FilePath --- published = project "published-data" - --- beamlineUpper :: Beamline -> String --- beamlineUpper b = [Data.Char.toUpper x | x <- show b] - --- nxs :: FilePath -> NxEntry -> (NxEntry -> DataFrameH5Path) -> Nxs --- nxs f e h = Nxs f e (h e) - --- nxs' :: FilePath -> NxEntry -> (NxEntry -> a) -> Nxs' a --- nxs' f e h = Nxs' f e (h e) - --- h5path :: NxEntry -> DataFrameH5Path --- h5path nxentry = --- DataFrameH5Path { h5pImage = DataItem (nxentry image) StrictDims --- , h5pGamma = DataItem (nxentry beamline gamma) ExtendDims --- , h5pDelta = DataItem (nxentry delta) ExtendDims --- , h5pWavelength = DataItem (nxentry beamline wavelength) StrictDims --- } --- where --- beamline :: String --- beamline = beamlineUpper Diffabs - --- image = "scan_data/data_53" --- gamma = "d13-1-cx1__EX__DIF.1-GAMMA__#1/raw_value" --- delta = "scan_data/actuator_1_1" --- wavelength = "D13-1-C03__OP__MONO__#1/wavelength" - --- sampleCalibration :: XRDCalibration --- sampleCalibration = XRDCalibration { xrdCalibrationName = "calibration" --- , xrdCalibrationOutputDir = published "calibration" --- , xrdCalibrationEntries = entries --- } --- where - --- idxs :: [Int] --- idxs = [3, 6, 9, 15, 18, 21, 24, 27, 30, 33, 36, 39, 43] - --- entry :: Int -> XRDCalibrationEntry --- entry idx = XRDCalibrationEntryNxs --- { xrdCalibrationEntryNxs'Nxs = nxs (published "calibration" "XRD18keV_26.nxs") "scan_26" h5path --- , xrdCalibrationEntryNxs'Idx = idx --- , xrdCalibrationEntryNxs'NptPath = published "calibration" printf "XRD18keV_26.nxs_%02d.npt" idx --- } - --- entries :: [XRDCalibrationEntry] --- entries = [ entry idx | idx <- idxs] - - --- sampleRef :: XRDRef --- sampleRef = XRDRef "reference" --- (published "calibration") --- (nxs (published "calibration" "XRD18keV_26.nxs") "scan_26" h5path) --- 6 -- BEWARE only the 6th poni was generated with the right Xpad_flat geometry. - --- bins :: DIM1 --- bins = ix1 8000 - --- multibins :: DIM1 --- multibins = ix1 25000 - --- threshold :: Threshold --- threshold = Threshold 800 - - --- p <- getPoniExtRef sampleRef - --- -- flip the ref poni in order to fit the reality --- -- let poniextref = p --- let poniextref = setPose p (MyMatrix HklB (ident 3)) --- -- let poniextref = setPose (Hkl.PyFAI.PoniExt.flip p) (MyMatrix HklB (ident 3)) - --- -- full calibration --- poniextref' <- calibrate sampleCalibration poniextref Xpad32 --- -- print p --- print poniextref --- print poniextref' - --- -- integrate each step of the scan --- _ <- mapM_ (integrateMesh poniextref') samples - --- return () - -melle ∷ IO () -melle = do - session2 - session4 diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Diffabs.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Diffabs.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -module Hkl.Projects.Diffabs (module X) where - -import Hkl.Projects.Diffabs.Charlier as X -import Hkl.Projects.Diffabs.Hamon as X -import Hkl.Projects.Diffabs.Hercules as X -import Hkl.Projects.Diffabs.IRDRx as X -import Hkl.Projects.Diffabs.Laure as X -import Hkl.Projects.Diffabs.Martinetto as X -import Hkl.Projects.Diffabs.Melle as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars/Romeden.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars/Romeden.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars/Romeden.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars/Romeden.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Projects.Mars.Romeden - ( romeden ) where - -import Codec.Picture (saveTiffImage) -import Control.Arrow ((&&&)) -import System.FilePath (()) -import System.FilePath.Glob (compile, globDir1) - -import Prelude hiding (concat, lookup, readFile, - writeFile) - -import Hkl - --- TODO --- ne pas planter lorsque l'image est manquante dans une nx entry. - -project ∷ FilePath --- project = "/nfs/ruche-mars/mars-soleil/com-mars/2017_Run2/comisioning_microfaisceau" --- project = "/home/experiences/instrumentation/picca" -project = "/media/picca/Transcend/ROMEDENNE" - -h5path ∷ NxEntry → DataFrameH5Path XrdFlat -h5path nxentry = - XrdFlatH5Path - (DataItemH5 (nxentry image) StrictDims) - where - image ∷ H5Path - image = "image#0/data" - -saveAsTiff' ∷ (Nxs XrdFlat, FilePath) → IO () -saveAsTiff' (n, o) = saveTiffImage o =<< toTiff n - -saveAsTiff ∷ (NxEntry -> DataFrameH5Path XrdFlat) → FilePath → IO () -saveAsTiff h5path' n = mapM_ (saveAsTiff' . (nxs &&& out)) =<< nxEntries n - where - nxs ∷ FilePath → Nxs XrdFlat - nxs nx = mkNxs (project n) nx h5path' - - out ∷ FilePath → FilePath - out nx = (project n) ++ nx ++ ".tiff" - --- Main - -romeden ∷ IO () -romeden = mapM_ (saveAsTiff h5path) =<< globDir1 (compile "*.nxs") project diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars/Schlegel.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars/Schlegel.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars/Schlegel.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars/Schlegel.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Projects.Mars.Schlegel - ( schlegel ) where - -import System.FilePath (()) - -import Prelude hiding (concat, lookup, readFile, writeFile) - -import Hkl - --- TODO --- check if the --- find a way to use integrateMulti with a small amount of memory. --- better mask for each detector. - --- Samples - -project :: FilePath -project = "/nfs/share-temp/picca/20160800" - -published :: FilePath -published = project "published-data" - -h5path :: NxEntry -> DataFrameH5Path XrdZeroD -h5path nxentry = - XrdZeroDH5Path - (DataItemH5 (nxentry image) StrictDims) - (DataItemConst 0.0485945) - where - image ∷ H5Path - image = "scan_data/data_01" - -sampleCalibration ∷ XrdZeroDCalibration PyFAI -sampleCalibration = XrdZeroDCalibration (XrdZeroDSample name outputdir entries) Xpad32 LaB6 - where - name ∷ String - name = "lab6" - - outputdir ∷ AbsDirPath - outputdir = published "xrd" "calibration" - - entries :: [XrdZeroDSource] - entries = [ XrdZeroDSourceNxs $ - mkNxs (project "2017" "Run3" "scan_5_01.nxs") "_5" h5path - ] - - --- bins :: DIM1 --- bins = ix1 1000 - --- multibins :: DIM1 --- multibins = ix1 10000 - --- threshold :: Maybe Threshold --- threshold = Just (Threshold 5000) - --- skipedFrames :: [Int] --- skipedFrames = [] - --- ceo2 :: XRDSample --- ceo2 = XRDSample "CeO2" --- (published "xrd" "CeO2") --- [ XrdNxs bins multibins threshold skipedFrames (XrdSourceNxs n) | n <- --- [ mkNxs (project "2016" "Run4" "2016-09-07" "IHR_29.nxs") "scan_29" h5path' --- , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_30.nxs") "scan_30" h5path' --- , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_56.nxs") "scan_56" h5path' --- , mkNxs (project "2016" "Run4" "2016-09-07" "IHR_58.nxs") "scan_58" h5path' --- ] --- ] - --- Main - -schlegel :: IO () -schlegel = do - -- pre-calibrate (extract from nexus to edf in order to do the - -- calibration) - extractEdf sampleCalibration - - -- p <- getPoniExtRef sampleRef - - -- let poniextref = move p (Pose (MyMatrix HklB (ident 3))) - - -- -- full calibration - -- poniextref' <- calibrate sampleCalibration poniextref - - -- print poniextref - -- print poniextref' - - -- -- Integrate the flyscan mesh - -- -- 4.680504680504681e-3 per images (2*60+18) / 29484 this contain - -- -- read/write and computation - -- -- integrateMesh (XrdMeshParams poniextref' mflat method) [fly] - - -- -- set the integration parameters - -- let mflat = Nothing - -- let aiMethod = Csr - -- let params = XrdOneDParams poniextref' mflat aiMethod - - -- -- integrate each step of the scan - -- integrate params [ceo2] - - -- -- this code doesn not work because there is not enought memory on - -- -- the computer. - -- -- integrateMulti params [ceo2] - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects/Mars.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects/Mars.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module Hkl.Projects.Mars (module X) where - -import Hkl.Projects.Mars.Schlegel as X -import Hkl.Projects.Mars.Romeden as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Projects.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Projects.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -module Hkl.Projects ( module X ) where - -import Hkl.Projects.D2AM as X -import Hkl.Projects.Diffabs as X -import Hkl.Projects.Mars as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/AzimuthalIntegrator.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/AzimuthalIntegrator.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/AzimuthalIntegrator.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/AzimuthalIntegrator.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.AzimuthalIntegrator - ( AIMethod(..) - ) where - -data AIMethod = Numpy | Cython | SplitPixel | Lut | Csr | NoSplitCsr | FullCsr | LutOcl | CsrOcl - -instance Show AIMethod where - show Numpy = "numpy" - show Cython = "cython" - show SplitPixel = "splitpixel" - show Lut = "lut" - show Csr = "csr" - show NoSplitCsr = "nosplit_csr" - show FullCsr = "full_csr" - show LutOcl = "lut_ocl" - show CsrOcl = "csr_ocl" diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Calib.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Calib.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Calib.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Calib.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.Calib - ( ToPyFAICalibArg(..) ) where - -import Data.Text (unpack) -import Numeric.Units.Dimensional.Prelude ((/~), nano, meter) - -import Hkl.Types ( WaveLength ) -import Hkl.Detector ( Detector ) -import Hkl.PyFAI.Calibrant ( Calibrant ) -import Hkl.PyFAI.Detector ( toPyFAI ) - -class ToPyFAICalibArg a where - toPyFAICalibArg ∷ a → String - -instance ToPyFAICalibArg FilePath where - toPyFAICalibArg f = f - -instance ToPyFAICalibArg (Detector a sh) where - toPyFAICalibArg d = "-D" ++ unpack (toPyFAI d) - -instance ToPyFAICalibArg Calibrant where - toPyFAICalibArg c = "-c " ++ show c - -instance ToPyFAICalibArg WaveLength where - toPyFAICalibArg w = "-w " ++ show ((w /~ nano meter) * 10) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Calibrant.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Calibrant.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Calibrant.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Calibrant.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.Calibrant - ( Calibrant(..) ) where - -data Calibrant = CeO2 | LaB6 - -instance Show Calibrant where - show CeO2 = "CeO2" - show LaB6 = "LaB6" diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Detector.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Detector.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Detector.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Detector.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.Detector - ( ToPyFAI(..) - ) where - -import Data.Text (Text) - -import Hkl.Detector - -class ToPyFAI a where - toPyFAI ∷ a → Text - -instance ToPyFAI (Detector a sh) where - toPyFAI Xpad32 = "Xpad_flat" - toPyFAI ImXpadS140 = "imxpad_s140" - toPyFAI XpadFlatCorrected = error "Unsupported Detector" - toPyFAI ZeroD = error "Unsupported Detector" - -instance ToPyFAI SomeDetector where - toPyFAI (SomeDetector v) = toPyFAI v diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Npt.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Npt.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Npt.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Npt.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hkl.PyFAI.Npt - ( Npt(..) - , NptEntry(..) - , NptPoint(..) - , nptP - , nptFromFile - ) where - -import Control.Applicative -import Data.Attoparsec.Text -import Data.Text -import Data.Text.IO (readFile) -import Numeric.Units.Dimensional.Prelude (Angle, Length, (*~), meter, radian) - -type Calibrant = Text - -data NptPoint = NptPoint { nptPointX :: Double - , nptPointY :: Double - } - deriving (Show) - -data NptEntry = NptEntry { nptEntryId :: Int - , nptEntryTth :: Angle Double - , nptEntryRing :: Int - , nptPoints :: [NptPoint] - } - deriving (Show) - -data Npt = Npt { nptComment :: [Text] - , nptCalibrant :: Calibrant - , nptWavelength :: Length Double - , npdDSpacing :: [Length Double] - , nptEntries :: [NptEntry] - } - deriving (Show) - -commentP :: Parser Text -commentP = "#" *> takeTill isEndOfLine <* endOfLine "commentP" - -headerP :: Parser [Text] -headerP = many1 commentP "headerP" - -calibrantP :: Parser Text -calibrantP = "calibrant: " *> takeTill isEndOfLine <* endOfLine "calibrantP" - -dspacingP :: Parser [Length Double] -dspacingP = "dspacing:" *> many1 lengthP' <* endOfLine "dspasingP" - -doubleP :: Text -> Parser Double -doubleP key = string key *> double <* endOfLine "doubleP" - -lengthP' :: Parser (Length Double) -lengthP' = do - skipSpace - value <- double - pure $ value *~ meter - -lengthP :: Text -> Parser (Length Double) -lengthP key = do - value <- doubleP key - pure $ value *~ meter - -angleP :: Text -> Parser (Angle Double) -angleP key = do - value <-doubleP key - pure $ value *~ radian - -intP :: Text -> Parser Int -intP key = string key *> decimal <* endOfLine "intP" - -nptPointP :: Parser NptPoint -nptPointP = NptPoint - <$> ("point: x=" *> double) - <*> (" y=" *> double <* endOfLine) - -nptEntryP :: Parser NptEntry -nptEntryP = NptEntry - <$> (skipSpace *> intP "New group of points: ") - <*> angleP "2theta: " - <*> intP "ring: " - <*> many nptPointP - -nptP :: Parser Npt -nptP = Npt - <$> headerP - <*> calibrantP - <*> lengthP "wavelength: " - <*> dspacingP - <*> many1 nptEntryP - "nptP" - -nptFromFile :: FilePath -> IO Npt -nptFromFile filename = do - content <- Data.Text.IO.readFile filename - return $ case parseOnly nptP content of - Left _ -> error $ "Can not parse the " ++ filename ++ " npt file" - Right a -> a diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/PoniExt.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/PoniExt.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/PoniExt.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/PoniExt.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.PoniExt - ( PoniExt(..) - , flip - , move - , set - ) where - -import Numeric.LinearAlgebra (ident) -import Numeric.Units.Dimensional.Prelude (Angle, Length) - -import Hkl.MyMatrix -import Hkl.PyFAI.Poni - -import Prelude hiding (flip) - -data PoniExt = PoniExt Poni Pose deriving (Show) - -flip :: PoniExt -> PoniExt -flip (PoniExt ps mym1) = PoniExt p mym1 - where - p = map poniEntryFlip ps - -set ∷ PoniExt - → Length Double -- distance - → Length Double -- poni1 - → Length Double -- poni2 - → Angle Double -- rot1 - → Angle Double -- rot2 - → Angle Double -- rot3 - → PoniExt -set (PoniExt ps _) d p1 p2 r1 r2 r3 = PoniExt p pose - where - p = map (poniEntrySet d p1 p2 r1 r2 r3) ps - pose = Pose (MyMatrix HklB (ident 3)) - -move :: PoniExt -> Pose -> PoniExt -move (PoniExt p1 (Pose mym1)) (Pose mym2) = PoniExt p (Pose mym2) - where - p = map (poniEntryMove mym1 mym2) p1 diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Poni.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Poni.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI/Poni.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI/Poni.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,245 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.PyFAI.Poni - ( Pose(..) - -- Poni - , Poni - , PoniPath - , poniP - , poniToText - -- PoniEntry - , PoniEntry - , poniEntryFlip - , poniEntryFromList - , poniEntryRotation - , poniEntryTranslation - , poniEntryToList - , poniEntrySet - , poniEntryMove - -- other - , fromAxisAndAngle - ) where - -import Control.Applicative (many, optional, (<|>)) -import Data.Attoparsec.Text (Parser, double, endOfLine, - isEndOfLine, many1, string, - takeTill, ()) -import Data.Text (Text, append, intercalate, - pack) -import Data.Vector.Storable (Vector, fromList) -import Numeric.LinearAlgebra (Matrix, atIndex, fromLists, - ident, scalar, tr, (<>)) -import Numeric.Units.Dimensional.Prelude (Angle, Length, degree, - meter, one, radian, (*~), - (+), (/~), (/~~)) -import Prelude hiding ((<>)) - -import Hkl.Detector -import Hkl.MyMatrix -import Hkl.PyFAI.Detector -import Hkl.Types - -type PoniPath = FilePath - --- Pose - -newtype Pose = Pose (MyMatrix Double) deriving (Show) - --- Poni - -data PoniEntry = PoniEntry { poniEntryHeader :: [Text] - , poniEntryDetector :: Maybe SomeDetector -- Detector Name - , poniEntryPixelSize1 :: Length Double -- pixels size 1 - , poniEntryPixelSize2 :: Length Double -- pixels size 1 - , poniEntryDistance :: Length Double -- pixels size 2 - , poniEntryPoni1 :: Length Double -- poni1 - , poniEntryPoni2 :: Length Double -- poni2 - , poniEntryRot1 :: Angle Double -- rot1 - , poniEntryRot2 :: Angle Double -- rot2 - , poniEntryRot3 :: Angle Double -- rot3 - , poniEntrySpline :: Maybe Text -- spline file - , poniEntryWavelength :: WaveLength -- wavelength - } - deriving (Show) - -type Poni = [PoniEntry] - -class ToPoni a where - toPoni ∷ a → Text - -instance ToPoni SomeDetector where - toPoni (SomeDetector v) = toPyFAI v - -instance ToPoni Double where - toPoni v = pack $ show v - -instance ToPoni Text where - toPoni = id - -commentP :: Parser Text -commentP = "#" *> takeTill isEndOfLine <* endOfLine "commentP" - -headerP :: Parser [Text] -headerP = many1 commentP "headerP" - -doubleP :: Text -> Parser Double -doubleP key = string key *> double <* endOfLine "doubleP" - -lengthP :: Text -> Parser (Length Double) -lengthP key = do - value <-doubleP key - pure $ value *~ meter - -angleP :: Text -> Parser (Angle Double) -angleP key = do - value <-doubleP key - pure $ value *~ radian - -detectorP ∷ ToPyFAI a ⇒ a → Parser a -detectorP d = do - _ ← "Detector: " *> string (toPyFAI d) <* endOfLine - pure d - -aDetectorP ∷ Parser SomeDetector -aDetectorP = (SomeDetector <$> detectorP Xpad32) <|> (SomeDetector <$> detectorP ImXpadS140) - -poniEntryP :: Parser PoniEntry -poniEntryP = PoniEntry - <$> headerP - <*> optional aDetectorP - <*> lengthP "PixelSize1: " - <*> lengthP "PixelSize2: " - <*> lengthP "Distance: " - <*> lengthP "Poni1: " - <*> lengthP "Poni2: " - <*> angleP "Rot1: " - <*> angleP "Rot2: " - <*> angleP "Rot3: " - <*> optional ("SplineFile: " *> takeTill isEndOfLine <* endOfLine) - <*> lengthP "Wavelength: " - "poniEntryP" - -poniP :: Parser Poni -poniP = many poniEntryP - -poniToText :: Poni -> Text -poniToText p = Data.Text.intercalate (Data.Text.pack "\n") (map poniEntryToText p) - -poniEntryToText :: PoniEntry -> Text -poniEntryToText p = intercalate (Data.Text.pack "\n") $ - map (Data.Text.append "#") (poniEntryHeader p) - ++ maybe [] (poniLine "Detector: ") (poniEntryDetector p) - ++ poniLine "PixelSize1: " (poniEntryPixelSize1 p /~ meter) - ++ poniLine "PixelSize2: " (poniEntryPixelSize2 p /~ meter) - ++ poniLine "Distance: " (poniEntryDistance p /~ meter) - ++ poniLine "Poni1: " (poniEntryPoni1 p /~ meter) - ++ poniLine "Poni2: " (poniEntryPoni2 p /~ meter) - ++ poniLine "Rot1: " (poniEntryRot1 p /~ radian) - ++ poniLine "Rot2: " (poniEntryRot2 p /~ radian) - ++ poniLine "Rot3: " (poniEntryRot3 p /~ radian) - ++ maybe [] (poniLine "SplineFile: ") (poniEntrySpline p) - ++ poniLine "Wavelength: " (poniEntryWavelength p /~ meter) - where - poniLine :: ToPoni a ⇒ String → a → [Text] - poniLine key v = [Data.Text.append (Data.Text.pack key) (toPoni v)] - -crossprod :: Vector Double -> Matrix Double -crossprod axis = fromLists [[ 0, -z, y], - [ z, 0, -x], - [-y, x, 0]] - where - x = axis `atIndex` 0 - y = axis `atIndex` 1 - z = axis `atIndex` 2 - -fromAxisAndAngle :: Vector Double -> Angle Double -> Matrix Double -fromAxisAndAngle axis angle = ident 3 Prelude.+ s * q Prelude.+ c * (q <> q) - where - c = scalar (1 - cos (angle /~ one)) - s = scalar (sin (angle /~ one)) - q = crossprod axis - -poniEntryFlip :: PoniEntry -> PoniEntry -poniEntryFlip p = p { poniEntryRot3 = new_rot3 } - where - rot3 = poniEntryRot3 p - new_rot3 = rot3 Numeric.Units.Dimensional.Prelude.+ 180 *~ degree - -poniEntryRotation :: PoniEntry -> Matrix Double -- TODO MyMatrix PyFAIB -poniEntryRotation e = Prelude.foldl (<>) (ident 3) rotations - where - rot1 = poniEntryRot1 e - rot2 = poniEntryRot2 e - rot3 = poniEntryRot3 e - rotations = Prelude.map (uncurry fromAxisAndAngle) - [ (fromList [0, 0, 1], rot3) - , (fromList [0, 1, 0], rot2) - , (fromList [1, 0, 0], rot1)] - -poniEntryTranslation :: PoniEntry -> Vector Double -poniEntryTranslation e = fromList ( [ poniEntryPoni1 e - , poniEntryPoni2 e - , poniEntryDistance e - ] /~~ meter ) - -poniEntryMove :: MyMatrix Double -> MyMatrix Double -> PoniEntry -> PoniEntry -poniEntryMove mym1 mym2 e = e { poniEntryRot1 = new_rot1 - , poniEntryRot2 = new_rot2 - , poniEntryRot3 = new_rot3 - } - where - rot1 = poniEntryRot1 e - rot2 = poniEntryRot2 e - rot3 = poniEntryRot3 e - rotations = Prelude.map (uncurry fromAxisAndAngle) - [ (Data.Vector.Storable.fromList [0, 0, 1], rot3) - , (Data.Vector.Storable.fromList [0, 1, 0], rot2) - , (Data.Vector.Storable.fromList [1, 0, 0], rot1)] - -- M1 . R0 = R1 - r1 = Prelude.foldl (<>) (ident 3) rotations -- pyFAIB - -- M2 . R0 = R2 - -- R2 = M2 . M1.T . R1 - r2 = Prelude.foldl (<>) m2 [tr m1, r1] - (new_rot1, new_rot2, new_rot3) = toEulerians r2 - - (MyMatrix _ m1) = changeBase mym1 PyFAIB - (MyMatrix _ m2) = changeBase mym2 PyFAIB - -poniEntrySet ∷ Length Double -- distance - → Length Double -- poni1 - → Length Double -- poni2 - → Angle Double -- rot1 - → Angle Double -- rot2 - → Angle Double -- rot3 - → PoniEntry - → PoniEntry -poniEntrySet d p1 p2 r1 r2 r3 p = - p { poniEntryDistance = d - , poniEntryPoni1 = p1 - , poniEntryPoni2 = p2 - , poniEntryRot1 = r1 - , poniEntryRot2 = r2 - , poniEntryRot3 = r3 - } - -poniEntryFromList :: PoniEntry -> [Double] -> PoniEntry -poniEntryFromList p [rot1, rot2, rot3, poni1, poni2, d] = - p { poniEntryDistance = d *~ meter - , poniEntryPoni1 = poni1 *~ meter - , poniEntryPoni2 = poni2 *~ meter - , poniEntryRot1 = rot1 *~ radian - , poniEntryRot2 = rot2 *~ radian - , poniEntryRot3 = rot3 *~ radian - } -poniEntryFromList _ _ = error "Can not convert to a PoniEntry" - -poniEntryToList :: PoniEntry -> [Double] -poniEntryToList p = [ poniEntryRot1 p /~ radian - , poniEntryRot2 p /~ radian - , poniEntryRot3 p /~ radian - , poniEntryPoni1 p /~ meter - , poniEntryPoni2 p /~ meter - , poniEntryDistance p /~ meter - ] diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/PyFAI.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/PyFAI.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -module Hkl.PyFAI (module X) where - -import Hkl.PyFAI.AzimuthalIntegrator as X -import Hkl.PyFAI.Calib as X -import Hkl.PyFAI.Calibrant as X -import Hkl.PyFAI.Detector as X -import Hkl.PyFAI.Poni as X -import Hkl.PyFAI.PoniExt as X -import Hkl.PyFAI.Npt as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Python.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Python.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Python.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Python.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Python - ( PyVal(..) ) where - -import Data.List (intercalate) - -class PyVal a where - toPyVal ∷ a → String - -instance PyVal a ⇒ PyVal (Maybe a) where - toPyVal (Just v) = toPyVal v - toPyVal Nothing = "None" - -instance PyVal String where - toPyVal = show - -instance PyVal [String] where - toPyVal vs = "[" ++ intercalate ",\n" (map toPyVal vs) ++ "]" - -instance PyVal Int where - toPyVal = show - -instance PyVal [Int] where - toPyVal is = "[" ++ intercalate ",\n" (map toPyVal is) ++ "]" - -instance PyVal Double where - toPyVal = show diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Script.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Script.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Script.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Script.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Script - ( Gnuplot - , Py2 - , Sh - , Script(..) - , run - , scriptRun - , scriptSave ) - where - -import Control.Monad (when) -import Data.Bits ((.|.)) -import Data.Text (Text) -import Data.Text.IO (writeFile) -import System.Directory (createDirectoryIfMissing, withCurrentDirectory) -import System.Exit ( ExitCode ( ExitSuccess ) ) -import System.FilePath ( (<.>), takeDirectory) -import System.Posix.Files (accessModes, groupModes, ownerModes, setFileMode) -import System.Posix.Types (FileMode) -import System.Process ( rawSystem ) -- callProcess for futur - -import Paths_hkl (getDataFileName) - -type Profile = Bool - -data Gnuplot -data Py2 -data Sh - -data Script a where - Py2Script ∷ (Text, FilePath) → Script Py2 - ScriptGnuplot ∷ (Text, FilePath) → Script Gnuplot - ScriptSh ∷ (Text, FilePath) → Script Sh - -scriptSave' ∷ Text → FilePath → FileMode → IO () -scriptSave' c f m = do - createDirectoryIfMissing True (takeDirectory f) - Data.Text.IO.writeFile f c - setFileMode f m - print $ "--> created : " ++ f - -scriptSave ∷ Script a → IO () -scriptSave (Py2Script (c, f)) = scriptSave' c f (ownerModes .|. groupModes) -scriptSave (ScriptGnuplot (c, f)) = scriptSave' c f accessModes -scriptSave (ScriptSh (c, f)) = scriptSave' c f (ownerModes .|. groupModes) - -scriptRun' ∷ FilePath → String → [String] → Bool → IO ExitCode -scriptRun' f prog args d - | d = withCurrentDirectory directory go - | otherwise = go - where - go :: IO ExitCode - go = rawSystem prog args - - directory :: FilePath - directory = takeDirectory f - -scriptRun ∷ Script a → Bool → IO ExitCode -scriptRun (Py2Script (_, p)) d = do - ExitSuccess ← scriptRun' p "python" args d - when p' ( do - gprof2dot ← getDataFileName "data/gprof2dot.py" - ExitSuccess ← rawSystem gprof2dot ["-f", "pstats", stats, "-o", stats <.> "dot"] - ExitSuccess ← rawSystem dot ["-Tsvg", "-o", stats <.> "svg", stats <.> "dot"] - return () - ) - return ExitSuccess - where - -- BEWARE once actived the profiling multiply by two the computing time. - p' ∷ Profile - p' = True - - dot ∷ String - dot = "dot" - - stats ∷ String - stats = p <.> "pstats" - - args :: [String] - args - | p' = ["-m" , "cProfile", "-o", stats, p] - | otherwise = [p] -scriptRun (ScriptGnuplot (_, p)) d = scriptRun' p "gnuplot" [p] d -scriptRun (ScriptSh (_, p)) d = scriptRun' p p [] d - -run ∷ Script a → Bool → IO ExitCode -run s b = do - scriptSave s - scriptRun s b diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Tiff.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Tiff.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Tiff.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Tiff.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Tiff - ( ToTiff(..) ) where - -import Codec.Picture ( DynamicImage ) - -class ToTiff a where - toTiff ∷ a → IO DynamicImage diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Utils.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Utils.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Utils.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Utils.hs 2021-12-08 09:14:21.000000000 +0000 @@ -1,14 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE UnicodeSyntax #-} module Hkl.Utils ( hasContent ) where -import Data.Text (Text) -import Data.Text.IO (writeFile) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) +import Data.Text (Text) +import Data.Text.IO (writeFile) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) hasContent ∷ FilePath → Text → IO () hasContent f c = do diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/Calibration.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/Calibration.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/Calibration.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/Calibration.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,286 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Xrd.Calibration - ( NptExt(..) - , XRDCalibrationEntry(..) - , XRDCalibration(..) - , calibrate - , extractEdf - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Array.Repa.Index (DIM2) -import Data.ByteString.Char8 (pack) -import Data.List (foldl') -import Data.Text (pack, unlines) -import Data.Vector.Storable (Vector, fromList, slice, - toList) -import Numeric.GSL.Minimization (MinimizeMethod (NMSimplex2), - minimizeV) -import Numeric.LinearAlgebra (Matrix, atIndex, ident, - ( #> ), (<>)) -import Numeric.Units.Dimensional.Prelude (meter, nano, radian, (*~), - (/~)) -import Pipes.Safe (MonadSafe, bracket, - runSafeT) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath.Posix (takeFileName, ()) -import Text.Printf (printf) - -import Prelude hiding ((<>)) - -import Hkl.C -import Hkl.DataSource -import Hkl.Detector -import Hkl.Edf -import Hkl.H5 -import Hkl.MyMatrix -import Hkl.Nxs -import Hkl.PyFAI -import Hkl.Python -import Hkl.Script -import Hkl.Types -import Hkl.Xrd.OneD - --- Calibration - -data NptExt a = NptExt { nptExtNpt :: Npt - , nptExtPose :: Pose - , nptExtDetector :: Detector a DIM2 - } - deriving (Show) - -data XRDCalibrationEntry = XRDCalibrationEntryNxs { xrdCalibrationEntryNxs'Nxs :: Nxs XrdOneD - , xrdCalibrationEntryNxs'Idx :: Int - , xrdCalibrationEntryNxs'NptPath :: FilePath - } - | XRDCalibrationEntryEdf { xrdCalibrationEntryEdf'Edf :: FilePath - , xrdCalibrationEntryEdf'NptPath :: FilePath - } - deriving (Show) - -data XRDCalibration a = XRDCalibration { xrdCalibrationName :: SampleName - , xrdCalibrationOutputDir :: AbsDirPath - , xrdCalibrationDetector ∷ Detector a DIM2 - , xrdCalibrationCalibrant ∷ Calibrant - , xrdCalibrationEntries :: [XRDCalibrationEntry] - } - deriving (Show) - -withDataItem :: MonadSafe m => File -> DataItem H5 -> (Dataset -> m r) -> m r -withDataItem hid (DataItemH5 name _) = bracket (liftIO acquire') (liftIO . release') - where - acquire' :: IO Dataset - acquire' = openDataset hid (Data.ByteString.Char8.pack name) Nothing - - release' :: Dataset -> IO () - release' = closeDataset - -getPoseNxs :: File -> DataFrameH5Path XrdOneD -> Int -> IO Pose -- TODO move to XRD -getPoseNxs f (XrdOneDH5Path _ g d w) i' = runSafeT $ - withDataItem f g $ \g' -> - withDataItem f d $ \d' -> - withDataItem f w $ \w' -> liftIO $ do - let mu = 0.0 - let komega = 0.0 - let kappa = 0.0 - let kphi = 0.0 - gamma <- get_position g' 0 - delta <- get_position d' i' - wavelength <- get_position w' 0 - let source = Source (wavelength *~ nano meter) - let positions = Data.Vector.Storable.fromList [mu, komega, kappa, kphi, gamma, delta] - let geometry = Geometry K6c source positions Nothing - let detector = ZeroD - m <- geometryDetectorRotationGet geometry detector - return $ Pose (MyMatrix HklB m) - - -getWavelength ∷ File → DataFrameH5Path XrdOneD → IO WaveLength -getWavelength f (XrdOneDH5Path _ _ _ w) = runSafeT $ - withDataItem f w $ \w' -> liftIO $ do - wavelength <- get_position w' 0 - return $ wavelength *~ nano meter - -readWavelength :: XRDCalibrationEntry -> IO WaveLength -readWavelength e = - withH5File f $ \h5file -> getWavelength h5file p - where - (Nxs f p) = xrdCalibrationEntryNxs'Nxs e - - -readXRDCalibrationEntry :: Detector a DIM2 -> XRDCalibrationEntry -> IO (NptExt a) -readXRDCalibrationEntry d e@XRDCalibrationEntryNxs{} = - withH5File f $ \h5file -> NptExt - <$> nptFromFile (xrdCalibrationEntryNxs'NptPath e) - <*> getPoseNxs h5file p idx - <*> pure d - where - idx = xrdCalibrationEntryNxs'Idx e - (Nxs f p) = xrdCalibrationEntryNxs'Nxs e -readXRDCalibrationEntry d e@(XRDCalibrationEntryEdf _ _) = - NptExt - <$> nptFromFile (xrdCalibrationEntryEdf'NptPath e) - <*> getPoseEdf (xrdCalibrationEntryEdf'Edf e) - <*> pure d - --- Poni Calibration - --- The minimized function is the quadratic difference of the --- theoretical tth angle and for each pixel, the computed tth angle. - --- synonyme types use in order to improve the calibration performance - -type NptEntry' = (Double, [Vector Double]) -- tth, detector pixels coordinates -type Npt' = (Double, [NptEntry']) -- wavelength, [NptEntry'] -type NptExt' a = (Npt', Matrix Double, Detector a DIM2) - -class ToGsl a where - toGsl ∷ a → Vector Double - -class FromGsl a where - fromGsl ∷ a → Vector Double → a - -class ToGslFunc a where - toGslFunc ∷ a → [NptExt b] → (Vector Double → Double) - -instance ToGsl PoniExt where - toGsl (PoniExt p _) = fromList $ poniEntryToList (last p) - -instance FromGsl PoniExt where - fromGsl (PoniExt p pose) v = PoniExt poni pose - where - poni ∷ Poni - poni = [poniEntryFromList (last p) (toList v)] - -instance ToGslFunc PoniExt where - toGslFunc _ npts = f (preCalibrate npts) - where - preCalibrate''' ∷ Detector a sh → NptEntry → NptEntry' - preCalibrate''' detector (NptEntry _ tth _ points) = (tth /~ radian, map (coordinates detector) points) - - preCalibrate'' ∷ Npt → Detector a sh → Npt' - preCalibrate'' n detector = (nptWavelength n /~ meter, map (preCalibrate''' detector) (nptEntries n)) - - preCalibrate' ∷ NptExt a → NptExt' a - preCalibrate' (NptExt n (Pose m) detector) = (preCalibrate'' n detector, m', detector) - where - (MyMatrix _ m') = changeBase m PyFAIB - - preCalibrate ∷ [NptExt a] → [NptExt' a] - preCalibrate = map preCalibrate' - - f :: [NptExt' a] → Vector Double → Double - f ns params = foldl' (f' rotation translation) 0 ns - where - rot1 = params `atIndex` 0 - rot2 = params `atIndex` 1 - rot3 = params `atIndex` 2 - - rotations = map (uncurry fromAxisAndAngle) - [ (fromList [0, 0, 1], rot3 *~ radian) - , (fromList [0, 1, 0], rot2 *~ radian) - , (fromList [1, 0, 0], rot1 *~ radian)] - - rotation = foldl' (<>) (ident 3) rotations - - translation :: Vector Double - translation = slice 3 3 params - - f' ∷ Matrix Double → Vector Double → Double → NptExt' a → Double - f' rotation translation x ((_wavelength, entries), m, _detector) = - foldl' (f'' translation r) x entries - where - r :: Matrix Double - r = m <> rotation - - f'' ∷ Vector Double → Matrix Double → Double → NptEntry' → Double - {-# INLINE f'' #-} - f'' translation r x (tth, pixels) = foldl' (f''' translation r tth) x pixels - - f''' ∷ Vector Double → Matrix Double → Double → Double → Vector Double → Double - {-# INLINE f''' #-} - f''' translation r tth x pixel = x + dtth * dtth - where - kf = r #> (pixel - translation) - x' = kf `atIndex` 0 - y' = kf `atIndex` 1 - z' = kf `atIndex` 2 - - dtth = tth - atan2 (sqrt (x'*x' + y'*y')) (-z') - -calibrate ∷ XRDCalibration a → PoniExt → IO PoniExt -calibrate (XRDCalibration _ _ d _ es) p = do - npts ← mapM (readXRDCalibrationEntry d) es - let guess = toGsl p - let f = toGslFunc p npts - let box = fromList [0.1, 0.1, 0.1, 0.01, 0.01, 0.01] - let (solution, _p) = minimizeV NMSimplex2 1E-16 3000 box f guess - print _p - return $ fromGsl p solution - --- Edf extraction before calibration - -edf ∷ AbsDirPath → FilePath → Int → FilePath -edf o n i = o f - where - f = takeFileName n ++ printf "_%02d.edf" i - -scriptExtractEdf ∷ AbsDirPath → [XRDCalibrationEntry] → Script Py2 -scriptExtractEdf o es = Py2Script (content, scriptPath) - where - content = Data.Text.unlines $ - map Data.Text.pack [ "#!/bin/env python" - , "" - , "from fabio.edfimage import edfimage" - , "from h5py import File" - , "" - , "NEXUSFILES = " ++ toPyVal nxss - , "IDXS = " ++ toPyVal idxs - , "IMAGEPATHS = " ++ toPyVal (imgs ∷ [String]) - , "OUTPUTS = " ++ toPyVal outputs - , "" - , "for filename, i, p, o in zip(NEXUSFILES, IDXS, IMAGEPATHS, OUTPUTS):" - , " with File(filename, mode='r') as f:" - , " edfimage(f[p][i]).write(o)" - ] - - (nxss, idxs, imgs) = unzip3 [(f, i, img) | (XRDCalibrationEntryNxs (Nxs f (XrdOneDH5Path (DataItemH5 img _) _ _ _)) i _) ← es] - - outputs ∷ [FilePath] - outputs = zipWith (edf o) nxss idxs - - scriptPath ∷ FilePath - scriptPath = o "pre-calibration.py" - -scriptPyFAICalib ∷ AbsDirPath → XRDCalibrationEntry → Detector a sh → Calibrant → WaveLength → Script Sh -scriptPyFAICalib o e d c w = ScriptSh (content, scriptPath) - where - content = Data.Text.unlines $ - map Data.Text.pack [ "#!/usr/bin/env sh" - , "" - , "pyFAI-calib " ++ unwords args - ] - - args = [ toPyFAICalibArg w - , toPyFAICalibArg c - , toPyFAICalibArg d - , toPyFAICalibArg (edf o n i) ] - - (XRDCalibrationEntryNxs (Nxs n _) i _) = e - - scriptPath ∷ FilePath - scriptPath = o takeFileName n ++ printf "_%02d.sh" i - - -instance ExtractEdf (XRDCalibration a) where - extractEdf (XRDCalibration _ o d c es) = do - let script = scriptExtractEdf o es - ExitSuccess ← run script False - mapM_ go es - where - go e = do - w ← readWavelength e - scriptSave $ scriptPyFAICalib o e d c w diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/Mesh.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/Mesh.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/Mesh.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/Mesh.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Xrd.Mesh - ( XrdMeshSample(..) - , XrdMesh'(..) - , XrdMeshParams(..) - , XrdMeshSource(..) - , integrateMesh - ) where - -import Control.Concurrent.Async (mapConcurrently) -import Control.Monad (void) -import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) -import Data.Array.Repa (Shape, DIM1, ix1, size) -import Data.Maybe (fromJust) -import Data.Vector.Storable (Vector, any, concat, head, singleton) -import Numeric.Units.Dimensional.Prelude (meter, nano, (/~), (*~)) -import System.Exit ( ExitCode( ExitSuccess ) ) -import System.FilePath ((), (<.>), dropExtension, splitDirectories, takeFileName) - -import qualified Data.Text as Text (unlines, pack) - -import Prelude hiding - ( any - , concat - , head - , lookup - , readFile - , unlines - ) -import Pipes ( lift ) - -import Hkl.C -import Hkl.DataSource -import Hkl.Detector -import Hkl.Flat -import Hkl.H5 -import Hkl.PyFAI -import Hkl.Python -import Hkl.MyMatrix -import Hkl.Nxs -import Hkl.Script -import Hkl.Types -import Hkl.Utils -import Hkl.Xrd.OneD - --- Types - -data XrdMeshSource = XrdMeshSourceNxs (Nxs XrdMesh) - | XrdMeshSourceNxsFly [Nxs XrdMesh] - deriving (Show) - -data XrdMesh' = XrdMesh DIM1 DIM1 (Maybe Threshold) XrdMeshSource deriving (Show) - -data XrdMeshSample = XrdMeshSample SampleName AbsDirPath [XrdMesh'] deriving (Show) -- nxss - -data XrdMeshParams a = XrdMeshParams PoniExt (Maybe (Flat a)) AIMethod - -data XrdMeshFrame = XrdMeshFrame - WaveLength - Pose - deriving (Show) - -class FrameND t where - rowND :: t -> MaybeT IO XrdMeshFrame - -instance FrameND (DataFrameH5 XrdMesh) where - - rowND (XrdMeshH5 _ _ _ _ _ g d w) = do - let mu = 0.0 - let komega = 0.0 - let kappa = 0.0 - let kphi = 0.0 - gamma <- get_position' g (ix1 0) - delta <- get_position' d (ix1 0) - wavelength <- get_position' w (ix1 0) - let source@(Source w') = Source (head wavelength *~ nano meter) - let positions = concat [mu, komega, kappa, kphi, gamma, delta] - let geometry = Geometry K6c source positions Nothing - let detector = ZeroD - m <- lift $ geometryDetectorRotationGet geometry detector - let pose = Pose (MyMatrix HklB m) - return $ XrdMeshFrame w' pose - where - get_position' :: Shape sh => DataSource a -> sh -> MaybeT IO (Vector Double) - get_position' (DataSourceH5 _ a ) b = lift $ do - v <- get_position_new a b - if any isNaN v then fail "File contains Nan" else return v - get_position' (DataSourceConst v) _ = lift $ return $ singleton v - - rowND (XrdMeshFlyH5 _ _ _ _ _ g d w) = do - let mu = 0.0 - let komega = 0.0 - let kappa = 0.0 - let kphi = 0.0 - gamma <- get_position' g (ix1 0) - delta <- get_position' d (ix1 0) - wavelength <- get_position' w (ix1 0) - let source@(Source w') = Source (head wavelength *~ nano meter) - let positions = concat [mu, komega, kappa, kphi, gamma, delta] - let geometry = Geometry K6c source positions Nothing - let detector = ZeroD - m <- lift $ geometryDetectorRotationGet geometry detector - let pose = Pose (MyMatrix HklB m) - return $ XrdMeshFrame w' pose - where - get_position' :: Shape sh => DataSource a -> sh -> MaybeT IO (Vector Double) - get_position' (DataSourceH5 _ a ) b = lift $ do - v <- get_position_new a b - if any isNaN v then fail "File contains Nan" else return v - get_position' (DataSourceConst v) _ = lift $ return $ singleton v - -integrateMesh ∷ XrdMeshParams a → [XrdMeshSample] → IO () -integrateMesh p ss = void $ mapConcurrently (integrateMesh' p) ss - -integrateMesh' ∷ XrdMeshParams a → XrdMeshSample → IO () -integrateMesh' p (XrdMeshSample _ output nxss) = mapM_ (integrateMesh'' p output) nxss - -getWaveLengthAndPoniExt' ∷ XrdMeshParams a → Nxs XrdMesh → IO (WaveLength, PoniExt) -getWaveLengthAndPoniExt' (XrdMeshParams ref _ _) nxs = - withDataSource nxs $ \h -> do - -- read the first frame and get the poni used for all the integration. - d <- runMaybeT $ rowND h - let (XrdMeshFrame w p) = fromJust d - let poniext = move ref p - return (w, poniext) - -getWaveLengthAndPoniExt ∷ XrdMeshParams a → XrdMeshSource → IO (WaveLength, PoniExt) -getWaveLengthAndPoniExt p (XrdMeshSourceNxs nxs) = getWaveLengthAndPoniExt' p nxs -getWaveLengthAndPoniExt p (XrdMeshSourceNxsFly (nxs:_)) = getWaveLengthAndPoniExt' p nxs -getWaveLengthAndPoniExt _ (XrdMeshSourceNxsFly []) = error "getWaveLengthAndPoniExt" - -getOutputPath' ∷ AbsDirPath → FilePath → (FilePath, FilePath, FilePath) -getOutputPath' o d = (poni, h5, py) - where - poni = o d d <.> "poni" - h5 = o d d <.> "h5" - py = o d d <.> "py" - -getOutputPath ∷ AbsDirPath → XrdMeshSource → (FilePath, FilePath, FilePath) -getOutputPath o (XrdMeshSourceNxs (Nxs f _)) = getOutputPath' o dir - where - dir ∷ FilePath - dir = (dropExtension . takeFileName) f -getOutputPath o (XrdMeshSourceNxsFly (Nxs _ h:_)) = getOutputPath' o dir - where - (XrdMeshFlyH5Path (DataItemH5 i _) _ _ _ _ _) = h - dir:_ = splitDirectories i -getOutputPath _ (XrdMeshSourceNxsFly []) = error "getOutputPath" - - -xrdMeshPy'' ∷ Maybe (Flat a) - → AIMethod -- pyFAI azimuthal integration method - → [FilePath] -- nexus files - → H5Path -- image path - → H5Path -- meshx path - → H5Path -- meshy path - → FilePath -- ponipath - → DIM1 -- bins - → Maybe Threshold -- threshold - → WaveLength -- wavelength - → FilePath -- output h5 - → FilePath -- script name - → Script Py2 -xrdMeshPy'' mflat m fs i x y p b mt w o scriptPath = Py2Script (content, scriptPath) - where - content = Text.unlines $ - map Text.pack ["#!/bin/env python" - , "" - , "import itertools" - , "import numpy" - , "from h5py import File" - , "from pyFAI import load" - , "" - , "PONIFILE = " ++ toPyVal p - , "NEXUSFILES = " ++ toPyVal fs - , "MESHX = " ++ toPyVal x - , "MESHY = " ++ toPyVal y - , "IMAGEPATH = " ++ toPyVal i - , "N = " ++ toPyVal (size b) - , "OUTPUT = " ++ toPyVal o - , "WAVELENGTH = " ++ toPyVal (w /~ meter) - , "" - , "# Load the flat" - , "flat = " ++ toPyVal mflat - , "" - , "# Load and prepare the common Azimuthal Integrator" - , "ai = load(PONIFILE)" - , "ai.wavelength = WAVELENGTH" - , "ai._empty = numpy.nan" - , "" - , "# Compute the fix part of the mask" - , "mask = numpy.zeros_like(ai.detector.mask, dtype=bool)" - , "mask[0:50, :] = True" - , "mask[910:960, :] = True" - , "mask[:,0:50] = True" - , "mask[:,510:560] = True" - , "if flat is None:" - , " mask = numpy.logical_or(mask, ai.detector.mask)" - , "" - , dummiesForPy mt - , "" - , "# Compute the size of the output" - , "FS = [File(n, mode='r') for n in NEXUSFILES]" - , "NX = 0" - , "NY = 0" - , "for f in FS:" - , " NX = f[MESHX].shape[1]" - , " NY += f[MESHY].shape[0]" - , "" - , "def gen(fs):" - , " for f in fs:" - , " for i in f[IMAGEPATH]:" - , " yield i" - , "" - , "# Create and fill the ouput file" - , "with File(OUTPUT, mode='w') as o:" - , " dataset = o.create_dataset('map', shape=(NY, NX, N), dtype='float')" - , " lines = gen(FS)" - , " for j, line in enumerate(lines):" - , " for i, img in enumerate(line):" - , " tth, I, sigma = ai.integrate1d(img, N, unit=\"2th_deg\"," - , " error_model=\"poisson\", correctSolidAngle=False," - , " method=\"" ++ show m ++ "\"," - , " mask=mask," - , " dummy=DUMMY, delta_dummy=DELTA_DUMMY," - , " safe=False, flat=flat)" - , " dataset[j, i] = I" - ] - -xrdMeshPy' ∷ XrdMeshParams a - → XrdMeshSource -- data source - → FilePath -- ponipath - → DIM1 -- bins - → Maybe Threshold -- threshold - → WaveLength -- wavelength - → FilePath -- output h5 - → FilePath -- script name - → Script Py2 -xrdMeshPy' (XrdMeshParams _ mflat m) (XrdMeshSourceNxs (Nxs f h5path)) p b mt w o scriptPath = - xrdMeshPy'' mflat m [f] i x y p b mt w o scriptPath - where - (XrdMeshH5Path (DataItemH5 i _) (DataItemH5 x _) (DataItemH5 y _) _ _ _) = h5path -xrdMeshPy' (XrdMeshParams _ mflat m) (XrdMeshSourceNxsFly nxss) p b mt w o scriptPath = - xrdMeshPy'' mflat m fs i x y p b mt w o scriptPath - where - fs ∷ [FilePath] - fs = [f | (Nxs f _) ← nxss] - - Nxs _ h5path:_ = nxss - - (XrdMeshFlyH5Path (DataItemH5 i _) (DataItemH5 x _) (DataItemH5 y _) _ _ _) = h5path - -integrateMesh'' ∷ XrdMeshParams a → AbsDirPath → XrdMesh' → IO () -integrateMesh'' p' output (XrdMesh b _ mt s) = do - -- get the poniext for all the scan - (w, PoniExt p _) <- getWaveLengthAndPoniExt p' s - - -- save this poni at the right place - let (ponipath, h5, py) = getOutputPath output s - ponipath `hasContent` poniToText p - - -- create the python script to do the integration - let script = xrdMeshPy' p' s ponipath b mt w h5 py - ExitSuccess ← run script False - - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/OneD.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/OneD.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/OneD.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/OneD.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,652 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Xrd.OneD - ( XrdOneD - , XRDRef(..) - , XrdRefSource(..) - , XRDSample(..) - , Threshold(..) - , XrdNxs(..) - , XrdOneDParams(..) - , XrdSource(..) - , PoniExt(..) - -- reference - , getPoseEdf - , getPoniExtRef - -- integration - , integrate - , substract - -- integrateMulti - , integrateMulti - , substractMulti - -- tools - , dummiesForPy - ) where - -import Control.Concurrent.Async (mapConcurrently) -import Control.Monad (forM_, forever, void, - zipWithM_) -import Control.Monad.Morph (hoist) -import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) -import Control.Monad.Trans.State.Strict (StateT, get, put) -import Data.Array.Repa (DIM1, ix1, size) -import Data.Attoparsec.Text (parseOnly) -import qualified Data.List as List (lookup) -import Data.Maybe (fromJust, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as Text (intercalate, pack, - unlines) -import Data.Text.IO (readFile) -import Data.Vector.Storable (concat, head) -import Numeric.LinearAlgebra (fromList) -import Numeric.Units.Dimensional.Prelude (meter, nano, (*~), (/~)) -import Pipes (Consumer, Pipe, await, lift, - runEffect, yield, (>->)) -import Pipes.Lift (evalStateP) -import Pipes.Prelude (drain, filter, toListM) -import Pipes.Safe (runSafeT) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath (dropExtension, - replaceExtension, - takeDirectory, takeFileName, - (<.>), ()) -import Text.Printf (printf) - -import Hkl.C (Factory (K6c), - Geometry (Geometry), - geometryDetectorRotationGet) -import Hkl.DataSource (DataItem (DataItemH5), - DataSource (DataSourceH5), - atIndex') -import Hkl.Detector (Detector (ZeroD)) -import Hkl.Edf (Edf (Edf), edfFromFile) -import Hkl.Flat (Flat) -import Hkl.H5 (lenH5Dataspace) -import Hkl.MyMatrix (Basis (HklB), - MyMatrix (MyMatrix)) -import Hkl.Nxs (DataFrameH5 (DataFrameH5), - DataFrameH5Path (XrdOneDH5Path), - Nxs (Nxs), XrdOneD, - withDataFrameH5) -import Hkl.PyFAI (AIMethod, Poni, - PoniExt (PoniExt), PoniPath, - Pose (Pose), move, poniP, - poniToText) -import Hkl.Python (PyVal, toPyVal) -import Hkl.Script (Gnuplot, Py2, - Script (Py2Script, ScriptGnuplot), - run, scriptSave) -import Hkl.Types (AbsDirPath, SampleName, - Source (Source)) -import Hkl.Utils (hasContent) - --- TODO --- When we skip the last frame there is problem. - --- Let's add a method in order to customize the movement of the poni. - --- Types - -newtype Threshold = Threshold Int deriving (Show) - -instance PyVal Threshold where - toPyVal (Threshold i) = toPyVal i - -data XrdRefSource = XrdRefNxs (Nxs XrdOneD) Int - | XrdRefEdf FilePath PoniPath - deriving (Show) - -data XRDRef = XRDRef SampleName AbsDirPath XrdRefSource - deriving (Show) - -data XrdSource = XrdSourceNxs (Nxs XrdOneD) - | XrdSourceEdf [FilePath] - deriving (Show) - -data XrdNxs - = XrdNxs - DIM1 -- bins - DIM1 -- bins for the multibins - (Maybe Threshold) -- threshold use to remove image Intensity - [Int] -- Index of the frames to skip - XrdSource -- data source - deriving (Show) - -data XRDSample = XRDSample SampleName AbsDirPath [XrdNxs] -- nxss - deriving (Show) - -data XrdOneDParams a = XrdOneDParams PoniExt (Maybe (Flat a)) AIMethod - -data DifTomoFrame sh = - DifTomoFrame { difTomoFrameNxs :: Nxs XrdOneD-- nexus of the current frame - , difTomoFrameIdx :: Int -- index of the current frame - , difTomoFrameEOF :: Bool -- is it the eof of the stream - , difTomoFrameGeometry :: Geometry -- diffractometer geometry - , difTomoFramePoniExt :: PoniExt -- the ref poniext - } deriving (Show) - -class Frame t where - len :: t -> IO (Maybe Int) - row :: t -> Int -> MaybeT IO (DifTomoFrame DIM1) - -instance Frame (DataFrameH5 XrdOneD) where - len (DataFrameH5 _ _ _ (DataSourceH5 _ d) _ _) = lenH5Dataspace d - - row d@(DataFrameH5 nxs' _ g d' w ponigen) idx = do - n <- lift $ len d - let eof = fromJust n - 1 == idx - let mu = 0.0 - let komega = 0.0 - let kappa = 0.0 - let kphi = 0.0 - gamma <- g `atIndex'` ix1 0 - delta <- d' `atIndex'` ix1 idx - wavelength <- w `atIndex'` ix1 0 - let source = Source (Data.Vector.Storable.head wavelength *~ nano meter) - let positions = Data.Vector.Storable.concat [mu, komega, kappa, kphi, gamma, delta] - -- print positions - let geometry = Geometry K6c source positions Nothing - let detector = ZeroD - m <- lift $ geometryDetectorRotationGet geometry detector - let pose = Pose (MyMatrix HklB m) - poniext <- lift $ ponigen pose idx - return $ DifTomoFrame { difTomoFrameNxs = nxs' - , difTomoFrameIdx = idx - , difTomoFrameEOF = eof - , difTomoFrameGeometry = geometry - , difTomoFramePoniExt = poniext - } - --- type PipeE e a b m r = EitherT e (Pipe a b m) r - -frames :: (Frame a) => Pipe a (DifTomoFrame DIM1) IO () -frames = do - d <- await - mn <- lift $ len d - case mn of - (Just n) -> forM_ [0..n-1] (\i' -> do - f <- lift $ runMaybeT $ row d i' - forM_ f yield) - Nothing -> error "Cannot extract frame length" - -frames' :: (Frame a) => [Int] -> Pipe a (DifTomoFrame DIM1) IO () -frames' is = do - d <- await - forM_ is (\i' -> do - f <- lift $ runMaybeT $ row d i' - forM_ f yield) - -skip :: [Int] -> DifTomoFrame sh -> Bool -skip is' (DifTomoFrame _ i _ _ _) = i `notElem` is' - --- {-# ANN module "HLint: ignore Use camelCase" #-} - - --- import Graphics.Rendering.Chart.Easy --- import Graphics.Rendering.Chart.Backend.Diagrams - --- plotPonies :: FilePath -> [PoniEntry] -> IO () --- plotPonies f entries = toFile def f $ do --- layout_title .= "Ponies" --- setColors [opaque blue] --- let values = map extract entries --- plot (line "am" [values [0,(0.5)..400]]) --- -- plot (points "am points" (signal [0,7..400])) --- where --- extract (PoniEntry _ _ (Length poni1) _ _ _ _ _ _) = poni1 - --- Usual methods - -dummiesForPy ∷ Maybe Threshold → String -dummiesForPy mt = unlines [ "# Compute the dummy values for the dynamic mask" - , "DUMMY=" ++ dummy - , "DELTA_DUMMY=" ++ delta_dummy - ] - where - dummy = maybe "None" (const "4294967296") mt -- TODO the default value depends on the number od bits per pixels. - delta_dummy = maybe "None" (\(Threshold t) → show (4294967296 - t)) mt - -getScanDir ∷ AbsDirPath → FilePath → FilePath -getScanDir o f = o (dropExtension . takeFileName) f - -pgen :: AbsDirPath -> FilePath -> Int -> FilePath -pgen o f i = o scandir scandir ++ printf "_%02d.poni" i - where - scandir = (dropExtension . takeFileName) f - -getPoseEdf :: FilePath -> IO Pose -getPoseEdf f = do - edf@(Edf lambda _) <- edfFromFile f - let mnes = map Text.pack ["_mu", "_keta", "_kap", "_kphi", "nu", "del"] - let source = Source lambda - let positions = fromList $ map (extract edf) mnes - let geometry = Geometry K6c source positions Nothing - let detector = ZeroD - m <- geometryDetectorRotationGet geometry detector - return $ Pose (MyMatrix HklB m) - where - extract :: Edf -> Text -> Double - extract (Edf _ ms) key = fromMaybe 0.0 (List.lookup key ms) - -poniFromFile :: FilePath -> IO Poni -poniFromFile filename = do - content <- Data.Text.IO.readFile filename - return $ case parseOnly poniP content of - Left _ -> error $ "Can not parse the " ++ filename ++ " poni file" - Right poni -> poni - -getPoniExtRef :: XRDRef -> IO PoniExt -getPoniExtRef (XRDRef _ output (XrdRefNxs nxs'@(Nxs f _) idx)) = do - poniExtRefs <- runSafeT $ - toListM ( withDataFrameH5 nxs' (gen output f) yield - >-> hoist lift ( frames' [idx])) - return $ difTomoFramePoniExt (Prelude.last poniExtRefs) - where - gen :: FilePath -> FilePath -> Pose -> Int -> IO PoniExt - gen root nxs'' p idx' = PoniExt - <$> poniFromFile (root scandir ++ printf "_%02d.poni" idx') - <*> pure p - where - scandir = takeFileName nxs'' -getPoniExtRef (XRDRef _ _ (XrdRefEdf e p)) = PoniExt - <$> poniFromFile p - <*> getPoseEdf e - -integrate ∷ XrdOneDParams a → [XRDSample] → IO () -integrate p ss = void $ mapConcurrently (integrate' p) ss - -integrate' ∷ XrdOneDParams a → XRDSample → IO () -integrate' p (XRDSample _ output nxss) = void $ mapConcurrently (integrate'' p output) nxss - -integrate'' ∷ XrdOneDParams a → AbsDirPath → XrdNxs → IO () -integrate'' p output (XrdNxs b _ mt is (XrdSourceNxs nxs'@(Nxs f _))) = do - print f - runSafeT $ runEffect $ - withDataFrameH5 nxs' (gen p) yield - >-> hoist lift (frames - >-> Pipes.Prelude.filter (skip is) - >-> savePonies (pgen output f) - >-> savePy p b mt - >-> saveGnuplot - >-> drain) - where - gen :: XrdOneDParams a -> Pose -> Int -> IO PoniExt - gen (XrdOneDParams ref' _ _) m _idx = return $ move ref' m - -createPy ∷ XrdOneDParams a → DIM1 → Maybe Threshold → FilePath → DifTomoFrame' sh → (Script Py2, FilePath) -createPy (XrdOneDParams _ mflat m) b mt scriptPath (DifTomoFrame' f poniPath) = (Py2Script (script, scriptPath), output) - where - script = Text.unlines $ - map Text.pack ["#!/bin/env python" - , "" - , "import numpy" - , "from h5py import File" - , "from pyFAI import load" - , "" - , "PONIFILE = " ++ toPyVal poniPath - , "NEXUSFILE = " ++ toPyVal nxs' - , "IMAGEPATH = " ++ toPyVal i' - , "IDX = " ++ toPyVal idx - , "N = " ++ toPyVal (size b) - , "OUTPUT = " ++ toPyVal output - , "WAVELENGTH = " ++ toPyVal (w /~ meter) - , "" - , "# load the flat" - , "flat = " ++ toPyVal mflat - , "" - , dummiesForPy mt - , "" - , "ai = load(PONIFILE)" - , "ai.wavelength = WAVELENGTH" - , "ai._empty = numpy.nan" - , "" - , "with File(NEXUSFILE, mode='r') as f:" - , " img = f[IMAGEPATH][IDX]" - , "" - , " # Compute the mask" - , " mask = numpy.zeros_like(img, dtype=bool)" - , " mask[:,550:] = True" - , " #mask_module[0:50, :] = True" - , " #mask_module[910:960, :] = True" - , " #mask_module[:,0:10] = True" - , " if flat is not None: # this should be removed for pyFAI >= 0.13.1 it is now done by PyFAI" - , " mask = numpy.logical_or(mask, flat == 0.0)" - , "" - , " ai.integrate1d(img, N, filename=OUTPUT, unit=\"2th_deg\", error_model=\"poisson\", correctSolidAngle=False, method=\"" ++ show m ++ "\", mask=mask, flat=flat, dummy=DUMMY, delta_dummy=DELTA_DUMMY)" - ] - (Nxs nxs' (XrdOneDH5Path (DataItemH5 i' _) _ _ _)) = difTomoFrameNxs f - idx = difTomoFrameIdx f - output = poniPath `replaceExtension` "dat" - (Geometry _ (Source w) _ _) = difTomoFrameGeometry f - --- Pipes - -data DifTomoFrame' sh = DifTomoFrame' { difTomoFrame'DifTomoFrame :: DifTomoFrame sh - , difTomoFrame'PoniPath :: FilePath - } - -savePonies :: (Int -> FilePath) -> Pipe (DifTomoFrame sh) (DifTomoFrame' sh) IO () -savePonies g = forever $ do - f <- await - let filename = g (difTomoFrameIdx f) - let (PoniExt p _) = difTomoFramePoniExt f - lift $ filename `hasContent` poniToText p - yield $ DifTomoFrame' { difTomoFrame'DifTomoFrame = f - , difTomoFrame'PoniPath = filename - } - -data DifTomoFrame'' sh = DifTomoFrame'' { difTomoFrame''DifTomoFrame' :: DifTomoFrame' sh - , difTomoFrame''PySCript :: Script Py2 - , difTomoFrame''DataPath :: FilePath - } - -savePy ∷ XrdOneDParams a → DIM1 → Maybe Threshold → Pipe (DifTomoFrame' sh) (DifTomoFrame'' sh) IO () -savePy p b mt = forever $ do - f@(DifTomoFrame' _difTomoFrame poniPath) <- await - let scriptPath = poniPath `replaceExtension`"py" - let (script, dataPath) = createPy p b mt scriptPath f - status <- lift $ run script True - case status of - ExitSuccess -> yield $ DifTomoFrame'' { difTomoFrame''DifTomoFrame' = f - , difTomoFrame''PySCript = script - , difTomoFrame''DataPath = dataPath - } - _ -> error "Script execution failed" - -data DifTomoFrame''' sh = DifTomoFrame''' { difTomoFrame'''DifTomoFrame'' ∷ DifTomoFrame'' sh - , difTomoFrame'''GnuplotScript ∷ Script Gnuplot - , difTomoFrame'''Curves ∷ [FilePath] - } - -mkGnuplot ∷ [FilePath] → FilePath → Script Gnuplot -mkGnuplot fs o = ScriptGnuplot (content, o) - where - content = Text.unlines $ - ["plot \\"] - ++ [Text.intercalate ",\\\n" [ Text.pack (show f ++ " u 1:2 w l") | f <- fs ]] - ++ ["pause -1"] - -saveGnuplot' :: Pipe (DifTomoFrame'' sh) (DifTomoFrame''' sh) (StateT [FilePath] IO) r -saveGnuplot' = forever $ do - curves <- lift get - f@(DifTomoFrame'' (DifTomoFrame' _ poniPath) _ dataPath) <- await - let curves' = curves ++ [dataPath] - let script = mkGnuplot curves' (takeDirectory poniPath "plot.gnuplot") - lift . lift $ scriptSave script - lift $ put $! curves' - yield $ DifTomoFrame''' { difTomoFrame'''DifTomoFrame'' = f - , difTomoFrame'''GnuplotScript = script - , difTomoFrame'''Curves = curves' - } - -saveGnuplot :: Pipe (DifTomoFrame'' sh) (DifTomoFrame''' sh) IO r -saveGnuplot = evalStateP [] saveGnuplot' - --- substract a sample from another one - -substractPy ∷ [FilePath] → [FilePath] → [FilePath] → FilePath → Script Py2 -substractPy fs1 fs2 os scriptPath = Py2Script (content, scriptPath) - where - content ∷ Text - content = Text.unlines $ - map Text.pack ["#!/bin/env python" - , "" - , "import numpy" - , "" - , "S1 = " ++ toPyVal fs1 - , "S2 = " ++ toPyVal fs2 - , "OUTPUTS = " ++ toPyVal os - , "" - , "def substract(f1, f2, o):" - , " a1 = numpy.genfromtxt(f1)" - , " a2 = numpy.genfromtxt(f2)" - , " res = numpy.copy(a2)" - , " res[:,1] -= a1[:,1]" - , " # TODO deal with the error propagation" - , " numpy.savetxt(output, res)" - , "" - , "for (s1, s2, output) in zip(S1, S2, OUTPUTS):" - , " substract(s1, s2, output)" - ] - -targetP ∷ (Int → FilePath) → Pipe (DifTomoFrame sh) FilePath IO () -targetP g = forever $ do - f ← await - let poniPath = g (difTomoFrameIdx f) - let dataPath = poniPath `replaceExtension` "dat" - yield dataPath - -target' ∷ XrdOneDParams a → AbsDirPath → XrdNxs → IO (FilePath, [FilePath]) -target' p output (XrdNxs _ _ _ is (XrdSourceNxs nxs'@(Nxs f _))) = do - fs ← runSafeT $ toListM $ - withDataFrameH5 nxs' (gen p) yield - >-> hoist lift (frames - >-> Pipes.Prelude.filter (skip is) - >-> targetP (pgen output f) - ) - return (getScanDir output f, fs) - where - gen :: XrdOneDParams a -> Pose -> Int -> IO PoniExt - gen (XrdOneDParams ref' _ _) m _idx = return $ move ref' m - -targets ∷ XrdOneDParams a → XRDSample → IO [(FilePath, [FilePath])] -targets p (XRDSample _ output nxss) = mapConcurrently (target' p output) nxss - -substract' ∷ XrdOneDParams a → XRDSample → XRDSample → IO () -substract' p s1@(XRDSample name _ _) s2 = do - -- compute the output of the s1 sample - -- we take only the first list of the sample - f1s:_ ← targets p s1 - -- compute the output of the s2 sample - f2s ← targets p s2 - -- do the substraction via a python script and add the gnuplot file - _ ← mapConcurrently (go f1s) f2s - return () - where - go ∷ (FilePath, [FilePath]) → (FilePath, [FilePath]) → IO () - go (_, f1) (d, f2) = do - -- compute the substracted output file names take into account - -- that f1 and f2 could have different length - let outputs = [dropExtension f ++ "-" ++ name <.> "dat" | (_, f) ← zip f1 f2] - -- compute the script name - let scriptPath = d "substract.py" - let script = substractPy f1 f2 outputs scriptPath - ExitSuccess ← run script False - -- gnuplot - let gnuplotPath = d "substract.gnuplot" - scriptSave $ mkGnuplot outputs gnuplotPath - return () - -substract ∷ XrdOneDParams a → XRDSample → [XRDSample] → IO () -substract p s = mapM_ (substract' p s) - --- PyFAI MultiGeometry - -integrateMulti ∷ XrdOneDParams a → [XRDSample] → IO () -integrateMulti p = mapM_ (integrateMulti' p) - -integrateMulti' ∷ XrdOneDParams a → XRDSample → IO () -integrateMulti' p (XRDSample _ output nxss) = mapM_ (integrateMulti'' p output) nxss - -integrateMulti'' ∷ XrdOneDParams a → AbsDirPath → XrdNxs → IO () -integrateMulti'' p output (XrdNxs _ mb mt is (XrdSourceNxs nxs'@(Nxs f _))) = do - print f - runSafeT $ runEffect $ - withDataFrameH5 nxs' (gen p) yield - >-> hoist lift (frames - >-> Pipes.Prelude.filter (skip is) - >-> savePonies (pgen output f) - >-> saveMultiGeometry p mb mt) - where - gen :: XrdOneDParams a -> Pose -> Int -> IO PoniExt - gen (XrdOneDParams ref' _ _) m _idx = return $ move ref' m - -integrateMulti'' p output (XrdNxs b _ mt _ (XrdSourceEdf fs)) = do - -- generate all the ponies - zipWithM_ (go p) fs ponies - - -- generate the multi.py python script - let scriptPath = output "multi.py" - let (script, _) = createMultiPyEdf p b mt fs ponies scriptPath (output "multi.dat") - scriptSave script - where - ponies = [output (dropExtension . takeFileName) f ++ ".poni" | f <- fs] - - go ∷ XrdOneDParams a → FilePath → FilePath → IO () - go (XrdOneDParams ref _ _) f o = do - m <- getPoseEdf f - let (PoniExt p' _) = move ref m - o `hasContent` poniToText p' - -createMultiPy ∷ XrdOneDParams a → DIM1 → Maybe Threshold → FilePath → DifTomoFrame' sh → [(Int, FilePath)] → (Script Py2, FilePath) -createMultiPy (XrdOneDParams _ mflat _) b mt scriptPath (DifTomoFrame' f _) idxPonies = (Py2Script (content, scriptPath), output) - where - content = Text.unlines $ - map Text.pack ["#!/bin/env python" - , "" - , "import numpy" - , "from h5py import File" - , "from pyFAI.multi_geometry import MultiGeometry" - , "" - , "NEXUSFILE = " ++ toPyVal nxs' - , "IMAGEPATH = " ++ toPyVal i' - , "BINS = " ++ toPyVal (size b) - , "OUTPUT = " ++ toPyVal output - , "WAVELENGTH = " ++ toPyVal (w /~ meter) - , "THRESHOLD = " ++ toPyVal mt - , "" - , "# load the flat" - , "flat = " ++ toPyVal mflat - , "" - , "# Load all images" - , "PONIES = " ++ toPyVal ponies - , "IDXS = " ++ toPyVal idxs - , "" - , "# Read all the images" - , "imgs = []" - , "with File(NEXUSFILE, mode='r') as f:" - , " for idx in IDXS:" - , " imgs.append(f[IMAGEPATH][idx])" - , "" - , "# Compute the mask" - , "mask = numpy.zeros_like(imgs[0], dtype=bool)" - , "mask[:,550:] = True" - , "if flat is not None: # this should be removed for pyFAI >= 0.13.1 it is now done by PyFAI" - , " mask = numpy.logical_or(mask, flat == 0.0)" - , "lst_mask = []" - , "for img in imgs: # remove all pixels above the threshold" - , " if THRESHOLD is not None:" - , " mask_t = numpy.where(img > THRESHOLD, True, False)" - , " lst_mask.append(numpy.logical_or(mask, mask_t))" - , " else:" - , " lst_mask.append(mask)" - , "" - , "# Integration multi-geometry 1D" - , "mg = MultiGeometry(PONIES, unit=\"2th_deg\", radial_range=(0,80))" - , "p = mg.integrate1d(imgs, BINS, lst_mask=lst_mask, lst_flat=flat)" - , "" - , "# Save the datas" - , "numpy.savetxt(OUTPUT, numpy.array(p).T)" - ] - (Nxs nxs' (XrdOneDH5Path (DataItemH5 i' _) _ _ _)) = difTomoFrameNxs f - output = "multi.dat" - (Geometry _ (Source w) _ _) = difTomoFrameGeometry f - (idxs, ponies) = unzip idxPonies - -createMultiPyEdf ∷ XrdOneDParams a → DIM1 → Maybe Threshold → [FilePath] → [FilePath] → FilePath → FilePath → (Script Py2, FilePath) -createMultiPyEdf (XrdOneDParams _ mflat _) b mt edfs ponies scriptPath output = (Py2Script (content, scriptPath), output) - where - content = Text.unlines $ - map Text.pack ["#!/bin/env python" - , "" - , "import numpy" - , "from fabio import open" - , "from pyFAI.multi_geometry import MultiGeometry" - , "" - , "EDFS = " ++ toPyVal edfs - , "PONIES = " ++ toPyVal ponies - , "BINS = " ++ toPyVal (size b) - , "OUTPUT = " ++ toPyVal output - , "THRESHOLD = " ++ toPyVal mt - , "" - , "# load the flat" - , "flat = " ++ toPyVal mflat - , "" - , "# Read all the images" - , "imgs = [open(edf).data for edf in EDFS]" - , "" - , "# Compute the mask" - , "mask = numpy.zeros_like(imgs[0], dtype=bool)" - , "if THRESHOLD is not None:" - , " for img in imgs:" - , " mask_t = numpy.where(img > THRESHOLD, True, False)" - , " mask = numpy.logical_or(mask, mask_t)" - , "" - , "# Integration multi-geometry 1D" - , "mg = MultiGeometry(PONIES, unit=\"2th_deg\", radial_range=(0,80))" - , "p = mg.integrate1d(imgs, BINS, lst_mask=mask)" - , "" - , "# Save the datas" - , "numpy.savetxt(OUTPUT, numpy.array(p).T)" - ] - -saveMulti' ∷ XrdOneDParams a → DIM1 → Maybe Threshold → Consumer (DifTomoFrame' sh) (StateT [(Int, FilePath)] IO) r -saveMulti' p b mt = forever $ do - idxPonies <- lift get - f'@(DifTomoFrame' f@(DifTomoFrame _ idx _ _ _) poniPath) <- await - let directory = takeDirectory poniPath - let filename = directory "multi.py" - let (script, _) = createMultiPy p b mt filename f' idxPonies - status ← lift . lift $ if difTomoFrameEOF f then run script True else return ExitSuccess - case status of - ExitSuccess -> lift $ put $! (idxPonies ++ [(idx, poniPath)]) - _ -> error "Script execution failed" - -saveMultiGeometry ∷ XrdOneDParams a → DIM1 → Maybe Threshold → Consumer (DifTomoFrame' sh) IO r -saveMultiGeometry p b mt = evalStateP [] (saveMulti' p b mt) - - --- substract a sample from another one - -targetMulti' ∷ XrdOneDParams a → AbsDirPath → XrdNxs → (FilePath, FilePath) -targetMulti' _ output (XrdNxs _ _ _ _ (XrdSourceNxs (Nxs f _))) = (d, o) - where - d = getScanDir output f - o = d "multi.dat" - -targetMulti ∷ XrdOneDParams a → XRDSample → [(FilePath, FilePath)] -targetMulti p (XRDSample _ output nxss) = map (targetMulti' p output) nxss - -substractMulti' ∷ XrdOneDParams a → XRDSample → XRDSample → IO () -substractMulti' p s1@(XRDSample name _ _) s2 = do - -- compute the output of the s1 sample - -- we take only the first list of the sample - let f1s:_ = targetMulti p s1 - -- compute the output of the s2 sample - let f2s = targetMulti p s2 - -- do the substraction via a python script and add the gnuplot file - _ ← mapConcurrently (go f1s) f2s - - return () - where - go ∷ (FilePath, FilePath) → (FilePath, FilePath) → IO () - go (_, f1) (d, f2) = do - -- compute the substracted output file names - let outputs = dropExtension f2 ++ "-" ++ name <.> "dat" - -- compute the script name - let scriptPath = d "multi-substract.py" - let script = substractPy [f1] [f2] [outputs] scriptPath - ExitSuccess ← run script False - -- gnuplot - let gnuplotPath = d "multi-substract.gnuplot" - scriptSave $ mkGnuplot [outputs] gnuplotPath - return () - -substractMulti ∷ XrdOneDParams a → XRDSample → [XRDSample] → IO () -substractMulti p s = mapM_ (substractMulti' p s) diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/ZeroD.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/ZeroD.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd/ZeroD.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd/ZeroD.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Hkl.Xrd.ZeroD - ( XrdZeroDCalibration(..) - , XrdZeroDSample(..) - , XrdZeroDSource(..) - , XrdZeroDParams(..) - ) where - -import Data.Array.Repa.Index (DIM2) -import Data.Text (unlines, pack) -import Numeric.Units.Dimensional.Prelude (meter, nano, (*~)) -import System.Exit ( ExitCode( ExitSuccess ) ) -import System.FilePath.Posix ((), takeFileName) -import Text.Printf ( printf ) - -import Hkl.DataSource ( DataItem ( DataItemH5, DataItemConst ) ) -import Hkl.Detector ( Detector ) -import Hkl.Edf ( ExtractEdf, extractEdf ) -import Hkl.Flat ( Flat ) -import Hkl.PyFAI ( AIMethod,Calibrant, PoniExt, Pose - , toPyFAICalibArg ) -import Hkl.Python ( toPyVal ) -import Hkl.Nxs ( DataFrameH5Path( XrdZeroDH5Path ) - , Nxs ( Nxs ) - , XrdZeroD - ) -import Hkl.Script ( Script ( Py2Script, ScriptSh ) - , Py2, Sh - , run - , scriptSave - ) -import Hkl.Types ( AbsDirPath, SampleName, WaveLength ) - --- Types - -newtype XrdZeroDSource = XrdZeroDSourceNxs (Nxs XrdZeroD) deriving (Show) - -data XrdZeroDSample = XrdZeroDSample SampleName AbsDirPath [XrdZeroDSource] deriving (Show) - -data XrdZeroDCalibration a = XrdZeroDCalibration XrdZeroDSample (Detector a DIM2) Calibrant deriving (Show) - -data XrdZeroDParams a = XrdZeroDParams PoniExt (Maybe (Flat a)) AIMethod deriving (Show) - -data XrdZeroDFrame = XrdMeshFrame WaveLength Pose deriving (Show) - -edf ∷ AbsDirPath → FilePath → Int → FilePath -edf o n i = o f - where - f = takeFileName n ++ printf "_%02d.edf" i - -scriptExtractEdf ∷ AbsDirPath → [XrdZeroDSource] → Script Py2 -scriptExtractEdf o es = Py2Script (content, scriptPath) - where - content = Data.Text.unlines $ - map Data.Text.pack [ "#!/usr/bin/env python" - , "" - , "from fabio.edfimage import edfimage" - , "from h5py import File" - , "" - , "NEXUSFILES = " ++ toPyVal nxss - , "IDXS = " ++ toPyVal idxs - , "IMAGEPATHS = " ++ toPyVal (imgs ∷ [String]) - , "OUTPUTS = " ++ toPyVal outputs - , "" - , "for filename, i, p, o in zip(NEXUSFILES, IDXS, IMAGEPATHS, OUTPUTS):" - , " with File(filename, mode='r') as f:" - , " edfimage(f[p][i]).write(o)" - ] - - idx ∷ Int - idx = 0 - - (nxss, idxs, imgs) = unzip3 [(f, idx, img) - | (XrdZeroDSourceNxs (Nxs f (XrdZeroDH5Path (DataItemH5 img _) _))) ← es] - - outputs ∷ [FilePath] - outputs = zipWith (edf o) nxss idxs - - scriptPath ∷ FilePath - scriptPath = o "pre-calibration.py" - -scriptPyFAICalib ∷ AbsDirPath → XrdZeroDSource → Detector a sh → Calibrant → Script Sh -scriptPyFAICalib o e@(XrdZeroDSourceNxs (Nxs n _)) d c = ScriptSh (content, scriptPath) - where - content = Data.Text.unlines $ - map Data.Text.pack [ "#!/usr/bin/env sh" - , "" - , "pyFAI-calib " ++ unwords args - ] - - args = [ toPyFAICalibArg (readWavelength e) - , toPyFAICalibArg c - , toPyFAICalibArg d - , toPyFAICalibArg (edf o n i) ] - - scriptPath ∷ FilePath - scriptPath = o takeFileName n ++ printf "_%02d.sh" i - - i ∷ Int - i = 0 - -readWavelength :: XrdZeroDSource -> WaveLength -readWavelength (XrdZeroDSourceNxs (Nxs _ (XrdZeroDH5Path _ (DataItemConst w)))) = w *~ nano meter - -instance ExtractEdf (XrdZeroDCalibration a) where - extractEdf (XrdZeroDCalibration s d c) = do - let script = scriptExtractEdf o es - ExitSuccess ← run script False - mapM_ go es - where - go e = scriptSave $ scriptPyFAICalib o e d c - - (XrdZeroDSample _ o es) = s diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl/Xrd.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl/Xrd.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -module Hkl.Xrd ( module X ) where - -import Hkl.Xrd.Calibration as X -import Hkl.Xrd.OneD as X -import Hkl.Xrd.Mesh as X -import Hkl.Xrd.ZeroD as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/hkl3d.hs hkl-5.0.0.2875/contrib/haskell/src/hkl3d.hs --- hkl-5.0.0.2816/contrib/haskell/src/hkl3d.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/hkl3d.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -import Hkl.Projects - -{-# ANN module "HLint: ignore Use camelCase" #-} - -main :: IO () --- main = main_calibration --- main = main_diffabs -main = mainSixs diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Hkl.hs hkl-5.0.0.2875/contrib/haskell/src/Hkl.hs --- hkl-5.0.0.2816/contrib/haskell/src/Hkl.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Hkl.hs 2021-12-08 09:14:21.000000000 +0000 @@ -1,5 +1,5 @@ {- - Copyright : Copyright (C) 2014-2020 Synchrotron SOLEIL + Copyright : Copyright (C) 2014-2021 Synchrotron SOLEIL L'Orme des Merisiers Saint-Aubin BP 48 91192 GIF-sur-YVETTE CEDEX License : GPL3+ @@ -13,19 +13,10 @@ import Hkl.Binoculars as X import Hkl.C as X -import Hkl.Conduit as X -import Hkl.DataSource as X import Hkl.Detector as X import Hkl.Engine as X -import Hkl.Flat as X import Hkl.H5 as X import Hkl.Lattice as X import Hkl.MyMatrix as X -import Hkl.Nxs as X import Hkl.Pipes as X -import Hkl.PyFAI as X -import Hkl.Python as X -import Hkl.Script as X -import Hkl.Tiff as X import Hkl.Types as X -import Hkl.Xrd as X diff -Nru hkl-5.0.0.2816/contrib/haskell/src/Tango/DeviceProxy.hsc hkl-5.0.0.2875/contrib/haskell/src/Tango/DeviceProxy.hsc --- hkl-5.0.0.2816/contrib/haskell/src/Tango/DeviceProxy.hsc 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/Tango/DeviceProxy.hsc 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} - -module Tango.DeviceProxy ( - deviceproxy - , DeviceProxy ) where - -import Control.Exception - -import Foreign.C -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Array -import Foreign.Marshal.Alloc - -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) -#include "tango.h" - -data DeviceProxy = DeviceProxy - -foreign import ccall "_ZN5Tango11DeviceProxyC1EPKcPN5CORBA3ORBE" deviceproxy_DeviceProxy :: (Ptr DeviceProxy) -> CString -> Ptr a -> IO () - -class New a where - new :: IO (Ptr a) - -instance Storable DeviceProxy where - sizeOf _ = #{size Tango::DeviceProxy} - -deviceproxy :: String -> IO (Ptr DeviceProxy) -deviceproxy d = do - device <- newCString d - dev <- malloc :: IO (Ptr DeviceProxy) - deviceproxy_DeviceProxy dev device nullPtr - return dev - -main :: IO () -main = do - diffractometer <- catch (deviceproxy "toto") - (\e -> do let err = show (e :: IOException) - hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err) - return "") - return () diff -Nru hkl-5.0.0.2816/contrib/haskell/src/xrd.hs hkl-5.0.0.2875/contrib/haskell/src/xrd.hs --- hkl-5.0.0.2816/contrib/haskell/src/xrd.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/src/xrd.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -module Main where - -import Hkl.Projects - -main :: IO () -main = charlier - -- irdrx - -- martinetto' - -- melle - -- d2am - -- charlier - -- laure - -- hercules - -- hamon - -- schlegel - -- romeden diff -Nru hkl-5.0.0.2816/contrib/haskell/test/BinocularsSpec.hs hkl-5.0.0.2875/contrib/haskell/test/BinocularsSpec.hs --- hkl-5.0.0.2816/contrib/haskell/test/BinocularsSpec.hs 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/contrib/haskell/test/BinocularsSpec.hs 2021-12-08 09:14:21.000000000 +0000 @@ -5,21 +5,22 @@ where -import Control.Monad (forM_) -import Data.Either (isRight) -import Data.Text.IO (readFile) +import Control.Monad (forM_) +import Data.Attoparsec.Text (parseOnly) +import Data.Either (isRight) +import Data.Text.IO (readFile) import Test.Hspec import Hkl.Binoculars import Paths_hkl -import Prelude hiding (readFile) +import Prelude hiding (readFile) spec :: Spec spec = do describe "parseBinocularsConfig" $ do - forM_ [ "data/test/config_hkl_facet.cfg" + forM_ [ "data/test/config_sixs_biggest.ini" -- , "data/test/config_map.txt" ] $ \f -> it f $ do cfg <- getConfig =<< Just <$> getDataFileName f @@ -28,3 +29,20 @@ (Left e) -> do print e False `shouldBe` True + + describe "parseConfigRange" $ do + it "parse a range" $ do + let p = parseOnly configRangeP "120 123-453" + p `shouldBe` (Right (ConfigRange [InputRangeSingle 120, InputRangeFromTo 123 453])) + it "parse a range" $ do + let p = parseOnly configRangeP "120,123-453" + p `shouldBe` (Right (ConfigRange [InputRangeSingle 120, InputRangeFromTo 123 453])) + it "parse a range" $ do + let p = parseOnly configRangeP "120,,,123-453" + p `shouldBe` (Right (ConfigRange [InputRangeSingle 120, InputRangeFromTo 123 453])) + it "parse a range" $ do + let p = parseOnly configRangeP "120-135 123-453" + p `shouldBe` (Right (ConfigRange [InputRangeFromTo 120 135, InputRangeFromTo 123 453])) + it "parse a range" $ do + let p = parseOnly configRangeP "120-135, 123-453" + p `shouldBe` (Right (ConfigRange [InputRangeFromTo 120 135, InputRangeFromTo 123 453])) diff -Nru hkl-5.0.0.2816/debian/changelog hkl-5.0.0.2875/debian/changelog --- hkl-5.0.0.2816/debian/changelog 2021-12-07 17:32:29.000000000 +0000 +++ hkl-5.0.0.2875/debian/changelog 2021-12-08 09:44:32.000000000 +0000 @@ -1,8 +1,14 @@ -hkl (5.0.0.2816-2build1) jammy; urgency=medium +hkl (5.0.0.2875-1) unstable; urgency=medium - * No-change rebuild against libgsl27 + [ Neil Williams ] + * Update control to add Debian PaN maintainers - -- Steve Langasek Tue, 07 Dec 2021 17:32:29 +0000 + [ Picca Frédéric-Emmanuel ] + * New upstream version 5.0.0.2875 + * Update standards version to 4.6.0, no changes needed. + * wrap-and-sort -ast + + -- Picca Frédéric-Emmanuel Wed, 08 Dec 2021 10:44:32 +0100 hkl (5.0.0.2816-2) unstable; urgency=medium diff -Nru hkl-5.0.0.2816/debian/control hkl-5.0.0.2875/debian/control --- hkl-5.0.0.2816/debian/control 2021-12-07 17:32:28.000000000 +0000 +++ hkl-5.0.0.2875/debian/control 2021-12-08 09:44:32.000000000 +0000 @@ -1,36 +1,40 @@ Source: hkl -Maintainer: Ubuntu Developers -XSBC-Original-Maintainer: Debian Science Maintainers -Uploaders: Picca Frédéric-Emmanuel +Maintainer: Debian PaN Maintainers +Uploaders: + Debian Science Maintainers , + Picca Frédéric-Emmanuel , Section: science Priority: optional -Build-Depends: autoconf-archive, - debhelper-compat (= 13), - gnuplot-nox, - gobject-introspection, - gtk-doc-tools, - libbullet-dev, - libg3d-dev, - libg3d-plugins, - libgirepository1.0-dev, - libgsl0-dev | libgsl-dev, - libgtk-3-dev, - libgtkglext1-dev, - libyaml-dev, - python3-gi, - python3-matplotlib, - python3-tk -Build-Depends-Indep: emacs | org-mode , - elpa-htmlize -Standards-Version: 4.5.0 +Build-Depends: + autoconf-archive, + debhelper-compat (= 13), + gnuplot-nox, + gobject-introspection, + gtk-doc-tools, + libbullet-dev, + libg3d-dev, + libg3d-plugins, + libgirepository1.0-dev, + libgsl0-dev | libgsl-dev, + libgtk-3-dev, + libgtkglext1-dev, + libyaml-dev, + python3-gi, + python3-matplotlib, + python3-tk, +Build-Depends-Indep: + elpa-htmlize , + emacs | org-mode , +Standards-Version: 4.6.0 Vcs-Browser: https://salsa.debian.org/science-team/hkl Vcs-Git: https://salsa.debian.org/science-team/hkl.git Homepage: https://repo.or.cz/hkl.git Package: ghkl Architecture: any -Depends: ${misc:Depends}, - ${shlibs:Depends} +Depends: + ${misc:Depends}, + ${shlibs:Depends}, Description: diffractometer computation control application The hkl library is a framework for diffraction computation and diffractometer control, heavily used at the SOLEIL synchrotron. It @@ -45,10 +49,13 @@ Architecture: any Multi-Arch: same Section: libs -Depends: ${misc:Depends}, - ${shlibs:Depends} -Suggests: libhkl-doc -Pre-Depends: ${misc:Pre-Depends} +Depends: + ${misc:Depends}, + ${shlibs:Depends}, +Suggests: + libhkl-doc, +Pre-Depends: + ${misc:Pre-Depends}, Description: diffractometer computation control library The hkl library is a framework for diffraction computation and diffractometer control, heavily used at the SOLEIL synchrotron. It @@ -62,13 +69,15 @@ Package: libhkl-dev Architecture: any Section: libdevel -Depends: gir1.2-hkl-5.0 (= ${binary:Version}), - install-info, - libglib2.0-dev, - libgsl-dev | libgsl0-dev, - libhkl5 (= ${binary:Version}), - ${misc:Depends} -Pre-Depends: ${misc:Pre-Depends} +Depends: + gir1.2-hkl-5.0 (= ${binary:Version}), + install-info, + libglib2.0-dev, + libgsl-dev | libgsl0-dev, + libhkl5 (= ${binary:Version}), + ${misc:Depends}, +Pre-Depends: + ${misc:Pre-Depends}, Description: diffractometer computation control library - development files The hkl library is a framework for diffraction computation and diffractometer control, heavily used at the SOLEIL synchrotron. It @@ -82,7 +91,9 @@ Package: libhkl-doc Architecture: all Section: doc -Depends: ${misc:Depends}, libjs-mathjax +Depends: + libjs-mathjax, + ${misc:Depends}, Multi-Arch: foreign Description: diffractometer computation control library - documentation The hkl library is a framework for diffraction computation and @@ -98,10 +109,12 @@ Architecture: any Multi-Arch: same Section: introspection -Depends: ${gir:Depends}, - ${misc:Depends}, - ${shlibs:Depends} -Pre-Depends: ${misc:Pre-Depends} +Depends: + ${gir:Depends}, + ${misc:Depends}, + ${shlibs:Depends}, +Pre-Depends: + ${misc:Pre-Depends}, Description: diffractometer computation control library - gir binding The hkl library is a framework for diffraction computation and diffractometer control, heavily used at the SOLEIL synchrotron. It diff -Nru hkl-5.0.0.2816/debian/tests/control hkl-5.0.0.2875/debian/tests/control --- hkl-5.0.0.2816/debian/tests/control 2021-09-18 08:41:33.000000000 +0000 +++ hkl-5.0.0.2875/debian/tests/control 2021-12-08 09:44:32.000000000 +0000 @@ -1,8 +1,8 @@ Tests: build python3 Depends: build-essential, + gir1.2-hkl-5.0, libhkl-dev, pkg-config, - gir1.2-hkl-5.0, python3, - python3-gi + python3-gi, diff -Nru hkl-5.0.0.2816/hkl/ccan/compiler/compiler.h hkl-5.0.0.2875/hkl/ccan/compiler/compiler.h --- hkl-5.0.0.2816/hkl/ccan/compiler/compiler.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/hkl/ccan/compiler/compiler.h 2021-12-08 09:14:21.000000000 +0000 @@ -271,6 +271,19 @@ #define NON_NULL_ARGS(...) #endif +#if HAVE_ATTRIBUTE_RETURNS_NONNULL +/** + * RETURNS_NONNULL - specify that this function cannot return NULL. + * + * Mainly an optimization opportunity, but can also suppress warnings. + * + * Example: + * RETURNS_NONNULL char *my_copy(char *buf); + */ +#define RETURNS_NONNULL __attribute__((__returns_nonnull__)) +#else +#define RETURNS_NONNULL +#endif #if HAVE_ATTRIBUTE_SENTINEL /** diff -Nru hkl-5.0.0.2816/hkl/ccan/configurator.c hkl-5.0.0.2875/hkl/ccan/configurator.c --- hkl-5.0.0.2816/hkl/ccan/configurator.c 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/hkl/ccan/configurator.c 2021-12-08 09:14:21.000000000 +0000 @@ -1,7 +1,7 @@ /* Simple tool to create config.h. * Would be much easier with ccan modules, but deliberately standalone. * - * Copyright 2011, 2020 Rusty Russell . MIT license. + * Copyright 2011 Rusty Russell . MIT license. * * c12r_err, c12r_errx functions copied from ccan/err/err.c * Copyright Rusty Russell . CC0 (Public domain) License. @@ -142,6 +142,9 @@ { "HAVE_ATTRIBUTE_NONNULL", "__attribute__((nonnull)) support", "DEFINES_FUNC", NULL, NULL, "static char *__attribute__((nonnull)) func(char *p) { return p; }" }, + { "HAVE_ATTRIBUTE_RETURNS_NONNULL", "__attribute__((returns_nonnull)) support", + "DEFINES_FUNC", NULL, NULL, + "static const char *__attribute__((returns_nonnull)) func(void) { return \"hi\"; }" }, { "HAVE_ATTRIBUTE_SENTINEL", "__attribute__((sentinel)) support", "DEFINES_FUNC", NULL, NULL, "static int __attribute__((sentinel)) func(int i, ...) { return i; }" }, @@ -411,7 +414,7 @@ "int main(int argc, char *argv[]) {\n" " (void)argc;\n" " char pad[sizeof(int *) * 1];\n" - " strncpy(pad, argv[0], sizeof(pad));\n" + " memcpy(pad, argv[0], sizeof(pad));\n" " int *x = (int *)pad, *y = (int *)(pad + 1);\n" " return *x == *y;\n" "}\n" }, @@ -495,6 +498,43 @@ " return __builtin_cpu_supports(\"mmx\");\n" "}" }, + { "HAVE_CLOSEFROM", "closefrom() offered by system", + "DEFINES_EVERYTHING", NULL, NULL, + "#include \n" + "#include \n" + "int main(void) {\n" + " closefrom(STDERR_FILENO + 1);\n" + " return 0;\n" + "}\n" + }, + { "HAVE_F_CLOSEM", "F_CLOSEM defined for fctnl.", + "DEFINES_EVERYTHING", NULL, NULL, + "#include \n" + "#include \n" + "int main(void) {\n" + " int res = fcntl(STDERR_FILENO + 1, F_CLOSEM, 0);\n" + " return res < 0;\n" + "}\n" + }, + { "HAVE_NR_CLOSE_RANGE", "close_range syscall available as __NR_close_range.", + "DEFINES_EVERYTHING", NULL, NULL, + "#include \n" + "#include \n" + "#include \n" + "int main(void) {\n" + " int res = syscall(__NR_close_range, STDERR_FILENO + 1, INT_MAX, 0);\n" + " return res < 0;\n" + "}\n" + }, + { "HAVE_F_MAXFD", "F_MAXFD defined for fcntl.", + "DEFINES_EVERYTHING", NULL, NULL, + "#include \n" + "#include \n" + "int main(void) {\n" + " int res = fcntl(0, F_MAXFD);\n" + " return res < 0;\n" + "}\n" + }, }; static void c12r_err(int eval, const char *fmt, ...) @@ -762,9 +802,7 @@ strcpy(cmd, wrapper); strcat(cmd, " ." DIR_SEP OUTPUT_FILE); output = run(cmd, &status); - if (wrapper) { - free(cmd); - } + free(cmd); if (!strstr(test->style, "EXECUTE") && status != 0) c12r_errx(EXIT_BAD_TEST, "Test for %s failed with %i:\n%s", diff -Nru hkl-5.0.0.2816/hkl/ccan/Makefile.am hkl-5.0.0.2875/hkl/ccan/Makefile.am --- hkl-5.0.0.2816/hkl/ccan/Makefile.am 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/hkl/ccan/Makefile.am 2021-12-08 09:14:21.000000000 +0000 @@ -7,32 +7,32 @@ noinst_LTLIBRARIES=libccan.la libccan_la_SOURCES = \ ccan_config.h \ - ptrint/ptrint.h \ - noerr/noerr.h \ - noerr/noerr.c \ + alignof/alignof.h \ + array_size/array_size.h \ + autodata/autodata.c \ + autodata/autodata.h \ + build_assert/build_assert.h \ + check_type/check_type.h \ + compiler/compiler.h \ + container_of/container_of.h \ coroutine/coroutine.c \ coroutine/coroutine.h \ - build_assert/build_assert.h \ - alignof/alignof.h \ + cppmagic/cppmagic.h \ + darray/darray.h \ generator/generator.c \ generator/generator.h \ - container_of/container_of.h \ + list/list.c \ + list/list.h \ + noerr/noerr.c \ + noerr/noerr.h \ + ptr_valid/ptr_valid.c \ + ptr_valid/ptr_valid.h \ + ptrint/ptrint.h \ + str/debug.c \ str/str.c \ str/str.h \ str/str_debug.h \ - str/debug.c \ - list/list.h \ - list/list.c \ - check_type/check_type.h \ - compiler/compiler.h \ - autodata/autodata.c \ - autodata/autodata.h \ - cppmagic/cppmagic.h \ - darray/darray.h \ - typesafe_cb/typesafe_cb.h \ - array_size/array_size.h \ - ptr_valid/ptr_valid.c \ - ptr_valid/ptr_valid.h + typesafe_cb/typesafe_cb.h ccanincludedir=$(includedir)/hkl-@VMAJ@/hkl/ccan nobase_ccaninclude_HEADERS= \ diff -Nru hkl-5.0.0.2816/INSTALL hkl-5.0.0.2875/INSTALL --- hkl-5.0.0.2816/INSTALL 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/INSTALL 2021-12-08 09:14:21.000000000 +0000 @@ -1,8 +1,8 @@ Installation Instructions ************************* - Copyright (C) 1994-1996, 1999-2002, 2004-2016 Free Software -Foundation, Inc. + Copyright (C) 1994-1996, 1999-2002, 2004-2017, 2020-2021 Free +Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright @@ -225,7 +225,7 @@ and if that doesn't work, install pre-built binaries of GCC for HP-UX. - HP-UX 'make' updates targets which have the same time stamps as their + HP-UX 'make' updates targets which have the same timestamps as their prerequisites, which makes it generally unusable when shipped generated files such as 'configure' are involved. Use GNU 'make' instead. diff -Nru hkl-5.0.0.2816/Makefile.am hkl-5.0.0.2875/Makefile.am --- hkl-5.0.0.2816/Makefile.am 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/Makefile.am 2021-12-08 09:14:21.000000000 +0000 @@ -1,11 +1,3 @@ - @rm -rf $(CCAN_TMP_DEST) && mkdir -p $(CCAN_TMP_DEST) - @rsync -av --exclude=Makefile.am $(CCAN_LOCAL_EXTRACT)/* $(CCAN_TMP_DEST) - @find $(CCAN_TMP_DEST)/ccan -maxdepth 2 -name '*.[ch]' | xargs sed -i -e 's,ccan/,hkl/ccan/,' - @find $(CCAN_TMP_DEST)/ccan -maxdepth 2 -name '*.[ch]' | xargs sed -i -e 's,"config.h",,' - @find $(CCAN_TMP_DEST)/ccan -maxdepth 2 -name '_info' | xargs rm -f - @find $(CCAN_TMP_DEST)/ccan -maxdepth 2 -name 'test' | xargs rm -rf - - @$(CCAN_CREATE_TREE) $(CCAN_PUBLIC_MODULES) ## Process this file with automake to produce Makefile.in ACLOCAL_AMFLAGS = -I m4 diff -Nru hkl-5.0.0.2816/third-party/datatype99.h hkl-5.0.0.2875/third-party/datatype99.h --- hkl-5.0.0.2816/third-party/datatype99.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/datatype99.h 2021-12-08 09:14:21.000000000 +0000 @@ -29,23 +29,24 @@ #include -#if !ML99_VERSION_COMPATIBLE(1, 9, 0) -#error Please, update Metalang99 to v1.9.0 or later. +#if !ML99_VERSION_COMPATIBLE(1, 13, 0) +#error Please, update Metalang99 to v1.13.0 or later. #endif #ifndef DATATYPE99_NO_ALIASES -#define datatype datatype99 -#define record record99 -#define match match99 -#define MATCHES MATCHES99 +#define datatype(...) datatype99(__VA_ARGS__) +#define derive(...) derive99(__VA_ARGS__) +#define record(...) record99(__VA_ARGS__) +#define match(val) match99(val) +#define MATCHES(val, tag) MATCHES99(val, tag) /// @deprecated Use `MATCHES` instead. -#define matches(val, tag_) \ +#define matches(val, tag) \ DATATYPE99_PRIV_PRAGMA_WARN("GCC warning \"`matches` is deprecated, use `MATCHES` instead\"") \ - MATCHES(val, tag_) -#define ifLet ifLet99 -#define of of99 -#define otherwise otherwise99 + MATCHES(val, tag) +#define ifLet(val, tag, ...) ifLet99(val, tag, __VA_ARGS__) +#define of(...) of99(__VA_ARGS__) +#define otherwise otherwise99 #define UnitT UnitT99 #define unit_v unit_v99 @@ -92,8 +93,12 @@ #define DATATYPE99_DERIVE_dummy_IMPL(...) ML99_empty() #define DATATYPE99_RECORD_DERIVE_dummy_IMPL(...) ML99_empty() +#define derive99(...) \ + 0derive(__VA_ARGS__) /* 0 is used as a prefix to cancel macro expansion; see \ + . */ + #define DATATYPE99_MAJOR 1 -#define DATATYPE99_MINOR 5 +#define DATATYPE99_MINOR 6 #define DATATYPE99_PATCH 0 #define DATATYPE99_VERSION_COMPATIBLE(x, y, z) \ @@ -118,14 +123,14 @@ v(ML99_TRAILING_SEMICOLON())) #define DATATYPE99_PRIV_withDerive_0(name, ...) \ - DATATYPE99_PRIV_withDerive_1(derive(dummy), name, __VA_ARGS__) + DATATYPE99_PRIV_withDerive_1(derive99(dummy), name, __VA_ARGS__) #define DATATYPE99_PRIV_withDerive_1(derivers, name, ...) \ ML99_call( \ DATATYPE99_PRIV_genDatatype, \ v(name), \ DATATYPE99_PRIV_parseVariants(__VA_ARGS__), \ - v(DATATYPE99_PRIV_ELIM_##derivers)) + v(ML99_CAT(DATATYPE99_PRIV_ELIM_, derivers))) #define DATATYPE99_PRIV_genDatatype_IMPL(name, variants, ...) \ ML99_TERMS( \ @@ -155,26 +160,21 @@ v(ML99_TRAILING_SEMICOLON())) #define DATATYPE99_PRIV_recordWithDerive_0(...) \ - DATATYPE99_PRIV_recordWithDerive_1(derive(dummy), __VA_ARGS__) + DATATYPE99_PRIV_recordWithDerive_1(derive99(dummy), __VA_ARGS__) #define DATATYPE99_PRIV_recordWithDerive_1(derivers, ...) \ ML99_call( \ DATATYPE99_PRIV_genRecord, \ DATATYPE99_PRIV_recordName(__VA_ARGS__), \ DATATYPE99_PRIV_recordFields(__VA_ARGS__), \ - v(DATATYPE99_PRIV_ELIM_##derivers)) + v(ML99_CAT(DATATYPE99_PRIV_ELIM_, derivers))) #define DATATYPE99_PRIV_recordName(...) v(ML99_VARIADICS_GET(0)(__VA_ARGS__)) #define DATATYPE99_PRIV_recordFields(...) \ - ML99_IF( \ - ML99_VARIADICS_IS_SINGLE(__VA_ARGS__), \ - DATATYPE99_PRIV_recordFieldsDummy, \ - DATATYPE99_PRIV_recordFieldsSeq) \ - (__VA_ARGS__) - -#define DATATYPE99_PRIV_recordFieldsDummy(...) ML99_list(v((char, dummy))) -#define DATATYPE99_PRIV_recordFieldsSeq(_name, ...) DATATYPE99_PRIV_parseFields(__VA_ARGS__) + ML99_CAT(DATATYPE99_PRIV_recordFields_, ML99_VARIADICS_IS_SINGLE(__VA_ARGS__))(__VA_ARGS__) +#define DATATYPE99_PRIV_recordFields_1(_name) ML99_list(v((char, dummy))) +#define DATATYPE99_PRIV_recordFields_0(_name, ...) DATATYPE99_PRIV_parseFields(__VA_ARGS__) #define DATATYPE99_PRIV_genRecord_IMPL(name, fields, ...) \ ML99_TERMS( \ @@ -220,10 +220,10 @@ // Derivation { -#define DATATYPE99_PRIV_IS_DERIVE(x) ML99_IS_TUPLE(ML99_CAT(DATATYPE99_PRIV_IS_DERIVE_, x)) -#define DATATYPE99_PRIV_IS_DERIVE_derive(...) () +#define DATATYPE99_PRIV_IS_DERIVE(x) ML99_IS_TUPLE(ML99_CAT(DATATYPE99_PRIV_IS_DERIVE_, x)) +#define DATATYPE99_PRIV_IS_DERIVE_0derive(...) () -#define DATATYPE99_PRIV_ELIM_derive(...) __VA_ARGS__ +#define DATATYPE99_PRIV_ELIM_0derive(...) __VA_ARGS__ #define DATATYPE99_PRIV_invokeDeriverForEach(prefix, name, repr, ...) \ ML99_variadicsForEach( \ @@ -284,10 +284,10 @@ #define MATCHES99(val, tag_) ((val).tag == tag_##Tag) /// @deprecated Use `MATCHES99` instead. -#define matches99(val, tag_) \ +#define matches99(val, tag) \ DATATYPE99_PRIV_PRAGMA_WARN( \ "GCC warning \"`matches99` is deprecated, use `MATCHES99` instead\"") \ - MATCHES99(val, tag_) + MATCHES99(val, tag) // } (Pattern matching) diff -Nru hkl-5.0.0.2816/third-party/Makefile.am hkl-5.0.0.2875/third-party/Makefile.am --- hkl-5.0.0.2816/third-party/Makefile.am 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/Makefile.am 2021-12-08 09:14:21.000000000 +0000 @@ -2,6 +2,7 @@ datatype99.h \ metalang99/assert.h \ metalang99/aux.h \ + metalang99/bool.h \ metalang99/choice.h \ metalang99/control.h \ metalang99/either.h \ @@ -33,13 +34,17 @@ metalang99/nat.h \ metalang99/nat/inc.h \ metalang99/priv/aux.h \ + metalang99/priv/bool.h \ metalang99/priv/compiler_attr.h \ metalang99/priv/compiler_specific.h \ metalang99/priv/logical.h \ metalang99/priv/pair.h \ + metalang99/priv/tuple.h \ metalang99/priv/util.h \ metalang99/priv/variadics/count.h \ metalang99/priv/variadics/get.h \ + metalang99/seq.h \ + metalang99/stmt.h \ metalang99/tuple.h \ metalang99/uint/dec.h \ metalang99/uint/div.h \ diff -Nru hkl-5.0.0.2816/third-party/metalang99/assert.h hkl-5.0.0.2875/third-party/metalang99/assert.h --- hkl-5.0.0.2816/third-party/metalang99/assert.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/assert.h 2021-12-08 09:14:21.000000000 +0000 @@ -2,6 +2,8 @@ * @file * Static assertions. * + * For the sake of convenience, this header automatically includes `metalang99/bool.h`. + * * @note [C99] Any of the following assertion macros must **not** appear on the same line number * twice with itself as well as with any other Metalang99 assertion macro. * @note [C11] The following assertion macros expand to `_Static_assert` and, therefore, can be used @@ -13,8 +15,8 @@ #include +#include #include -#include /** * The same as #ML99_ASSERT but results in a Metalang99 term. @@ -56,8 +58,8 @@ #define ML99_ASSERT_EQ(lhs, rhs) ML99_ASSERT_UNEVAL((ML99_EVAL(lhs)) == (ML99_EVAL(rhs))) /** - * Asserts the C constant expression @p expr; static_assert in pure C99. + * Asserts the C constant expression @p expr; + * [static_assert](https://en.cppreference.com/w/c/error/static_assert) in pure C99. * * # Examples * diff -Nru hkl-5.0.0.2816/third-party/metalang99/bool.h hkl-5.0.0.2875/third-party/metalang99/bool.h --- hkl-5.0.0.2816/third-party/metalang99/bool.h 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/bool.h 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,246 @@ +/** + * @file + * Boolean algebra. + */ + +#ifndef ML99_BOOL_H +#define ML99_BOOL_H + +#include +#include + +#include + +/** + * Truth. + */ +#define ML99_true(...) ML99_callUneval(ML99_true, ) + +/** + * Falsehood. + */ +#define ML99_false(...) ML99_callUneval(ML99_false, ) + +/** + * Logical negation. + * + * # Examples + * + * @code + * #include + * + * // 1 + * ML99_not(v(0)) + * + * // 0 + * ML99_not(v(1)) + * @endcode + */ +#define ML99_not(x) ML99_call(ML99_not, x) + +/** + * Logical conjunction. + * + * # Examples + * + * @code + * #include + * + * // 0 + * ML99_and(v(0), v(0)) + * + * // 0 + * ML99_and(v(0), v(1)) + * + * // 0 + * ML99_and(v(1), v(0)) + * + * // 1 + * ML99_and(v(1), v(1)) + * @endcode + */ +#define ML99_and(x, y) ML99_call(ML99_and, x, y) + +/** + * Logical inclusive OR. + * + * # Examples + * @code + * #include + * + * // 0 + * ML99_or(v(0), v(0)) + * + * // 1 + * ML99_or(v(0), v(1)) + * + * // 1 + * ML99_or(v(1), v(0)) + * + * // 1 + * ML99_or(v(1), v(1)) + * @endcode + */ +#define ML99_or(x, y) ML99_call(ML99_or, x, y) + +/** + * Logical exclusive OR. + * + * # Examples + * + * @code + * #include + * + * // 0 + * ML99_xor(v(0), v(0)) + * + * // 1 + * ML99_xor(v(0), v(1)) + * + * // 1 + * ML99_xor(v(1), v(0)) + * + * // 0 + * ML99_xor(v(1), v(1)) + * @endcode + */ +#define ML99_xor(x, y) ML99_call(ML99_xor, x, y) + +/** + * Tests @p x and @p y for equality. + * + * # Examples + * + * @code + * #include + * + * // 1 + * ML99_boolEq(v(0), v(0)) + * + * // 0 + * ML99_boolEq(v(0), v(1)) + * + * // 0 + * ML99_boolEq(v(1), v(0)) + * + * // 1 + * ML99_boolEq(v(1), v(1)) + * @endcode + */ +#define ML99_boolEq(x, y) ML99_call(ML99_boolEq, x, y) + +/** + * Matches @p x against the two cases: if it is 0 or 1. + * + * # Examples + * + * @code + * #include + * + * #define MATCH_1_IMPL() v(Billie) + * #define MATCH_0_IMPL() v(Jean) + * + * // Billie + * ML99_boolMatch(v(1), v(MATCH_)) + * + * // Jean + * ML99_boolMatch(v(0), v(MATCH_)) + * @endcode + * + * @note This function calls @p f with #ML99_call, so no partial application occurs, and so + * arity specifiers are not needed. + */ +#define ML99_boolMatch(x, matcher) ML99_call(ML99_boolMatch, x, matcher) + +/** + * The same as #ML99_boolMatch but provides additional arguments to all branches. + * + * # Examples + * + * @code + * #include + * + * #define MATCH_1_IMPL(x, y, z) v(Billie ~ x y z) + * #define MATCH_0_IMPL(x, y, z) v(Jean ~ x y z) + * + * // Billie ~ 1 2 3 + * ML99_boolMatchWithArgs(v(1), v(MATCH_), v(1, 2, 3)) + * + * // Jean ~ 1 2 3 + * ML99_boolMatchWithArgs(v(0), v(MATCH_), v(1, 2, 3)) + * @endcode + */ +#define ML99_boolMatchWithArgs(x, matcher, ...) \ + ML99_call(ML99_boolMatchWithArgs, x, matcher, __VA_ARGS__) + +/** + * If @p cond is true, evaluates to @p x, otherwise @p y. + * + * # Examples + * + * @code + * #include + * + * // 123 + * ML99_if(v(1), v(123), v(18)) + * + * // 18 + * ML99_if(v(0), v(123), v(18)) + * @endcode + */ +#define ML99_if(cond, x, y) ML99_call(ML99_if, cond, x, y) + +/** + * The plain version of #ML99_if. + * + * This macro can imitate lazy evaluation: `ML99_IF(, , )` will expand to + * one of the two terms, which can be evaluated further; if `` is 0, then `` will + * **not** be evaluated, and the same with ``. + * + * @note @p x and @p y can possibly expand to commas. It means that you can supply `ML99_TERMS(...)` + * as a branch, for example. + */ +#define ML99_IF(cond, x, y) ML99_PRIV_UNTUPLE(ML99_PRIV_IF(cond, (x), (y))) + +#define ML99_TRUE(...) 1 +#define ML99_FALSE(...) 0 + +#define ML99_NOT(x) ML99_PRIV_NOT(x) +#define ML99_AND(x, y) ML99_PRIV_AND(x, y) +#define ML99_OR(x, y) ML99_PRIV_OR(x, y) +#define ML99_XOR(x, y) ML99_PRIV_XOR(x, y) +#define ML99_BOOL_EQ(x, y) ML99_PRIV_BOOL_EQ(x, y) + +#ifndef DOXYGEN_IGNORE + +#define ML99_true_IMPL(...) v(ML99_TRUE()) +#define ML99_false_IMPL(...) v(ML99_FALSE()) + +#define ML99_not_IMPL(x) v(ML99_NOT(x)) +#define ML99_and_IMPL(x, y) v(ML99_AND(x, y)) +#define ML99_or_IMPL(x, y) v(ML99_OR(x, y)) +#define ML99_xor_IMPL(x, y) v(ML99_XOR(x, y)) +#define ML99_boolEq_IMPL(x, y) v(ML99_BOOL_EQ(x, y)) + +#define ML99_boolMatch_IMPL(x, matcher) ML99_callUneval(matcher##x, ) +#define ML99_boolMatchWithArgs_IMPL(x, matcher, ...) ML99_callUneval(matcher##x, __VA_ARGS__) + +#define ML99_if_IMPL(cond, x, y) v(ML99_PRIV_IF(cond, x, y)) + +// Arity specifiers { + +#define ML99_true_ARITY 1 +#define ML99_false_ARITY 1 +#define ML99_not_ARITY 1 +#define ML99_and_ARITY 2 +#define ML99_or_ARITY 2 +#define ML99_xor_ARITY 2 +#define ML99_boolEq_ARITY 2 +#define ML99_boolMatch_ARITY 2 +#define ML99_boolMatchWithArgs_ARITY 3 +#define ML99_if_ARITY 3 +// } (Arity specifiers) + +#endif // DOXYGEN_IGNORE + +#endif // ML99_BOOL_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/choice.h hkl-5.0.0.2875/third-party/metalang99/choice.h --- hkl-5.0.0.2816/third-party/metalang99/choice.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/choice.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,13 +1,15 @@ /** * @file - * Choice types. + * Choice types: `(tag, ...)`. * - * A choice type is a type with several alternatives. Perhaps the most common example of a choice - * type is a binary tree: + * A choice type, also known as [tagged union], is represented as `(tag, ...)`, where `tag` is the + * type of a value and `...` is the value. Perhaps the most common example of a choice type is a + * binary tree: * - * [examples/binary_tree.c] + * [[examples/binary_tree.c](https://github.com/Hirrolot/metalang99/blob/master/examples/binary_tree.c)] * @include binary_tree.c + * + * [tagged union]: https://en.wikipedia.org/wiki/Tagged_union */ #ifndef ML99_CHOICE_H @@ -22,8 +24,8 @@ * * # Examples * - * See examples/binary_tree.c. + * See + * [examples/binary_tree.c](https://github.com/Hirrolot/metalang99/blob/master/examples/binary_tree.c). * * @note Specify `~` if you do not want to supply data; then, to match it, write a `_` parameter to * ignore. @@ -33,26 +35,44 @@ /** * Evaluates to the tag of @p choice. * + * This macro is essentially the same as `ML99_tupleGet(0)`. + * * # Examples * * @code * #include * - * // Foo - * ML99_choiceTag(ML99_choice(v(Foo), v(1, 2, 3))) + * // foo + * ML99_choiceTag(ML99_choice(v(foo), v(1, 2, 3))) * @endcode */ #define ML99_choiceTag(choice) ML99_call(ML99_choiceTag, choice) /** + * Evaluates to the data of @p choice. + * + * This macro is essentially the same as #ML99_tupleTail. + * + * # Examples + * + * @code + * #include + * + * // 1, 2, 3 + * ML99_choiceData(ML99_choice(v(foo), v(1, 2, 3))) + * @endcode + */ +#define ML99_choiceData(choice) ML99_call(ML99_choiceData, choice) + +/** * Matches the instance @p choice of a choice type. * * This macro results in `ML99_call(ML99_cat(matcher, ML99_choiceTag(choice)), )`. * * # Examples * - * See examples/binary_tree.c. + * See + * [examples/binary_tree.c](https://github.com/Hirrolot/metalang99/blob/master/examples/binary_tree.c). */ #define ML99_match(choice, matcher) ML99_call(ML99_match, choice, matcher) @@ -76,29 +96,30 @@ #define ML99_matchWithArgs(choice, matcher, ...) \ ML99_call(ML99_matchWithArgs, choice, matcher, __VA_ARGS__) -#define ML99_CHOICE(tag, ...) (tag, __VA_ARGS__) -#define ML99_CHOICE_TAG(choice) ML99_PRIV_HEAD_AUX choice +#define ML99_CHOICE(tag, ...) (tag, __VA_ARGS__) +#define ML99_CHOICE_TAG(choice) ML99_PRIV_HEAD_AUX choice +#define ML99_CHOICE_DATA(choice) ML99_PRIV_TAIL_AUX choice #ifndef DOXYGEN_IGNORE -#define ML99_choice_IMPL(tag, ...) v(ML99_CHOICE(tag, __VA_ARGS__)) -#define ML99_choiceTag_IMPL(choice) v(ML99_CHOICE_TAG(choice)) +#define ML99_choice_IMPL(tag, ...) v(ML99_CHOICE(tag, __VA_ARGS__)) +#define ML99_choiceTag_IMPL(choice) v(ML99_CHOICE_TAG(choice)) +#define ML99_choiceData_IMPL(choice) v(ML99_CHOICE_DATA(choice)) #define ML99_match_IMPL(choice, matcher) \ - ML99_callUneval(ML99_PRIV_CAT(matcher, ML99_PRIV_HEAD_AUX choice), ML99_PRIV_CHOICE_DATA choice) + ML99_callUneval(ML99_PRIV_CAT(matcher, ML99_PRIV_HEAD_AUX choice), ML99_PRIV_TAIL_AUX choice) #define ML99_matchWithArgs_IMPL(choice, matcher, ...) \ ML99_callUneval( \ ML99_PRIV_CAT(matcher, ML99_PRIV_HEAD_AUX choice), \ - ML99_PRIV_CHOICE_DATA choice, \ + ML99_PRIV_TAIL_AUX choice, \ __VA_ARGS__) -#define ML99_PRIV_CHOICE_DATA ML99_PRIV_TAIL_AUX - // Arity specifiers { #define ML99_choice_ARITY 2 #define ML99_choiceTag_ARITY 1 +#define ML99_choiceData_ARITY 1 #define ML99_match_ARITY 2 #define ML99_matchWithArgs_ARITY 3 // } (Arity specifiers) diff -Nru hkl-5.0.0.2816/third-party/metalang99/control.h hkl-5.0.0.2875/third-party/metalang99/control.h --- hkl-5.0.0.2816/third-party/metalang99/control.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/control.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,126 +1,13 @@ /** * @file - * Control flow operators. + * This module is deprecated and exists only for backwards compatibility. */ #ifndef ML99_CONTROL_H #define ML99_CONTROL_H -#include - -#include -#include -#include - -/** - * If @p cond is true, evaluates to @p x, otherwise @p y. - * - * # Examples - * - * @code - * #include - * #include - * - * // 123 - * ML99_if(ML99_true(), v(123), v(18)) - * - * // 18 - * ML99_if(ML99_false(), v(123), v(18)) - * @endcode - */ -#define ML99_if(cond, x, y) ML99_call(ML99_if, cond, x, y) - -/** - * Invokes @p f @p n times, providing an iteration index each time. - * - * # Examples - * - * @code - * #include - * #include - * - * // _0 _1 _2 - * ML99_repeat(v(3), ML99_appl(v(ML99_cat), v(_))) - * @endcode - */ -#define ML99_repeat(n, f) ML99_call(ML99_repeat, n, f) - -/** - * Pastes provided arguments @p n times. - * - * # Examples - * - * @code - * #include - * - * // ~ ~ ~ ~ ~ - * ML99_times(v(5), v(~)) - * @endcode - */ -#define ML99_times(n, ...) ML99_call(ML99_times, n, __VA_ARGS__) - -/** - * Overloads @p f on a number of arguments. - * - * This function counts the number of provided arguments, appends it to @p f and calls the resulting - * macro identifier with provided arguments. - * - * At most 63 variadic arguments are acceptable. - * - * # Examples - * - * @code - * #include - * - * #define X(...) ML99_OVERLOAD(X_, __VA_ARGS__) - * #define X_1(a) Billie & a - * #define X_2(a, b) Jean & a & b - * - * // Billie & 4 - * X(4) - * - * // Jean & 5 & 6 - * X(5, 6) - * @endcode - * - * @note @p f need not be postfixed with `_IMPL`. It is literally invoked as `ML99_CAT(f, - * ML99_VARIADICS_COUNT(...))(...)`. - */ -#define ML99_OVERLOAD(f, ...) ML99_PRIV_CAT(f, ML99_PRIV_VARIADICS_COUNT(__VA_ARGS__))(__VA_ARGS__) - -/** - * The plain version of #ML99_if. - * - * This macro can be used to imitate lazy evaluation: `ML99_IF(, , )` will - * expand to one of the terms, which can be evaluated further. - * - * Also, you can conditionally call a plain macro like this: `ML99_IF(, , )(args...)`, - * where `` and `` are plain macros. - * - * @note @p x and @p y can possibly expand to commas. It means that you can supply `ML99_TERMS(...)` - * as a branch, for example. - */ -#define ML99_IF(cond, x, y) ML99_UNTUPLE(ML99_PRIV_IF(cond, (x), (y))) - -#ifndef DOXYGEN_IGNORE - -#define ML99_if_IMPL(cond, x, y) v(ML99_PRIV_IF(cond, x, y)) - -#define ML99_repeat_IMPL(n, f) ML99_natMatchWithArgs_IMPL(n, ML99_PRIV_repeat_, f) -#define ML99_PRIV_repeat_Z_IMPL(...) v(ML99_PRIV_EMPTY()) -#define ML99_PRIV_repeat_S_IMPL(i, f) ML99_TERMS(ML99_repeat_IMPL(i, f), ML99_appl_IMPL(f, i)) - -#define ML99_times_IMPL(n, ...) ML99_natMatchWithArgs_IMPL(n, ML99_PRIV_times_, __VA_ARGS__) -#define ML99_PRIV_times_Z_IMPL(...) v(ML99_PRIV_EMPTY()) -#define ML99_PRIV_times_S_IMPL(i, ...) ML99_TERMS(v(__VA_ARGS__), ML99_times_IMPL(i, __VA_ARGS__)) - -// Arity specifiers { - -#define ML99_if_ARITY 3 -#define ML99_repeat_ARITY 2 -#define ML99_times_ARITY 2 -// } (Arity specifiers) - -#endif // DOXYGEN_IGNORE +#include // ML99_if, ML99_IF +#include // ML99_times, ML99_repeat +#include // ML99_OVERLOAD #endif // ML99_CONTROL_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/either.h hkl-5.0.0.2875/third-party/metalang99/either.h --- hkl-5.0.0.2816/third-party/metalang99/either.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/either.h 2021-12-08 09:14:21.000000000 +0000 @@ -6,9 +6,11 @@ #ifndef ML99_EITHER_H #define ML99_EITHER_H +#include + +#include #include -#include -#include +#include /** * The left value @p x. @@ -122,14 +124,22 @@ #define ML99_isLeft_IMPL(either) v(ML99_IS_LEFT(either)) #define ML99_isRight_IMPL(either) v(ML99_IS_RIGHT(either)) -#define ML99_PRIV_IS_LEFT(either) ML99_DETECT_IDENT(ML99_PRIV_IS_LEFT_, ML99_CHOICE_TAG(either)) -#define ML99_PRIV_IS_LEFT_left () +// ML99_eitherEq_IMPL { #define ML99_eitherEq_IMPL(cmp, either, other) \ - ML99_PRIV_IF( \ - ML99_PRIV_EITHER_TAGS_ARE_EQUAL(either, other), \ - ML99_appl2_IMPL(cmp, ML99_PRIV_CHOICE_DATA either, ML99_PRIV_CHOICE_DATA other), \ - v(ML99_FALSE())) + ML99_matchWithArgs_IMPL(either, ML99_PRIV_eitherEq_, cmp, other) + +#define ML99_PRIV_eitherEq_left_IMPL(x, cmp, other) \ + ML99_matchWithArgs_IMPL(other, ML99_PRIV_eitherEq_left_, cmp, x) +#define ML99_PRIV_eitherEq_right_IMPL(x, cmp, other) \ + ML99_matchWithArgs_IMPL(other, ML99_PRIV_eitherEq_right_, cmp, x) + +#define ML99_PRIV_eitherEq_left_left_IMPL(y, cmp, x) ML99_appl2_IMPL(cmp, x, y) +#define ML99_PRIV_eitherEq_left_right_IMPL ML99_false_IMPL + +#define ML99_PRIV_eitherEq_right_left_IMPL ML99_false_IMPL +#define ML99_PRIV_eitherEq_right_right_IMPL(y, cmp, x) ML99_appl2_IMPL(cmp, x, y) +// } (ML99_eitherEq_IMPL) #define ML99_unwrapLeft_IMPL(either) ML99_match_IMPL(either, ML99_PRIV_unwrapLeft_) #define ML99_PRIV_unwrapLeft_left_IMPL(x) v(x) @@ -141,10 +151,8 @@ ML99_fatal(ML99_unwrapRight, expected ML99_right but found ML99_left) #define ML99_PRIV_unwrapRight_right_IMPL(x) v(x) -#define ML99_PRIV_EITHER_TAGS_ARE_EQUAL(either, other) \ - ML99_OR( \ - ML99_AND(ML99_IS_LEFT(either), ML99_IS_LEFT(other)), \ - ML99_AND(ML99_IS_RIGHT(either), ML99_IS_RIGHT(other))) +#define ML99_PRIV_IS_LEFT(either) ML99_DETECT_IDENT(ML99_PRIV_IS_LEFT_, ML99_CHOICE_TAG(either)) +#define ML99_PRIV_IS_LEFT_left () // Arity specifiers { diff -Nru hkl-5.0.0.2816/third-party/metalang99/eval/eval.h hkl-5.0.0.2875/third-party/metalang99/eval/eval.h --- hkl-5.0.0.2816/third-party/metalang99/eval/eval.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/eval/eval.h 2021-12-08 09:14:21.000000000 +0000 @@ -9,7 +9,6 @@ #include #include #include -#include #define ML99_PRIV_EVAL(...) \ ML99_PRIV_REC_UNROLL(ML99_PRIV_EVAL_MATCH( \ @@ -32,7 +31,11 @@ #define ML99_PRIV_EVAL_MATCH(k, k_cx, folder, acc, head, ...) \ ML99_PRIV_CHECK_TERM(head, ML99_PRIV_TERM_MATCH) \ - (head, ML99_PRIV_EVAL_)(k, k_cx, folder, acc, (__VA_ARGS__), ML99_PRIV_EVAL_TERM_DATA head) + (head)(k, k_cx, folder, acc, (__VA_ARGS__), ML99_PRIV_TERM_DATA head) + +#define ML99_PRIV_TERM_MATCH(term) ML99_PRIV_CAT(ML99_PRIV_EVAL_, ML99_PRIV_TERM_KIND term) +#define ML99_PRIV_TERM_KIND(kind, ...) kind +#define ML99_PRIV_TERM_DATA(_kind, ...) __VA_ARGS__ // Reduction rules { @@ -93,20 +96,25 @@ (0end, ~), \ ~) +/* + * In this subroutine, we employ the following optimisation: + * + * - If `evaluated_op` expands to many terms, we first evaluate these terms and accumulate them + * (`ML99_PRIV_EVAL_0callUneval_K_1`). + * - Otherwise, we just paste a single term with the rest of the tail + * (`ML99_PRIV_EVAL_0callUneval_K_0`). + */ #define ML99_PRIV_EVAL_0callUneval_K(k, k_cx, folder, acc, tail, evaluated_op, ...) \ - /* If the metafunction `evaluated_op` expands to many terms, we first evaluate these terms and \ - * accumulate them, otherwise, we just paste the single term with the rest of the tail. This \ - * optimisation results in a huge performance improvement. */ \ - ML99_PRIV_IF( \ - ML99_PRIV_CONTAINS_COMMA(evaluated_op##_IMPL(__VA_ARGS__)), \ - ML99_PRIV_EVAL_0callUneval_K_REGULAR, \ - ML99_PRIV_EVAL_0callUneval_K_OPTIMIZED) \ - (k, k_cx, folder, acc, tail, evaluated_op##_IMPL(__VA_ARGS__)) + ML99_PRIV_EVAL_0callUneval_K_AUX(k, k_cx, folder, acc, tail, evaluated_op##_IMPL(__VA_ARGS__)) + +#define ML99_PRIV_EVAL_0callUneval_K_AUX(k, k_cx, folder, acc, tail, ...) \ + ML99_PRIV_CAT(ML99_PRIV_EVAL_0callUneval_K_, ML99_PRIV_CONTAINS_COMMA(__VA_ARGS__)) \ + (k, k_cx, folder, acc, tail, __VA_ARGS__) -#define ML99_PRIV_EVAL_0callUneval_K_OPTIMIZED(k, k_cx, folder, acc, tail, body) \ +#define ML99_PRIV_EVAL_0callUneval_K_0(k, k_cx, folder, acc, tail, body) \ ML99_PRIV_MACHINE_REDUCE(k, k_cx, folder, acc, body, ML99_PRIV_EXPAND tail) -#define ML99_PRIV_EVAL_0callUneval_K_REGULAR(k, k_cx, folder, acc, tail, ...) \ +#define ML99_PRIV_EVAL_0callUneval_K_1(k, k_cx, folder, acc, tail, ...) \ ML99_PRIV_MACHINE_REDUCE( \ ML99_PRIV_EVAL_0v_K, \ (k, k_cx, folder, acc, tail), \ diff -Nru hkl-5.0.0.2816/third-party/metalang99/eval/syntax_checker.h hkl-5.0.0.2875/third-party/metalang99/eval/syntax_checker.h --- hkl-5.0.0.2816/third-party/metalang99/eval/syntax_checker.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/eval/syntax_checker.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,40 +1,39 @@ #ifndef ML99_EVAL_SYNTAX_CHECKER_H #define ML99_EVAL_SYNTAX_CHECKER_H +#include #include +#include #include #include #define ML99_PRIV_CHECK_TERM(term, default) \ - ML99_PRIV_IF(ML99_PRIV_IS_UNTUPLE(term), ML99_PRIV_SYNTAX_CHECKER_EMIT_ERROR, default) + ML99_PRIV_IF(ML99_PRIV_IS_UNTUPLE(term), ML99_PRIV_EMIT_SYNTAX_ERROR, default) // clang-format off -#define ML99_PRIV_SYNTAX_CHECKER_EMIT_ERROR(term, ...) \ +#define ML99_PRIV_EMIT_SYNTAX_ERROR(term) \ ML99_PRIV_REC_CONTINUE(ML99_PRIV_REC_STOP)((~), ML99_PRIV_SYNTAX_ERROR(term)) \ /* Consume arguments passed to ML99_PRIV_TERM_MATCH, see eval.h. */ \ ML99_PRIV_EMPTY // clang-format on #define ML99_PRIV_SYNTAX_ERROR(invalid_term) \ - ML99_PRIV_IF( \ - ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(invalid_term), \ - ML99_PRIV_SYNTAX_ERROR_COMMA_AUX, \ - ML99_PRIV_SYNTAX_ERROR_AUX) \ + ML99_PRIV_CAT(ML99_PRIV_SYNTAX_ERROR_, ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(invalid_term)) \ (invalid_term) #ifdef ML99_PRIV_EMIT_ERROR -#define ML99_PRIV_SYNTAX_ERROR_AUX(invalid_term) \ +#define ML99_PRIV_SYNTAX_ERROR_0(invalid_term) \ ML99_PRIV_EMIT_ERROR("invalid term `" #invalid_term "`"); -#define ML99_PRIV_SYNTAX_ERROR_COMMA_AUX(invalid_term) \ +#define ML99_PRIV_SYNTAX_ERROR_1(invalid_term) \ ML99_PRIV_EMIT_ERROR("invalid term `" #invalid_term "`, did you miss a comma?"); #else // clang-format off -#define ML99_PRIV_SYNTAX_ERROR_AUX(invalid_term) !"Metalang99 syntax error": {invalid_term} -#define ML99_PRIV_SYNTAX_ERROR_COMMA_AUX(invalid_term) \ +#define ML99_PRIV_SYNTAX_ERROR_0(invalid_term) !"Metalang99 syntax error": {invalid_term} +#define ML99_PRIV_SYNTAX_ERROR_1(invalid_term) \ !"Metalang99 syntax error (did you miss a comma?)": {invalid_term} // clang-format on diff -Nru hkl-5.0.0.2816/third-party/metalang99/gen.h hkl-5.0.0.2875/third-party/metalang99/gen.h --- hkl-5.0.0.2816/third-party/metalang99/gen.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/gen.h 2021-12-08 09:14:21.000000000 +0000 @@ -2,105 +2,24 @@ * @file * Support for C language constructions. * - * # Statement chaining - * - * This module exports a bunch of so-called _statement chaining macros_: they expect a statement - * right after their invocation, and moreover, an invocation of such a macro with a statement - * afterwards altogether form a single statement. - * - * How can this be helpful? Imagine you are writing a macro with the following syntax: - * - * @code - * MY_MACRO(...) { bla bla bla } - * @endcode - * - * Then `MY_MACRO` must expand to a _statement prefix_, i.e. something that expects a statement - * after itself. One possible solution is to make `MY_MACRO` expand to a sequence of statement - * chaining macros like this: - * - * @code - * #define MY_MACRO(...) \ - * ML99_INTRODUCE_VAR_TO_STMT(int x = 5) \ - * ML99_CHAIN_EXPR_STMT(printf("%d\n", x)) \ - * and so on... - * @endcode - * - * Here `ML99_CHAIN_EXPR_STMT` accepts the statement formed by `ML99_CHAIN_EXPR_STMT`, which in turn - * accepts the next statement and so on, until a caller of `MY_MACRO` specifies the final statement, - * thus completing the chain. - * - * @see https://www.chiark.greenend.org.uk/~sgtatham/mp/ for a more involved explanation. + * Some decent usage examples can be found in + * [datatype99/examples/derive](https://github.com/Hirrolot/datatype99/tree/master/examples/derive). */ #ifndef ML99_GEN_H #define ML99_GEN_H +#include + #include -#include #include #include #include #include -#include #include -#ifdef __COUNTER__ - -/** - * Generates a unique identifier @p id in the namespace @p prefix. - * - * Let `FOO` be the name of an enclosing macro. Then `FOO_` must be specified for @p prefix, and @p - * id should be given any meaningful name (this makes debugging easier). - * - * # Examples - * - * @code - * #include - * - * #define FOO(...) FOO_NAMED(ML99_GEN_SYM(FOO_, x), __VA_ARGS__) - * #define FOO_NAMED(x_sym, ...) \ - * do { int x_sym = 5; __VA_ARGS__ } while (0) - * - * // `x` here will not conflict with the `x` inside `FOO`. - * FOO({ - * int x = 7; - * printf("x is %d\n", x); // x is 7 - * }); - * @endcode - * - * @note Two identical calls to #ML99_GEN_SYM will yield different identifiers, therefore, to refer - * to the result later, you must save it in an auxiliary macro's parameter, as shown in the example - * above. - * @note #ML99_GEN_SYM is defined only if `__COUNTER__` is defined, which must be a macro yielding - * integral literals starting from 0 incremented by 1 each time it is called. Currently, it is - * supported at least by Clang, GCC, TCC, and MSVC. - * @see https://en.wikipedia.org/wiki/Hygienic_macro - */ -#define ML99_GEN_SYM(prefix, id) ML99_CAT4(prefix, id, _, __COUNTER__) - -#endif // __COUNTER__ - -/** - * Forces a caller to put a trailing semicolon. - * - * It is useful when defining macros, to make them formatted as complete statements. - * - * # Examples - * - * @code - * #include - * - * #define MY_MACRO(fn_name, val_ty, val) \ - * inline static val_ty fn_name(void) { return val; } \ - * ML99_TRAILING_SEMICOLON() - * - * // Defines a function which always returns 0. - * MY_MACRO(zero, int, 0); - * @endcode - * - * @note This macro expands to a C declaration, therefore, it can be used outside of functions too. - */ -#define ML99_TRAILING_SEMICOLON(...) struct ml99_priv_trailing_semicolon +#include // For backwards compatibility. +#include // For backwards compatibility: ML99_GEN_SYM, ML99_TRAILING_SEMICOLON. /** * Puts a semicolon after provided arguments. @@ -175,7 +94,7 @@ #define ML99_invoke(f, ...) ML99_call(ML99_invoke, f, __VA_ARGS__) /** - * A shortcut for `ML99_semicoloned(ML99_invoked(f, ...))`. + * A shortcut for `ML99_semicoloned(ML99_invoke(f, ...))`. */ #define ML99_invokeStmt(f, ...) ML99_call(ML99_invokeStmt, f, __VA_ARGS__) @@ -187,12 +106,10 @@ * @code * #include * - * // ML99_INTRODUCE_VAR_TO_STMT(int x = 5) { + * // if (1 == 1) { * // printf("x = %d\n", x); * // } - * ML99_prefixedBlock( - * v(ML99_INTRODUCE_VAR_TO_STMT(int x = 5)), - * v(printf("x = %d\n", x);)) + * ML99_prefixedBlock(v(if (1 == 1)), v(printf("x = %d\n", x);)) * @endcode */ #define ML99_prefixedBlock(prefix, ...) ML99_call(ML99_prefixedBlock, prefix, __VA_ARGS__) @@ -260,196 +177,134 @@ #define ML99_anonEnum(...) ML99_call(ML99_anonEnum, __VA_ARGS__) /** - * Generates \f$(T_0 \ \_0, ..., T_n \ \_n)\f$. - * - * If @p type_list is empty, this macro results in `(void)`. + * Generates a function pointer. * * # Examples * * @code * #include * - * // (int _0, long long _1, const char * _2) - * ML99_indexedParams(ML99_list(v(int, long long, const char *))) + * // int (*add)(int x, int y) + * ML99_fnPtr(v(int), v(add), v(int x), v(int y)) * - * // (void) - * ML99_indexedParams(ML99_nil()) + * // const char *(*title)(void) + * ML99_fnPtr(v(const char *), v(title), v(void)) * @endcode */ -#define ML99_indexedParams(type_list) ML99_call(ML99_indexedParams, type_list) +#define ML99_fnPtr(ret_ty, name, ...) ML99_call(ML99_fnPtr, ret_ty, name, __VA_ARGS__) /** - * Generates \f$T_0 \ \_0; ...; T_n \ \_n\f$. - * - * If @p type_list is empty, this macro results in emptiness. - * - * # Examples - * - * @code - * #include - * - * // int _0; long long _1; const char * _2; - * ML99_indexedFields(ML99_list(v(int, long long, const char *))) - * - * // ML99_empty() - * ML99_indexedFields(ML99_nil()) - * @endcode + * A shortcut for `ML99_semicoloned(ML99_fnPtr(ret_ty, name, ...))`. */ -#define ML99_indexedFields(type_list) ML99_call(ML99_indexedFields, type_list) +#define ML99_fnPtrStmt(ret_ty, name, ...) ML99_call(ML99_fnPtrStmt, ret_ty, name, __VA_ARGS__) /** - * Generates \f$\{ \_0, ..., \_{n - 1} \}\f$. - * - * If @p n is 0, this macro results in `{ 0 }`. + * Pastes provided arguments @p n times. * * # Examples * * @code * #include * - * // { _0, _1, _2 } - * ML99_indexedInitializerList(v(3)) - * - * // { 0 } - * ML99_indexedInitializerList(v(0)) + * // ~ ~ ~ ~ ~ + * ML99_times(v(5), v(~)) * @endcode */ -#define ML99_indexedInitializerList(n) ML99_call(ML99_indexedInitializerList, n) +#define ML99_times(n, ...) ML99_call(ML99_times, n, __VA_ARGS__) /** - * Generates \f$\_0, ..., \_{n - 1}\f$. - * - * If @p n is 0, this macro results in emptiness. + * Invokes @p f @p n times, providing an iteration index each time. * * # Examples * * @code * #include + * #include * - * // _0, _1, _2 - * ML99_indexedArgs(v(3)) - * - * // ML99_empty() - * ML99_indexedArgs(v(0)) + * // _0 _1 _2 + * ML99_repeat(v(3), ML99_appl(v(ML99_cat), v(_))) * @endcode */ -#define ML99_indexedArgs(n) ML99_call(ML99_indexedArgs, n) +#define ML99_repeat(n, f) ML99_call(ML99_repeat, n, f) /** - * A statement chaining macro which introduces several variable definitions to a statement right - * after its invocation. - * - * Variable definitions must be specified as in the first clause of the for-loop. + * Generates \f$(T_0 \ \_0, ..., T_n \ \_n)\f$. * - * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * If @p type_list is empty, this macro results in `(void)`. * - * # Example + * # Examples * * @code * #include * - * for (int i = 0; i < 10; i++) - * ML99_INTRODUCE_VAR_TO_STMT(double x = 5.0, y = 7.0) - * if (i % 2 == 0) - * printf("i = %d, x = %f, y = %f\n", i, x, y); + * // (int _0, long long _1, const char * _2) + * ML99_indexedParams(ML99_list(v(int, long long, const char *))) + * + * // (void) + * ML99_indexedParams(ML99_nil()) * @endcode */ -#define ML99_INTRODUCE_VAR_TO_STMT(...) \ - ML99_PRIV_SHADOWS(for (__VA_ARGS__, *ml99_priv_break = (void *)0; \ - ml99_priv_break != (void *)1; \ - ml99_priv_break = (void *)1)) +#define ML99_indexedParams(type_list) ML99_call(ML99_indexedParams, type_list) /** - * The same as #ML99_INTRODUCE_VAR_TO_STMT but deals with a single non-`NULL` pointer. - * - * In comparison with #ML99_INTRODUCE_VAR_TO_STMT, this macro generates a little less code. It - * introduces a pointer to @p ty identified by @p name and initialised to @p init. + * Generates \f$T_0 \ \_0; ...; T_n \ \_n\f$. * - * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * If @p type_list is empty, this macro results in emptiness. * - * # Example + * # Examples * * @code * #include * - * double x = 5.0, y = 7.0; + * // int _0; long long _1; const char * _2; + * ML99_indexedFields(ML99_list(v(int, long long, const char *))) * - * for (int i = 0; i < 10; i++) - * ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(double, x_ptr, &x) - * ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(double, y_ptr, &y) - * printf("i = %d, x = %f, y = %f\n", i, *x_ptr, *y_ptr); + * // ML99_empty() + * ML99_indexedFields(ML99_nil()) * @endcode - * - * @note Unlike #ML99_INTRODUCE_VAR_TO_STMT, the generated pointer is guaranteed to be used at least - * once, meaning that you do not need to suppress the unused variable warning. - * @note @p init is guaranteed to be executed only once. */ -#define ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(ty, name, init) \ - ML99_PRIV_SHADOWS(for (ty *name = (init); name != (void *)0; name = (void *)0)) +#define ML99_indexedFields(type_list) ML99_call(ML99_indexedFields, type_list) /** - * A statement chaining macro which executes an expression statement derived from @p expr right - * before the next statement. + * Generates \f$\{ \_0, ..., \_{n - 1} \}\f$. * - * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * If @p n is 0, this macro results in `{ 0 }`. * - * # Example + * # Examples * * @code * #include * - * int x; + * // { _0, _1, _2 } + * ML99_indexedInitializerList(v(3)) * - * for(;;) - * ML99_CHAIN_EXPR_STMT(x = 5) - * ML99_CHAIN_EXPR_STMT(printf("%d\n", x)) - * puts("abc"); + * // { 0 } + * ML99_indexedInitializerList(v(0)) * @endcode */ -#define ML99_CHAIN_EXPR_STMT(expr) \ - ML99_PRIV_SHADOWS(for (int ml99_priv_expr_stmt_break = ((expr), 0); \ - ml99_priv_expr_stmt_break != 1; \ - ml99_priv_expr_stmt_break = 1)) - -/** - * The same as #ML99_CHAIN_EXPR_STMT but executes @p expr **after** the next statement. - */ -#define ML99_CHAIN_EXPR_STMT_AFTER(expr) \ - ML99_PRIV_SHADOWS(for (int ml99_priv_expr_stmt_after_break = 0; \ - ml99_priv_expr_stmt_after_break != 1; \ - ((expr), ml99_priv_expr_stmt_after_break = 1))) +#define ML99_indexedInitializerList(n) ML99_call(ML99_indexedInitializerList, n) /** - * A statement chaining macro which suppresses the "unused X" warning right before a statement after - * its invocation. + * Generates \f$\_0, ..., \_{n - 1}\f$. * - * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * If @p n is 0, this macro results in emptiness. * - * # Example + * # Examples * * @code * #include * - * int x, y; + * // _0, _1, _2 + * ML99_indexedArgs(v(3)) * - * for(;;) - * ML99_SUPPRESS_UNUSED_BEFORE_STMT(x) - * ML99_SUPPRESS_UNUSED_BEFORE_STMT(y) - * puts("abc"); + * // ML99_empty() + * ML99_indexedArgs(v(0)) * @endcode - * - * @deprecated Use `ML99_CHAIN_EXPR_STMT((void)expr)` instead. */ -#define ML99_SUPPRESS_UNUSED_BEFORE_STMT(expr) ML99_CHAIN_EXPR_STMT((void)expr) +#define ML99_indexedArgs(n) ML99_call(ML99_indexedArgs, n) #ifndef DOXYGEN_IGNORE -#define ML99_PRIV_SHADOWS(...) \ - ML99_CLANG_PRAGMA("clang diagnostic push") \ - ML99_CLANG_PRAGMA("clang diagnostic ignored \"-Wshadow\"") \ - __VA_ARGS__ \ - ML99_CLANG_PRAGMA("clang diagnostic pop") - #define ML99_semicoloned_IMPL(...) v(__VA_ARGS__;) #define ML99_braced_IMPL(...) v({__VA_ARGS__}) #define ML99_assign_IMPL(lhs, ...) v(lhs = __VA_ARGS__) @@ -459,6 +314,8 @@ #define ML99_invoke_IMPL(f, ...) v(f(__VA_ARGS__)) #define ML99_invokeStmt_IMPL(f, ...) v(f(__VA_ARGS__);) #define ML99_typedef_IMPL(ident, ...) v(typedef __VA_ARGS__ ident;) +#define ML99_fnPtr_IMPL(ret_ty, name, ...) v(ret_ty (*name)(__VA_ARGS__)) +#define ML99_fnPtrStmt_IMPL(ret_ty, name, ...) v(ret_ty (*name)(__VA_ARGS__);) // clang-format off #define ML99_prefixedBlock_IMPL(prefix, ...) v(prefix {__VA_ARGS__}) @@ -470,6 +327,14 @@ #define ML99_anonEnum_IMPL(...) v(enum {__VA_ARGS__}) // clang-format on +#define ML99_times_IMPL(n, ...) ML99_natMatchWithArgs_IMPL(n, ML99_PRIV_times_, __VA_ARGS__) +#define ML99_PRIV_times_Z_IMPL ML99_empty_IMPL +#define ML99_PRIV_times_S_IMPL(i, ...) ML99_TERMS(v(__VA_ARGS__), ML99_times_IMPL(i, __VA_ARGS__)) + +#define ML99_repeat_IMPL(n, f) ML99_natMatchWithArgs_IMPL(n, ML99_PRIV_repeat_, f) +#define ML99_PRIV_repeat_Z_IMPL ML99_empty_IMPL +#define ML99_PRIV_repeat_S_IMPL(i, f) ML99_TERMS(ML99_repeat_IMPL(i, f), ML99_appl_IMPL(f, i)) + // ML99_indexedParams_IMPL { #define ML99_indexedParams_IMPL(type_list) \ @@ -479,9 +344,9 @@ ML99_variadicsTail(ML99_PRIV_indexedParamsAux_IMPL(type_list, 0)))) #define ML99_PRIV_indexedParamsAux_IMPL(type_list, i) \ - ML99_matchWithArgs_IMPL(type_list, ML99_PRIV_indexedParamsAux_, i) -#define ML99_PRIV_indexedParamsAux_nil_IMPL(...) v(ML99_EMPTY()) -#define ML99_PRIV_indexedParamsAux_cons_IMPL(x, xs, i) \ + ML99_matchWithArgs_IMPL(type_list, ML99_PRIV_indexedParams_, i) +#define ML99_PRIV_indexedParams_nil_IMPL ML99_empty_IMPL +#define ML99_PRIV_indexedParams_cons_IMPL(x, xs, i) \ ML99_TERMS(v(, x _##i), ML99_PRIV_indexedParamsAux_IMPL(xs, ML99_INC(i))) // } (ML99_indexedParams_IMPL) @@ -491,7 +356,7 @@ #define ML99_PRIV_indexedFieldsAux_IMPL(type_list, i) \ ML99_matchWithArgs_IMPL(type_list, ML99_PRIV_indexedFields_, i) -#define ML99_PRIV_indexedFields_nil_IMPL(...) v(ML99_EMPTY()) +#define ML99_PRIV_indexedFields_nil_IMPL ML99_empty_IMPL #define ML99_PRIV_indexedFields_cons_IMPL(x, xs, i) \ ML99_TERMS(v(x _##i;), ML99_PRIV_indexedFieldsAux_IMPL(xs, ML99_INC(i))) // } (ML99_indexedFields_IMPL) @@ -525,6 +390,10 @@ #define ML99_anonUnion_ARITY 1 #define ML99_enum_ARITY 2 #define ML99_anonEnum_ARITY 1 +#define ML99_fnPtr_ARITY 3 +#define ML99_fnPtrStmt_ARITY 3 +#define ML99_repeat_ARITY 2 +#define ML99_times_ARITY 2 #define ML99_indexedParams_ARITY 1 #define ML99_indexedFields_ARITY 1 #define ML99_indexedInitializerList_ARITY 1 diff -Nru hkl-5.0.0.2816/third-party/metalang99/ident.h hkl-5.0.0.2875/third-party/metalang99/ident.h --- hkl-5.0.0.2816/third-party/metalang99/ident.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/ident.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,6 @@ /** * @file - * Identifier manipulation. + * Identifiers: `[a-zA-Z0-9_]+`. * * An identifier is a sequence of characters. A character is one of: * @@ -16,10 +16,11 @@ #ifndef ML99_IDENT_H #define ML99_IDENT_H +#include +#include #include #include -#include /** * Tells whether @p ident belongs to a set of identifiers defined by @p prefix. @@ -62,8 +63,8 @@ * * # Predefined detectors * - * - `ML99_C_KEYWORD_DETECTOR` detects all the C11 keywords. + * - `ML99_C_KEYWORD_DETECTOR` detects all the [C11 + * keywords](https://en.cppreference.com/w/c/keyword). * - `ML99_LOWERCASE_DETECTOR` detects lowercase letters (`abcdefghijklmnopqrstuvwxyz`). * - `ML99_UPPERCASE_DETECTOR` detects uppercase letters (`ABCDEFGHIJKLMNOPQRSTUVWXYZ`). * - `ML99_DIGIT_DETECTOR` detects digits (`0123456789`). @@ -192,24 +193,27 @@ #define ML99_DETECT_IDENT(prefix, ident) ML99_PRIV_IS_TUPLE_FAST(ML99_PRIV_CAT(prefix, ident)) #define ML99_IDENT_EQ(prefix, x, y) ML99_DETECT_IDENT(ML99_PRIV_CAT3(prefix, x, _), y) + #define ML99_CHAR_EQ(x, y) \ ML99_PRIV_IF( \ ML99_DETECT_IDENT(ML99_UNDERSCORE_DETECTOR, x), \ ML99_DETECT_IDENT(ML99_UNDERSCORE_DETECTOR, y), \ - ML99_OR( \ + ML99_PRIV_OR3( \ ML99_IDENT_EQ(ML99_LOWERCASE_DETECTOR, x, y), \ - ML99_OR( \ - ML99_IDENT_EQ(ML99_UPPERCASE_DETECTOR, x, y), \ - ML99_IDENT_EQ(ML99_DIGIT_DETECTOR, x, y)))) + ML99_IDENT_EQ(ML99_UPPERCASE_DETECTOR, x, y), \ + ML99_IDENT_EQ(ML99_DIGIT_DETECTOR, x, y))) + #define ML99_IS_LOWERCASE(x) ML99_IDENT_EQ(ML99_LOWERCASE_DETECTOR, x, x) #define ML99_IS_UPPERCASE(x) ML99_IDENT_EQ(ML99_UPPERCASE_DETECTOR, x, x) #define ML99_IS_DIGIT(x) ML99_IDENT_EQ(ML99_DIGIT_DETECTOR, x, x) + #define ML99_IS_CHAR(x) \ - ML99_OR( \ + ML99_PRIV_OR4( \ ML99_IS_LOWERCASE(x), \ - ML99_OR( \ - ML99_IS_UPPERCASE(x), \ - ML99_OR(ML99_IS_DIGIT(x), ML99_DETECT_IDENT(ML99_UNDERSCORE_DETECTOR, x)))) + ML99_IS_UPPERCASE(x), \ + ML99_IS_DIGIT(x), \ + ML99_DETECT_IDENT(ML99_UNDERSCORE_DETECTOR, x)) + #define ML99_CHAR_LIT(x) ML99_PRIV_CAT(ML99_PRIV_CHAR_LIT_, x) #ifndef DOXYGEN_IGNORE diff -Nru hkl-5.0.0.2816/third-party/metalang99/lang/closure.h hkl-5.0.0.2875/third-party/metalang99/lang/closure.h --- hkl-5.0.0.2816/third-party/metalang99/lang/closure.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/lang/closure.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,7 @@ #ifndef ML99_LANG_CLOSURE_H #define ML99_LANG_CLOSURE_H +#include #include #include diff -Nru hkl-5.0.0.2816/third-party/metalang99/lang.h hkl-5.0.0.2875/third-party/metalang99/lang.h --- hkl-5.0.0.2816/third-party/metalang99/lang.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/lang.h 2021-12-08 09:14:21.000000000 +0000 @@ -6,7 +6,8 @@ #ifndef ML99_LANG_H #define ML99_LANG_H -#include +#include +#include #include #include @@ -43,11 +44,12 @@ /** * Applies arguments to @p f. * - * This function implements partial - * application: instead of invoking a metafunction with all arguments at once, you specify each - * argument separately. This concept allows better re-use of metafunctions by specifying some - * arguments immediately, and the other arguments later, even in different execution contexts (for - * example, see this SO answer). + * This function implements [partial + * application](https://en.wikipedia.org/wiki/Partial_application): instead of invoking a + * metafunction with all arguments at once, you specify each argument separately. This concept + * allows better re-use of metafunctions by specifying some arguments immediately, and the other + * arguments later, even in different execution contexts (for example, see this [SO + * answer](https://stackoverflow.com/a/12414292/13166656)). * * @p f must be either a term reducing to a macro name or a term obtained via another call to * #ML99_appl. If @p f is a macro name, then a macro named `_ARITY` (its arity specifier) diff -Nru hkl-5.0.0.2816/third-party/metalang99/list.h hkl-5.0.0.2875/third-party/metalang99/list.h --- hkl-5.0.0.2816/third-party/metalang99/list.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/list.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,17 +1,18 @@ /** * @file - * List manipulation. + * Cons-lists. */ #ifndef ML99_LIST_H #define ML99_LIST_H +#include #include +#include #include -#include -#include #include +#include #include #include @@ -34,6 +35,40 @@ #define ML99_nil(...) ML99_callUneval(ML99_nil, ) /** + * Checks @p list for non-emptiness. + * + * # Examples + * + * @code + * #include + * + * // 1 + * ML99_isCons(ML99_list(v(1, 2, 3))) + * + * // 0 + * ML99_isCons(ML99_nil()) + * @endcode + */ +#define ML99_isCons(list) ML99_call(ML99_isCons, list) + +/** + * Checks @p list for emptiness. + * + * # Examples + * + * @code + * #include + * + * // 0 + * ML99_isNil(ML99_list(v(1, 2, 3))) + * + * // 1 + * ML99_isNil(ML99_nil()) + * @endcode + */ +#define ML99_isNil(list) ML99_call(ML99_isNil, list) + +/** * Extracts the head from the non-empty list @p list. * * # Examples @@ -112,15 +147,14 @@ #define ML99_list(...) ML99_call(ML99_list, __VA_ARGS__) /** - * Constructs a list from comma-separated tuples. + * Constructs a list from comma-separated [tuples](tuple.html). * * It sequentially applies @p f to each untupled argument, thus forming the resulting list. If some * argument is not a tuple, a fatal error is emitted. * * The result is `ML99_list(ML99_appl(f, ML99_untuple(x1)), ..., ML99_appl(f, ML99_untuple(xN)))`. * - * At most 63 arguments are acceptable. Additionally, all the preconditions of #ML99_isUntuple are - * inherited for each argument after @p f. + * Each variadic argument inherits all the preconditions of #ML99_isUntuple. * * # Examples * @@ -137,6 +171,23 @@ #define ML99_listFromTuples(f, ...) ML99_call(ML99_listFromTuples, f, __VA_ARGS__) /** + * Constructs a list from the [sequence](seq.html) @p seq. + * + * # Examples + * + * @code + * #include + * + * // ML99_nil() + * ML99_listFromSeq(v()) + * + * // ML99_list(v(1, 2, 3)) + * ML99_listFromSeq(v((1)(2)(3))) + * @endcode + */ +#define ML99_listFromSeq(seq) ML99_call(ML99_listFromSeq, seq) + +/** * Computes the length of @p list. * * # Examples @@ -156,8 +207,7 @@ /** * Evaluates a metaprogram that reduces to a list, then unwraps it. * - * It behaves the same as the composition of ML99_EVAL and - * #ML99_listUnwrap. + * It behaves the same as the composition of #ML99_EVAL and #ML99_listUnwrap. * * # Examples * @@ -226,7 +276,7 @@ * @code * #include * - * // 1 2 3 + * // Literally 1 2 3 * ML99_listUnwrap(ML99_list(v(1, 2, 3))) * @endcode * @@ -244,8 +294,8 @@ * @code * #include * - * // 1, 2, 3 - * ML99_listUnwrap(ML99_list(v(1, 2, 3))) + * // Literally 1, 2, 3 + * ML99_listUnwrapCommaSep(ML99_list(v(1, 2, 3))) * @endcode * * @note The resulting value is still a valid Metalang99 term that need to be evaluated further. @@ -269,40 +319,6 @@ #define ML99_listReverse(list) ML99_call(ML99_listReverse, list) /** - * Checks @p list for non-emptiness. - * - * # Examples - * - * @code - * #include - * - * // 1 - * ML99_isCons(ML99_list(v(1, 2, 3))) - * - * // 0 - * ML99_isCons(ML99_nil()) - * @endcode - */ -#define ML99_isCons(list) ML99_call(ML99_isCons, list) - -/** - * Checks @p list for emptiness. - * - * # Examples - * - * @code - * #include - * - * // 0 - * ML99_isNil(ML99_list(v(1, 2, 3))) - * - * // 1 - * ML99_isNil(ML99_nil()) - * @endcode - */ -#define ML99_isNil(list) ML99_call(ML99_isNil, list) - -/** * Extracts the @p i -indexed element. * * # Examples @@ -504,6 +520,26 @@ #define ML99_listFilter(f, list) ML99_call(ML99_listFilter, f, list) /** + * A combination of #ML99_listFilter and #ML99_listMap. + * + * It builds a new list by applying @p f to each element in @p list: if @p f yields `ML99_just(x)`, + * `x` is passed to the new list, otherwise (`ML99_nothing()`), the value is neglected. + * + * # Examples + * + * @code + * #include + * #include + * + * #define MAYBE_LIST ML99_list(ML99_just(v(5)), ML99_nothing(), ML99_just(v(7))) + * + * // 5, 7 + * ML99_listFilterMap(v(ML99_id), MAYBE_LIST) + * @endcode + */ +#define ML99_listFilterMap(f, list) ML99_call(ML99_listFilterMap, f, list) + +/** * Tests @p list and @p other for equality. * * # Examples @@ -695,6 +731,9 @@ #define ML99_cons_IMPL(x, xs) v(ML99_CONS(x, xs)) #define ML99_nil_IMPL(...) v(ML99_NIL()) +#define ML99_isCons_IMPL(list) v(ML99_IS_CONS(list)) +#define ML99_isNil_IMPL(list) v(ML99_IS_NIL(list)) + #define ML99_listHead_IMPL(list) ML99_match_IMPL(list, ML99_PRIV_listHead_) #define ML99_PRIV_listHead_nil_IMPL(_) ML99_PRIV_EMPTY_LIST_ERROR(listHead) #define ML99_PRIV_listHead_cons_IMPL(x, _xs) v(x) @@ -752,26 +791,27 @@ // ML99_listFromTuples_IMPL { -#define ML99_listFromTuples_IMPL(f, ...) \ - ML99_PRIV_listFromTuplesProgress_IMPL(f, ML99_VARIADICS_COUNT(__VA_ARGS__), __VA_ARGS__, ~) +#define ML99_listFromTuples_IMPL(f, ...) ML99_PRIV_listFromTuplesAux_IMPL(f, __VA_ARGS__, ~) -#define ML99_PRIV_listFromTuplesProgress_IMPL(f, count, x, ...) \ - ML99_PRIV_IF( \ - ML99_IS_UNTUPLE(x), \ - ML99_PRIV_listFromTuplesError, \ - ML99_PRIV_listFromTuplesProgressAux) \ - (f, count, x, __VA_ARGS__) +#define ML99_PRIV_listFromTuplesAux_IMPL(f, x, ...) \ + ML99_PRIV_CAT(ML99_PRIV_listFromTuples_, ML99_IS_UNTUPLE(x))(f, x, __VA_ARGS__) -#define ML99_PRIV_listFromTuplesError(_f, _count, x, ...) ML99_PRIV_NOT_TUPLE_ERROR(x) -#define ML99_PRIV_listFromTuplesProgressAux(f, count, x, ...) \ +#define ML99_PRIV_listFromTuples_1(_f, x, ...) ML99_PRIV_NOT_TUPLE_ERROR(x) +#define ML99_PRIV_listFromTuples_0(f, x, ...) \ ML99_cons( \ ML99_appl_IMPL(f, ML99_UNTUPLE(x)), \ ML99_PRIV_IF( \ - ML99_NAT_EQ(count, 1), \ + ML99_VARIADICS_IS_SINGLE(__VA_ARGS__), \ v(ML99_NIL()), \ - ML99_callUneval(ML99_PRIV_listFromTuplesProgress, f, ML99_DEC(count), __VA_ARGS__))) + ML99_callUneval(ML99_PRIV_listFromTuplesAux, f, __VA_ARGS__))) // } (ML99_listFromTuples_IMPL) +#define ML99_listFromSeq_IMPL(seq) \ + ML99_PRIV_CAT(ML99_PRIV_listFromSeq_, ML99_SEQ_IS_EMPTY(seq))(seq) +#define ML99_PRIV_listFromSeq_1 ML99_nil_IMPL +#define ML99_PRIV_listFromSeq_0(seq) \ + ML99_cons(v(ML99_SEQ_GET(0)(seq)), ML99_callUneval(ML99_listFromSeq, ML99_SEQ_TAIL(seq))) + #define ML99_listLen_IMPL(list) ML99_match_IMPL(list, ML99_PRIV_listLen_) #define ML99_PRIV_listLen_nil_IMPL(_) v(0) #define ML99_PRIV_listLen_cons_IMPL(_x, xs) ML99_inc(ML99_listLen_IMPL(xs)) @@ -784,15 +824,12 @@ #define ML99_listAppendItem_IMPL(item, list) ML99_listAppend_IMPL(list, ML99_CONS(item, ML99_NIL())) -#define ML99_isCons_IMPL(list) v(ML99_IS_CONS(list)) -#define ML99_isNil_IMPL(list) v(ML99_IS_NIL(list)) - #define ML99_listUnwrap_IMPL(list) ML99_match_IMPL(list, ML99_PRIV_listUnwrap_) -#define ML99_PRIV_listUnwrap_nil_IMPL(_) v(ML99_EMPTY()) +#define ML99_PRIV_listUnwrap_nil_IMPL ML99_empty_IMPL #define ML99_PRIV_listUnwrap_cons_IMPL(x, xs) ML99_TERMS(v(x), ML99_listUnwrap_IMPL(xs)) #define ML99_listReverse_IMPL(list) ML99_match_IMPL(list, ML99_PRIV_listReverse_) -#define ML99_PRIV_listReverse_nil_IMPL(_) v(ML99_NIL()) +#define ML99_PRIV_listReverse_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listReverse_cons_IMPL(x, xs) ML99_listAppendItem(v(x), ML99_listReverse_IMPL(xs)) #define ML99_listGet_IMPL(i, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listGet_, i) @@ -818,38 +855,38 @@ #define ML99_listIntersperse_IMPL(item, list) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listIntersperse_, item) -#define ML99_PRIV_listIntersperse_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listIntersperse_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listIntersperse_cons_IMPL(x, xs, item) \ ML99_cons(v(x), ML99_listPrependToAll_IMPL(item, xs)) #define ML99_listPrependToAll_IMPL(item, list) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listPrependToAll_, item) -#define ML99_PRIV_listPrependToAll_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listPrependToAll_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listPrependToAll_cons_IMPL(x, xs, item) \ ML99_cons(v(item), ML99_cons(v(x), ML99_listPrependToAll_IMPL(item, xs))) -#define ML99_listMap_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listMap_, f) -#define ML99_PRIV_listMap_nil_IMPL(...) v(ML99_NIL()) +#define ML99_listMap_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listMap_, f) +#define ML99_PRIV_listMap_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listMap_cons_IMPL(x, xs, f) \ ML99_cons(ML99_appl_IMPL(f, x), ML99_listMap_IMPL(f, xs)) #define ML99_listMapI_IMPL(f, list) ML99_PRIV_listMapIAux_IMPL(f, list, 0) #define ML99_PRIV_listMapIAux_IMPL(f, list, i) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listMapI_, f, i) -#define ML99_PRIV_listMapI_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listMapI_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listMapI_cons_IMPL(x, xs, f, i) \ ML99_cons(ML99_appl2_IMPL(f, x, i), ML99_PRIV_listMapIAux_IMPL(f, xs, ML99_INC(i))) #define ML99_listMapInPlace_IMPL(f, list) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listMapInPlace_, f) -#define ML99_PRIV_listMapInPlace_nil_IMPL(...) v(ML99_EMPTY()) +#define ML99_PRIV_listMapInPlace_nil_IMPL ML99_empty_IMPL #define ML99_PRIV_listMapInPlace_cons_IMPL(x, xs, f) \ ML99_TERMS(ML99_appl_IMPL(f, x), ML99_listMapInPlace_IMPL(f, xs)) #define ML99_listMapInPlaceI_IMPL(f, list) ML99_PRIV_listMapInPlaceIAux_IMPL(f, list, 0) #define ML99_PRIV_listMapInPlaceIAux_IMPL(f, list, i) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listMapInPlaceI_, f, i) -#define ML99_PRIV_listMapInPlaceI_nil_IMPL(...) v(ML99_EMPTY()) +#define ML99_PRIV_listMapInPlaceI_nil_IMPL ML99_empty_IMPL #define ML99_PRIV_listMapInPlaceI_cons_IMPL(x, xs, f, i) \ ML99_TERMS(ML99_appl2_IMPL(f, x, i), ML99_PRIV_listMapInPlaceIAux_IMPL(f, xs, ML99_INC(i))) @@ -863,14 +900,34 @@ #define ML99_listForInitLast_IMPL(list, f_init, f_last) \ ML99_listMapInitLast_IMPL(f_init, f_last, list) -#define ML99_listFilter_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listFilter_, f) -#define ML99_PRIV_listFilter_nil_IMPL(...) v(ML99_NIL()) +// ML99_listFilter_IMPL { + +#define ML99_listFilter_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listFilter_, f) + +#define ML99_PRIV_listFilter_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listFilter_cons_IMPL(x, xs, f) \ ML99_call( \ - ML99_call(ML99_if, ML99_appl_IMPL(f, x), v(ML99_cons, ML99_PRIV_listFilterRest)), \ - v(x), \ + ML99_boolMatchWithArgs, \ + ML99_appl_IMPL(f, x), \ + v(ML99_PRIV_listFilter_cons_, x), \ ML99_listFilter_IMPL(f, xs)) -#define ML99_PRIV_listFilterRest_IMPL(_x, rest) v(rest) + +#define ML99_PRIV_listFilter_cons_1_IMPL(x, rest) v(ML99_CONS(x, rest)) +#define ML99_PRIV_listFilter_cons_0_IMPL(_x, rest) v(rest) +// } (ML99_listFilter_IMPL) + +// ML99_listFilterMap_IMPL { + +#define ML99_listFilterMap_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listFilterMap_, f) + +#define ML99_PRIV_listFilterMap_nil_IMPL ML99_nil_IMPL +#define ML99_PRIV_listFilterMap_cons_IMPL(x, xs, f) \ + ML99_call(ML99_matchWithArgs, ML99_appl_IMPL(f, x), v(ML99_PRIV_listFilterMap_cons_, f, xs)) + +#define ML99_PRIV_listFilterMap_cons_just_IMPL(y, f, xs) \ + ML99_cons(v(y), ML99_listFilterMap_IMPL(f, xs)) +#define ML99_PRIV_listFilterMap_cons_nothing_IMPL(_, f, xs) ML99_listFilterMap_IMPL(f, xs) +// } (ML99_listFilterMap_IMPL) // ML99_listEq_IMPL { @@ -881,7 +938,7 @@ #define ML99_PRIV_listEq_cons_IMPL(x, xs, other, cmp) \ ML99_matchWithArgs_IMPL(other, ML99_PRIV_listEq_cons_, x, xs, cmp) -#define ML99_PRIV_listEq_cons_nil_IMPL(...) v(ML99_FALSE()) +#define ML99_PRIV_listEq_cons_nil_IMPL ML99_false_IMPL #define ML99_PRIV_listEq_cons_cons_IMPL(other_x, other_xs, x, xs, cmp) \ ML99_call( \ ML99_call(ML99_if, ML99_appl2_IMPL(cmp, x, other_x), v(ML99_listEq, ML99_false)), \ @@ -890,31 +947,38 @@ #define ML99_listContains_IMPL(cmp, item, list) \ ML99_matchWithArgs_IMPL(list, ML99_PRIV_listContains_, item, cmp) -#define ML99_PRIV_listContains_nil_IMPL(...) v(ML99_FALSE()) +#define ML99_PRIV_listContains_nil_IMPL ML99_false_IMPL #define ML99_PRIV_listContains_cons_IMPL(x, xs, item, cmp) \ ML99_call( \ ML99_call(ML99_if, ML99_appl2_IMPL(cmp, x, item), v(ML99_true, ML99_listContains)), \ v(cmp, item, xs)) -#define ML99_listTake_IMPL(n, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listTake_, n) -#define ML99_PRIV_listTake_nil_IMPL(...) v(ML99_NIL()) +#define ML99_listTake_IMPL(n, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listTake_, n) +#define ML99_PRIV_listTake_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listTake_cons_IMPL(x, xs, i) \ ML99_PRIV_IF( \ ML99_NAT_EQ(i, 0), \ v(ML99_NIL()), \ ML99_cons(v(x), ML99_listTake_IMPL(ML99_DEC(i), xs))) -#define ML99_listTakeWhile_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listTakeWhile_, f) -#define ML99_PRIV_listTakeWhile_nil_IMPL(...) v(ML99_NIL()) +// ML99_listTakeWhile_IMPL { + +#define ML99_listTakeWhile_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listTakeWhile_, f) + +#define ML99_PRIV_listTakeWhile_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listTakeWhile_cons_IMPL(x, xs, f) \ ML99_call( \ - ML99_call(ML99_if, ML99_appl_IMPL(f, x), v(ML99_PRIV_listTakeWhileProgress, ML99_nil)), \ - v(x, xs, f)) -#define ML99_PRIV_listTakeWhileProgress_IMPL(x, xs, f) \ + ML99_boolMatchWithArgs, \ + ML99_appl_IMPL(f, x), \ + v(ML99_PRIV_listTakeWhile_cons_, x, xs, f)) + +#define ML99_PRIV_listTakeWhile_cons_1_IMPL(x, xs, f) \ ML99_cons(v(x), ML99_listTakeWhile_IMPL(f, xs)) +#define ML99_PRIV_listTakeWhile_cons_0_IMPL ML99_nil_IMPL +// } (ML99_listTakeWhile_IMPL) -#define ML99_listDrop_IMPL(n, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listDrop_, n) -#define ML99_PRIV_listDrop_nil_IMPL(...) v(ML99_NIL()) +#define ML99_listDrop_IMPL(n, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listDrop_, n) +#define ML99_PRIV_listDrop_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listDrop_cons_IMPL(x, xs, i) \ ML99_PRIV_IF(ML99_NAT_EQ(i, 0), v(ML99_CONS(x, xs)), ML99_listDrop_IMPL(ML99_DEC(i), xs)) @@ -922,28 +986,26 @@ #define ML99_listDropWhile_IMPL(f, list) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listDropWhile_, f) -#define ML99_PRIV_listDropWhile_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listDropWhile_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listDropWhile_cons_IMPL(x, xs, f) \ ML99_call( \ - ML99_call( \ - ML99_if, \ - ML99_appl_IMPL(f, x), \ - v(ML99_PRIV_listDropWhileProgress, ML99_PRIV_listDropWhileDone)), \ - v(x, xs, f)) + ML99_boolMatchWithArgs, \ + ML99_appl_IMPL(f, x), \ + v(ML99_PRIV_listDropWhile_cons_, x, xs, f)) -#define ML99_PRIV_listDropWhileDone_IMPL(x, xs, _f) v(ML99_CONS(x, xs)) -#define ML99_PRIV_listDropWhileProgress_IMPL(_x, xs, f) ML99_listDropWhile_IMPL(f, xs) +#define ML99_PRIV_listDropWhile_cons_0_IMPL(x, xs, _f) v(ML99_CONS(x, xs)) +#define ML99_PRIV_listDropWhile_cons_1_IMPL(_x, xs, f) ML99_listDropWhile_IMPL(f, xs) // } (ML99_listDropWhile_IMPL) // ML99_listZip_IMPL { #define ML99_listZip_IMPL(list, other) ML99_matchWithArgs_IMPL(list, ML99_PRIV_listZip_, other) -#define ML99_PRIV_listZip_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listZip_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listZip_cons_IMPL(x, xs, other) \ ML99_matchWithArgs_IMPL(other, ML99_PRIV_listZip_cons_, x, xs) -#define ML99_PRIV_listZip_cons_nil_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listZip_cons_nil_IMPL ML99_nil_IMPL #define ML99_PRIV_listZip_cons_cons_IMPL(other_x, other_xs, x, xs) \ ML99_cons(v(ML99_TUPLE(x, other_x)), ML99_listZip_IMPL(xs, other_xs)) // } (ML99_listZip_IMPL) @@ -965,7 +1027,7 @@ #define ML99_listReplicate_IMPL(n, item) \ ML99_natMatchWithArgs_IMPL(n, ML99_PRIV_listReplicate_, item) -#define ML99_PRIV_listReplicate_Z_IMPL(...) v(ML99_NIL()) +#define ML99_PRIV_listReplicate_Z_IMPL ML99_nil_IMPL #define ML99_PRIV_listReplicate_S_IMPL(n, item) ML99_cons(v(item), ML99_listReplicate_IMPL(n, item)) // ML99_listPartition_IMPL { @@ -978,14 +1040,12 @@ #define ML99_PRIV_listPartitionAux_IMPL(f, x, acc) \ ML99_call( \ - ML99_call( \ - ML99_if, \ - ML99_appl_IMPL(f, x), \ - v(ML99_PRIV_listPartitionExtendFst, ML99_PRIV_listPartitionExtendSnd)), \ - v(x, ML99_TUPLE_GET(0)(acc), ML99_TUPLE_GET(1)(acc))) + ML99_boolMatchWithArgs, \ + ML99_appl_IMPL(f, x), \ + v(ML99_PRIV_listPartition_, x, ML99_UNTUPLE(acc))) -#define ML99_PRIV_listPartitionExtendFst_IMPL(x, fst, snd) v(ML99_TUPLE(ML99_CONS(x, fst), snd)) -#define ML99_PRIV_listPartitionExtendSnd_IMPL(x, fst, snd) v(ML99_TUPLE(fst, ML99_CONS(x, snd))) +#define ML99_PRIV_listPartition_1_IMPL(x, fst, snd) v(ML99_TUPLE(ML99_CONS(x, fst), snd)) +#define ML99_PRIV_listPartition_0_IMPL(x, fst, snd) v(ML99_TUPLE(fst, ML99_CONS(x, snd))) // } (ML99_listPartition_IMPL) #define ML99_listAppl_IMPL(f, list) ML99_listFoldl_IMPL(ML99_appl, f, list) @@ -998,11 +1058,10 @@ v(ML99_EMPTY()), \ ML99_variadicsTail(ML99_PRIV_listUnwrapCommaSepAux_IMPL(list))) -#define ML99_PRIV_listUnwrapCommaSepAux_IMPL(xs) \ - ML99_match_IMPL(xs, ML99_PRIV_listUnwrapCommaSepAux_) +#define ML99_PRIV_listUnwrapCommaSepAux_IMPL(xs) ML99_match_IMPL(xs, ML99_PRIV_listUnwrapCommaSep_) -#define ML99_PRIV_listUnwrapCommaSepAux_nil_IMPL(_) v(ML99_EMPTY()) -#define ML99_PRIV_listUnwrapCommaSepAux_cons_IMPL(x, xs) \ +#define ML99_PRIV_listUnwrapCommaSep_nil_IMPL ML99_empty_IMPL +#define ML99_PRIV_listUnwrapCommaSep_cons_IMPL(x, xs) \ ML99_TERMS(v(, x), ML99_PRIV_listUnwrapCommaSepAux_IMPL(xs)) // } (ML99_listUnwrapCommaSep_IMPL) @@ -1017,20 +1076,21 @@ #define ML99_cons_ARITY 2 #define ML99_nil_ARITY 1 +#define ML99_isCons_ARITY 1 +#define ML99_isNil_ARITY 1 #define ML99_listHead_ARITY 1 #define ML99_listTail_ARITY 1 #define ML99_listLast_ARITY 1 #define ML99_listInit_ARITY 1 #define ML99_list_ARITY 1 #define ML99_listFromTuples_ARITY 2 +#define ML99_listFromSeq_ARITY 1 #define ML99_listLen_ARITY 1 #define ML99_listAppend_ARITY 2 #define ML99_listAppendItem_ARITY 2 #define ML99_listUnwrap_ARITY 1 #define ML99_listUnwrapCommaSep_ARITY 1 #define ML99_listReverse_ARITY 1 -#define ML99_isCons_ARITY 1 -#define ML99_isNil_ARITY 1 #define ML99_listGet_ARITY 2 #define ML99_listFoldr_ARITY 3 #define ML99_listFoldl_ARITY 3 @@ -1045,6 +1105,7 @@ #define ML99_listMapInitLast_ARITY 3 #define ML99_listForInitLast_ARITY 3 #define ML99_listFilter_ARITY 2 +#define ML99_listFilterMap_ARITY 2 #define ML99_listEq_ARITY 3 #define ML99_listContains_ARITY 3 #define ML99_listTake_ARITY 2 diff -Nru hkl-5.0.0.2816/third-party/metalang99/logical.h hkl-5.0.0.2875/third-party/metalang99/logical.h --- hkl-5.0.0.2816/third-party/metalang99/logical.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/logical.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,154 +1,11 @@ /** * @file - * Boolean algebra. + * This module is deprecated and exists only for backwards compatibility. */ #ifndef ML99_LOGICAL_H #define ML99_LOGICAL_H -#include - -#include - -/** - * Truth. - */ -#define ML99_true(...) ML99_callUneval(ML99_true, ) - -/** - * Falsehood. - */ -#define ML99_false(...) ML99_callUneval(ML99_false, ) - -/** - * Logical negation. - * - * # Examples - * - * @code - * // 1 - * ML99_not(v(0)) - * - * // 0 - * ML99_not(v(1)) - * @endcode - */ -#define ML99_not(x) ML99_call(ML99_not, x) - -/** - * Logical conjunction. - * - * # Examples - * - * @code - * // 0 - * ML99_and(v(0), v(0)) - * - * // 0 - * ML99_and(v(0), v(1)) - * - * // 0 - * ML99_and(v(1), v(0)) - * - * // 1 - * ML99_and(v(1), v(1)) - * @endcode - */ -#define ML99_and(x, y) ML99_call(ML99_and, x, y) - -/** - * Logical inclusive OR. - * - * # Examples - * - * @code - * // 0 - * ML99_or(v(0), v(0)) - * - * // 1 - * ML99_or(v(0), v(1)) - * - * // 1 - * ML99_or(v(1), v(0)) - * - * // 1 - * ML99_or(v(1), v(1)) - * @endcode - */ -#define ML99_or(x, y) ML99_call(ML99_or, x, y) - -/** - * Logical exclusive OR. - * - * # Examples - * - * @code - * // 0 - * ML99_xor(v(0), v(0)) - * - * // 1 - * ML99_xor(v(0), v(1)) - * - * // 1 - * ML99_xor(v(1), v(0)) - * - * // 0 - * ML99_xor(v(1), v(1)) - * @endcode - */ -#define ML99_xor(x, y) ML99_call(ML99_xor, x, y) - -/** - * Tests @p x and @p y for equality. - * - * # Examples - * @code - * // 1 - * ML99_boolEq(v(0), v(0)) - * - * // 0 - * ML99_boolEq(v(0), v(1)) - * - * // 0 - * ML99_boolEq(v(1), v(0)) - * - * // 1 - * ML99_boolEq(v(1), v(1)) - * @endcode - */ -#define ML99_boolEq(x, y) ML99_call(ML99_boolEq, x, y) - -#define ML99_TRUE(...) 1 -#define ML99_FALSE(...) 0 - -#define ML99_NOT(x) ML99_PRIV_NOT(x) -#define ML99_AND(x, y) ML99_PRIV_AND(x, y) -#define ML99_OR(x, y) ML99_PRIV_OR(x, y) -#define ML99_XOR(x, y) ML99_PRIV_XOR(x, y) -#define ML99_BOOL_EQ(x, y) ML99_PRIV_BOOL_EQ(x, y) - -#ifndef DOXYGEN_IGNORE - -#define ML99_true_IMPL(...) v(ML99_TRUE()) -#define ML99_false_IMPL(...) v(ML99_FALSE()) - -#define ML99_not_IMPL(x) v(ML99_NOT(x)) -#define ML99_and_IMPL(x, y) v(ML99_AND(x, y)) -#define ML99_or_IMPL(x, y) v(ML99_OR(x, y)) -#define ML99_xor_IMPL(x, y) v(ML99_XOR(x, y)) -#define ML99_boolEq_IMPL(x, y) v(ML99_BOOL_EQ(x, y)) - -// Arity specifiers { - -#define ML99_true_ARITY 1 -#define ML99_false_ARITY 1 -#define ML99_not_ARITY 1 -#define ML99_and_ARITY 2 -#define ML99_or_ARITY 2 -#define ML99_xor_ARITY 2 -#define ML99_boolEq_ARITY 2 -// } (Arity specifiers) - -#endif // DOXYGEN_IGNORE +#include #endif // ML99_LOGICAL_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/maybe.h hkl-5.0.0.2875/third-party/metalang99/maybe.h --- hkl-5.0.0.2816/third-party/metalang99/maybe.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/maybe.h 2021-12-08 09:14:21.000000000 +0000 @@ -6,9 +6,11 @@ #ifndef ML99_MAYBE_H #define ML99_MAYBE_H +#include + +#include #include -#include -#include +#include /** * Some value @p x. @@ -105,22 +107,26 @@ #define ML99_isJust_IMPL(maybe) v(ML99_IS_JUST(maybe)) #define ML99_isNothing_IMPL(maybe) v(ML99_IS_NOTHING(maybe)) -#define ML99_PRIV_IS_JUST(maybe) ML99_DETECT_IDENT(ML99_PRIV_IS_JUST_, ML99_CHOICE_TAG(maybe)) -#define ML99_PRIV_IS_JUST_just () +// ML99_maybeEq_IMPL { #define ML99_maybeEq_IMPL(cmp, maybe, other) \ - ML99_PRIV_IF( \ - ML99_AND(ML99_IS_NOTHING(maybe), ML99_IS_NOTHING(other)), \ - v(ML99_TRUE()), \ - ML99_PRIV_IF( \ - ML99_AND(ML99_IS_JUST(maybe), ML99_IS_JUST(other)), \ - ML99_appl2_IMPL(cmp, ML99_PRIV_CHOICE_DATA maybe, ML99_PRIV_CHOICE_DATA other), \ - v(ML99_FALSE()))) + ML99_matchWithArgs_IMPL(maybe, ML99_PRIV_maybeEq_, cmp, other) + +#define ML99_PRIV_maybeEq_just_IMPL(x, cmp, other) \ + ML99_matchWithArgs_IMPL(other, ML99_PRIV_maybeEq_just_, cmp, x) +#define ML99_PRIV_maybeEq_nothing_IMPL(_, _cmp, other) v(ML99_IS_NOTHING(other)) + +#define ML99_PRIV_maybeEq_just_just_IMPL(y, cmp, x) ML99_appl2_IMPL(cmp, x, y) +#define ML99_PRIV_maybeEq_just_nothing_IMPL ML99_false_IMPL +// } (ML99_maybeEq_IMPL) -#define ML99_maybeUnwrap_IMPL(maybe) ML99_match_IMPL(maybe, ML99_PRIV_maybeUnwrap_) +#define ML99_maybeUnwrap_IMPL(maybe) ML99_match_IMPL(maybe, ML99_PRIV_maybeUnwrap_) +#define ML99_PRIV_maybeUnwrap_just_IMPL(x) v(x) #define ML99_PRIV_maybeUnwrap_nothing_IMPL(_) \ ML99_fatal(ML99_maybeUnwrap, expected ML99_just but found ML99_nothing) -#define ML99_PRIV_maybeUnwrap_just_IMPL(x) v(x) + +#define ML99_PRIV_IS_JUST(maybe) ML99_DETECT_IDENT(ML99_PRIV_IS_JUST_, ML99_CHOICE_TAG(maybe)) +#define ML99_PRIV_IS_JUST_just () // Arity specifiers { diff -Nru hkl-5.0.0.2816/third-party/metalang99/nat/div.h hkl-5.0.0.2875/third-party/metalang99/nat/div.h --- hkl-5.0.0.2816/third-party/metalang99/nat/div.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/nat/div.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,7 @@ #ifndef ML99_NAT_DIV_H #define ML99_NAT_DIV_H +#include #include #include diff -Nru hkl-5.0.0.2816/third-party/metalang99/nat/eq.h hkl-5.0.0.2875/third-party/metalang99/nat/eq.h --- hkl-5.0.0.2816/third-party/metalang99/nat/eq.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/nat/eq.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,7 +1,7 @@ #ifndef ML99_NAT_EQ_H #define ML99_NAT_EQ_H -#include +#include #define ML99_PRIV_NAT_EQ(x, y) ML99_PRIV_NAT_EQ_AUX(x, y) #define ML99_PRIV_NAT_EQ_AUX(x, y) ML99_PRIV_IS_TUPLE_FAST(ML99_PRIV_NAT_EQ_##x##_##y) diff -Nru hkl-5.0.0.2816/third-party/metalang99/nat.h hkl-5.0.0.2875/third-party/metalang99/nat.h --- hkl-5.0.0.2816/third-party/metalang99/nat.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/nat.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,6 +1,6 @@ /** * @file - * Natural numbers ([0; 255]). + * Natural numbers: [0; 255]. * * Most of the time, natural numbers are used for iteration; they are not meant for CPU-bound tasks * such as Fibonacci numbers or factorials. @@ -9,14 +9,14 @@ #ifndef ML99_NAT_H #define ML99_NAT_H +#include + #include #include #include #include -#include #include -#include /** * \f$x + 1\f$ @@ -51,7 +51,7 @@ #define ML99_dec(x) ML99_call(ML99_dec, x) /** - * Matches @p x to the two cases: if it is zero or positive. + * Matches @p x against the two cases: if it is zero or positive. * * # Examples * @@ -90,9 +90,6 @@ * // Jean ~ 122 ~ 1 2 3 * ML99_natMatchWithArgs(v(123), v(MATCH_), v(1, 2, 3)) * @endcode - * - * @note This function calls @p f with #ML99_call, so no partial application occurs, and so - * arity specifiers are not needed. */ #define ML99_natMatchWithArgs(x, matcher, ...) \ ML99_call(ML99_natMatchWithArgs, x, matcher, __VA_ARGS__) @@ -402,7 +399,7 @@ #define ML99_INC(x) ML99_PRIV_INC(x) #define ML99_DEC(x) ML99_PRIV_DEC(x) #define ML99_NAT_EQ(x, y) ML99_PRIV_NAT_EQ(x, y) -#define ML99_NAT_NEQ(x, y) ML99_NOT(ML99_NAT_EQ(x, y)) +#define ML99_NAT_NEQ(x, y) ML99_PRIV_NOT(ML99_NAT_EQ(x, y)) #define ML99_DIV_CHECKED(x, y) ML99_PRIV_DIV_CHECKED(x, y) /** @@ -412,6 +409,8 @@ #ifndef DOXYGEN_IGNORE +// Pattern matching { + #define ML99_natMatch_IMPL(x, matcher) \ ML99_PRIV_IF( \ ML99_NAT_EQ(x, 0), \ @@ -423,28 +422,34 @@ ML99_NAT_EQ(x, 0), \ ML99_callUneval(matcher##Z, __VA_ARGS__), \ ML99_callUneval(matcher##S, ML99_DEC(x), __VA_ARGS__)) +// } (Pattern matching) -#define ML99_inc_IMPL(x) v(ML99_INC(x)) -#define ML99_dec_IMPL(x) v(ML99_DEC(x)) +// Comparison operators { #define ML99_natEq_IMPL(x, y) v(ML99_NAT_EQ(x, y)) #define ML99_natNeq_IMPL(x, y) v(ML99_NAT_NEQ(x, y)) -#define ML99_greater_IMPL(x, y) ML99_lesser_IMPL(y, x) -#define ML99_greaterEq_IMPL(x, y) \ - ML99_PRIV_IF(ML99_NAT_EQ(x, y), v(ML99_TRUE()), ML99_greater_IMPL(x, y)) - #define ML99_lesser_IMPL(x, y) \ ML99_PRIV_IF( \ ML99_NAT_EQ(y, 0), \ - v(ML99_FALSE()), \ + v(ML99_PRIV_FALSE()), \ ML99_PRIV_IF( \ ML99_NAT_EQ(x, ML99_DEC(y)), \ - v(ML99_TRUE()), \ + v(ML99_PRIV_TRUE()), \ ML99_callUneval(ML99_lesser, x, ML99_DEC(y)))) #define ML99_lesserEq_IMPL(x, y) ML99_greaterEq_IMPL(y, x) +#define ML99_greater_IMPL(x, y) ML99_lesser_IMPL(y, x) +#define ML99_greaterEq_IMPL(x, y) \ + ML99_PRIV_IF(ML99_NAT_EQ(x, y), v(ML99_PRIV_TRUE()), ML99_greater_IMPL(x, y)) +// } (Comparison operators) + +// Arithmetical operators { + +#define ML99_inc_IMPL(x) v(ML99_INC(x)) +#define ML99_dec_IMPL(x) v(ML99_DEC(x)) + #define ML99_add_IMPL(x, y) \ ML99_PRIV_IF(ML99_NAT_EQ(y, 0), v(x), ML99_callUneval(ML99_add, ML99_INC(x), ML99_DEC(y))) #define ML99_sub_IMPL(x, y) \ @@ -452,6 +457,16 @@ #define ML99_mul_IMPL(x, y) \ ML99_PRIV_IF(ML99_NAT_EQ(y, 0), v(0), ML99_add(v(x), ML99_callUneval(ML99_mul, x, ML99_DEC(y)))) +#define ML99_add3_IMPL(x, y, z) ML99_add(ML99_add_IMPL(x, y), v(z)) +#define ML99_sub3_IMPL(x, y, z) ML99_sub(ML99_sub_IMPL(x, y), v(z)) +#define ML99_mul3_IMPL(x, y, z) ML99_mul(ML99_mul_IMPL(x, y), v(z)) +#define ML99_div3_IMPL(x, y, z) ML99_div(ML99_div_IMPL(x, y), v(z)) + +#define ML99_min_IMPL(x, y) ML99_call(ML99_if, ML99_lesser_IMPL(x, y), v(x, y)) +#define ML99_max_IMPL(x, y) ML99_call(ML99_if, ML99_lesser_IMPL(x, y), v(y, x)) + +#define ML99_divChecked_IMPL(x, y) v(ML99_DIV_CHECKED(x, y)) + // ML99_mod_IMPL { #define ML99_mod_IMPL(x, y) \ @@ -462,20 +477,12 @@ #define ML99_PRIV_modAux_IMPL(x, y, acc) \ ML99_PRIV_IF( \ - ML99_OR(ML99_NAT_EQ(x, 0), ML99_IS_JUST(ML99_DIV_CHECKED(x, y))), \ + ML99_PRIV_OR(ML99_NAT_EQ(x, 0), ML99_IS_JUST(ML99_DIV_CHECKED(x, y))), \ v(acc), \ ML99_callUneval(ML99_PRIV_modAux, ML99_DEC(x), y, ML99_INC(acc))) // } (ML99_mod_IMPL) -#define ML99_divChecked_IMPL(x, y) v(ML99_DIV_CHECKED(x, y)) - -#define ML99_add3_IMPL(x, y, z) ML99_add(ML99_add_IMPL(x, y), v(z)) -#define ML99_sub3_IMPL(x, y, z) ML99_sub(ML99_sub_IMPL(x, y), v(z)) -#define ML99_mul3_IMPL(x, y, z) ML99_mul(ML99_mul_IMPL(x, y), v(z)) -#define ML99_div3_IMPL(x, y, z) ML99_div(ML99_div_IMPL(x, y), v(z)) - -#define ML99_min_IMPL(x, y) ML99_call(ML99_if, ML99_lesser_IMPL(x, y), v(x, y)) -#define ML99_max_IMPL(x, y) ML99_call(ML99_if, ML99_lesser_IMPL(x, y), v(y, x)) +// } (Arithmetical operators) #define ML99_assertIsNat_IMPL(x) \ ML99_PRIV_IF( \ diff -Nru hkl-5.0.0.2816/third-party/metalang99/priv/bool.h hkl-5.0.0.2875/third-party/metalang99/priv/bool.h --- hkl-5.0.0.2816/third-party/metalang99/priv/bool.h 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/priv/bool.h 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,46 @@ +#ifndef ML99_PRIV_BOOL_H +#define ML99_PRIV_BOOL_H + +#define ML99_PRIV_TRUE(...) 1 +#define ML99_PRIV_FALSE(...) 0 + +#define ML99_PRIV_NOT(b) ML99_PRIV_LOGICAL_OVERLOAD_SINGLE(ML99_PRIV_NOT_, b) +#define ML99_PRIV_NOT_0 1 +#define ML99_PRIV_NOT_1 0 + +#define ML99_PRIV_AND(x, y) ML99_PRIV_LOGICAL_OVERLOAD(ML99_PRIV_AND_, x, y) +#define ML99_PRIV_AND_00 0 +#define ML99_PRIV_AND_01 0 +#define ML99_PRIV_AND_10 0 +#define ML99_PRIV_AND_11 1 + +#define ML99_PRIV_OR(x, y) ML99_PRIV_LOGICAL_OVERLOAD(ML99_PRIV_OR_, x, y) +#define ML99_PRIV_OR_00 0 +#define ML99_PRIV_OR_01 1 +#define ML99_PRIV_OR_10 1 +#define ML99_PRIV_OR_11 1 + +#define ML99_PRIV_OR3(a, b, c) ML99_PRIV_OR(a, ML99_PRIV_OR(b, c)) +#define ML99_PRIV_OR4(a, b, c, d) ML99_PRIV_OR3(a, b, ML99_PRIV_OR(c, d)) + +#define ML99_PRIV_XOR(x, y) ML99_PRIV_LOGICAL_OVERLOAD(ML99_PRIV_XOR_, x, y) +#define ML99_PRIV_XOR_00 0 +#define ML99_PRIV_XOR_01 1 +#define ML99_PRIV_XOR_10 1 +#define ML99_PRIV_XOR_11 0 + +#define ML99_PRIV_BOOL_EQ(x, y) ML99_PRIV_LOGICAL_OVERLOAD(ML99_PRIV_BOOL_EQ_, x, y) +#define ML99_PRIV_BOOL_EQ_00 1 +#define ML99_PRIV_BOOL_EQ_01 0 +#define ML99_PRIV_BOOL_EQ_10 0 +#define ML99_PRIV_BOOL_EQ_11 1 + +#define ML99_PRIV_LOGICAL_OVERLOAD(op, x, y) op##x##y +#define ML99_PRIV_LOGICAL_OVERLOAD_SINGLE(op, b) op##b + +#define ML99_PRIV_IF(cond, x, y) ML99_PRIV_IF_OVERLOAD(cond)(x, y) +#define ML99_PRIV_IF_OVERLOAD(cond) ML99_PRIV_IF_##cond +#define ML99_PRIV_IF_0(_x, y) y +#define ML99_PRIV_IF_1(x, _y) x + +#endif // ML99_PRIV_BOOL_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/priv/tuple.h hkl-5.0.0.2875/third-party/metalang99/priv/tuple.h --- hkl-5.0.0.2816/third-party/metalang99/priv/tuple.h 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/priv/tuple.h 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,33 @@ +#ifndef ML99_PRIV_TUPLE_H +#define ML99_PRIV_TUPLE_H + +#include +#include + +#define ML99_PRIV_IS_TUPLE(x) ML99_PRIV_NOT(ML99_PRIV_IS_UNTUPLE(x)) +#define ML99_PRIV_IS_TUPLE_FAST(x) ML99_PRIV_NOT(ML99_PRIV_IS_UNTUPLE_FAST(x)) + +#define ML99_PRIV_IS_UNTUPLE(x) \ + ML99_PRIV_IF( \ + ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(x), \ + ML99_PRIV_TRUE, \ + ML99_PRIV_IS_UNTUPLE_FAST) \ + (x) + +#define ML99_PRIV_IS_UNTUPLE_FAST(x) ML99_PRIV_SND(ML99_PRIV_IS_UNTUPLE_FAST_TEST x, 1) +#define ML99_PRIV_IS_UNTUPLE_FAST_TEST(...) ~, 0 + +#define ML99_PRIV_UNTUPLE(x) ML99_PRIV_EXPAND x + +/** + * Checks whether @p x takes the form `(...) (...) ...`. + * + * This often happens when you miss a comma between items: + * - `v(123) v(456)` + * - `(Foo, int) (Bar, int)` (as in Datatype99) + * - etc. + */ +#define ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(x) \ + ML99_PRIV_CONTAINS_COMMA(ML99_PRIV_EXPAND(ML99_PRIV_COMMA ML99_PRIV_EMPTY x)) + +#endif // ML99_PRIV_TUPLE_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/priv/util.h hkl-5.0.0.2875/third-party/metalang99/priv/util.h --- hkl-5.0.0.2816/third-party/metalang99/priv/util.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/priv/util.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,8 +1,6 @@ #ifndef ML99_PRIV_UTIL_H #define ML99_PRIV_UTIL_H -#include - #define ML99_PRIV_CAT(x, y) ML99_PRIV_PRIMITIVE_CAT(x, y) #define ML99_PRIV_PRIMITIVE_CAT(x, y) x##y @@ -11,6 +9,7 @@ #define ML99_PRIV_EXPAND(...) __VA_ARGS__ #define ML99_PRIV_EMPTY(...) +#define ML99_PRIV_COMMA(...) , #define ML99_PRIV_HEAD(...) ML99_PRIV_HEAD_AUX(__VA_ARGS__, ~) #define ML99_PRIV_HEAD_AUX(x, ...) x @@ -21,36 +20,8 @@ #define ML99_PRIV_SND(...) ML99_PRIV_SND_AUX(__VA_ARGS__, ~) #define ML99_PRIV_SND_AUX(_x, y, ...) y -#define ML99_PRIV_IF(cond, x, y) ML99_PRIV_PRIMITIVE_CAT(ML99_PRIV_IF_, cond)(x, y) -#define ML99_PRIV_IF_0(_x, y) y -#define ML99_PRIV_IF_1(x, _y) x - -#define ML99_PRIV_IS_TUPLE(x) ML99_PRIV_NOT(ML99_PRIV_IS_UNTUPLE(x)) -#define ML99_PRIV_IS_TUPLE_FAST(x) ML99_PRIV_NOT(ML99_PRIV_IS_UNTUPLE_FAST(x)) - -#define ML99_PRIV_IS_UNTUPLE(x) \ - ML99_PRIV_IF(ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(x), 1, ML99_PRIV_IS_UNTUPLE_FAST(x)) - -#define ML99_PRIV_IS_UNTUPLE_FAST(x) ML99_PRIV_SND(ML99_PRIV_IS_UNTUPLE_FAST_TEST x, 1) -#define ML99_PRIV_IS_UNTUPLE_FAST_TEST(...) ~, 0 - -/** - * Checks whether @p x takes the form `(...) (...) ...`. - * - * This often happens when you miss a comma between items: - * - `v(123) v(456)` - * - `(Foo, int) (Bar, int)` (as in Datatype99) - * - etc. - */ -#define ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING(x) \ - ML99_PRIV_CONTAINS_COMMA(ML99_PRIV_EXPAND( \ - ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING_TEST_1 ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING_TEST_0 x)) -#define ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING_TEST_0(...) ML99_PRIV_EMPTY() -#define ML99_PRIV_IS_DOUBLE_TUPLE_BEGINNING_TEST_1(...) , - -#define ML99_PRIV_CONTAINS_COMMA(...) ML99_PRIV_X_AS_COMMA(__VA_ARGS__, ML99_PRIV_COMMA, ~) +#define ML99_PRIV_CONTAINS_COMMA(...) ML99_PRIV_X_AS_COMMA(__VA_ARGS__, ML99_PRIV_COMMA(), ~) #define ML99_PRIV_X_AS_COMMA(_head, x, ...) ML99_PRIV_CONTAINS_COMMA_RESULT(x, 0, 1, ~) #define ML99_PRIV_CONTAINS_COMMA_RESULT(x, _, result, ...) result -#define ML99_PRIV_COMMA , #endif // ML99_PRIV_UTIL_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/seq.h hkl-5.0.0.2875/third-party/metalang99/seq.h --- hkl-5.0.0.2816/third-party/metalang99/seq.h 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/seq.h 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,204 @@ +/** + * @file + * Sequences: `(x)(y)(z)`. + * + * A sequence is represented as `(...) (...) ...`. For example, these are sequences: + * - `(~, ~, ~)` + * - `(1)(2)(3)` + * - `(+, -, *, /)(123)(~)` + * + * Sequences can represent syntax like `X(...) Y(...) Z(...)`, where `X`, `Y`, and `Z` expand to a + * [tuple](tuple.html), thereby forming a sequence. A perfect example is + * [Interface99](https://github.com/Hirrolot/interface99), which allows a user to define a software + * interface via a number of `vfunc(...)` macro invocations: + * + * @code + * #define Shape_IFACE \ + * vfunc( int, perim, const VSelf) \ + * vfunc(void, scale, VSelf, int factor) + * + * interface(Shape); + * @endcode + * + * With `vfunc` being defined as follows (simplified): + * + * @code + * #define vfunc(ret_ty, name, ...) (ret_ty, name, __VA_ARGS__) + * @endcode + * + * @note Sequences are more time and space-efficient than lists, but export less functionality; if a + * needed function is missed, invoking #ML99_listFromSeq and then manipulating with the resulting + * Cons-list might be helpful. + */ + +#ifndef ML99_SEQ_H +#define ML99_SEQ_H + +#include +#include +#include + +#include + +/** + * True iff @p seq contains no elements (which means an empty preprocessing lexeme). + * + * # Examples + * + * @code + * #include + * + * // 1 + * ML99_seqIsEmpty(v()) + * + * // 0 + * ML99_seqIsEmpty(v((~)(~)(~))) + * @endcode + */ +#define ML99_seqIsEmpty(seq) ML99_call(ML99_seqIsEmpty, seq) + +/** + * Expands to a metafunction extracting the @p i -indexed element of @p seq. + * + * @p i can range from 0 to 7, inclusively. + * + * # Examples + * + * @code + * #include + * + * // 2 + * ML99_seqGet(1)(v((1)(2)(3))) + * @endcode + */ +#define ML99_seqGet(i) ML99_PRIV_CAT(ML99_PRIV_seqGet_, i) + +/** + * Extracts the tail of @p seq. + * + * @p seq must contain at least one element. If @p seq contains **only** one element, the result is + * `ML99_empty()`. + * + * # Examples + * + * @code + * #include + * + * // (2)(3) + * ML99_seqTail(v((1)(2)(3))) + * @endcode + */ +#define ML99_seqTail(seq) ML99_call(ML99_seqTail, seq) + +/** + * Applies @p f to each element in @p seq. + * + * The result is `ML99_appl(f, x1) ... ML99_appl(f, xN)`. + * + * # Examples + * + * @code + * #include + * + * #define F_IMPL(x) v(@x) + * #define F_ARITY 1 + * + * // @x @y @z + * ML99_seqForEach(v(F), v((x)(y)(z))) + * @endcode + */ +#define ML99_seqForEach(f, seq) ML99_call(ML99_seqForEach, f, seq) + +/** + * Applies @p f to each element in @p seq with an index. + * + * The result is `ML99_appl2(f, 0, x1) ... ML99_appl2(f, N - 1, xN)`. + * + * @code + * #include + * + * #define F_IMPL(i, x) v(@x##i) + * #define F_ARITY 2 + * + * // @x0 @y1 @z2 + * ML99_seqForEachI(v(F), v((x)(y)(z))) + * @endcode + */ +#define ML99_seqForEachI(f, seq) ML99_call(ML99_seqForEachI, f, seq) + +#define ML99_SEQ_IS_EMPTY(seq) ML99_PRIV_NOT(ML99_PRIV_CONTAINS_COMMA(ML99_PRIV_COMMA seq)) +#define ML99_SEQ_GET(i) ML99_PRIV_CAT(ML99_PRIV_SEQ_GET_, i) +#define ML99_SEQ_TAIL(seq) ML99_PRIV_TAIL(ML99_PRIV_COMMA seq) + +#ifndef DOXYGEN_IGNORE + +#define ML99_seqIsEmpty_IMPL(seq) v(ML99_SEQ_IS_EMPTY(seq)) + +#define ML99_PRIV_seqGet_0(seq) ML99_call(ML99_PRIV_seqGet_0, seq) +#define ML99_PRIV_seqGet_1(seq) ML99_call(ML99_PRIV_seqGet_1, seq) +#define ML99_PRIV_seqGet_2(seq) ML99_call(ML99_PRIV_seqGet_2, seq) +#define ML99_PRIV_seqGet_3(seq) ML99_call(ML99_PRIV_seqGet_3, seq) +#define ML99_PRIV_seqGet_4(seq) ML99_call(ML99_PRIV_seqGet_4, seq) +#define ML99_PRIV_seqGet_5(seq) ML99_call(ML99_PRIV_seqGet_5, seq) +#define ML99_PRIV_seqGet_6(seq) ML99_call(ML99_PRIV_seqGet_6, seq) +#define ML99_PRIV_seqGet_7(seq) ML99_call(ML99_PRIV_seqGet_7, seq) + +#define ML99_PRIV_seqGet_0_IMPL(seq) v(ML99_SEQ_GET(0)(seq)) +#define ML99_PRIV_seqGet_1_IMPL(seq) v(ML99_SEQ_GET(1)(seq)) +#define ML99_PRIV_seqGet_2_IMPL(seq) v(ML99_SEQ_GET(2)(seq)) +#define ML99_PRIV_seqGet_3_IMPL(seq) v(ML99_SEQ_GET(3)(seq)) +#define ML99_PRIV_seqGet_4_IMPL(seq) v(ML99_SEQ_GET(4)(seq)) +#define ML99_PRIV_seqGet_5_IMPL(seq) v(ML99_SEQ_GET(5)(seq)) +#define ML99_PRIV_seqGet_6_IMPL(seq) v(ML99_SEQ_GET(6)(seq)) +#define ML99_PRIV_seqGet_7_IMPL(seq) v(ML99_SEQ_GET(7)(seq)) + +#define ML99_PRIV_SEQ_GET_0(seq) ML99_PRIV_UNTUPLE(ML99_PRIV_HEAD(ML99_PRIV_SEQ_SEPARATE seq)) +#define ML99_PRIV_SEQ_GET_1(seq) ML99_PRIV_SEQ_GET_0(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_2(seq) ML99_PRIV_SEQ_GET_1(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_3(seq) ML99_PRIV_SEQ_GET_2(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_4(seq) ML99_PRIV_SEQ_GET_3(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_5(seq) ML99_PRIV_SEQ_GET_4(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_6(seq) ML99_PRIV_SEQ_GET_5(ML99_SEQ_TAIL(seq)) +#define ML99_PRIV_SEQ_GET_7(seq) ML99_PRIV_SEQ_GET_6(ML99_SEQ_TAIL(seq)) + +#define ML99_PRIV_SEQ_SEPARATE(...) (__VA_ARGS__), + +#define ML99_seqTail_IMPL(seq) v(ML99_SEQ_TAIL(seq)) + +#define ML99_seqForEach_IMPL(f, seq) \ + ML99_PRIV_CAT(ML99_PRIV_seqForEach_, ML99_SEQ_IS_EMPTY(seq))(f, seq) +#define ML99_PRIV_seqForEach_1(...) v(ML99_PRIV_EMPTY()) +#define ML99_PRIV_seqForEach_0(f, seq) \ + ML99_TERMS( \ + ML99_appl_IMPL(f, ML99_SEQ_GET(0)(seq)), \ + ML99_callUneval(ML99_seqForEach, f, ML99_SEQ_TAIL(seq))) + +#define ML99_seqForEachI_IMPL(f, seq) ML99_PRIV_seqForEachIAux_IMPL(f, 0, seq) +#define ML99_PRIV_seqForEachIAux_IMPL(f, i, seq) \ + ML99_PRIV_CAT(ML99_PRIV_seqForEachI_, ML99_SEQ_IS_EMPTY(seq))(f, i, seq) +#define ML99_PRIV_seqForEachI_1(...) v(ML99_PRIV_EMPTY()) +#define ML99_PRIV_seqForEachI_0(f, i, seq) \ + ML99_TERMS( \ + ML99_appl2_IMPL(f, i, ML99_SEQ_GET(0)(seq)), \ + ML99_callUneval(ML99_PRIV_seqForEachIAux, f, ML99_PRIV_INC(i), ML99_SEQ_TAIL(seq))) + +// Arity specifiers { + +#define ML99_seqIsEmpty_ARITY 1 +#define ML99_seqTail_ARITY 1 +#define ML99_seqForEach_ARITY 2 +#define ML99_seqForEachI_ARITY 2 + +#define ML99_PRIV_seqGet_0_ARITY 1 +#define ML99_PRIV_seqGet_1_ARITY 1 +#define ML99_PRIV_seqGet_2_ARITY 1 +#define ML99_PRIV_seqGet_3_ARITY 1 +#define ML99_PRIV_seqGet_4_ARITY 1 +#define ML99_PRIV_seqGet_5_ARITY 1 +#define ML99_PRIV_seqGet_6_ARITY 1 +#define ML99_PRIV_seqGet_7_ARITY 1 +// } (Arity specifiers) + +#endif // DOXYGEN_IGNORE + +#endif // ML99_SEQ_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/stmt.h hkl-5.0.0.2875/third-party/metalang99/stmt.h --- hkl-5.0.0.2816/third-party/metalang99/stmt.h 1970-01-01 00:00:00.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/stmt.h 2021-12-08 09:14:21.000000000 +0000 @@ -0,0 +1,155 @@ +/** + * @file + * Statement chaining. + * + * This module exports a bunch of so-called _statement chaining macros_: they expect a statement + * right after their invocation, and moreover, an invocation of such a macro with a statement + * afterwards altogether form a single statement. + * + * How can this be helpful? Imagine you are writing a macro with the following syntax: + * + * @code + * MY_MACRO(...) { bla bla bla } + * @endcode + * + * Then `MY_MACRO` must expand to a _statement prefix_, i.e., something that expects a statement + * after itself. One possible solution is to make `MY_MACRO` expand to a sequence of statement + * chaining macros like this: + * + * @code + * #define MY_MACRO(...) \ + * ML99_INTRODUCE_VAR_TO_STMT(int x = 5) \ + * ML99_CHAIN_EXPR_STMT(printf("%d\n", x)) \ + * // and so on... + * @endcode + * + * Here #ML99_INTRODUCE_VAR_TO_STMT accepts the statement formed by #ML99_CHAIN_EXPR_STMT, which, in + * turn, accepts the next statement and so on, until a caller of `MY_MACRO` specifies the final + * statement, thus completing the chain. + * + * @see https://www.chiark.greenend.org.uk/~sgtatham/mp/ for a more involved explanation. + */ + +#ifndef ML99_STMT_H +#define ML99_STMT_H + +#include + +/** + * A statement chaining macro that introduces several variable definitions to a statement right + * after its invocation. + * + * Variable definitions must be specified as in the first clause of the for-loop. + * + * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * + * # Example + * + * @code + * #include + * + * for (int i = 0; i < 10; i++) + * ML99_INTRODUCE_VAR_TO_STMT(double x = 5.0, y = 7.0) + * if (i % 2 == 0) + * printf("i = %d, x = %f, y = %f\n", i, x, y); + * @endcode + */ +#define ML99_INTRODUCE_VAR_TO_STMT(...) \ + ML99_PRIV_SHADOWS(for (__VA_ARGS__, *ml99_priv_break = (void *)0; \ + ml99_priv_break != (void *)1; \ + ml99_priv_break = (void *)1)) + +/** + * The same as #ML99_INTRODUCE_VAR_TO_STMT but deals with a single non-`NULL` pointer. + * + * In comparison with #ML99_INTRODUCE_VAR_TO_STMT, this macro generates a little less code. It + * introduces a pointer to @p ty identified by @p name and initialised to @p init. + * + * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * + * # Example + * + * @code + * #include + * + * double x = 5.0, y = 7.0; + * + * for (int i = 0; i < 10; i++) + * ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(double, x_ptr, &x) + * ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(double, y_ptr, &y) + * printf("i = %d, x = %f, y = %f\n", i, *x_ptr, *y_ptr); + * @endcode + * + * @note Unlike #ML99_INTRODUCE_VAR_TO_STMT, the generated pointer is guaranteed to be used at least + * once, meaning that you do not need to suppress the unused variable warning. + * @note @p init is guaranteed to be executed only once. + */ +#define ML99_INTRODUCE_NON_NULL_PTR_TO_STMT(ty, name, init) \ + ML99_PRIV_SHADOWS(for (ty *name = (init); name != (void *)0; name = (void *)0)) + +/** + * A statement chaining macro that executes an expression statement derived from @p expr right + * before the next statement. + * + * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * + * # Example + * + * @code + * #include + * + * int x; + * + * for(;;) + * ML99_CHAIN_EXPR_STMT(x = 5) + * ML99_CHAIN_EXPR_STMT(printf("%d\n", x)) + * puts("abc"); + * @endcode + */ +#define ML99_CHAIN_EXPR_STMT(expr) \ + ML99_PRIV_SHADOWS(for (int ml99_priv_expr_stmt_break = ((expr), 0); \ + ml99_priv_expr_stmt_break != 1; \ + ml99_priv_expr_stmt_break = 1)) + +/** + * The same as #ML99_CHAIN_EXPR_STMT but executes @p expr **after** the next statement. + */ +#define ML99_CHAIN_EXPR_STMT_AFTER(expr) \ + ML99_PRIV_SHADOWS(for (int ml99_priv_expr_stmt_after_break = 0; \ + ml99_priv_expr_stmt_after_break != 1; \ + ((expr), ml99_priv_expr_stmt_after_break = 1))) + +/** + * A statement chaining macro that suppresses the "unused X" warning right before a statement after + * its invocation. + * + * Top-level `break`/`continue` inside a user-provided statement are prohibited. + * + * # Example + * + * @code + * #include + * + * int x, y; + * + * for(;;) + * ML99_SUPPRESS_UNUSED_BEFORE_STMT(x) + * ML99_SUPPRESS_UNUSED_BEFORE_STMT(y) + * puts("abc"); + * @endcode + * + * @deprecated Use `ML99_CHAIN_EXPR_STMT((void)expr)` instead. + */ +#define ML99_SUPPRESS_UNUSED_BEFORE_STMT(expr) ML99_CHAIN_EXPR_STMT((void)expr) + +#ifndef DOXYGEN_IGNORE + +#define ML99_PRIV_SHADOWS(...) \ + ML99_CLANG_PRAGMA("clang diagnostic push") \ + ML99_CLANG_PRAGMA("clang diagnostic ignored \"-Wshadow\"") \ + __VA_ARGS__ \ + ML99_CLANG_PRAGMA("clang diagnostic pop") + +#endif // DOXYGEN_IGNORE + +#endif // ML99_STMT_H diff -Nru hkl-5.0.0.2816/third-party/metalang99/tuple.h hkl-5.0.0.2875/third-party/metalang99/tuple.h --- hkl-5.0.0.2816/third-party/metalang99/tuple.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/tuple.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,20 +1,23 @@ /** * @file - * Tuple manipulation. + * Tuples: `(x, y, z)`. * - * A tuple is represented as `(x1, ..., xN)`. Tuples are more time and space-efficient than lists, - * but export less functionality. + * A tuple is represented as `(x1, ..., xN)`. Tuples are a convenient way to deal with product + * types. For example: * - * Tuples are a convenient way to deal with product types. For example: - * - * [examples/rectangle.c] + * [[examples/rectangle.c](https://github.com/Hirrolot/metalang99/blob/master/examples/rectangle.c)] * @include rectangle.c + * + * @note Tuples are more time and space-efficient than lists, but export less functionality; if a + * needed function is missed, invoking #ML99_list and then manipulating with the resulting Cons-list + * might be helpful. */ #ifndef ML99_TUPLE_H #define ML99_TUPLE_H +#include +#include #include #include @@ -45,12 +48,17 @@ * // (v(1, 2, 3)) * ML99_tupleEval(v(1, 2, 3)) * @endcode + * + * @deprecated I have seen no single use case over time. Please, [open an + * issue](https://github.com/Hirrolot/metalang99/issues/new/choose) if you need this function. */ #define ML99_tupleEval(...) ML99_call(ML99_tupleEval, __VA_ARGS__) /** * Untuples the tuple @p x, leaving the result unevaluated. * + * If @p x is not a tuple, it emits a fatal error. + * * # Examples * * @code @@ -63,9 +71,9 @@ #define ML99_untuple(x) ML99_call(ML99_untuple, x) /** - * The same as #ML99_untuple, except that it emits a fatal error if @p x is not a tuple. + * The same as #ML99_untuple. * - * The preconditions are the same as of #ML99_isUntuple. + * @deprecated Use #ML99_untuple instead. */ #define ML99_untupleChecked(x) ML99_call(ML99_untupleChecked, x) @@ -80,6 +88,8 @@ * // 1, 2, 3 * ML99_untupleEval(v((v(1, 2, 3)))) * @endcode + * + * @deprecated For the same reason as #ML99_tupleEval. */ #define ML99_untupleEval(x) ML99_call(ML99_untupleEval, x) @@ -272,16 +282,16 @@ #define ML99_tuple_IMPL(...) v(ML99_TUPLE(__VA_ARGS__)) #define ML99_tupleEval_IMPL(...) v((v(__VA_ARGS__))) -#define ML99_untuple_IMPL(x) v(ML99_UNTUPLE(x)) -#define ML99_untupleChecked_IMPL(x) \ - ML99_PRIV_IF(ML99_IS_TUPLE(x), ML99_PRIV_UNTUPLE_CHECKED_AUX, ML99_PRIV_NOT_TUPLE_ERROR)(x) -#define ML99_untupleEval_IMPL(x) ML99_PRIV_EXPAND x -#define ML99_isTuple_IMPL(x) v(ML99_IS_TUPLE(x)) -#define ML99_isUntuple_IMPL(x) v(ML99_IS_UNTUPLE(x)) -#define ML99_tupleCount_IMPL(x) v(ML99_TUPLE_COUNT(x)) -#define ML99_tupleIsSingle_IMPL(x) v(ML99_TUPLE_IS_SINGLE(x)) +#define ML99_untuple_IMPL(x) \ + ML99_PRIV_IF(ML99_IS_TUPLE(x), ML99_PRIV_UNTUPLE_TERM, ML99_PRIV_NOT_TUPLE_ERROR)(x) +#define ML99_untupleChecked_IMPL(x) ML99_untuple_IMPL(x) +#define ML99_untupleEval_IMPL(x) ML99_PRIV_EXPAND x +#define ML99_isTuple_IMPL(x) v(ML99_IS_TUPLE(x)) +#define ML99_isUntuple_IMPL(x) v(ML99_IS_UNTUPLE(x)) +#define ML99_tupleCount_IMPL(x) v(ML99_TUPLE_COUNT(x)) +#define ML99_tupleIsSingle_IMPL(x) v(ML99_TUPLE_IS_SINGLE(x)) -#define ML99_PRIV_UNTUPLE_CHECKED_AUX(x) v(ML99_UNTUPLE(x)) +#define ML99_PRIV_UNTUPLE_TERM(x) v(ML99_UNTUPLE(x)) #define ML99_PRIV_tupleGet_0(x) ML99_call(ML99_PRIV_tupleGet_0, x) #define ML99_PRIV_tupleGet_1(x) ML99_call(ML99_PRIV_tupleGet_1, x) diff -Nru hkl-5.0.0.2816/third-party/metalang99/util.h hkl-5.0.0.2875/third-party/metalang99/util.h --- hkl-5.0.0.2816/third-party/metalang99/util.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/util.h 2021-12-08 09:14:21.000000000 +0000 @@ -8,7 +8,7 @@ #include -#include // For backward compatibility. +#include // For backwards compatibility. #include /** @@ -27,6 +27,9 @@ * // ERROR: 123ABC is not a valid Metalang99 term. * ML99_catEval(v(123), v(ABC)) * @endcode + * + * @deprecated I have seen no single use case over time. Please, [open an + * issue](https://github.com/Hirrolot/metalang99/issues/new/choose) if you need this function. */ #define ML99_catEval(a, b) ML99_call(ML99_catEval, a, b) @@ -176,8 +179,7 @@ * ML99_todo(v(F)) * @endcode * - * @see Rust's std::todo\! (thanks for - * the idea!) + * @see [Rust's std::todo\!](https://doc.rust-lang.org/core/macro.todo.html) (thanks for the idea!) */ #define ML99_todo(f) ML99_call(ML99_todo, f) @@ -212,8 +214,8 @@ * ML99_unimplemented(v(F)) * @endcode * - * @see Rust's - * std::unimplemented\! (thanks for the idea!) + * @see [Rust's std::unimplemented\!](https://doc.rust-lang.org/core/macro.unimplemented.html) + * (thanks for the idea!) */ #define ML99_unimplemented(f) ML99_call(ML99_unimplemented, f) @@ -233,6 +235,65 @@ */ #define ML99_unimplementedWithMsg(f, message) ML99_call(ML99_unimplementedWithMsg, f, message) +#ifdef __COUNTER__ + +/** + * Generates a unique identifier @p id in the namespace @p prefix. + * + * Let `FOO` be the name of an enclosing macro. Then `FOO_` must be specified for @p prefix, and @p + * id should be given any meaningful name (this makes debugging easier). + * + * # Examples + * + * @code + * #include + * + * #define FOO(...) FOO_NAMED(ML99_GEN_SYM(FOO_, x), __VA_ARGS__) + * #define FOO_NAMED(x_sym, ...) \ + * do { int x_sym = 5; __VA_ARGS__ } while (0) + * + * // `x` here will not conflict with the `x` inside `FOO`. + * FOO({ + * int x = 7; + * printf("x is %d\n", x); // x is 7 + * }); + * @endcode + * + * @note Two identical calls to #ML99_GEN_SYM will yield different identifiers, therefore, to refer + * to the result later, you must save it in an auxiliary macro's parameter, as shown in the example + * above. + * @note #ML99_GEN_SYM is defined only if `__COUNTER__` is defined, which must be a macro yielding + * integral literals starting from 0 incremented by 1 each time it is called. Currently, it is + * supported at least by Clang, GCC, TCC, and MSVC. + * @see https://en.wikipedia.org/wiki/Hygienic_macro + */ +#define ML99_GEN_SYM(prefix, id) ML99_CAT4(prefix, id, _, __COUNTER__) + +#endif // __COUNTER__ + +/** + * Forces a caller to put a trailing semicolon. + * + * It is useful when defining macros, to make them formatted as complete statements. + * + * # Examples + * + * @code + * #include + * + * #define MY_MACRO(fn_name, val_ty, val) \ + * inline static val_ty fn_name(void) { return val; } \ + * ML99_TRAILING_SEMICOLON() + * + * // Defines a function that always returns 0. + * MY_MACRO(zero, int, 0); + * @endcode + * + * @note #ML99_TRAILING_SEMICOLON is to be used outside of functions: unlike the `do { ... } while + * (0)` idiom, this macro expands to a C declaration. + */ +#define ML99_TRAILING_SEMICOLON(...) struct ml99_priv_trailing_semicolon + /** * Concatenates @p a with @p b as-is, without expanding them. * @@ -299,29 +360,6 @@ /** * Expands to a single comma, consuming all arguments. - * - * # Examples - * - * Consider this variation of X-Macro: - * - * @code - * #include - * - * #define FOO X(1) X(2, 3) X(4, 5, 6) - * #define BAR - * - * #define X ML99_COMMA - * - * // , , , - * FOO - * - * // (No commas.) - * BAR - * @endcode - * - * Later, with #ML99_variadicsIsSingle, we can detect whether or not `FOO` and `BAR` result in one - * or more invocation of `X`. This technique is used in Interface99 to detect marker interfaces. */ #define ML99_COMMA(...) , diff -Nru hkl-5.0.0.2816/third-party/metalang99/variadics.h hkl-5.0.0.2875/third-party/metalang99/variadics.h --- hkl-5.0.0.2816/third-party/metalang99/variadics.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99/variadics.h 2021-12-08 09:14:21.000000000 +0000 @@ -1,22 +1,19 @@ /** * @file - * Variadic arguments manipulation. + * Variadic arguments: `x, y, z`. * - * Metalang99 does not provide a lot of stuff in this module; if a needed function is missed, - * invoking #ML99_list and then manipulating with the resulting Cons-list might be helpful. + * @note Variadics are more time and space-efficient than lists, but export less functionality; if a + * needed function is missed, invoking #ML99_list and then manipulating with the resulting Cons-list + * might be helpful. */ #ifndef ML99_VARIADICS_H #define ML99_VARIADICS_H -#include -#include #include - #include #include -#include /** * Computes a count of its arguments. @@ -91,43 +88,68 @@ * * The result is `ML99_appl(f, x1) ... ML99_appl(f, xN)`. * - * If you already have variadics, using this macro is more efficient than - * `ML99_listUnwrap(ML99_listMap(v(f), ML99_list(v(...))))`. - * - * At most 63 variadic arguments are acceptable. - * * # Examples * * @code - * #include + * #include * * #define F_IMPL(x) v(@x) * #define F_ARITY 1 * - * // @1 @2 @3 - * ML99_variadicsForEach(v(F), v(1, 2, 3)) + * // @x @y @z + * ML99_variadicsForEach(v(F), v(x, y, z)) * @endcode - * - * @note Unlike #ML99_listMap, @p f can evaluate to many commas. */ #define ML99_variadicsForEach(f, ...) ML99_call(ML99_variadicsForEach, f, __VA_ARGS__) /** * Applies @p f to each argument with an index. * - * The result is `ML99_appl2(f, x1, 0) ... ML99_appl2(f, xN, N)`. + * The result is `ML99_appl2(f, x1, 0) ... ML99_appl2(f, xN, N - 1)`. * - * If you already have variadics, using this macro is more efficient than - * `ML99_listUnwrap(ML99_listMapI(v(f), ML99_list(v(...))))`. + * @code + * #include * - * At most 63 variadic arguments are acceptable. + * #define F_IMPL(x, i) v(@x##i) + * #define F_ARITY 2 * - * @note Unlike #ML99_listMapI, @p f can evaluate to many commas. + * // @x0 @y1 @z2 + * ML99_variadicsForEachI(v(F), v(x, y, z)) + * @endcode */ #define ML99_variadicsForEachI(f, ...) ML99_call(ML99_variadicsForEachI, f, __VA_ARGS__) +/** + * Overloads @p f on a number of arguments. + * + * This function counts the number of provided arguments, appends it to @p f and calls the resulting + * macro identifier with provided arguments. + * + * At most 63 variadic arguments are acceptable. + * + * # Examples + * + * @code + * #include + * + * #define X(...) ML99_OVERLOAD(X_, __VA_ARGS__) + * #define X_1(a) Billie & a + * #define X_2(a, b) Jean & a & b + * + * // Billie & 4 + * X(4) + * + * // Jean & 5 & 6 + * X(5, 6) + * @endcode + * + * @note @p f need not be postfixed with `_IMPL`. It is literally invoked as `ML99_CAT(f, + * ML99_VARIADICS_COUNT(...))(...)`. + */ +#define ML99_OVERLOAD(f, ...) ML99_PRIV_CAT(f, ML99_PRIV_VARIADICS_COUNT(__VA_ARGS__))(__VA_ARGS__) + #define ML99_VARIADICS_COUNT(...) ML99_PRIV_VARIADICS_COUNT(__VA_ARGS__) -#define ML99_VARIADICS_IS_SINGLE(...) ML99_NOT(ML99_PRIV_CONTAINS_COMMA(__VA_ARGS__)) +#define ML99_VARIADICS_IS_SINGLE(...) ML99_PRIV_NOT(ML99_PRIV_CONTAINS_COMMA(__VA_ARGS__)) #define ML99_VARIADICS_GET(i) ML99_PRIV_CAT(ML99_PRIV_VARIADICS_GET_, i) #define ML99_VARIADICS_TAIL(...) ML99_PRIV_TAIL(__VA_ARGS__) @@ -177,92 +199,56 @@ // ML99_variadicsForEach_IMPL { #define ML99_variadicsForEach_IMPL(f, ...) \ - ML99_PRIV_variadicsForEachAux_IMPL(f, ML99_PRIV_VARIADICS_COUNT(__VA_ARGS__), __VA_ARGS__, ~) - -#define ML99_PRIV_variadicsForEachAux_IMPL(f, count, ...) \ - ML99_PRIV_IF( \ - ML99_PRIV_NAT_EQ(count, 1), \ - ML99_PRIV_VARIADICS_FOR_EACH_DONE, \ - ML99_PRIV_VARIADICS_FOR_EACH_PROGRESS) \ - (f, count, __VA_ARGS__) - -#define ML99_PRIV_VARIADICS_FOR_EACH_DONE(f, _count, x, _) ML99_appl_IMPL(f, x) -#define ML99_PRIV_VARIADICS_FOR_EACH_PROGRESS(f, count, x, ...) \ - ML99_TERMS( \ - ML99_appl_IMPL(f, x), \ - ML99_callUneval(ML99_PRIV_variadicsForEachAux, f, ML99_PRIV_DEC(count), __VA_ARGS__)) + ML99_PRIV_CAT(ML99_PRIV_variadicsForEach_, ML99_VARIADICS_IS_SINGLE(__VA_ARGS__)) \ + (f, __VA_ARGS__) +#define ML99_PRIV_variadicsForEach_1(f, x) ML99_appl_IMPL(f, x) +#define ML99_PRIV_variadicsForEach_0(f, x, ...) \ + ML99_TERMS(ML99_appl_IMPL(f, x), ML99_callUneval(ML99_variadicsForEach, f, __VA_ARGS__)) // } (ML99_variadicsForEach_IMPL) // ML99_variadicsForEachI_IMPL { -#define ML99_variadicsForEachI_IMPL(f, ...) \ - ML99_PRIV_variadicsForEachIAux_IMPL( \ - f, \ - 0, \ - ML99_PRIV_VARIADICS_COUNT(__VA_ARGS__), \ - __VA_ARGS__, \ - ~) - -#define ML99_PRIV_variadicsForEachIAux_IMPL(f, i, count, ...) \ - ML99_PRIV_IF( \ - ML99_PRIV_NAT_EQ(count, 1), \ - ML99_PRIV_VARIADICS_FOR_EACH_I_DONE, \ - ML99_PRIV_VARIADICS_FOR_EACH_I_PROGRESS) \ - (f, i, count, __VA_ARGS__) +#define ML99_variadicsForEachI_IMPL(f, ...) ML99_PRIV_variadicsForEachIAux_IMPL(f, 0, __VA_ARGS__) -#define ML99_PRIV_VARIADICS_FOR_EACH_I_DONE(f, i, _count, x, _) ML99_appl2_IMPL(f, x, i) -#define ML99_PRIV_VARIADICS_FOR_EACH_I_PROGRESS(f, i, count, x, ...) \ +#define ML99_PRIV_variadicsForEachIAux_IMPL(f, i, ...) \ + ML99_PRIV_CAT(ML99_PRIV_variadicsForEachI_, ML99_VARIADICS_IS_SINGLE(__VA_ARGS__)) \ + (f, i, __VA_ARGS__) + +#define ML99_PRIV_variadicsForEachI_1(f, i, x) ML99_appl2_IMPL(f, x, i) +#define ML99_PRIV_variadicsForEachI_0(f, i, x, ...) \ ML99_TERMS( \ ML99_appl2_IMPL(f, x, i), \ - ML99_callUneval( \ - ML99_PRIV_variadicsForEachIAux, \ - f, \ - ML99_PRIV_INC(i), \ - ML99_PRIV_DEC(count), \ - __VA_ARGS__)) + ML99_callUneval(ML99_PRIV_variadicsForEachIAux, f, ML99_PRIV_INC(i), __VA_ARGS__)) // } (ML99_variadicsForEachI_IMPL) /* - * Proposition: The count of arguments of `ML99_PRIV_VARIADICS_COUNT` is `x` returned from - * `ML99_PRIV_VARIADICS_COUNT_AUX`. - * - * Proof: - * 1) Let N be the length of __VA_ARGS__. - * 2) Let (args...) ---> (params...) mean that (params...) are initialised with (args...). - * - * Then - * ({~ N times}, {63, ..., 1}, ~) ---> ({_1, ..., _63}, x, ...) - * - * And since N belongs to [1; 63]: - * ({63, ..., 1}, ~) ---> ({_(N + 1), ..., _63}, x, ...) - * - * (N, ..., 1, ~) ---> (x, ...) - * (N) ---> (x) - */ - -/* * The StackOverflow solution: . * * This macro supports at most 63 arguments because C99 allows implementations to handle only 127 - * parameters/arguments per macro definition/invocation (C99 | 5.2.4 Environmental limits). Thus, + * parameters/arguments per macro definition/invocation (C99 | 5.2.4 Environmental limits), and * `ML99_PRIV_VARIADICS_COUNT_AUX` already accepts 64 arguments. */ - // clang-format off -#define ML99_PRIV_VARIADICS_COUNT(...) \ - ML99_PRIV_VARIADICS_COUNT_AUX( \ - __VA_ARGS__, 63, 62, 61, 60, 59, 58, 57, 56, 55, 54, 53, 52, 51, 50, 49, \ - 48, 47, 46, 45, 44, 43, 42, 41, 40, 39, 38, 37, 36, 35, 34, 33, 32, 31, \ - 30, 29, 28, 27, 26, 25, 24, 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, 13, \ - 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1, ~) - -#define ML99_PRIV_VARIADICS_COUNT_AUX( \ - _1, _2, _3, _4, _5, _6, _7, _8, _9, _10, _11, _12, _13, _14, _15, _16, \ - _17, _18, _19, _20, _21, _22, _23, _24, _25, _26, _27, _28, _29, _30, _31, \ - _32, _33, _34, _35, _36, _37, _38, _39, _40, _41, _42, _43, _44, _45, _46, \ - _47, _48, _49, _50, _51, _52, _53, _54, _55, _56, _57, _58, _59, _60, _61, \ - _62, _63, x, ...) \ - x +#define ML99_PRIV_VARIADICS_COUNT(...) \ + ML99_PRIV_VARIADICS_COUNT_AUX( \ + __VA_ARGS__, \ + 63, 62, 61, 60, 59, 58, 57, 56, 55, 54, \ + 53, 52, 51, 50, 49, 48, 47, 46, 45, 44, \ + 43, 42, 41, 40, 39, 38, 37, 36, 35, 34, \ + 33, 32, 31, 30, 29, 28, 27, 26, 25, 24, \ + 23, 22, 21, 20, 19, 18, 17, 16, 15, 14, \ + 13, 12, 11, 10, 9, 8, 7, 6, 5, 4, \ + 3, 2, 1, ~) + +#define ML99_PRIV_VARIADICS_COUNT_AUX( \ + _1, _2, _3, _4, _5, _6, _7, _8, _9, _10, \ + _11, _12, _13, _14, _15, _16, _17, _18, _19, _20, \ + _21, _22, _23, _24, _25, _26, _27, _28, _29, _30, \ + _31, _32, _33, _34, _35, _36, _37, _38, _39, _40, \ + _41, _42, _43, _44, _45, _46, _47, _48, _49, _50, \ + _51, _52, _53, _54, _55, _56, _57, _58, _59, _60, \ + _61, _62, _63, x, ...) \ + x // clang-format on // Arity specifiers { diff -Nru hkl-5.0.0.2816/third-party/metalang99.h hkl-5.0.0.2875/third-party/metalang99.h --- hkl-5.0.0.2816/third-party/metalang99.h 2021-09-16 12:50:37.000000000 +0000 +++ hkl-5.0.0.2875/third-party/metalang99.h 2021-12-08 09:14:21.000000000 +0000 @@ -6,20 +6,23 @@ #endif #include +#include #include -#include +#include #include #include #include #include #include #include +#include +#include #include #include #include #define ML99_MAJOR 1 -#define ML99_MINOR 10 +#define ML99_MINOR 13 #define ML99_PATCH 0 #define ML99_VERSION_COMPATIBLE(x, y, z) \