#!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)) ; slow but who cares (define (game-has-revealed-square? game) (define yeah? #f) (vector-for-each (lambda (square) (when (square-revealed? square) (set! yeah? #t))) (game-squares game)) yeah?) ; 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) (when (game-has-revealed-square? game) (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)))))