Creating small evaluation prompt

5 files changed, 207 insertions, 0 deletions

diff --git a/sources/rl/core.h b/sources/rl/core.h
new file mode 100644
index 0000000..09c5555
--- /dev/null
+++ b/sources/rl/core.h
@@ -0,0 +1,35 @@
+#include "raylib.h"
+#include "s7/s7.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+static s7_pointer rl_get_mouse_position(s7_scheme *s7, s7_pointer args) {  
+  Vector2 mouse_pos = GetMousePosition();
+  s7_pointer vec = s7_make_float_vector(s7, 2, 1, NULL);
+  s7_vector_set(s7, vec, 0, s7_make_real(s7, mouse_pos.x));
+  s7_vector_set(s7, vec, 1, s7_make_real(s7, mouse_pos.y));
+  return vec;
+}
+
+static s7_pointer rl_is_key_down(s7_scheme *s7, s7_pointer args) {
+  int key = s7_integer(s7_car(args));
+  bool isKey = IsKeyDown(key);
+  return(s7_make_boolean(s7, isKey));
+}
+
+static s7_pointer rl_get_char_pressed(s7_scheme *s7, s7_pointer args) {
+  int key = GetCharPressed();
+  return(s7_make_integer(s7, key));
+}
+
+static s7_pointer rl_get_key_pressed(s7_scheme *s7, s7_pointer args) {
+  int key = GetKeyPressed();
+  return(s7_make_integer(s7, key));
+}
+
+static void rl_core_define_methods(s7_scheme *s7) {
+  s7_define_function(s7, "rl-is-key-down", rl_is_key_down, 1, 0, false, "(rl-is-key-down KEY)");
+  s7_define_function(s7, "rl-get-mouse-position", rl_get_mouse_position, 0, 0, false, "(rl-get-mouse-position)");
+  s7_define_function(s7, "rl-get-char-pressed", rl_get_char_pressed, 0, 0, false, "(rl-get-char-pressed)");
+  s7_define_function(s7, "rl-get-key-pressed", rl_get_key_pressed, 0, 0, false, "(rl-get-key-pressed)");
+}
diff --git a/sources/rl/shapes.h b/sources/rl/shapes.h
new file mode 100644
index 0000000..0033a5b
--- /dev/null
+++ b/sources/rl/shapes.h
@@ -0,0 +1,20 @@
+#include "raylib.h"
+#include "s7/s7.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+static s7_pointer rl_draw_rectangle(s7_scheme *s7, s7_pointer args) {
+  Color *c = (Color *)s7_c_object_value(s7_car(s7_cdr(s7_cdr(s7_cdr(s7_cdr(args))))));
+  
+  DrawRectangle(s7_integer(s7_car(args)),
+		s7_integer(s7_car(s7_cdr(args))),
+		s7_integer(s7_car(s7_cdr(s7_cdr(args)))),
+		s7_integer(s7_car(s7_cdr(s7_cdr(s7_cdr(args))))),
+		*c);
+
+  return(NULL);
+}
+
+static void rl_shapes_define_methods(s7_scheme *s7) {
+  s7_define_function(s7, "rl-draw-rectangle", rl_draw_rectangle, 5, 0, false, "test");
+}
diff --git a/sources/rl/text.h b/sources/rl/text.h
new file mode 100644
index 0000000..6fd53e2
--- /dev/null
+++ b/sources/rl/text.h
@@ -0,0 +1,20 @@
+#include "raylib.h"
+#include "s7/s7.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+static s7_pointer rl_draw_text(s7_scheme *s7, s7_pointer args) {
+  Color *c = (Color *)s7_c_object_value(s7_car(s7_cddddr(args)));
+  
+  DrawText(s7_string(s7_car(args)),
+	   s7_integer(s7_cadr(args)),
+	   s7_integer(s7_caddr(args)),
+	   s7_integer(s7_cadddr(args)),
+	   *c);
+  
+  return(NULL);
+}
+
+static void rl_text_define_methods(s7_scheme *s7) {
+  s7_define_function(s7, "rl-draw-text", rl_draw_text, 5, 0, false, "test");
+}
diff --git a/sources/rl/texture.h b/sources/rl/texture.h
new file mode 100644
index 0000000..8dfb996
--- /dev/null
+++ b/sources/rl/texture.h
@@ -0,0 +1,29 @@
+int texture_2d_tag;
+
+static s7_pointer free_texture_2d(s7_scheme *s7, s7_pointer obj) {
+  Texture2D *texture = (Texture2D *) s7_c_object_value(obj);
+  UnloadTexture(*texture);
+  free(texture);
+  return(NULL);
+}
+
+static s7_pointer rl_draw_texture(s7_scheme *s7, s7_pointer args) {
+  Texture2D *texture = (Texture2D *) s7_c_object_value(s7_car(args));
+  DrawTexture(*texture, 100, 100, WHITE);
+  return(NULL);
+}
+
+static s7_pointer rl_load_texture(s7_scheme *s7, s7_pointer args) {
+  Texture2D texture = LoadTexture("./assets/test.png");
+  Texture2D *texture_ptr = (Texture2D *) malloc(sizeof(Texture2D));
+  *texture_ptr = texture;
+  return (s7_make_c_object(s7, texture_2d_tag, (void *) texture_ptr));
+}
+
+static void rl_texture_define_methods(s7_scheme *s7) {
+  s7_define_function(s7, "rl-load-texture", rl_load_texture, 0, 0, false, "test");
+  s7_define_function(s7, "rl-draw-texture", rl_draw_texture, 1, 0, false, "test");
+  
+  texture_2d_tag = s7_make_c_type(s7, "texture-2d");
+  s7_c_type_set_gc_free(s7, texture_2d_tag, free_texture_2d);
+}
diff --git a/sources/rl/types.h b/sources/rl/types.h
new file mode 100644
index 0000000..4a7244f
--- /dev/null
+++ b/sources/rl/types.h
@@ -0,0 +1,103 @@
+#include "raylib.h"
+#include "s7/s7.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+// ======================================
+// Color
+
+static int color_type_tag = 0;
+
+static s7_pointer free_color(s7_scheme *sc, s7_pointer obj)
+{
+  free(s7_c_object_value(obj));
+  return(NULL);
+}
+
+static s7_pointer make_color(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)malloc(sizeof(Color));
+
+  c->r = s7_integer(s7_car(args));
+  c->g = s7_integer(s7_cadr(args));
+  c->b = s7_integer(s7_caddr(args));
+  c->a = 255;
+  
+  return(s7_make_c_object(sc, color_type_tag, (void *)c));
+}
+
+static s7_pointer color_to_string(s7_scheme *sc, s7_pointer args)
+{
+  s7_pointer result;
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  char *str = (char *)calloc(32, sizeof(char));
+  snprintf(str, 32, "<color %d %d %d>", c->r, c->g, c->b);
+  result = s7_make_string(sc, str);
+  free(str);
+  return(result);
+}
+
+static s7_pointer is_color(s7_scheme *sc, s7_pointer args)
+{
+  return(s7_make_boolean(sc, 
+			 s7_is_c_object(s7_car(args)) &&
+			 s7_c_object_type(s7_car(args)) == color_type_tag));
+}
+
+static s7_pointer color_r(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  return(s7_make_integer(sc, c->r));
+}
+
+static s7_pointer set_color_r(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  c->r = s7_integer(s7_cadr(args));
+  return(s7_cadr(args));
+}
+
+static s7_pointer color_g(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  return(s7_make_integer(sc, c->g));
+}
+
+static s7_pointer set_color_g(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  c->g = s7_integer(s7_cadr(args));
+  return(s7_cadr(args));
+}
+
+static s7_pointer color_b(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  return(s7_make_integer(sc, c->b));
+}
+
+static s7_pointer set_color_b(s7_scheme *sc, s7_pointer args)
+{
+  Color *c = (Color *)s7_c_object_value(s7_car(args));
+  c->b = s7_integer(s7_cadr(args));
+  return(s7_cadr(args));
+}
+
+
+
+// ======================================
+
+static void rl_register_types(s7_scheme *s7) {
+  color_type_tag = s7_make_c_type(s7, "color");
+  s7_c_type_set_gc_free(s7, color_type_tag, free_color);
+  s7_c_type_set_to_string(s7, color_type_tag, color_to_string);
+  
+  s7_define_function(s7, "make-color", make_color, 3, 0, false, "(make-color r g b) makes a new color");
+  
+  s7_define_function(s7, "color?", is_color, 1, 0, false, "(color? anything) returns #t if its argument is a color object");
+
+  s7_define_variable(s7, "color-r", s7_dilambda(s7, "color-r", color_r, 1, 0, set_color_r, 2, 0, "color r field"));
+  s7_define_variable(s7, "color-g", s7_dilambda(s7, "color-g", color_g, 1, 0, set_color_g, 2, 0, "color g field"));
+  s7_define_variable(s7, "color-b", s7_dilambda(s7, "color-b", color_b, 1, 0, set_color_b, 2, 0, "color b field"));
+}
+