mouse! fixes!
This commit is contained in:
parent
7f42919cea
commit
0dcf703917
1 changed files with 86 additions and 35 deletions
119
main.scm
119
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)
|
||||
|
@ -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)))
|
||||
|
||||
|
|
Loading…
Reference in a new issue