;; ;; chicken-sdl2: CHICKEN Scheme bindings to Simple DirectMedia Layer 2 ;; ;; Copyright © 2013–2021 John Croisant. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in ;; the documentation and/or other materials provided with the ;; distribution. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. (export create-window! get-window-from-id destroy-window! update-window-surface! update-window-surface-rects! show-window! hide-window! maximize-window! minimize-window! raise-window! restore-window! flash-window! window-bordered? window-bordered-set! window-borders-size ;; SDL 2.0.5+ window-brightness window-brightness-set! ;; TODO: window-data ;; TODO: window-data-set! window-display-index window-display-mode window-display-mode-set! window-flags window-flags-raw window-fullscreen window-fullscreen-set! ;; TODO: window-gamma-ramp ;; TODO: window-gamma-ramp-set! window-grab? window-grab-set! window-keyboard-grab? window-keyboard-grab-set! ;; SDL 2.0.16+ window-mouse-grab? window-mouse-grab-set! ;; SDL 2.0.16+ grabbed-window ;; SDL 2.0.4+ window-resizable? window-resizable-set! ;; SDL 2.0.5+ window-always-on-top? ;; SDL 2.0.5+ window-always-on-top-set! ;; SDL 2.0.5+ window-icon-set! window-id window-maximum-size window-maximum-size-set! window-minimum-size window-minimum-size-set! window-opacity window-opacity-set! ;; SDL 2.0.5+ window-pixel-format window-pixel-format-raw window-position window-position-set! window-size window-size-set! window-surface window-title window-title-set! ;; TODO: window-wm-info set-window-modal-for!) (: %window-pos->int (* symbol symbol -> integer)) (define (%window-pos->int pos fn-name x-or-y) (case pos ((undefined) SDL_WINDOWPOS_UNDEFINED) ((centered) SDL_WINDOWPOS_CENTERED) (else (if (integer? pos) pos (error fn-name (sprintf "invalid window ~A position" x-or-y) pos))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CREATE / GET / DESTROY WINDOW (: create-window! (string enum enum integer integer &optional (list-of symbol) -> sdl2:window)) (define (create-window! title x y w h #!optional (flags '())) (try-call (SDL_CreateWindow title (%window-pos->int x 'create-window! 'x) (%window-pos->int y 'create-window! 'y) w h (pack-window-flags flags)) fail?: (%struct-fail window?))) (: get-window-from-id (integer -> sdl2:window)) (define (get-window-from-id id) (try-call (SDL_GetWindowFromID id) fail?: (%struct-fail window?))) (: destroy-window! (sdl2:window* -> void)) (define (destroy-window! window) (SDL_DestroyWindow window)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; UPDATE WINDOW SURFACE (: update-window-surface! (sdl2:window* -> void)) (define (update-window-surface! window) (try-call (SDL_UpdateWindowSurface window)) (void)) (: update-window-surface-rects! (sdl2:window* (or (list-of sdl2:rect*) (vector-of sdl2:rect*)) -> void)) (define (update-window-surface-rects! window rects) (receive (rect-array len) (%rects->array rects) (try-call (SDL_UpdateWindowSurfaceRects window rect-array len) on-fail: (free rect-array)) (free rect-array) (void))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WINDOW MANAGEMENT (: show-window! (sdl2:window* -> void)) (define (show-window! window) (SDL_ShowWindow window)) (: hide-window! (sdl2:window* -> void)) (define (hide-window! window) (SDL_HideWindow window)) (: maximize-window! (sdl2:window* -> void)) (define (maximize-window! window) (SDL_MaximizeWindow window)) (: minimize-window! (sdl2:window* -> void)) (define (minimize-window! window) (SDL_MinimizeWindow window)) (: raise-window! (sdl2:window* -> void)) (define (raise-window! window) (SDL_RaiseWindow window)) (: restore-window! (sdl2:window* -> void)) (define (restore-window! window) (SDL_RestoreWindow window)) #+libSDL-2.0.16+ (: flash-window! (sdl2:window* enum -> void)) (define-versioned (flash-window! window operation) libSDL-2.0.16+ (try-call (SDL_FlashWindow window (symbol->flash-operation operation))) (void)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WINDOW PROPERTIES (: window-bordered? (sdl2:window* -> boolean)) (define (window-bordered? window) (zero? (bitwise-and SDL_WINDOW_BORDERLESS (window-flags-raw window)))) (: window-bordered-set! (sdl2:window* boolean -> void)) (define (window-bordered-set! window bordered?) (SDL_SetWindowBordered window bordered?)) (set! (setter window-bordered?) window-bordered-set!) #+libSDL-2.0.5+ (: window-borders-size (sdl2:window* -> fixnum fixnum fixnum fixnum)) (define-versioned (window-borders-size window) libSDL-2.0.5+ (with-temp-mem ((top-out (%allocate-Sint32)) (left-out (%allocate-Sint32)) (bottom-out (%allocate-Sint32)) (right-out (%allocate-Sint32))) (try-call (SDL_GetWindowBordersSize window top-out left-out bottom-out right-out)) (values (pointer-s32-ref top-out) (pointer-s32-ref left-out) (pointer-s32-ref bottom-out) (pointer-s32-ref right-out)))) (: window-brightness-set! (sdl2:window* float -> void)) (define (window-brightness-set! window brightness) (try-call (SDL_SetWindowBrightness window brightness)) (void)) (: window-brightness (sdl2:window* -> float)) (define (window-brightness window) (SDL_GetWindowBrightness window)) (set! (setter window-brightness) window-brightness-set!) ;; TODO: window-data ;; TODO: window-data-set! (: window-display-index (sdl2:window* -> integer)) (define (window-display-index window) (try-call (SDL_GetWindowDisplayIndex window))) (: window-display-mode (sdl2:window* -> sdl2:display-mode)) (define (window-display-mode window) (let ((mode (alloc-display-mode))) (try-call (SDL_GetWindowDisplayMode window mode) on-fail: (free-display-mode! mode)) mode)) (: window-display-mode-set! (sdl2:window* sdl2:display-mode* -> void)) (define (window-display-mode-set! window mode) (try-call (SDL_SetWindowDisplayMode window mode)) (void)) (set! (setter window-display-mode) window-display-mode-set!) (: window-flags (sdl2:window* -> (list-of symbol))) (define (window-flags window) (unpack-window-flags (window-flags-raw window) #t)) (: window-flags-raw (sdl2:window* -> integer)) (define (window-flags-raw window) (SDL_GetWindowFlags window)) (: window-fullscreen (sdl2:window* -> (or symbol false))) (define (window-fullscreen window) (let ((flags-mask (window-flags-raw window))) (cond ((= SDL_WINDOW_FULLSCREEN_DESKTOP (bitwise-and SDL_WINDOW_FULLSCREEN_DESKTOP flags-mask)) 'fullscreen-desktop) ((= SDL_WINDOW_FULLSCREEN (bitwise-and SDL_WINDOW_FULLSCREEN flags-mask)) 'fullscreen) (else #f)))) (: window-fullscreen-set! (sdl2:window* (or symbol boolean integer) -> void)) (define (window-fullscreen-set! window mode) (let ((mode-int (if (integer? mode) mode (case mode ((fullscreen #t) SDL_WINDOW_FULLSCREEN) ((fullscreen-desktop) SDL_WINDOW_FULLSCREEN_DESKTOP) ((#f) 0) (else (error 'window-fullscreen-set! "Invalid fullscreen mode" mode)))))) (try-call (SDL_SetWindowFullscreen window mode-int)) (void))) (set! (setter window-fullscreen) window-fullscreen-set!) ;; TODO: window-gamma-ramp ;; TODO: window-gamma-ramp-set! (: window-grab-set! (sdl2:window* boolean -> void)) (define (window-grab-set! window grab?) (SDL_SetWindowGrab window grab?)) (: window-grab? (sdl2:window* -> boolean)) (define (window-grab? window) (SDL_GetWindowGrab window)) (set! (setter window-grab?) window-grab-set!) #+libSDL-2.0.16+ (: window-keyboard-grab-set! (sdl2:window* boolean -> void)) (define-versioned (window-keyboard-grab-set! window grab?) libSDL-2.0.16+ (SDL_SetWindowKeyboardGrab window grab?)) #+libSDL-2.0.16+ (: window-keyboard-grab? (sdl2:window* -> boolean)) (define-versioned (window-keyboard-grab? window) libSDL-2.0.16+ (SDL_GetWindowKeyboardGrab window)) (set! (setter window-keyboard-grab?) window-keyboard-grab-set!) #+libSDL-2.0.16+ (: window-mouse-grab-set! (sdl2:window* boolean -> void)) (define-versioned (window-mouse-grab-set! window grab?) libSDL-2.0.16+ (SDL_SetWindowMouseGrab window grab?)) #+libSDL-2.0.16+ (: window-mouse-grab? (sdl2:window* -> boolean)) (define-versioned (window-mouse-grab? window) libSDL-2.0.16+ (SDL_GetWindowMouseGrab window)) (set! (setter window-mouse-grab?) window-mouse-grab-set!) #+libSDL-2.0.4+ (: grabbed-window (-> (or sdl2:window false))) (define-versioned (grabbed-window) libSDL-2.0.4+ (let ((window (SDL_GetGrabbedWindow))) (if (struct-null? window) #f window))) #+libSDL-2.0.5+ (: window-resizable-set! (sdl2:window* boolean -> void)) (define-versioned (window-resizable-set! window resizable?) libSDL-2.0.5+ (SDL_SetWindowResizable window resizable?)) (: window-resizable? (sdl2:window* -> boolean)) (define (window-resizable? window) (= SDL_WINDOW_RESIZABLE (bitwise-and SDL_WINDOW_RESIZABLE (window-flags-raw window)))) #+libSDL-2.0.5+ (set! (setter window-resizable?) window-resizable-set!) #+libSDL-2.0.5+ (: window-always-on-top? (sdl2:window* -> boolean)) (define-versioned (window-always-on-top? window) libSDL-2.0.5+ (= SDL_WINDOW_ALWAYS_ON_TOP (bitwise-and SDL_WINDOW_ALWAYS_ON_TOP (window-flags-raw window)))) #+libSDL-2.0.16+ (: window-always-on-top-set! (sdl2:window* boolean -> void)) (define-versioned (window-always-on-top-set! window on-top) libSDL-2.0.16+ (SDL_SetWindowAlwaysOnTop window on-top)) #+libSDL-2.0.16+ (set! (setter window-always-on-top?) window-always-on-top-set!) (: window-icon-set! (sdl2:window* sdl2:surface* -> void)) (define (window-icon-set! window icon) (SDL_SetWindowIcon window icon)) (: window-id (sdl2:window* -> integer)) (define (window-id window) (try-call (SDL_GetWindowID window) fail?: zero?)) (: window-maximum-size-set! (sdl2:window* (list integer integer) -> void)) (define (window-maximum-size-set! window size) (SDL_SetWindowMaximumSize window (car size) (cadr size))) (: window-maximum-size (sdl2:window* -> integer integer)) (define (window-maximum-size window) (with-temp-mem ((w-out (%allocate-Sint32)) (h-out (%allocate-Sint32))) (SDL_GetWindowMaximumSize window w-out h-out) (values (pointer-s32-ref w-out) (pointer-s32-ref h-out)))) (set! (setter window-maximum-size) window-maximum-size-set!) (: window-minimum-size-set! (sdl2:window* (list integer integer) -> void)) (define (window-minimum-size-set! window size) (SDL_SetWindowMinimumSize window (car size) (cadr size))) (: window-minimum-size (sdl2:window* -> integer integer)) (define (window-minimum-size window) (with-temp-mem ((w-out (%allocate-Sint32)) (h-out (%allocate-Sint32))) (SDL_GetWindowMinimumSize window w-out h-out) (values (pointer-s32-ref w-out) (pointer-s32-ref h-out)))) (set! (setter window-minimum-size) window-minimum-size-set!) #+libSDL-2.0.5+ (: window-opacity-set! (sdl2:window* (list float) -> void)) (define-versioned (window-opacity-set! window opacity) libSDL-2.0.5+ (try-call (SDL_SetWindowOpacity window opacity)) (void)) #+libSDL-2.0.5+ (: window-opacity (sdl2:window* -> float)) (define-versioned (window-opacity window) libSDL-2.0.5+ (with-temp-mem ((opacity-out (%allocate-float))) (try-call (SDL_GetWindowOpacity window opacity-out) on-fail: (free opacity-out)) (values (pointer-f32-ref opacity-out)))) (set! (setter window-opacity) window-opacity-set!) (: window-pixel-format (sdl2:window* -> symbol)) (define (window-pixel-format window) (pixel-format-enum->symbol (SDL_GetWindowPixelFormat window))) (: window-pixel-format-raw (sdl2:window* -> integer)) (define (window-pixel-format-raw window) (SDL_GetWindowPixelFormat window)) (: window-position-set! (sdl2:window* (list integer integer) -> void)) (define (window-position-set! window pos) (SDL_SetWindowPosition window (%window-pos->int (car pos) 'window-position-set! 'x) (%window-pos->int (cadr pos) 'window-position-set! 'y))) (: window-position (sdl2:window* -> integer integer)) (define (window-position window) (with-temp-mem ((x-out (%allocate-Sint32)) (y-out (%allocate-Sint32))) (SDL_GetWindowPosition window x-out y-out) (values (pointer-s32-ref x-out) (pointer-s32-ref y-out)))) (set! (setter window-position) window-position-set!) (: window-size-set! (sdl2:window* (list integer integer) -> void)) (define (window-size-set! window size) (SDL_SetWindowSize window (car size) (cadr size))) (: window-size (sdl2:window* -> integer integer)) (define (window-size window) (with-temp-mem ((w-out (%allocate-Sint32)) (h-out (%allocate-Sint32))) (SDL_GetWindowSize window w-out h-out) (values (pointer-s32-ref w-out) (pointer-s32-ref h-out)))) (set! (setter window-size) window-size-set!) (: window-surface (sdl2:window* -> sdl2:surface*)) (define (window-surface window) (try-call (SDL_GetWindowSurface window) fail?: (%struct-fail surface?))) (: window-title-set! (sdl2:window* string -> void)) (define (window-title-set! window title) (SDL_SetWindowTitle window title)) (: window-title (sdl2:window* -> string)) (define (window-title window) (SDL_GetWindowTitle window)) (set! (setter window-title) window-title-set!) ;; TODO: window-wm-info #+libSDL-2.0.5+ (: set-window-modal-for! (sdl2:window* sdl2:window* -> void)) (define-versioned (set-window-modal-for! modal-window parent-window) libSDL-2.0.5+ (try-call (SDL_SetWindowModalFor modal-window parent-window)) (void))