746 lines
23 KiB
Scheme
746 lines
23 KiB
Scheme
#!r6rs
|
|
; main thing i'd like to do is be compatible with these:
|
|
; https://www.mzrg.com/mines/msx/index.html
|
|
; let's do about the minimum to do what i want
|
|
; keep the names almost exactly the same for googling's sake
|
|
(load-shared-object "libraylib.so")
|
|
|
|
; color
|
|
(define-ftype Color
|
|
(struct
|
|
[r unsigned-8]
|
|
[g unsigned-8]
|
|
[b unsigned-8]
|
|
[a unsigned-8]))
|
|
|
|
(define (set-color-r! color r) (ftype-set! Color (r) color r))
|
|
(define (set-color-g! color g) (ftype-set! Color (g) color g))
|
|
(define (set-color-b! color b) (ftype-set! Color (b) color b))
|
|
(define (set-color-a! color a) (ftype-set! Color (a) color a))
|
|
|
|
(define (color-r color) (ftype-ref Color (r) color))
|
|
(define (color-g color) (ftype-ref Color (g) color))
|
|
(define (color-b color) (ftype-ref Color (b) color))
|
|
(define (color-a color) (ftype-ref Color (a) color))
|
|
|
|
(define (color-components c) (list (color-r c) (color-g c) (color-b c) (color-a c)))
|
|
|
|
(define color
|
|
(case-lambda
|
|
[(r g b) (color r g b 255)]
|
|
[(r g b a)
|
|
(define c (make-ftype-pointer Color (foreign-alloc (ftype-sizeof Color))))
|
|
(set-color-r! c r)
|
|
(set-color-g! c g)
|
|
(set-color-b! c b)
|
|
(set-color-a! c a)
|
|
c]))
|
|
|
|
(define color-from-hsv-inner
|
|
(foreign-procedure #f "ColorFromHSV" (float float float) (& Color)))
|
|
(define (color-from-hsv h s v)
|
|
(let ([color (make-ftype-pointer Color (foreign-alloc (ftype-sizeof Color)))])
|
|
(color-from-hsv-inner color h s v)
|
|
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)))
|
|
|
|
; window
|
|
(define init-window
|
|
(foreign-procedure #f "InitWindow" (int int string) void))
|
|
|
|
(define close-window
|
|
(foreign-procedure #f "CloseWindow" () void))
|
|
|
|
(define window-should-close?
|
|
(foreign-procedure #f "WindowShouldClose" () boolean))
|
|
|
|
; drawing
|
|
(define clear-background
|
|
(foreign-procedure #f "ClearBackground" ((& Color)) void))
|
|
|
|
(define begin-drawing
|
|
(foreign-procedure #f "BeginDrawing" () void))
|
|
|
|
(define end-drawing
|
|
; doesn't help, but i'm pretty sure this *is* collect safe
|
|
(foreign-procedure __collect_safe "EndDrawing" () void))
|
|
|
|
; timing
|
|
(define set-target-fps
|
|
(foreign-procedure #f "SetTargetFPS" (int) void))
|
|
|
|
(define get-frame-time
|
|
(foreign-procedure #f "GetFrameTime" () float))
|
|
|
|
(define get-time
|
|
(foreign-procedure #f "GetTime" () double))
|
|
|
|
(define get-fps
|
|
(foreign-procedure #f "GetFPS" () int))
|
|
|
|
; filesystem
|
|
|
|
(define get-working-directory
|
|
(foreign-procedure #f "GetWorkingDirectory" () string))
|
|
|
|
(define get-application-directory
|
|
(foreign-procedure #f "GetApplicationDirectory" () string))
|
|
|
|
(define change-directory
|
|
(foreign-procedure #f "ChangeDirectory" (string) boolean))
|
|
|
|
; text
|
|
|
|
(define draw-fps
|
|
(foreign-procedure #f "DrawFPS" (int int) void))
|
|
|
|
(define draw-text
|
|
(foreign-procedure #f "DrawText" (string int int int (& Color)) void))
|
|
|
|
; texture
|
|
|
|
; shouldn't really need to use these structs, just pass them around
|
|
; which is what we could use void* for... oops.
|
|
(define-ftype Image
|
|
(struct
|
|
[data void*]
|
|
[width int]
|
|
[height int]
|
|
[mipmaps int]
|
|
[format int]))
|
|
|
|
(define-ftype Texture
|
|
(struct
|
|
[id unsigned]
|
|
[width int]
|
|
[height int]
|
|
[mipmaps int]
|
|
[format int]))
|
|
|
|
(define-ftype Texture2D Texture)
|
|
|
|
; really need this one though
|
|
(define-ftype Rectangle
|
|
(struct
|
|
[x float]
|
|
[y float]
|
|
[width float]
|
|
[height float]))
|
|
|
|
(define (set-rectangle-x! rect x) (ftype-set! Rectangle (x) rect (exact->inexact x)))
|
|
(define (set-rectangle-y! rect y) (ftype-set! Rectangle (y) rect (exact->inexact y)))
|
|
(define (set-rectangle-width! rect width) (ftype-set! Rectangle (width) rect (exact->inexact width)))
|
|
(define (set-rectangle-height! rect height) (ftype-set! Rectangle (height) rect (exact->inexact height)))
|
|
|
|
(define (rectangle-x rect) (ftype-ref Rectangle (x) rect))
|
|
(define (rectangle-y rect) (ftype-ref Rectangle (y) rect))
|
|
|
|
(define rectangle
|
|
(case-lambda
|
|
[(x y width) (rectangle x y width width)]
|
|
[(x y width height)
|
|
(define rect (make-ftype-pointer Rectangle (foreign-alloc (ftype-sizeof Rectangle))))
|
|
(set-rectangle-x! rect x)
|
|
(set-rectangle-y! rect y)
|
|
(set-rectangle-width! rect width)
|
|
(set-rectangle-height! rect height)
|
|
rect]))
|
|
|
|
(define-ftype Vector2
|
|
(struct
|
|
[x float]
|
|
[y float]))
|
|
|
|
(define (set-vector2-x! vec2 x) (ftype-set! Vector2 (x) vec2 (exact->inexact x)))
|
|
(define (set-vector2-y! vec2 y) (ftype-set! Vector2 (y) vec2 (exact->inexact y)))
|
|
|
|
(define (vector2-x vec2) (ftype-ref Vector2 (x) vec2))
|
|
(define (vector2-y vec2) (ftype-ref Vector2 (y) vec2))
|
|
|
|
(define (vector2 x y)
|
|
(define vec2 (make-ftype-pointer Vector2 (foreign-alloc (ftype-sizeof Vector2))))
|
|
(set-vector2-x! vec2 x)
|
|
(set-vector2-y! vec2 y)
|
|
vec2)
|
|
|
|
(define (vector2+-bin a b)
|
|
(vector2 (+ (vector2-x a)
|
|
(vector2-x b))
|
|
(+ (vector2-y a)
|
|
(vector2-y b))))
|
|
(define vector2-origin (vector2 0 0))
|
|
|
|
(define (vector2+ . vs)
|
|
(fold-left vector2+-bin
|
|
vector2-origin
|
|
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"
|
|
(string)
|
|
(& Image))])
|
|
(case-lambda
|
|
[(file-name)
|
|
(let ([ret (make-ftype-pointer
|
|
Image
|
|
(foreign-alloc (ftype-sizeof Image)))])
|
|
(f ret file-name)
|
|
ret)]
|
|
[(struct file-name) (f struct file-name) struct])))
|
|
|
|
(define load-texture
|
|
(let ([f (foreign-procedure #f "LoadTexture"
|
|
(string)
|
|
(& Texture))])
|
|
(case-lambda
|
|
[(file-name)
|
|
(let ([ret (make-ftype-pointer
|
|
Texture
|
|
(foreign-alloc (ftype-sizeof Texture)))])
|
|
(f ret file-name)
|
|
ret)]
|
|
[(struct file-name) (f struct file-name) struct])))
|
|
|
|
(define unload-texture
|
|
(foreign-procedure #f "UnloadTexture" ((& Texture2D)) void))
|
|
|
|
(define draw-texture-rec
|
|
(foreign-procedure #f "DrawTextureRec" ((& Texture2D) (& Rectangle) (& Vector2) (& Color)) void))
|
|
|
|
(define draw-texture-pro
|
|
(foreign-procedure #f "DrawTexturePro"
|
|
((& Texture2D) (& Rectangle) (& Rectangle) (& Vector2) float (& Color))
|
|
void))
|
|
|
|
; we only really need the rec version
|
|
|
|
(define (draw-texture-nice texture src dest)
|
|
(draw-texture-pro texture src rect (vector2 0.0 0.0) 0.0 WHITE))
|
|
|
|
; scheme magicks
|
|
|
|
(define-syntax with-draw
|
|
(syntax-rules ()
|
|
[(_ body ...)
|
|
(begin (begin-drawing)
|
|
body ...
|
|
(end-drawing))]))
|
|
|
|
(define-syntax while
|
|
(syntax-rules ()
|
|
[(_ test body ...)
|
|
(do []
|
|
[(not test) #f]
|
|
body ...)]))
|
|
|
|
(define-syntax until
|
|
(syntax-rules ()
|
|
[(_ test body ...)
|
|
(do []
|
|
[test #f]
|
|
body ...)]))
|
|
|
|
; my stuff :]
|
|
|
|
(define *skin-paths* '("./skins" "."))
|
|
; a global var for skin would probably be worthwhile but idk
|
|
; could also just be lazy and open the game, draw, screenshot, close
|
|
|
|
; could be fun to do weird stuff with skins (randomly choosing, &c)
|
|
|
|
(define (load-skin filename)
|
|
(define path
|
|
(find file-exists?
|
|
(map (lambda (p) (string-append p "/" filename))
|
|
*skin-paths*)))
|
|
(unless path
|
|
(error
|
|
'load-skin
|
|
(string-append
|
|
"failed to load `" filename "`. tried paths "
|
|
(with-output-to-string (lambda () (write *skin-paths*))))))
|
|
(load-texture path))
|
|
|
|
(define skin-width 144)
|
|
(define skin-height 122)
|
|
|
|
(define square-width (/ skin-width 9))
|
|
|
|
(define number-rects
|
|
(list->vector
|
|
; the bottom and right sides are 1 pixel shy, it works out
|
|
(map (lambda (n)
|
|
(rectangle (* n square-width) 0 square-width square-width))
|
|
(iota 9))))
|
|
|
|
(define square-types '(unknown pressed mine flag no-mine pressed-mine question pressed-question))
|
|
|
|
(define-syntax make-rects
|
|
(syntax-rules ()
|
|
[(_ types (type n) body ...)
|
|
(map (lambda (type n)
|
|
(cons type (begin body ...)))
|
|
types
|
|
(iota (length types)))]))
|
|
|
|
(define square-rects
|
|
(make-rects square-types (type n)
|
|
(rectangle (* n square-width) square-width square-width square-width)))
|
|
|
|
(define gap (* 1/144 skin-width))
|
|
(define segment-end (* 13/144 skin-width))
|
|
(define segments '(0 1 2 3 4 5 6 7 8 9 -))
|
|
|
|
(define segment-width (/ (- skin-width (+ (* (sub1 (length segments)) gap) segment-end)) (length segments)))
|
|
(define segment-height (* 21/11 segment-width))
|
|
|
|
(define segment-rects
|
|
(make-rects segments (seg n)
|
|
(rectangle (* n (+ segment-width gap))
|
|
(add1 (* 2 square-width))
|
|
segment-width
|
|
segment-height)))
|
|
|
|
(define smileys-end (* 10/144 skin-width))
|
|
(define smileys '(happy surprised dead cool pressed))
|
|
(define smiley-width (/ (- skin-width (* (sub1 (length smileys)) gap) smileys-end)
|
|
(length smileys)))
|
|
|
|
(define smiley-rects
|
|
(make-rects smileys (smiley n)
|
|
(rectangle (* n (+ smiley-width gap)) (+ (* 2 square-width) gap segment-height gap)
|
|
smiley-width smiley-width)))
|
|
|
|
; we'll want the pro blitting to stretch stuff out efficiently
|
|
(define border-width (/ skin-width 12))
|
|
(define border-height (- border-width gap))
|
|
|
|
(define last-y (+ square-width square-width gap segment-height gap smiley-width gap))
|
|
|
|
(define border-corner-size (cons border-width border-height))
|
|
(define border-vertical-size (cons gap border-height))
|
|
(define border-horizontal-size (cons border-width gap))
|
|
|
|
; this seems like a good enough compromise
|
|
(define (make-rects y base)
|
|
(map
|
|
(lambda (t/r)
|
|
(cons (car t/r)
|
|
(rectangle
|
|
(cadr t/r)
|
|
y
|
|
(caddr t/r)
|
|
(cdddr t/r))))
|
|
base))
|
|
|
|
(define border-rects
|
|
(append
|
|
(make-rects
|
|
last-y
|
|
`((top-left . (0 . ,border-corner-size))
|
|
(top . (,(+ border-width gap) . ,border-vertical-size))
|
|
(top-right . (,(+ border-width gap gap gap) . ,border-corner-size))))
|
|
(make-rects
|
|
(+ last-y border-height gap)
|
|
`((down-left-1 . (0 . ,border-horizontal-size))
|
|
(down-right-1 . (,(+ border-width gap gap gap) . ,border-horizontal-size))))
|
|
(make-rects
|
|
(+ last-y border-height gap gap gap)
|
|
`((mid-left . (0 . ,border-corner-size))
|
|
(mid . (,(+ border-width gap) . ,border-vertical-size))
|
|
(mid-right . (,(+ border-width gap gap gap) . ,border-corner-size))))
|
|
(make-rects
|
|
(+ last-y border-height gap gap gap border-height gap)
|
|
`((down-left-2 . (0 . ,border-horizontal-size))
|
|
(down-right-2 . (,(+ border-width gap gap gap) . ,border-horizontal-size))))
|
|
(make-rects
|
|
(+ last-y border-height gap gap gap border-height gap gap gap)
|
|
`((bottom-left . (0 . ,border-corner-size))
|
|
(bottom . (,(+ border-width gap) . ,border-vertical-size))
|
|
(bottom-right . (,(+ border-width gap gap gap) . ,border-corner-size))))))
|
|
|
|
(define blank-display-width (* 41/144 skin-width))
|
|
(define blank-display-height (* 25/121 skin-height))
|
|
|
|
(define blank-display-x (+ border-width gap gap gap border-width gap))
|
|
|
|
(define blank-display-rect
|
|
(rectangle blank-display-x
|
|
last-y
|
|
blank-display-width
|
|
blank-display-height))
|
|
|
|
; we'll want a draw background func, we are NOT blitting one pixel at a time lol
|
|
; we could also just test the color of this
|
|
(define background-rect
|
|
(rectangle (+ blank-display-x blank-display-width gap)
|
|
last-y
|
|
gap
|
|
gap))
|
|
|
|
(define (blit-from-skin skin rect pos)
|
|
;; (display skin) (display " ") (display rect) (display " ") (display pos)
|
|
;; (newline)
|
|
(draw-texture-rec skin rect pos WHITE)
|
|
;; (random-seed (* 1000 (add1 (inexact->exact (+ (rectangle-x rect) (rectangle-y rect))))))
|
|
#; (draw-texture-rec skin rect (vector2+ pos (vector2 (* (random 8) (sin *t*)) (* (random 8) (cos *t*)))) WHITE))
|
|
|
|
(define (blit-number skin n pos)
|
|
(let ([rect (vector-ref number-rects n)])
|
|
(blit-from-skin skin rect pos)))
|
|
|
|
(define (blit-square skin square pos)
|
|
(if (number? square)
|
|
(blit-number skin square pos)
|
|
(blit-from-skin skin (cdr (assq square square-rects)) pos)))
|
|
|
|
(define (blit-segment skin seg pos)
|
|
(blit-from-skin skin (cdr (assq seg segment-rects)) pos))
|
|
|
|
(define (blit-smiley skin smiley pos)
|
|
(blit-from-skin skin (cdr (assq smiley smiley-rects)) pos))
|
|
|
|
(define (blit-border-piece skin border pos)
|
|
(blit-from-skin skin (cdr (assq border border-rects)) pos))
|
|
|
|
(define (blit-blank-display skin pos)
|
|
(blit-from-skin skin blank-display-rect pos))
|
|
|
|
(define-syntax for-each-skin-segment
|
|
(syntax-rules ()
|
|
[(_ segments (seg n) body ...)
|
|
(for-each (lambda (seg n) body ...)
|
|
segments
|
|
(iota (length segments)))]))
|
|
|
|
(define-record-type square
|
|
(fields (immutable mine?)
|
|
(mutable num-adjacent)
|
|
(mutable flagged?)
|
|
(mutable questioned?)
|
|
(mutable revealed?)))
|
|
|
|
(define (vector-swap! vec i1 i2)
|
|
(unless (= i1 i2)
|
|
(let ([x1 (vector-ref vec i1)]
|
|
[x2 (vector-ref vec i2)])
|
|
(vector-set! vec i1 x2)
|
|
(vector-set! vec i2 x1))))
|
|
|
|
(define (vector-shuffle! vec)
|
|
(for-each (lambda (i1)
|
|
(vector-swap! vec i1 (random (add1 i1))))
|
|
(reverse (iota (vector-length vec))))
|
|
vec)
|
|
|
|
(define (vector-shuffle vec)
|
|
(define out (vector-copy vec))
|
|
(vector-shuffle! out))
|
|
|
|
#;
|
|
(map (lambda (_) (apply string-append (map symbol->string (vector->list (vector-shuffle '#(e l v i s))))))
|
|
(iota 200))
|
|
|
|
(define (list-shuffle list)
|
|
(vector->list (vector-shuffle! (list->vector list))))
|
|
|
|
(define (base-square) (make-square #f #f #f #f #f))
|
|
|
|
(define (make-squares n mine?)
|
|
(map (lambda (_) (make-square mine? #f #f #f #f))
|
|
(iota n)))
|
|
|
|
(define-record-type game (fields squares width height num-mines (mutable num-flagged) (mutable over?)))
|
|
|
|
;unknown pressed mine flag no-mine pressed-mine question pressed-question
|
|
|
|
(define (game-square-at game x y)
|
|
(vector-ref (game-squares game)
|
|
(+ x (* y (game-width game)))))
|
|
|
|
(define (vector2-adjacent? a b)
|
|
(and (<= (abs (- (vector2-x a) (vector2-x b))) 1)
|
|
(<= (abs (- (vector2-y a) (vector2-y b))) 1)))
|
|
|
|
(define (pair-adjacent? a b)
|
|
(and (<= (abs (- (car a) (car b))) 1)
|
|
(<= (abs (- (cdr a) (cdr b))) 1)))
|
|
|
|
(define (square-mouse-over)
|
|
(cons (floor (/ (get-mouse-x) square-width))
|
|
(floor (/ (get-mouse-y) square-width))))
|
|
|
|
; not correct (we need to know whether the square is revealed)
|
|
(define (square-pressed? x y)
|
|
(or
|
|
(and (button-down? 'left) (equal? (cons x y) (square-mouse-over)))
|
|
(and (button-down? 'middle) (pair-adjacent? (cons x y) (square-mouse-over)))))
|
|
|
|
(define (square-type square x y)
|
|
(cond
|
|
[(square-flagged? square) 'flag]
|
|
[(not (square-revealed? square))
|
|
(if (square-pressed? x y)
|
|
'pressed
|
|
'unknown)]
|
|
[(square-mine? square) 'mine]
|
|
[else (square-num-adjacent square)]))
|
|
|
|
; preliminary
|
|
(define (game-square-type-at game x y)
|
|
(square-type (game-square-at game x y) x y))
|
|
|
|
(define (game-in-bounds? game x y)
|
|
(and (< -1 x (game-width game))
|
|
(< -1 y (game-height game))))
|
|
|
|
(define (game-map-around proc game x y)
|
|
(map (lambda (x/y) (proc game (car x/y) (cdr x/y)))
|
|
(filter (lambda (x/y) (game-in-bounds? game (car x/y) (cdr x/y)))
|
|
(map (lambda (x/y)
|
|
(cons (+ x (car x/y)) (+ y (cdr x/y))))
|
|
'((-1 . -1) ( 0 . -1) ( 1 . -1)
|
|
(-1 . 0) ( 1 . 0)
|
|
(-1 . 1) ( 0 . 1) ( 1 . 1))))))
|
|
|
|
(define (game-around game x y)
|
|
(game-map-around game-square-at game x y))
|
|
|
|
; remember: prefer functions over macros
|
|
; game last for consistency with for-each
|
|
(define (game-squares-for-each proc game)
|
|
(for-each
|
|
(lambda (x)
|
|
(for-each
|
|
(lambda (y) (proc x y))
|
|
(iota (game-height game))))
|
|
(iota (game-width game))))
|
|
|
|
(define (fill-game-arounds! game)
|
|
(game-squares-for-each
|
|
(lambda (x y)
|
|
(define square (game-square-at game x y))
|
|
(square-num-adjacent-set! square
|
|
(length (filter square-mine? (game-around game x y)))))
|
|
game))
|
|
|
|
|
|
; as feared, make-vector references the same thing
|
|
(define (new-game mines width height)
|
|
(define squares (list->vector (append (make-squares mines #t)
|
|
(make-squares (- (* width height) mines) #f))))
|
|
(define game (make-game squares width height mines 0 #f))
|
|
(vector-shuffle! squares)
|
|
(fill-game-arounds! game)
|
|
game)
|
|
|
|
(define (game-reveal! game x y)
|
|
(define square (game-square-at game x y))
|
|
(unless (square-revealed? square)
|
|
(if (square-mine? square)
|
|
(game-over?-set! game #t)
|
|
(begin (square-revealed?-set! square #t)
|
|
(when (zero? (square-num-adjacent square))
|
|
(game-map-around game-reveal! game x y))))))
|
|
|
|
(define (game-tick! game)
|
|
(define mouse-x (car (square-mouse-over)))
|
|
(define mouse-y (cdr (square-mouse-over)))
|
|
(define mouse-in-bounds? (game-in-bounds? game mouse-x mouse-y))
|
|
(define mouse-square (and mouse-in-bounds? (game-square-at game mouse-x mouse-y)))
|
|
(define redraw?
|
|
(and mouse-in-bounds?
|
|
(or (button-down? 'left)
|
|
(button-down? 'middle)
|
|
(button-down? 'right)
|
|
|
|
(button-released? 'left)
|
|
(button-released? 'middle)
|
|
(button-released? 'right))))
|
|
|
|
; not quite perfectly correct
|
|
(when (and mouse-in-bounds? (button-pressed? 'right) (not (square-revealed? mouse-square)))
|
|
(game-num-flagged-set!
|
|
game
|
|
((if (square-flagged? mouse-square) sub1 add1) (game-num-flagged game)))
|
|
(square-flagged?-set! mouse-square (not (square-flagged? mouse-square))))
|
|
|
|
(when (and mouse-in-bounds?
|
|
(not (square-flagged? mouse-square))
|
|
(or (button-pressed? 'left) (button-pressed? 'middle)))
|
|
(if (and (square-revealed? mouse-square)
|
|
(= (square-num-adjacent mouse-square)
|
|
(length
|
|
(filter square-flagged?
|
|
(game-around game mouse-x mouse-y)))))
|
|
(game-map-around
|
|
(lambda (game x y)
|
|
(unless (square-flagged? (game-square-at game x y))
|
|
(game-reveal! game x y)))
|
|
game mouse-x mouse-y)
|
|
(game-reveal! game mouse-x mouse-y)))
|
|
|
|
redraw?)
|
|
|
|
; flags don't actually matter!
|
|
(define (game-won? game)
|
|
(define won? #t)
|
|
(vector-for-each
|
|
(lambda (square)
|
|
(when (boolean=? (square-mine? square) (square-revealed? square))
|
|
(set! won? #f)))
|
|
(game-squares game))
|
|
won?)
|
|
|
|
(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) 2 0 20 color)
|
|
|
|
(draw-write `(left down . ,(button-down? 'left)) 1 20 10 color)
|
|
(draw-write `(middle down . ,(button-down? 'middle)) 1 30 10 color)
|
|
(draw-write `(right down . ,(button-down? 'right)) 1 40 10 color)
|
|
|
|
(draw-write `(left pressed . ,(button-pressed? 'left)) 1 50 10 color)
|
|
(draw-write `(middle pressed . ,(button-pressed? 'middle)) 1 60 10 color)
|
|
(draw-write `(right pressed . ,(button-pressed? 'right)) 1 70 10 color)
|
|
|
|
(draw-write `(left released . ,(button-released? 'left)) 1 80 10 color)
|
|
(draw-write `(middle released . ,(button-released? 'middle)) 1 90 10 color)
|
|
(draw-write `(right released . ,(button-released? 'right)) 1 100 10 color))
|
|
|
|
(define (draw-game-squares game skin pos)
|
|
(define draw-pos (vector2 413 413))
|
|
(game-squares-for-each
|
|
(lambda (x y)
|
|
(set-vector2-x! draw-pos (+ (vector2-x pos) (* x square-width)))
|
|
(set-vector2-y! draw-pos (+ (vector2-y pos) (* y square-width)))
|
|
(blit-square skin (game-square-type-at game x y) draw-pos))
|
|
game))
|
|
|
|
(define (game-draw game skin)
|
|
(draw-game-squares game skin vector2-origin))
|
|
; draw-game-over as a separate thing would be nice
|
|
|
|
; the game shows -99 when (- num-mines num-flagged) is less than -99
|
|
(define (run-game mines width height seed skin-path)
|
|
(init-window (* width square-width) (* height square-width) "mineschemer")
|
|
(set-target-fps 60)
|
|
|
|
(display "seed: ") (display seed)
|
|
(newline)
|
|
(random-seed seed)
|
|
|
|
(let ([skin (load-texture skin-path)]
|
|
[game (new-game mines width height)])
|
|
;; (display skin)
|
|
;; (newline)
|
|
|
|
(with-draw (game-draw game skin))
|
|
; 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
|
|
; this saves a lot of resources
|
|
(when (game-tick! game)
|
|
; something leaks memory. huh!
|
|
; methinks it's all those foreign vector2s
|
|
; seems so
|
|
;; (clear-background BLACK)
|
|
; okay, we could be a bit smarter about what we redraw, but redrawing shouldn't leak *any* memory
|
|
(game-draw game skin)
|
|
; hacky, yeah
|
|
(when (game-over? game)
|
|
(draw-text "GAME OVER" 0 0 20 (color 255 0 0)))
|
|
(when (game-won? game)
|
|
(draw-text "A COMPLETER IS YOU" 0 20 10 WHITE)))
|
|
#;(draw-mouse-info BLACK)
|
|
))
|
|
(unload-texture skin)
|
|
(close-window)))
|
|
|
|
; let's save playing with shaders for later
|
|
|
|
; seems like minesweeper.online doesn't need middle-clicking to be separate (left-clicking performs the same function)
|
|
|
|
(define (get-nano-seed)
|
|
(time-nanosecond (current-time)))
|
|
|
|
(unless (and
|
|
(pair? (command-line-arguments))
|
|
(>= 4 (length (cdr (command-line-arguments))) 3)
|
|
(for-all number? (map string->number (cdr (command-line-arguments)))))
|
|
(display "i need 3-4 numbers (MINES WIDTH HEIGHT SEED)")
|
|
(exit 1))
|
|
|
|
; i really need some actual arg parsing this is embarassing
|
|
(apply run-game (append (map string->number (cdr (command-line-arguments)))
|
|
(list (get-nano-seed) (car (command-line-arguments)))))
|