mbk/mineschemer
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

megaW00T: skin recreated. we have all the pieces!

Browse source
This commit is contained in:
mehbark 2023-12-23 13:09:02 -05:00
parent a12a2d05fb
commit d981990978
1 changed files with 199 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

209
main.scm
View file

@ -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
; the bottom and right sides are 1 pixel shy, it works out
(map (lambda (n)
; the bottom and right sides are 1 pixel shy, it works out
(rectangle (* n width) 0 width width))
(iota 9)))))
(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)))