(test-group "sdl2:free-surface!" (let ((surface (sdl2:make-surface* 10 10 24))) (assert (not (sdl2:struct-null? surface))) (test "returns void" (void) (sdl2:free-surface! surface)) (test-assert "nullifies the surface" (sdl2:struct-null? surface))) (test-error "throws error if given non-surface" (sdl2:free-surface! (sdl2:make-rect)))) (test-group "sdl2:make-surface" (define test-make-surface-with-valid-depth (lambda (depth) (test-group (sprintf "depth ~A" depth) (let ((surface (sdl2:make-surface 10 20 depth))) (test-assert "creates and returns a new sdl2:surface" (and (sdl2:surface? surface) (not (sdl2:struct-null? surface)))) (test "surface has the correct width and height" '(10 20) (list (sdl2:surface-w surface) (sdl2:surface-h surface))) (let ((format (sdl2:surface-format surface))) (test "surface has the correct depth" depth (sdl2:pixel-format-bits-per-pixel format)) (when (<= depth 8) (test "surface has all zero masks" (list 0 0 0 0) (list (sdl2:pixel-format-rmask format) (sdl2:pixel-format-gmask format) (sdl2:pixel-format-bmask format) (sdl2:pixel-format-amask format))) (test-assert "surface has a palette" (not (sdl2:struct-null? (sdl2:pixel-format-palette format))))) (when (<= 15 depth 24) (test-assert "surface has non-zero Rmask" (positive? (sdl2:pixel-format-rmask format))) (test-assert "surface has non-zero Gmask" (positive? (sdl2:pixel-format-gmask format))) (test-assert "surface has non-zero Bmask" (positive? (sdl2:pixel-format-bmask format))) (test-assert "surface has zero Amask" (zero? (sdl2:pixel-format-amask format)))) (when (= depth 32) (test "surface has appropriate masks for system byte order" (if (= SDL:SDL_BYTEORDER SDL:SDL_BIG_ENDIAN) (list #xff000000 #x00ff0000 #x0000ff00 #x000000ff) (list #x000000ff #x0000ff00 #x00ff0000 #xff000000)) (list (sdl2:pixel-format-rmask format) (sdl2:pixel-format-gmask format) (sdl2:pixel-format-bmask format) (sdl2:pixel-format-amask format))))))))) (define (test-make-surface-with-valid-format-symbol format) (test-group (sprintf "format ~A" format) (test-assert "creates and returns a new sdl2:surface" (let ((surface (sdl2:make-surface 10 20 format))) (and (sdl2:surface? surface) (not (sdl2:struct-null? surface))))) (test "surface has the correct format" format (sdl2:pixel-format-format (sdl2:surface-format (sdl2:make-surface 10 20 format)))))) (define (test-make-surface-with-valid-format-integer name format) (test-group (sprintf "format ~A (~A)" name format) (test-assert "creates and returns a new sdl2:surface" (let ((surface (sdl2:make-surface 10 20 format))) (and (sdl2:surface? surface) (not (sdl2:struct-null? surface))))) (test "surface has the correct format" format (sdl2:pixel-format-format-raw (sdl2:surface-format (sdl2:make-surface 10 20 format)))))) (for-each test-make-surface-with-valid-depth '(1 4 8 12 15 16 24 32)) (for-each test-make-surface-with-valid-format-symbol '(index8 rgb332 argb4444 rgb565 rgba8888)) (for-each (cut apply test-make-surface-with-valid-format-integer <>) `((SDL_PIXELFORMAT_INDEX1LSB ,SDL:SDL_PIXELFORMAT_INDEX1LSB) (SDL_PIXELFORMAT_RGB555 ,SDL:SDL_PIXELFORMAT_RGB555) (SDL_PIXELFORMAT_ARGB1555 ,SDL:SDL_PIXELFORMAT_ARGB1555) (SDL_PIXELFORMAT_RGBX8888 ,SDL:SDL_PIXELFORMAT_RGBX8888))) (test-error "throws error if width is not an integer" (sdl2:make-surface 10.5 20 32)) (test-error "throws error if width is negative" (sdl2:make-surface -1 20 32)) (test-error "throws error if height is not an integer" (sdl2:make-surface 10 20.5 32)) (test-error "throws error if height is negative" (sdl2:make-surface 10 -1 32)) (test-error "throws error if depth is negative" (sdl2:make-surface 10 20 -24)) (test-error "throws error if depth is a float" (sdl2:make-surface 10 20 24.5)) (test-error "throws error if depth is a string" (sdl2:make-surface 10 20 "rgba8888"))) (test-group "sdl2:create-rgb-surface*" (test-assert "returns a new sdl2:surface on success" (sdl2:surface? (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 #x00FF0000 #x0000FF00 #x000000FF))) (test-error "throws error if rmask is not an integer" (sdl2:create-rgb-surface* 0 10 10 32 12345678.9 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if rmask is negative" (sdl2:create-rgb-surface* 0 10 10 32 -1 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if rmask is too large" (sdl2:create-rgb-surface* 0 10 10 32 #x11FF000000 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is not an integer" (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 12345678.9 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is negative" (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 -1 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is too large" (sdl2:create-rgb-surface* 0 10 10 32 #xFF0000 #x1100FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if bmask is not an integer" (sdl2:create-rgb-surface* 0 10 10 32 #x00FF0000 #x0000FF00 12345678.9 #x000000FF)) (test-error "throws error if bmask is negative" (sdl2:create-rgb-surface* 0 10 10 32 #x00FF0000 #x0000FF00 -1 #x000000FF)) (test-error "throws error if bmask is too large" (sdl2:create-rgb-surface* 0 10 10 32 #x00FF0000 #x0000FF00 #x110000FF00 #x000000FF)) (test-error "throws error if amask is not an integer" (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 #x00FF0000 #x0000FF00 12345678.9)) (test-error "throws error if amask is negative" (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 #x00FF0000 #x0000FF00 -1)) (test-error "throws error if amask is too large" (sdl2:create-rgb-surface* 0 10 10 32 #xFF000000 #x00FF0000 #x0000FF00 #x11000000FF))) (test-group "sdl2:create-rgb-surface-from*" (let* ((original (sdl2:make-surface 10 10 32)) (pixels (sdl2:surface-pixels-raw original)) (pitch (sdl2:surface-pitch original))) (test-assert "returns a new sdl2:surface on success" (sdl2:surface? (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 #x00FF0000 #x0000FF00 #x000000FF))) (test-error "throws error if rmask is not an integer" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch 12345678.9 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if rmask is negative" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch -1 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if rmask is too large" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #x11FF000000 #x00FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is not an integer" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 12345678.9 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is negative" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 -1 #x0000FF00 #x000000FF)) (test-error "throws error if gmask is too large" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF0000 #x1100FF0000 #x0000FF00 #x000000FF)) (test-error "throws error if bmask is not an integer" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #x00FF0000 #x0000FF00 12345678.9 #x000000FF)) (test-error "throws error if bmask is negative" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #x00FF0000 #x0000FF00 -1 #x000000FF)) (test-error "throws error if bmask is too large" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #x00FF0000 #x0000FF00 #x110000FF00 #x000000FF)) (test-error "throws error if amask is not an integer" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 #x00FF0000 #x0000FF00 12345678.9)) (test-error "throws error if amask is negative" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 #x00FF0000 #x0000FF00 -1)) (test-error "throws error if amask is too large" (sdl2:create-rgb-surface-from* pixels 10 10 32 pitch #xFF000000 #x00FF0000 #x0000FF00 #x11000000FF)))) (versioned-test-group "sdl2:create-rgb-surface-with-format*" libSDL-2.0.5+ (define (do-test depth sym raw) (test (sprintf "creates a surface with the desired format (~A)" sym) raw (let* ((surf (sdl2:create-rgb-surface-with-format* 0 10 10 depth sym)) (fmt (sdl2:pixel-format-format-raw (sdl2:surface-format surf)))) (sdl2:free-surface! surf) fmt))) (do-test 8 'rgb332 SDL:SDL_PIXELFORMAT_RGB332) (do-test 16 'bgra5551 SDL:SDL_PIXELFORMAT_BGRA5551) (do-test 32 'rgba8888 SDL:SDL_PIXELFORMAT_RGBA8888)) (versioned-test-group "sdl2:create-rgb-surface-with-format-from*" libSDL-2.0.5+ (define (do-test depth sym raw) (let* ((surf1 (sdl2:create-rgb-surface-with-format* 0 10 10 depth sym)) (surf2 (sdl2:create-rgb-surface-with-format-from* (sdl2:surface-pixels-raw surf1) 10 10 (sdl2:surface-pitch surf1) depth sym))) (test (sprintf "creates a surface with the desired format (~A)" sym) raw (sdl2:pixel-format-format-raw (sdl2:surface-format surf2))) (sdl2:fill-rect! surf1 #f 123) (test (sprintf "shares pixel data with original surface (~A)" sym) 123 (sdl2:surface-ref-raw surf2 5 5)) (sdl2:free-surface! surf1) (sdl2:free-surface! surf2))) (do-test 8 'rgb332 SDL:SDL_PIXELFORMAT_RGB332) (do-test 16 'bgra5551 SDL:SDL_PIXELFORMAT_BGRA5551) (do-test 32 'rgba8888 SDL:SDL_PIXELFORMAT_RGBA8888)) (test-group "sdl2:convert-surface" (define format (sdl2:make-pixel-format 'rgba8888)) (define orig (sdl2:make-surface 10 10 24)) (sdl2:fill-rect! orig #f (sdl2:make-color 1 2 3)) (test "Returns surface with correct format (struct)" SDL:SDL_PIXELFORMAT_RGBA8888 (sdl2:pixel-format-format-raw (sdl2:surface-format (sdl2:convert-surface orig format)))) (test "Returns surface with correct format (symbol)" SDL:SDL_PIXELFORMAT_RGBA8888 (sdl2:pixel-format-format-raw (sdl2:surface-format (sdl2:convert-surface orig 'rgba8888)))) (test "Returns surface with correct format (integer)" SDL:SDL_PIXELFORMAT_RGBA8888 (sdl2:pixel-format-format-raw (sdl2:surface-format (sdl2:convert-surface orig SDL:SDL_PIXELFORMAT_RGBA8888))))) (test-group "sdl2:duplicate-surface" (define surf1 (sdl2:make-surface 5 5 24)) (sdl2:fill-rect! surf1 #f (sdl2:make-color 12 34 56)) (test-assert "Returns a different surface" (let ((surf2 (sdl2:duplicate-surface surf1))) (and (sdl2:surface? surf2) (not (sdl2:struct-eq? surf1 surf2))))) (test "Has the same format as original" (sdl2:pixel-format-format (sdl2:surface-format surf1)) (sdl2:pixel-format-format (sdl2:surface-format (sdl2:duplicate-surface surf1)))) (test "Has identical pixel data as original" '(12 34 56 255) (let ((surf2 (sdl2:duplicate-surface surf1))) (sdl2:color->list (sdl2:surface-ref surf2 1 2))))) (test-group "sdl2:fill-rects!" (let ((surf (sdl2:make-surface 10 10 16))) (test-assert "Accepts a list of rects" (no-error? (sdl2:fill-rects! surf (list (sdl2:make-rect 1 2 3 4) (sdl2:make-rect 2 3 4 5) (sdl2:make-rect 3 4 5 6)) (sdl2:make-color 64 128 255)))) (test-assert "Accepts a vector of rects" (no-error? (sdl2:fill-rects! surf (vector (sdl2:make-rect 1 2 3 4) (sdl2:make-rect 2 3 4 5) (sdl2:make-rect 3 4 5 6)) (sdl2:make-color 64 128 255)))))) (test-group "sdl2:surface-color-key?" (test "Returns #t if surface has a color key" #t (let ((surf (sdl2:make-surface 1 1 24))) (sdl2:surface-color-key-set! surf 0) (sdl2:surface-color-key? surf))) (test "Returns #f if surface does not have a color key" #f (sdl2:surface-color-key? (sdl2:make-surface 1 1 24))) (test "Alias surface-colour-key? is same procedure" sdl2:surface-colour-key? sdl2:surface-color-key?)) (test-group "sdl2:surface-blend-mode" (test "Returns symbol for built-in blend modes" 'blend (let ((surf (sdl2:make-surface 1 1 32))) (sdl2:surface-blend-mode-set! surf 'blend) (sdl2:surface-blend-mode surf))) (cond-expand (libSDL-2.0.6+ (let* ((good-drivers ;; Drivers that support custom blend modes '("direct3d" "direct3d11" "opengl" "opengles" "opengles2")) (available-drivers (map sdl2:get-video-driver (iota (sdl2:get-num-video-drivers)))) (driver (find (cut member <> good-drivers) available-drivers))) (if (not driver) (test-assert "No driver supports custom blend modes; skipping test" #t) (test "Returns integer for custom blend modes" 173082673 (begin (sdl2:quit!) (sdl2:init!) (sdl2:video-init! driver) (let ((surf (sdl2:make-surface 1 1 32))) (set! (sdl2:surface-blend-mode surf) (sdl2:compose-custom-blend-mode 'src-color 'one-minus-dst-color 'add 'src-alpha 'one-minus-dst-alpha 'add)) (sdl2:surface-blend-mode surf))))))) (else (test-assert "SDL version lacks custom blend modes; skipping test" #t)))) (versioned-test-group "sdl2:compose-custom-blend-mode" libSDL-2.0.6+ (test "Returns blend mode as integer (given symbols)" 173082673 (sdl2:compose-custom-blend-mode 'src-color 'one-minus-dst-color 'add 'src-alpha 'one-minus-dst-alpha 'add)) (test "Returns blend mode as integer (given integers)" 173082673 (sdl2:compose-custom-blend-mode SDL:SDL_BLENDFACTOR_SRC_COLOR SDL:SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR SDL:SDL_BLENDOPERATION_ADD SDL:SDL_BLENDFACTOR_SRC_ALPHA SDL:SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA SDL:SDL_BLENDOPERATION_ADD))) (versioned-test-group "sdl2:get-yuv-conversion-mode" libSDL-2.0.8+ (test-assert "Returns a symbol" (symbol? (sdl2:get-yuv-conversion-mode))) (test "Setter procedure (with symbol)" 'jpeg (begin (sdl2:yuv-conversion-mode-set! 'jpeg) (sdl2:get-yuv-conversion-mode))) (test "Setter procedure (with integer)" 'bt601 (begin (sdl2:yuv-conversion-mode-set! SDL:SDL_YUV_CONVERSION_BT601) (sdl2:get-yuv-conversion-mode))) (test "set! (with symbol)" 'jpeg (begin (set! (sdl2:get-yuv-conversion-mode) 'jpeg) (sdl2:get-yuv-conversion-mode))) (test "set! (with integer)" 'bt601 (begin (set! (sdl2:get-yuv-conversion-mode) SDL:SDL_YUV_CONVERSION_BT601) (sdl2:get-yuv-conversion-mode))))