mbk/mineschemer
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

mouse! fixes!

Browse source
This commit is contained in:
mehbark 2023-12-23 19:44:32 -05:00
parent 7f42919cea
commit 0dcf703917
1 changed files with 86 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

121
main.scm
View file

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