summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--scripts/main.scm33
-rw-r--r--scripts/structs.scm79
-rw-r--r--scripts/utils.scm8
-rw-r--r--sources/core.h11
-rw-r--r--sources/main.c6
-rw-r--r--sources/shapes.h20
-rw-r--r--sources/text.h12
-rw-r--r--sources/types.h103
8 files changed, 259 insertions, 13 deletions
diff --git a/scripts/main.scm b/scripts/main.scm
index 2507424..0e98e7a 100644
--- a/scripts/main.scm
+++ b/scripts/main.scm
@@ -1,16 +1,33 @@
(load "./scripts/keys.scm")
+(load "./scripts/structs.scm")
+(load "./scripts/utils.scm")
+
+;; (define a 0)
+;; (define b (rl-load-texture))
+
+(define text-box (make-rect 30 180 250 80))
+(define mouse-on-text #f)
-(define a 0)
-(define b (rl-load-texture))
(define (update)
- (cond ((rl-is-key-down KEY_RIGHT) (set! b (rl-load-texture))) ;; right
- ((rl-is-key-down KEY_LEFT) (set! a (+ a 1))) ;; left
- ((rl-is-key-down KEY_DOWN) (gc)) ;; down
- )
+;; (cond ((rl-is-key-down KEY_RIGHT) (set! b (rl-load-texture))) ;; right
+;; ((rl-is-key-down KEY_LEFT) (set! a (+ a 1))) ;; left
+;; ((rl-is-key-down KEY_DOWN) (gc)) ;; down
+;; )
+;; (display (rl-get-mouse-position))
+;; (newline)
+
+ (define mouse-pos (rl-get-mouse-position))
+ (define mouse-pos-point (make-point (mouse-pos 0) (mouse-pos 1)))
+ (set! mouse-on-text (is-point-inside-rect? mouse-pos-point text-box))
+
+
+ #f
)
(define (draw)
- (rl-draw-text (number->string a))
- (rl-draw-texture b)
+ (rl-draw-rectangle (rect-x text-box) (rect-y text-box) (rect-width text-box) (rect-height text-box) (make-color 190 100 255))
+
+ (rl-draw-text (format #f "~A" mouse-on-text) 100 100 30 (make-color 100 100 100))
+ #f
)
diff --git a/scripts/structs.scm b/scripts/structs.scm
new file mode 100644
index 0000000..e6be071
--- /dev/null
+++ b/scripts/structs.scm
@@ -0,0 +1,79 @@
+;; ============================================================
+;; define defstruct macro
+(define-macro (defstruct struct-name . fields)
+ (let* ((name (if (list? struct-name) (car struct-name) struct-name))
+ (sname (if (string? name) name (symbol->string name)))
+
+ (fsname (if (list? struct-name)
+ (let ((cname (assoc :conc-name (cdr struct-name))))
+ (if cname
+ (symbol->string (cadr cname))
+ sname))
+ sname))
+
+ (make-name (if (list? struct-name)
+ (let ((cname (assoc :constructor (cdr struct-name))))
+ (if cname
+ (cadr cname)
+ (symbol "make-" sname)))
+ (symbol "make-" sname)))
+
+ (copy-name (if (list? struct-name)
+ (let ((cname (assoc :copier (cdr struct-name))))
+ (if cname
+ (cadr cname)
+ (symbol "copy-" sname)))
+ (symbol "copy-" sname)))
+
+ (field-names (map (lambda (n)
+ (symbol->string (if (list? n) (car n) n)))
+ fields))
+
+ (field-types (map (lambda (field)
+ (if (list? field)
+ (apply (lambda* (val type read-only) type) (cdr field))
+ #f))
+ fields))
+
+ (field-read-onlys (map (lambda (field)
+ (if (list? field)
+ (apply (lambda* (val type read-only) read-only) (cdr field))
+ #f))
+ fields)))
+
+ `(begin
+ (define ,(symbol sname "?")
+ (lambda (obj)
+ (and (vector? obj)
+ (eq? (obj 0) ',(string->symbol sname)))))
+
+ (define* (,make-name
+ ,@(map (lambda (n)
+ (if (and (list? n)
+ (>= (length n) 2))
+ (list (car n) (cadr n))
+ (list n #f)))
+ fields))
+ (vector ',(string->symbol sname) ,@(map string->symbol field-names)))
+
+ (define ,copy-name copy)
+
+ ,@(map (let ((ctr 1))
+ (lambda (n type read-only)
+ (let ((val (if read-only
+ `(define ,(symbol fsname "-" n)
+ (lambda (arg) (arg ,ctr)))
+ `(define ,(symbol fsname "-" n)
+ (dilambda
+ (lambda (arg) (arg ,ctr))
+ (lambda (arg val) (set! (arg ,ctr) val)))))))
+ (set! ctr (+ 1 ctr))
+ val)))
+ field-names field-types field-read-onlys))))
+
+
+;; ============================================================
+;; Structures
+
+(defstruct rect (x 0.0) (y 0.0) (width 0.0) (height 0.0))
+(defstruct point (x 0.0) (y 0.0))
diff --git a/scripts/utils.scm b/scripts/utils.scm
new file mode 100644
index 0000000..3348075
--- /dev/null
+++ b/scripts/utils.scm
@@ -0,0 +1,8 @@
+(define (is-point-inside-rect? point rect)
+ (cond ((not (point? point)) #f)
+ ((not (rect? rect)) #f)
+ (else (and (>= (point-x point) (rect-x rect))
+ (>= (point-y point) (rect-y rect))
+ (<= (point-x point) (+ (rect-x rect) (rect-width rect)))
+ (<= (point-y point) (+ (rect-y rect) (rect-height rect))))
+ )))
diff --git a/sources/core.h b/sources/core.h
index 7e387de..70a7d81 100644
--- a/sources/core.h
+++ b/sources/core.h
@@ -3,6 +3,14 @@
#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);
@@ -10,5 +18,6 @@ static s7_pointer rl_is_key_down(s7_scheme *s7, s7_pointer args) {
}
static void rl_core_define_methods(s7_scheme *s7) {
- s7_define_function(s7, "rl-is-key-down", rl_is_key_down, 1, 0, false, "test");
+ 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)");
}
diff --git a/sources/main.c b/sources/main.c
index 5086080..5556460 100644
--- a/sources/main.c
+++ b/sources/main.c
@@ -5,9 +5,11 @@
#include "raylib.h"
#include "s7.h"
+#include "types.h"
#include "text.h"
#include "texture.h"
#include "core.h"
+#include "shapes.h"
#include <math.h>
#include <stdio.h>
@@ -41,10 +43,12 @@ void main_loop(){
int main(int argc, char* argv[]) {
s7 = s7_init();
-
+
+ rl_register_types(s7);
rl_text_define_methods(s7);
rl_texture_define_methods(s7);
rl_core_define_methods(s7);
+ rl_shapes_define_methods(s7);
const int screen_width = 800;
const int screen_height = 600;
diff --git a/sources/shapes.h b/sources/shapes.h
new file mode 100644
index 0000000..dc73011
--- /dev/null
+++ b/sources/shapes.h
@@ -0,0 +1,20 @@
+#include "raylib.h"
+#include "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/text.h b/sources/text.h
index a0e3497..0759d2f 100644
--- a/sources/text.h
+++ b/sources/text.h
@@ -4,11 +4,17 @@
#include <stdlib.h>
static s7_pointer rl_draw_text(s7_scheme *s7, s7_pointer args) {
- printf("%s\n", s7_string(s7_car(args)));
- DrawText(s7_string(s7_car(args)), 200, 80, 20, RED);
+ 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, 1, 0, false, "test");
+ s7_define_function(s7, "rl-draw-text", rl_draw_text, 5, 0, false, "test");
}
diff --git a/sources/types.h b/sources/types.h
new file mode 100644
index 0000000..7f8acc4
--- /dev/null
+++ b/sources/types.h
@@ -0,0 +1,103 @@
+#include "raylib.h"
+#include "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"));
+}
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 09:55:16 +0000