mineschemer/main.scm

#!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 num-flagged))

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

(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-around game x y)
  (map (lambda (x/y) (game-square-at 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))))))

; 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))
  (vector-shuffle! squares)
  (fill-game-arounds! game)
  game)


(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))
    (square-flagged?-set! mouse-square (not (square-flagged? mouse-square))))

  redraw?)

(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)
  (init-window (* width square-width) (* height square-width) "mineschemer")
  (set-target-fps 60)

  (let ([skin (load-skin "xp-flowers.bmp")]
	[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))
	    #;(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)