mouse! fixes!

main.scm

@@ -45,6 +45,7 @@
     color))
 
 (define WHITE (color 255 255 255 255))
+(define BLACK (color 0 0 0 255))
 
 ;; (define c (color 1 2 3 4))
 ;; (display (list (color-r c) (color-g c) (color-b c) (color-a c)))
@@ -178,6 +179,35 @@
 	     (vector2 0 0)
 	     vs))
 
+; mouse
+(define is-mouse-button-pressed
+  (foreign-procedure #f "IsMouseButtonPressed" (int) boolean))
+(define is-mouse-button-down
+  (foreign-procedure #f "IsMouseButtonDown" (int) boolean))
+(define is-mouse-button-released
+  (foreign-procedure #f "IsMouseButtonReleased" (int) boolean))
+
+(define get-mouse-x
+  (foreign-procedure #f "GetMouseX" () int))
+(define get-mouse-y
+  (foreign-procedure #f "GetMouseY" () int))
+
+(define-syntax define-button-helper
+  (syntax-rules ()
+    [(_ name base)
+     (define (name button)
+       (case button
+	 ['left   (base 0)]
+	 ['middle (base 2)]
+	 ['right  (base 1)]
+	 [else (error name "unkown button type" button)]))]))
+
+(define-button-helper button-pressed?  is-mouse-button-pressed)
+(define-button-helper button-down?     is-mouse-button-down)
+(define-button-helper button-released? is-mouse-button-released)
+
+; might just not do questioning lol
+
 ; adapted from https://github.com/Yunoinsky/chez-raylib/blob/main/src/raylib.sls
 (define load-image
   (let ([f (foreign-procedure #f "LoadImage"
@@ -417,36 +447,6 @@
 	       segments
 	       (iota (length segments)))]))
 
-(define (redraw-skin skin)
-  ;; using the same color as the skin is deceptive
-  ;; (clear-background (color 0 0 255))
-  (for-each (lambda (n)
-	      (blit-number skin n (vector2 (* square-width n) 0)))
-	    (iota 9))
-  (for-each-skin-segment
-   square-types (square n)
-   (blit-square skin square (vector2 (* square-width n) square-width)))
-  (for-each-skin-segment
-   segments (seg n)
-   (blit-segment skin seg (vector2 (* n (+ segment-width gap))
-				   (add1 (* 2 square-width)))))
-  (for-each-skin-segment
-   smileys (smiley n)
-   (blit-smiley skin smiley (vector2 (* n (+ smiley-width gap))
-				     (+ square-width square-width gap segment-height gap))))
-  (blit-blank-display
-   skin
-   (vector2 blank-display-x
-	    last-y))
-  (blit-from-skin skin background-rect
-		  (vector2 (+ blank-display-x blank-display-width gap)
-			   last-y))
-  (for-each (lambda (t/r)
-	      (blit-border-piece skin (car t/r)
-				 (vector2 (rectangle-x (cdr t/r))
-					  (rectangle-y (cdr t/r)))))
-	    border-rects))
-
 (define-record-type square
   (fields (immutable mine?)
 	  (mutable num-adjacent)
@@ -490,7 +490,7 @@
 
 (define (game-square-at game x y)
   (vector-ref (game-squares game)
-	      (+ x (* y (game-height game)))))
+	      (+ x (* y (game-width game)))))
 
 ; preliminary
 (define (game-square-type-at game x y)
@@ -548,8 +548,58 @@
        (blit-square skin (game-square-type-at game x y) pos)))
    game))
 
-;; (define (square-mouse-over game)
+(define (square-mouse-over)
-;;   (cons (/ )))
+  (cons (floor (/ (get-mouse-x) square-width))
+	(floor (/ (get-mouse-y) square-width))))
+
+(define (draw-write obj x y size color)
+  (draw-text (with-output-to-string (lambda () (write obj)))
+	     x y size color))
+
+(define (redraw-skin skin)
+  ;; using the same color as the skin is deceptive
+  ;; (clear-background (color 0 0 255))
+  (for-each (lambda (n)
+	      (blit-number skin n (vector2 (* square-width n) 0)))
+	    (iota 9))
+  (for-each-skin-segment
+   square-types (square n)
+   (blit-square skin square (vector2 (* square-width n) square-width)))
+  (for-each-skin-segment
+   segments (seg n)
+   (blit-segment skin seg (vector2 (* n (+ segment-width gap))
+				   (add1 (* 2 square-width)))))
+  (for-each-skin-segment
+   smileys (smiley n)
+   (blit-smiley skin smiley (vector2 (* n (+ smiley-width gap))
+				     (+ square-width square-width gap segment-height gap))))
+  (blit-blank-display
+   skin
+   (vector2 blank-display-x
+	    last-y))
+  (blit-from-skin skin background-rect
+		  (vector2 (+ blank-display-x blank-display-width gap)
+			   last-y))
+  (for-each (lambda (t/r)
+	      (blit-border-piece skin (car t/r)
+				 (vector2 (rectangle-x (cdr t/r))
+					  (rectangle-y (cdr t/r)))))
+	    border-rects))
+
+(define (draw-mouse-info color)
+  (draw-write (square-mouse-over) 0 0 20 color)
+
+  (draw-write `(left down   . ,(button-down? 'left))   0 20 10 color)
+  (draw-write `(middle down . ,(button-down? 'middle)) 0 30 10 color)
+  (draw-write `(right down  . ,(button-down? 'right))  0 40 10 color)
+
+  (draw-write `(left pressed   . ,(button-pressed? 'left))   0 50 10 color)
+  (draw-write `(middle pressed . ,(button-pressed? 'middle)) 0 60 10 color)
+  (draw-write `(right pressed  . ,(button-pressed? 'right))  0 70 10 color)
+
+  (draw-write `(left released   . ,(button-released? 'left))   0 80  10 color)
+  (draw-write `(middle released . ,(button-released? 'middle)) 0 90  10 color)
+  (draw-write `(right released  . ,(button-released? 'right))  0 100 10 color))
 
 ; the game shows -99 when you (- num-mines num-flagged) is less than -99
 (define (run-game mines width height)
@@ -562,10 +612,11 @@
     ;; (newline)
 
 ; with the actual game, we almost certainly don't have to redraw everything every time
+; but we can afford it if laziness necessitates it
     (until (window-should-close?)
 	   (with-draw
 	    (draw-game-squares game skin (vector2 0 0))
-	    ))
+	    (draw-mouse-info WHITE)))
     (unload-texture skin)
     (close-window)))