guile/testbed.cc

#include <vtestbed/config/real_type.hh>
#include <vtestbed/core/ship.hh>
#include <vtestbed/core/testbed.hh>
#include <vtestbed/guile/grid.hh>
#include <vtestbed/guile/macros.hh>
#include <vtestbed/guile/traits.hh>

using object_type = vtb::core::Testbed<VTB_REAL_TYPE,3>;
using traits_type = vtb::guile::Traits<object_type>;
using ship_type = vtb::core::Ship<VTB_REAL_TYPE>;
using ship_traits = vtb::guile::Traits<ship_type>;
using wave_generator_type =
    std::unique_ptr<vtb::core::Wavy_surface_generator<VTB_REAL_TYPE,3>>;

namespace {
    SCM type;
    SCM kw_policy, kw_ship, kw_wave_generator;
    SCM sym_opencl, sym_openmp;
}

namespace vtb {

    namespace guile {

        template <> SCM traits_type::type() { return ::type; }

        SCM make_testbed(SCM rest) {
            auto* wrapper = make_wrapper<object_type>();
            SCM policy = sym_opencl, ship = SCM_UNDEFINED, wave_generator = SCM_UNDEFINED;
            scm_c_bind_keyword_arguments("make-testbed", rest,
                                         scm_t_keyword_arguments_flags{},
                                         kw_policy, &policy, kw_ship, &ship,
                                         kw_wave_generator, &wave_generator,
                                         SCM_UNDEFINED);
            if (symbol_equal(policy, sym_opencl)) { wrapper->get()->opencl_solvers(); }
            else if (symbol_equal(policy, sym_openmp)) { wrapper->get()->openmp_solvers(); }
            else { throw_error("bad policy"); return SCM_UNSPECIFIED; }
            if (is_bound(ship)) {
                auto* w = get_wrapper<ship_type>(ship);
                wrapper->get()->ship(*w->get());
            }
            if (is_bound(wave_generator)) {
                auto* w = get_wrapper<wave_generator_type>(wave_generator);
                wrapper->get()->wavy_surface_generator(std::move(w->get()));
            }
            return make_object<object_type>(traits_type::type(), wrapper);
        }

        SCM testbed_policy(SCM object, SCM policy) {
            auto* self = get_object<object_type>(object);
            if (symbol_equal(policy, sym_opencl)) { self->opencl_solvers(); }
            else if (symbol_equal(policy, sym_openmp)) { self->openmp_solvers(); }
            else { throw_error("bad policy"); return SCM_UNSPECIFIED; }
            return SCM_UNSPECIFIED;
        }

        SCM testbed_step(SCM object, SCM dt) {
            get_object<object_type>(object)->step(scm_to_double(dt));
            return SCM_UNSPECIFIED;
        }

        SCM testbed_reset(SCM object) {
            get_object<object_type>(object)->reset();
            return SCM_UNSPECIFIED;
        }

        SCM testbed_time_instant(SCM object) {
            return to_scm(get_object<object_type>(object)->time_instant());
        }

        SCM testbed_grid(SCM object) {
            return grid_make(get_object<object_type>(object)->grid());
        }

        template <> void
        traits_type::define() {
            kw_policy = scm_from_utf8_keyword("policy");
            kw_ship = scm_from_utf8_keyword("ship");
            kw_wave_generator = scm_from_utf8_keyword("wave-generator");
            sym_opencl = scm_from_utf8_symbol("opencl");
            sym_openmp = scm_from_utf8_symbol("openmp");
            ::type = define_type<object_type>("<virtual-testbed>");
            define_procedure("make-testbed", 0, 0, 1,
                             VTB_GUILE_1(make_testbed));
            define_procedure("testbed-policy", 2, 0, 0, VTB_GUILE_2(testbed_policy));
            define_procedure("testbed-step", 2, 0, 0, VTB_GUILE_2(testbed_step));
            define_procedure("testbed-time-instant", 1, 0, 0,
                             VTB_GUILE_1(testbed_time_instant));
            define_procedure("testbed-reset!", 1, 0, 0, VTB_GUILE_1(testbed_reset));
            define_procedure("testbed-grid", 1, 0, 0, VTB_GUILE_1(testbed_grid));
        }

    }

}