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 WHITE (color 255 255 255 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
  (foreign-procedure #f "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
  (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 y)
  (define vec2 (make-ftype-pointer Vector2 (foreign-alloc (ftype-sizeof Vector2))))
  (set-vector2-x! vec2 x)
  (set-vector2-y! vec2 y)
  vec2)

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

; we only really need the rec version

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

; 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 number-rects
  (let ([width (/ skin-width 9)])
    (list->vector
     (map (lambda (n)
	    ; the bottom and right sides are 1 pixel shy, it works out
	    (rectangle (* n width) 0 width width))
	  (iota 9)))))

(define (blit-number skin n pos)
  (let ([rect (vector-ref number-rects n)])
    (draw-texture-rec skin rect pos WHITE)))

(define (main)
  (init-window 100 100 "hello")
  (set-target-fps 60)

  (let ([skin (load-skin "xp-flowers.bmp")])
    ;; (display skin)
    ;; (newline)

; with the actual game, we probably don't have to draw every time
    (until (window-should-close?)
	   (with-draw
	    (clear-background (color 0 0 0 0))
	    (for-each (lambda (n)
			(blit-number skin n (vector2 (* 10 n) (* 10 n))))
		      (iota 9))))
    (unload-texture skin)
    (close-window)))