From d9819909788033c9d9d29964eda9ca75d1107abc Mon Sep 17 00:00:00 2001 From: mehbark Date: Sat, 23 Dec 2023 13:09:02 -0500 Subject: [PATCH] megaW00T: skin recreated. we have all the pieces! --- main.scm | 213 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 199 insertions(+), 14 deletions(-) diff --git a/main.scm b/main.scm index cb44ab0..8c58635 100644 --- a/main.scm +++ b/main.scm @@ -37,6 +37,13 @@ (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 c (color 1 2 3 4)) @@ -129,6 +136,9 @@ (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)] @@ -187,8 +197,16 @@ (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 @@ -215,6 +233,8 @@ ; 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) @@ -234,33 +254,198 @@ (define skin-width 144) (define skin-height 122) +(define square-width (/ skin-width 9)) + (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))))) + (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)) (define (blit-number skin n pos) (let ([rect (vector-ref number-rects n)]) - (draw-texture-rec skin rect pos WHITE))) + (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 (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 (main) - (init-window 100 100 "hello") + (init-window skin-width skin-height "mineschemer") (set-target-fps 60) - (let ([skin (load-skin "xp-flowers.bmp")]) + (let ([skin (load-skin "xp-flowers.bmp")] + [h 0.0]) ;; (display skin) ;; (newline) -; with the actual game, we probably don't have to draw every time +; with the actual game, we almost certainly don't have to redraw everything every time (until (window-should-close?) + (set! h (+ 1 h)) (with-draw - (clear-background (color 0 0 0 0)) - (for-each (lambda (n) - (blit-number skin n (vector2 (* 10 n) (* 10 n)))) - (iota 9)))) + (clear-background (color-from-hsv h 1.0 1.0)) + (redraw-skin skin))) (unload-texture skin) (close-window)))