summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/api.texi41
-rw-r--r--sdl2/bindings.scm33
-rw-r--r--sdl2/input/mouse.scm74
3 files changed, 146 insertions, 2 deletions
diff --git a/doc/api.texi b/doc/api.texi
index 8e0fe73..85e5bf7 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -313,6 +313,47 @@ Return @code{#t} if @var{button} is currently being pressed.
Return @code{#t} if @var{button} is not currently being pressed.
@end deffn
+@deffn {Procedure} make-system-cursor cursor-type
+Create a new cursor from the system's available set, chosen by
+@var{cursor-type}. The possible values for @var{cursor-type} are:
+
+@itemize
+@item @code{arrow}
+@item @code{crosshair}
+@item @code{hand}
+@item @code{i-beam}
+@item @code{size-north-south}
+@item @code{size-northwest-southeast}
+@item @code{size-northeast-southwest}
+@item @code{size-west-east}
+@item @code{size-all}
+@item @code{no}
+@item @code{wait}
+@item @code{wait-arrow}
+@end itemize
+
+@end deffn
+
+@deffn {Procedure} make-surface-cursor surface hot-x hot-y
+Create a new cursor from a surface and the given hotspot coordinates
+(@var{hot-x}, @var{hot-y}).
+@end deffn
+
+@deffn {Procedure} get-cursor
+Return the cursor currently in use. The returned cursor object is
+internally managed and it's not necessary to call
+@code{delete-cursor!} for it.
+@end deffn
+
+@deffn {Procedure} set-cursor! cursor
+Set the current cursor to @var{cursor}. If @var{cursor} is @code{#f},
+the system default cursor is restored.
+@end deffn
+
+@deffn {Procedure} delete-cursor! cursor
+Free the memory used by @var{cursor}. Be careful!
+@end deffn
+
@node Joysticks
@subsection Joysticks
diff --git a/sdl2/bindings.scm b/sdl2/bindings.scm
index 897a0dc..954aa8b 100644
--- a/sdl2/bindings.scm
+++ b/sdl2/bindings.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2015, 2016, 2021 David Thompson <dthompson2@worcester.edu>
;;; Copyright © 2018 Eero Leno <eero@leno.fi>
;;; Copyright © 2019 Pierre-Antoine Rouby <contact@parouby.fr>
+;;; Copyright © 2022 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;
;;; This file is part of guile-sdl2.
;;;
@@ -1028,6 +1029,38 @@ RETURN-TYPE and accept arguments of ARG-TYPES."
(define-foreign sdl-warp-mouse-global
int "SDL_WarpMouseGlobal" (list int int))
+(define-public SDL_SYSTEM_CURSOR_ARROW 0)
+(define-public SDL_SYSTEM_CURSOR_IBEAM 1)
+(define-public SDL_SYSTEM_CURSOR_WAIT 2)
+(define-public SDL_SYSTEM_CURSOR_CROSSHAIR 3)
+(define-public SDL_SYSTEM_CURSOR_WAITARROW 4)
+(define-public SDL_SYSTEM_CURSOR_SIZENWSE 5)
+(define-public SDL_SYSTEM_CURSOR_SIZENESW 6)
+(define-public SDL_SYSTEM_CURSOR_SIZEWE 7)
+(define-public SDL_SYSTEM_CURSOR_SIZENS 8)
+(define-public SDL_SYSTEM_CURSOR_SIZEALL 9)
+(define-public SDL_SYSTEM_CURSOR_NO 10)
+(define-public SDL_SYSTEM_CURSOR_HAND 11)
+(define-public SDL_NUM_SYSTEM_CURSORS 12)
+
+(define-foreign sdl-create-system-cursor
+ '* "SDL_CreateSystemCursor" (list int))
+
+(define-foreign sdl-create-color-cursor
+ '* "SDL_CreateColorCursor" (list '* int int))
+
+(define-foreign sdl-free-cursor
+ void "SDL_FreeCursor" (list '*))
+
+(define-foreign sdl-set-cursor
+ void "SDL_SetCursor" (list '*))
+
+(define-foreign sdl-get-cursor
+ '* "SDL_GetCursor" '())
+
+(define-foreign sdl-show-cursor
+ int "SDL_ShowCursor" (list int))
+
;;;
;;; Timer
diff --git a/sdl2/input/mouse.scm b/sdl2/input/mouse.scm
index ba0d81e..4a3869d 100644
--- a/sdl2/input/mouse.scm
+++ b/sdl2/input/mouse.scm
@@ -1,5 +1,6 @@
;;; guile-sdl2 --- FFI bindings for SDL2
;;; Copyright © 2017, 2021 David Thompson <dthompson2@worcester.edu>
+;;; Copyright © 2022 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;
;;; This file is part of guile-sdl2.
;;;
@@ -19,12 +20,13 @@
;;; Commentary:
;;
-;; Mouse input.
+;; Mouse input and cursor manipulation.
;;
;;; Code:
(define-module (sdl2 input mouse)
#:use-module (ice-9 match)
+ #:use-module (ice-9 format)
#:use-module (rnrs bytevectors)
#:use-module (sdl2)
#:use-module ((sdl2 bindings) #:prefix ffi:)
@@ -35,7 +37,12 @@
mouse-button-released?
set-show-cursor!
cursor-visible?
- warp-mouse))
+ warp-mouse
+ create-system-cursor
+ create-surface-cursor
+ get-cursor
+ set-cursor!
+ delete-cursor!))
(define (make-int)
(make-bytevector (sizeof int)))
@@ -92,3 +99,66 @@ coordinates (X, Y)."
x y)
(unless (= (ffi:sdl-warp-mouse-global x y) 0)
(sdl-error "warp-mouse" "failed to warp mouse globally"))))
+
+
+;;;
+;;; Cursors
+;;;
+
+(define-wrapped-pointer-type <cursor>
+ cursor?
+ wrap-cursor unwrap-cursor
+ (lambda (cursor port)
+ (format port "#<cursor ~x>"
+ (pointer-address (unwrap-cursor cursor)))))
+
+(define (make-system-cursor cursor-type)
+ "Return a new cursor from the system's available set, chosen by
+CURSOR-TYPE. Valid cursor types are: arrow, crosshair, hand, i-beam,
+no, size-north-south, size-northwest-southeast,
+size-northeast-southwest, size-east-west, size-all, wait, and
+wait-arrow."
+ (let* ((id (case cursor-type
+ ((arrow) ffi:SDL_SYSTEM_CURSOR_ARROW)
+ ((crosshair) ffi:SDL_SYSTEM_CURSOR_CROSSHAIR)
+ ((hand) ffi:SDL_SYSTEM_CURSOR_HAND)
+ ((i-beam) ffi:SDL_SYSTEM_CURSOR_IBEAM)
+ ((no) ffi:SDL_SYSTEM_CURSOR_NO)
+ ((size-north-south) ffi:SDL_SYSTEM_CURSOR_SIZENS)
+ ((size-northwest-southeast) ffi:SDL_SYSTEM_CURSOR_SIZENWSE)
+ ((size-northeast-southwest) ffi:SDL_SYSTEM_CURSOR_SIZENESW)
+ ((size-west-east) ffi:SDL_SYSTEM_CURSOR_SIZEWE)
+ ((size-all) ffi:SDL_SYSTEM_CURSOR_SIZEALL)
+ ((wait) ffi:SDL_SYSTEM_CURSOR_WAIT)
+ ((wait-arrow) ffi:SDL_SYSTEM_CURSOR_WAITARROW)
+ (else
+ (sdl-error "make-system-cursor" "unknown cursor type"))))
+ (ptr (ffi:sdl-create-system-cursor id)))
+ (if (null-pointer? ptr)
+ (sdl-error "make-system-cursor" "failed to create system cursor")
+ (wrap-cursor ptr))))
+
+(define (make-color-cursor surface hot-x hot-y)
+ "Make a cursor from SURFACE with a hot spot of (HOT-X, HOT-Y)."
+ (let ((ptr (ffi:sdl-create-color-cursor
+ ((@@ (sdl2 surface) unwrap-surface) surface) hot-x hot-y)))
+ (if (null-pointer? ptr)
+ (sdl-error "make-color-cursor" "failed to create color cursor")
+ (wrap-cursor ptr))))
+
+(define (get-cursor)
+ "Return the cursor currently in use. The returned cursor object is
+internally managed and it's not necessary to call delete-cursor! for
+it."
+ (wrap-cursor (ffi:sdl-get-cursor)))
+
+(define (set-cursor! cursor)
+ "Set current cursor to CURSOR. If CURSOR is #f, the system default
+cursor is restored."
+ (ffi:sdl-set-cursor (if cursor
+ (unwrap-cursor cursor)
+ %null-pointer)))
+
+(define (delete-cursor! cursor)
+ "Free the memory used by CURSOR. Be careful!"
+ (ffi:sdl-free-cursor (unwrap-cursor cursor)))