(wip) Basic textbox API

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))))
+	      )))