guile/grid.cc

#include <vtestbed/config/real_type.hh>
#include <vtestbed/core/grid.hh>
#include <vtestbed/guile/base.hh>
#include <vtestbed/guile/grid.hh>
#include <vtestbed/guile/macros.hh>

namespace {
    SCM type;
    SCM kw_min, kw_max, kw_npoints, kw_nsegments;
    SCM kw_begin_index, kw_end_index;
    const char* grid_goops = R"(
(use-modules (oop goops))
(define-method (write (grid <grid>) port) (display (grid->string grid) port))
)";
}

namespace vtb {

    namespace guile {

        template <int N>
        class Grid_wrapper {

        public:
            vtb::core::Grid<VTB_REAL_TYPE,N> grid;
            const int dimensions = N;

            Grid_wrapper() = default;

            Grid_wrapper(SCM min, SCM max, SCM npoints, SCM nsegments, SCM begin, SCM end) {
                this->min(min);
                this->max(max);
                if (is_bound(begin)) { this->begin(begin); }
                else { grid.begin() = VTB_REAL_TYPE{}; }
                if (is_bound(end)) { this->end(end); }
                else if (is_bound(npoints)) { this->num_points(npoints); }
                else { this->num_segments(nsegments); }
            }

            SCM min() {
                SCM ret = SCM_EOL;
                for (int i=N-1; i>=0; --i) {
                    ret = scm_cons(to_scm(grid.lbound(i)), ret);
                }
                return ret;
            }

            SCM max() {
                SCM ret = SCM_EOL;
                for (int i=N-1; i>=0; --i) {
                    ret = scm_cons(to_scm(grid.ubound(i)), ret);
                }
                return ret;
            }

            SCM begin() {
                SCM ret = SCM_EOL;
                for (int i=N-1; i>=0; --i) {
                    ret = scm_cons(to_scm(grid.begin(i)), ret);
                }
                return ret;
            }

            SCM end() {
                SCM ret = SCM_EOL;
                for (int i=N-1; i>=0; --i) {
                    ret = scm_cons(to_scm(grid.end(i)), ret);
                }
                return ret;
            }

            void min(SCM min) {
                for (int i=0; i<N; ++i) {
                    grid.lbound(i) = scm_to_double(scm_car(min));
                    min = scm_cdr(min);
                }
            }

            void max(SCM max) {
                for (int i=0; i<N; ++i) {
                    grid.ubound(i) = scm_to_double(scm_car(max));
                    max = scm_cdr(max);
                }
            }

            void begin(SCM begin) {
                for (int i=0; i<N; ++i) {
                    grid.begin(i) = scm_to_int(scm_car(begin));
                    begin = scm_cdr(begin);
                }
            }

            void end(SCM end) {
                for (int i=0; i<N; ++i) {
                    grid.end(i) = scm_to_int(scm_car(end));
                    end = scm_cdr(end);
                }
            }

            void num_points(SCM npoints) {
                for (int i=0; i<N; ++i) {
                    grid.end(i) = grid.begin(i) + scm_to_int(scm_car(npoints));
                    npoints = scm_cdr(npoints);
                }
            }

            void num_segments(SCM nsegments) {
                for (int i=0; i<N; ++i) {
                    grid.end(i) = grid.begin(i) + 1+scm_to_int(scm_car(nsegments));
                    nsegments = scm_cdr(nsegments);
                }
            }

            SCM select(SCM indices) {
                SCM min = SCM_EOL;
                SCM max = SCM_EOL;
                SCM begin = SCM_EOL;
                SCM end = SCM_EOL;
                while (indices != SCM_EOL) {
                    int i = scm_to_int(scm_car(indices));
                    min = scm_cons(to_scm(grid.lbound(i)), min);
                    max = scm_cons(to_scm(grid.ubound(i)), max);
                    begin = scm_cons(to_scm(grid.begin(i)), begin);
                    end = scm_cons(to_scm(grid.end(i)), end);
                    indices = scm_cdr(indices);
                }
                min = scm_reverse(min);
                max = scm_reverse(max);
                begin = scm_reverse(begin);
                end = scm_reverse(end);
                return scm_call(scm_variable_ref(scm_c_lookup("make-grid")),
                                kw_min, min, kw_max, max,
                                kw_begin_index, begin, kw_end_index, end,
                                SCM_UNDEFINED);
            }

            SCM compact() const {
                auto* wrapper = allocate_pointerless<Grid_wrapper>("grid");
                wrapper->grid = this->grid;
                wrapper->grid.compact();
                return scm_make_foreign_object_2(::type, wrapper,
                                                 reinterpret_cast<void*>(size_t(dimensions)));
            }

            SCM to_string() const {
                std::stringstream tmp;
                tmp << this->grid;
                return to_scm(tmp.str());
            }

        };

        template <int N> inline Grid_wrapper<N>*
        get_grid_wrapper(SCM object) {
            return reinterpret_cast<Grid_wrapper<N>*>(scm_foreign_object_ref(object, 0));
        }

        inline size_t
        get_dimensions(SCM object) {
            return reinterpret_cast<size_t>(scm_foreign_object_ref(object, 1));
        }

        SCM make_grid(SCM rest) {
            SCM min = SCM_UNDEFINED, max = SCM_UNDEFINED, npoints = SCM_UNDEFINED,
                nsegments = SCM_UNDEFINED, begin = SCM_UNDEFINED, end = SCM_UNDEFINED;
            scm_c_bind_keyword_arguments("make-grid", rest,
                                         scm_t_keyword_arguments_flags{},
                                         kw_min, &min, kw_max, &max,
                                         kw_npoints, &npoints, kw_nsegments, &nsegments,
                                         kw_begin_index, &begin, kw_end_index, &end,
                                         SCM_UNDEFINED);
            if (!is_bound(min) || !is_bound(max)) {
                throw_error("missing min/max");
                return SCM_UNSPECIFIED;
            }
            if (is_bound(npoints) && is_bound(nsegments)) {
                throw_error("both num-points and num-segments defined");
                return SCM_UNSPECIFIED;
            }
            if ((is_bound(end) && (is_bound(npoints) || is_bound(nsegments)))) {
                throw_error("use either begin-index and end-index, "
                            "or begin-index and num-points/num-segments");
                return SCM_UNSPECIFIED;
            }
            if (!is_list(min) || !is_list(max) ||
                (is_bound(npoints) && !is_list(npoints)) ||
                (is_bound(nsegments) && !is_list(nsegments))) {
                throw_error("min/max/num-points/num-segments is not a list");
                return SCM_UNSPECIFIED;
            }
            auto dimensions = length(min);
            if (length(max) != dimensions ||
                (is_bound(npoints) && length(npoints) != dimensions) ||
                (is_bound(nsegments) && length(nsegments) != dimensions) ||
                (is_bound(begin) && length(begin) != dimensions) ||
                (is_bound(end) && length(end) != dimensions)) {
                throw_error("min/max/num-points/num-segments/begin-index/end-index "
                            "have different length");
                return SCM_UNSPECIFIED;
            }
            void* wrapper = nullptr;
            switch (dimensions) {
                case 1:
                    wrapper = construct_pointerless<Grid_wrapper<1>>(
                        "grid", min, max, npoints, nsegments, begin, end);
                    break;
                case 2:
                    wrapper = construct_pointerless<Grid_wrapper<2>>(
                        "grid", min, max, npoints, nsegments, begin, end);
                    break;
                case 3:
                    wrapper = construct_pointerless<Grid_wrapper<3>>(
                        "grid", min, max, npoints, nsegments, begin, end);
                    break;
                case 4:
                    wrapper = construct_pointerless<Grid_wrapper<4>>(
                        "grid", min, max, npoints, nsegments, begin, end);
                    break;
                default: throw_error("bad no. of dimensions"); return SCM_UNSPECIFIED;
            }
            return scm_make_foreign_object_2(::type, wrapper,
                                             reinterpret_cast<void*>(size_t(dimensions)));
        }

        SCM grid_min(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->min();
                case 2: return get_grid_wrapper<2>(object)->min();
                case 3: return get_grid_wrapper<3>(object)->min();
                case 4: return get_grid_wrapper<4>(object)->min();
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_max(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->max();
                case 2: return get_grid_wrapper<2>(object)->max();
                case 3: return get_grid_wrapper<3>(object)->max();
                case 4: return get_grid_wrapper<4>(object)->max();
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_begin_index(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->begin();
                case 2: return get_grid_wrapper<2>(object)->begin();
                case 3: return get_grid_wrapper<3>(object)->begin();
                case 4: return get_grid_wrapper<4>(object)->begin();
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_end_index(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->end();
                case 2: return get_grid_wrapper<2>(object)->end();
                case 3: return get_grid_wrapper<3>(object)->end();
                case 4: return get_grid_wrapper<4>(object)->end();
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_select(SCM object, SCM indices) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->select(indices);
                case 2: return get_grid_wrapper<2>(object)->select(indices);
                case 3: return get_grid_wrapper<3>(object)->select(indices);
                case 4: return get_grid_wrapper<4>(object)->select(indices);
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_compact(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->compact();
                case 2: return get_grid_wrapper<2>(object)->compact();
                case 3: return get_grid_wrapper<3>(object)->compact();
                case 4: return get_grid_wrapper<4>(object)->compact();
            }
            return SCM_UNSPECIFIED;
        }

        SCM grid_to_string(SCM object) {
            scm_assert_foreign_object_type(::type, object);
            switch (get_dimensions(object)) {
                case 1: return get_grid_wrapper<1>(object)->to_string();
                case 2: return get_grid_wrapper<2>(object)->to_string();
                case 3: return get_grid_wrapper<3>(object)->to_string();
                case 4: return get_grid_wrapper<4>(object)->to_string();
            }
            return SCM_UNSPECIFIED;
        }

        void grid_define() {
            kw_min = scm_from_utf8_keyword("min");
            kw_max = scm_from_utf8_keyword("max");
            kw_npoints = scm_from_utf8_keyword("num-points");
            kw_nsegments = scm_from_utf8_keyword("num-segments");
            kw_begin_index = scm_from_utf8_keyword("begin-index");
            kw_end_index = scm_from_utf8_keyword("end-index");
            ::type = scm_make_foreign_object_type(
                scm_from_utf8_symbol("grid"),
                scm_list_2(scm_from_utf8_symbol("grid"), scm_from_utf8_symbol("dimensions")),
                nullptr);
            scm_c_define("<grid>", ::type);
            define_procedure("make-grid", 0, 0, 1, VTB_GUILE_1(make_grid));
            define_procedure("grid-min", 1, 0, 0, VTB_GUILE_1(grid_min));
            define_procedure("grid-max", 1, 0, 0, VTB_GUILE_1(grid_max));
            define_procedure("grid-begin-index", 1, 0, 0, VTB_GUILE_1(grid_begin_index));
            define_procedure("grid-end-index", 1, 0, 0, VTB_GUILE_1(grid_end_index));
            define_procedure("grid-select", 2, 0, 0, VTB_GUILE_2(grid_select));
            define_procedure("grid-compact!", 1, 0, 0, VTB_GUILE_1(grid_compact));
            define_procedure("grid->string", 1, 0, 0, VTB_GUILE_1(grid_to_string));
            scm_c_eval_string(grid_goops);
        }

    }

}

template <class T, int N> SCM
vtb::guile::grid_make(const vtb::core::Grid<T,N>& grid) {
    auto* wrapper = allocate_pointerless<Grid_wrapper<N>>("grid");
    wrapper->grid = grid;
    return scm_make_foreign_object_2(::type, wrapper, reinterpret_cast<void*>(size_t(N)));
}

template SCM
vtb::guile::grid_make<VTB_REAL_TYPE,1>(const vtb::core::Grid<VTB_REAL_TYPE,1>& grid);

template SCM
vtb::guile::grid_make<VTB_REAL_TYPE,2>(const vtb::core::Grid<VTB_REAL_TYPE,2>& grid);

template SCM
vtb::guile::grid_make<VTB_REAL_TYPE,3>(const vtb::core::Grid<VTB_REAL_TYPE,3>& grid);

template SCM
vtb::guile::grid_make<VTB_REAL_TYPE,4>(const vtb::core::Grid<VTB_REAL_TYPE,4>& grid);