diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/main.scm | 33 | ||||
| -rw-r--r-- | scripts/structs.scm | 79 | ||||
| -rw-r--r-- | scripts/utils.scm | 8 |
3 files changed, 112 insertions, 8 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)))) + ))) |