megaW00T: skin recreated. we have all the pieces!

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))
+   (map (lambda (n)
-	  (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))
+	    (clear-background (color-from-hsv h 1.0 1.0))
-	    (for-each (lambda (n)
+	    (redraw-skin skin)))
-			(blit-number skin n (vector2 (* 10 n) (* 10 n))))
-		      (iota 9))))
     (unload-texture skin)
     (close-window)))