diff --git a/main.scm b/main.scm index 37e7d80..d45810e 100644 --- a/main.scm +++ b/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) -;; (cons (/ ))) +(define (square-mouse-over) + (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) @@ -561,11 +611,12 @@ ;; (display skin) ;; (newline) - ; with the actual game, we almost certainly don't have to redraw everything every time +; 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)))