;;;; sdl.scm - Simple SDL binding for Chicken ; Copyright (C) 2002-2004 Tony Garnock-Jones ; ; This library is free software; you can redistribute it and/or modify ; it under the terms of the GNU Library General Public License as ; published by the Free Software Foundation; either version 2 of the ; License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, but ; WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Library General Public License for more details. ; ; You should have received a copy of the GNU Library General Public ; License along with this library; if not, write to the Free ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ; USA ; --------------------------------------------------------------------------- (module sdl ( *sdl-egg-version* SDL_BUTTON ; sdl gfx make-sdl-rect sdl-rect? sdl-rect-x sdl-rect-y sdl-rect-w sdl-rect-h make-sdl-pixel-format sdl-pixel-format? sdl-pixel-format-bytes-per-pixel sdl-surface-flags sdl-surface-pixel-format sdl-surface-width sdl-surface-height sdl-surface-pitch sdl-surface-pixels sdl-surface-pixels-length sdl-get-clip-rect! sdl-set-clip-rect! sdl-set-color-key! sdl-set-alpha! sdl-display-format sdl-display-format-alpha sdl-convert-surface ; sdl system stuff sdl-init sdl-init-sub-system sdl-quit-sub-system sdl-quit sdl-was-init sdl-get-error sdl-clear-error! sdl-wm-set-caption sdl-wm-get-caption-title sdl-wm-get-caption-icon sdl-wm-get-caption sdl-wm-set-icon sdl-wm-iconify-window sdl-wm-toggle-full-screen sdl-wm-grab-input sdl-get-ticks sdl-delay timer? get-time-of-day get-time-of-day sdl-add-relative-timer! make-sdl-event sdl-event? sdl-event-type sdl-pump-events sdl-poll-event! sdl-wait-event!* sdl-wait-event! sdl-push-event sdl-event-state! sdl-get-mouse-state sdl-enable-unicode sdl-get-video-surface sdl-video-driver-name sdl-set-video-mode sdl-video-mode-ok sdl-show-cursor sdl-map-rgb sdl-map-rgba sdl-fill-rect sdl-flip sdl-surface? sdl-create-rgb-surface sdl-free-surface sdl-blit-surface sdl-with-clip-rect make-sdl-color sdl-color? sdl-color-r sdl-color-g sdl-color-b make-sdl-joystick sdl-joystick? sdl-joystick-event-state sdl-joystick-update sdl-num-joysticks sdl-joystick-name sdl-joystick-open sdl-joystick-opened sdl-joystick-index sdl-joystick-num-axes sdl-joystick-num-balls sdl-joystick-num-hats sdl-joystick-num-buttons sdl-joystick-update sdl-joystick-get-axis sdl-joystick-get-hat sdl-joystick-get-button sdl-joystick-close sdl-gl-swap-buffers sdl-gl-set-attribute sdl-gl-get-attribute ; SDL ttf ttf-init ttf-was-init ttf-quit ttf-font? ttf-font-pointer ttf-open-font ttf-open-font-index ttf-close-font ttf-get-font-style ttf-set-font-style ttf-font-height ttf-font-ascent ttf-font-descent ttf-font-line-skip ttf-font-faces ttf-font-face-is-fixed-width? ttf-font-face-family-name ttf-font-face-style-name ttf-size-text! ttf-size-utf8! ttf-render-text-solid ttf-render-utf8-solid ttf-render-text-shaded ttf-render-utf8-shaded ttf-render-text-blended ttf-render-utf8-blended ; SDL image img-load rotozoom-surface zoom-surface ;SDL net make-sdl-ip-address sdl-ip-address? sdl-ip-address-a sdl-ip-address-b sdl-ip-address-c sdl-ip-address-d sdl-ip-address-port sdl-net-init sdl-net-quit sdl-net-resolve-host! sdl-net-resolve-ip sdl-net-resolve-host make-sdl-tcp-socket sdl-tcp-socket? sdl-net-tcp-open sdl-net-tcp-accept sdl-net-tcp-get-peer-address sdl-net-tcp-send sdl-net-tcp-recv sdl-net-tcp-close sdl-net-tcp-send-string sdl-net-tcp-recv-string sdl-net-tcp-add-socket! sdl-net-tcp-del-socket! sdl-net-check-sockets sdl-net-socket-ready? sdl-net-socket-set? sdl-net-socket-set-pointer-set! sdl-net-write-16 sdl-net-write-32 sdl-net-read-16 sdl-net-read-32 sdl-event? sdl-event-gain set-sdl-event-gain! sdl-event-which set-sdl-event-which! sdl-event-state set-sdl-event-state! sdl-event-scancode set-sdl-event-scancode! sdl-event-sym set-sdl-event-sym! sdl-event-mod set-sdl-event-mod! sdl-event-unicode set-sdl-event-unicode! sdl-event-x set-sdl-event-x! sdl-event-y set-sdl-event-y! sdl-event-xrel set-sdl-event-xrel! sdl-event-yrel set-sdl-event-yrel! sdl-event-axis set-sdl-event-axis! sdl-event-ball set-sdl-event-ball! sdl-event-hat set-sdl-event-hat! sdl-event-value set-sdl-event-value! sdl-event-button set-sdl-event-button! sdl-event-w set-sdl-event-w! sdl-event-h set-sdl-event-h! sdl-event-buffer-set! heap? ; constants SDL_INIT_TIMER SDL_INIT_AUDIO SDL_INIT_VIDEO SDL_INIT_CDROM SDL_INIT_JOYSTICK SDL_INIT_EVERYTHING SDL_INIT_NOPARACHUTE ;; For sdl-creatergbsurface or sdl-setvideomode SDL_SWSURFACE SDL_HWSURFACE SDL_ASYNCBLIT ;; For sdl-setvideomode SDL_ANYFORMAT SDL_HWPALETTE SDL_DOUBLEBUF SDL_FULLSCREEN SDL_OPENGL SDL_OPENGLBLIT SDL_RESIZABLE SDL_NOFRAME ;; Read-only - internal SDL_HWACCEL SDL_SRCCOLORKEY SDL_RLEACCELOK SDL_RLEACCEL SDL_SRCALPHA SDL_PREALLOC ; For sdl-wm-grabinput SDL_GRAB_QUERY SDL_GRAB_OFF SDL_GRAB_ON SDL_NOEVENT ; Unused (do not remove) SDL_ACTIVEEVENT ; Application loses/gains visibility SDL_KEYDOWN ; Keys pressed SDL_KEYUP ; Keys released SDL_MOUSEMOTION ; Mouse moved SDL_MOUSEBUTTONDOWN ; Mouse button pressed SDL_MOUSEBUTTONUP ; Mouse button released SDL_JOYAXISMOTION ; Joystick axis motion SDL_JOYBALLMOTION ; Joystick trackball motion SDL_JOYHATMOTION ; Joystick hat position change SDL_JOYBUTTONDOWN ; Joystick button pressed SDL_JOYBUTTONUP ; Joystick button released SDL_QUIT ; User-requested quit SDL_SYSWMEVENT ; System specific event SDL_EVENT_RESERVEDA ; Reserved for future use.. SDL_EVENT_RESERVEDB ; Reserved for future use.. SDL_VIDEORESIZE ; User resized video mode SDL_VIDEOEXPOSE ; Screen needs to be redrawn SDL_EVENT_RESERVED2 ; Reserved for future use.. SDL_EVENT_RESERVED3 ; Reserved for future use.. SDL_EVENT_RESERVED4 ; Reserved for future use.. SDL_EVENT_RESERVED5 ; Reserved for future use.. SDL_EVENT_RESERVED6 ; Reserved for future use.. SDL_EVENT_RESERVED7 ; Reserved for future use.. SDL_USEREVENT ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use SDL_NUMEVENTS SDL_ACTIVEEVENTMASK SDL_KEYDOWNMASK SDL_KEYUPMASK SDL_MOUSEMOTIONMASK SDL_MOUSEBUTTONDOWNMASK SDL_MOUSEBUTTONUPMASK SDL_MOUSEEVENTMASK SDL_JOYAXISMOTIONMASK SDL_JOYBALLMOTIONMASK SDL_JOYHATMOTIONMASK SDL_JOYBUTTONDOWNMASK SDL_JOYBUTTONUPMASK SDL_JOYEVENTMASK SDL_VIDEORESIZEMASK SDL_VIDEOEXPOSEMASK SDL_QUITMASK SDL_SYSWMEVENTMASK SDL_ALLEVENTS ; General button/key states SDL_PRESSED SDL_RELEASED ; Mouse button states SDL_BUTTON_LEFT SDL_BUTTON_MIDDLE SDL_BUTTON_RIGHT SDL_BUTTON_WHEELUP SDL_BUTTON_WHEELDOWN SDL_BUTTON_LMASK ; = SDL_BUTTON(SDL_BUTTON_LEFT) SDL_BUTTON_MMASK ; = SDL_BUTTON(SDL_BUTTON_MIDDLE) SDL_BUTTON_RMASK ; = SDL_BUTTON(SDL_BUTTON_RIGHT) SDL_QUERY SDL_IGNORE SDL_DISABLE SDL_ENABLE SDL_GL_RED_SIZE SDL_GL_GREEN_SIZE SDL_GL_BLUE_SIZE SDL_GL_ALPHA_SIZE SDL_GL_BUFFER_SIZE SDL_GL_DOUBLEBUFFER SDL_GL_DEPTH_SIZE SDL_GL_STENCIL_SIZE SDL_GL_ACCUM_RED_SIZE SDL_GL_ACCUM_GREEN_SIZE SDL_GL_ACCUM_BLUE_SIZE SDL_GL_ACCUM_ALPHA_SIZE SDL_GL_STEREO SDL_GL_MULTISAMPLEBUFFERS SDL_GL_MULTISAMPLESAMPLES SDL_GL_SWAP_CONTROL SDL_GL_ACCELERATED_VISUAL TTF_STYLE_NORMAL TTF_STYLE_BOLD TTF_STYLE_ITALIC TTF_STYLE_UNDERLINE ) ;--------------------------------------------------------------------------- (import chicken scheme foreign) (use srfi-1) (use srfi-4) (use srfi-13) (use srfi-18) (use lolevel) (foreign-declare #< 1300 # include # include # else # include # endif #else # include #endif #include #include "SDL.h" #include "SDL_ttf.h" #include "SDL_image.h" #include "SDL_rotozoom.h" #include #include "SDL_net.h" EOF ) (include "heap.scm") (include "timer.scm") ;--------------------------------------------------------------------------- ;; The first two components are arbitrary - the main version of the library. ;; The third is the date (YYMMDD, with leading zeros removed). ;; The fourth is a counter just in case we release more than one version in ;; one day. (define *sdl-egg-version* '(0 5 91025 0)) ;--------------------------------------------------------------------------- (define-syntax --sdl-flags (lambda (e r c) `(,(r 'begin) ,@(append-map (lambda (str) (let* ((sym (string->symbol str)) (psym (string->symbol (string-append "-" str)))) `((,(r 'define-foreign-variable) ,psym unsigned-integer ,str) (,(r 'define) ,sym ,psym)))) (cdr e))))) ; Subsystem definitions, for sdl-init etc. (--sdl-flags "SDL_INIT_TIMER" "SDL_INIT_AUDIO" "SDL_INIT_VIDEO" "SDL_INIT_CDROM" "SDL_INIT_JOYSTICK" "SDL_INIT_EVERYTHING" "SDL_INIT_NOPARACHUTE") (--sdl-flags ;; For sdl-creatergbsurface or sdl-setvideomode "SDL_SWSURFACE" "SDL_HWSURFACE" "SDL_ASYNCBLIT" ;; For sdl-setvideomode "SDL_ANYFORMAT" "SDL_HWPALETTE" "SDL_DOUBLEBUF" "SDL_FULLSCREEN" "SDL_OPENGL" "SDL_OPENGLBLIT" "SDL_RESIZABLE" "SDL_NOFRAME" ;; Read-only - internal "SDL_HWACCEL" "SDL_SRCCOLORKEY" "SDL_RLEACCELOK" "SDL_RLEACCEL" "SDL_SRCALPHA" "SDL_PREALLOC" ) ; For sdl-wm-grabinput (--sdl-flags "SDL_GRAB_QUERY" "SDL_GRAB_OFF" "SDL_GRAB_ON") (--sdl-flags "SDL_NOEVENT" ; Unused (do not remove) "SDL_ACTIVEEVENT" ; Application loses/gains visibility "SDL_KEYDOWN" ; Keys pressed "SDL_KEYUP" ; Keys released "SDL_MOUSEMOTION" ; Mouse moved "SDL_MOUSEBUTTONDOWN" ; Mouse button pressed "SDL_MOUSEBUTTONUP" ; Mouse button released "SDL_JOYAXISMOTION" ; Joystick axis motion "SDL_JOYBALLMOTION" ; Joystick trackball motion "SDL_JOYHATMOTION" ; Joystick hat position change "SDL_JOYBUTTONDOWN" ; Joystick button pressed "SDL_JOYBUTTONUP" ; Joystick button released "SDL_QUIT" ; User-requested quit "SDL_SYSWMEVENT" ; System specific event "SDL_EVENT_RESERVEDA" ; Reserved for future use.. "SDL_EVENT_RESERVEDB" ; Reserved for future use.. "SDL_VIDEORESIZE" ; User resized video mode "SDL_VIDEOEXPOSE" ; Screen needs to be redrawn "SDL_EVENT_RESERVED2" ; Reserved for future use.. "SDL_EVENT_RESERVED3" ; Reserved for future use.. "SDL_EVENT_RESERVED4" ; Reserved for future use.. "SDL_EVENT_RESERVED5" ; Reserved for future use.. "SDL_EVENT_RESERVED6" ; Reserved for future use.. "SDL_EVENT_RESERVED7" ; Reserved for future use.. "SDL_USEREVENT" ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use "SDL_NUMEVENTS" ) (--sdl-flags "SDL_ACTIVEEVENTMASK" "SDL_KEYDOWNMASK" "SDL_KEYUPMASK" "SDL_MOUSEMOTIONMASK" "SDL_MOUSEBUTTONDOWNMASK" "SDL_MOUSEBUTTONUPMASK" "SDL_MOUSEEVENTMASK" "SDL_JOYAXISMOTIONMASK" "SDL_JOYBALLMOTIONMASK" "SDL_JOYHATMOTIONMASK" "SDL_JOYBUTTONDOWNMASK" "SDL_JOYBUTTONUPMASK" "SDL_JOYEVENTMASK" "SDL_VIDEORESIZEMASK" "SDL_VIDEOEXPOSEMASK" "SDL_QUITMASK" "SDL_SYSWMEVENTMASK" "SDL_ALLEVENTS" ) ; General button/key states (--sdl-flags "SDL_PRESSED" "SDL_RELEASED" ) ; Mouse button states ; The macro SDL_BUTTON is parameterised, so we have to recreate it as ; a function (define (SDL_BUTTON x) (arithmetic-shift SDL_PRESSED (- x 1))) (--sdl-flags "SDL_BUTTON_LEFT" "SDL_BUTTON_MIDDLE" "SDL_BUTTON_RIGHT" "SDL_BUTTON_WHEELUP" "SDL_BUTTON_WHEELDOWN" "SDL_BUTTON_LMASK" ; = SDL_BUTTON(SDL_BUTTON_LEFT) "SDL_BUTTON_MMASK" ; = SDL_BUTTON(SDL_BUTTON_MIDDLE) "SDL_BUTTON_RMASK" ; = SDL_BUTTON(SDL_BUTTON_RIGHT) ) ; For sdl-eventstate (--sdl-flags "SDL_QUERY" "SDL_IGNORE" "SDL_DISABLE" "SDL_ENABLE") ;--------------------------------------------------------------------------- (define-foreign-variable sizeof-sdl-rect int "sizeof(SDL_Rect)") (define-record sdl-rect buffer) (let ((maker make-sdl-rect)) (set! make-sdl-rect (lambda (x y w h) (let ((r (maker (make-blob sizeof-sdl-rect)))) (sdl-rect-x-set! r x) (sdl-rect-y-set! r y) (sdl-rect-w-set! r w) (sdl-rect-h-set! r h) r)))) (define-record-printer (sdl-rect s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (-sdl-unbox-rect e) (let ((p (##sys#make-pointer))) (if e (##core#inline "C_pointer_to_block" p (sdl-rect-buffer e))) p)) (define-foreign-type SDL_Rect (c-pointer "SDL_Rect") -sdl-unbox-rect) (define sdl-rect-x (foreign-lambda* short ((SDL_Rect c)) "return(c->x);")) (define sdl-rect-y (foreign-lambda* short ((SDL_Rect c)) "return(c->y);")) (define sdl-rect-w (foreign-lambda* unsigned-short ((SDL_Rect c)) "return(c->w);")) (define sdl-rect-h (foreign-lambda* unsigned-short ((SDL_Rect c)) "return(c->h);")) (define sdl-rect-x-set! (foreign-lambda* void ((SDL_Rect c) (short x)) "c->x = x;")) (define sdl-rect-y-set! (foreign-lambda* void ((SDL_Rect c) (short y)) "c->y = y;")) (define sdl-rect-w-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short w)) "c->w = w;")) (define sdl-rect-h-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short h)) "c->h = h;")) ;--------------------------------------------------------------------------- (define-record sdl-pixel-format pointer) (define-record-printer (sdl-pixel-format p out) (for-each (lambda (x) (display x out)) (list "#"))) (define-foreign-type SDL_PixelFormat (c-pointer "SDL_PixelFormat") sdl-pixel-format-pointer make-sdl-pixel-format) (define sdl-pixel-format-bytes-per-pixel (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf)) "return(pf->BytesPerPixel);")) ;--------------------------------------------------------------------------- (define-record sdl-surface pointer) (define-record-printer (sdl-surface s out) (for-each (lambda (x) (display x out)) (list "#"))) (define-foreign-type SDL_Surface (c-pointer "SDL_Surface") sdl-surface-pointer make-sdl-surface) (define (sdl-surface-flags s) ((foreign-lambda* unsigned-integer ((SDL_Surface s)) "return(s->flags);") s)) (define (sdl-surface-pixel-format s) ((foreign-lambda* SDL_PixelFormat ((SDL_Surface s)) "return(s->format);") s)) (define (sdl-surface-width s) ((foreign-lambda* integer ((SDL_Surface s)) "return(s->w);") s)) (define (sdl-surface-height s) ((foreign-lambda* integer ((SDL_Surface s)) "return(s->h);") s)) (define (sdl-surface-pitch s) ((foreign-lambda* unsigned-short ((SDL_Surface s)) "return(s->pitch);") s)) (define (sdl-surface-pixels s) ((foreign-lambda* (c-pointer byte) ((SDL_Surface s)) "return(s->pixels);") s)) ;; Computes the number of bytes of storage pointed to by ;; sdl-surface-pixels. (define (sdl-surface-pixels-length s) (* (sdl-surface-height s) (sdl-surface-pitch s))) ;; Modifies its second argument. (define sdl-get-clip-rect! (foreign-lambda void "SDL_GetClipRect" SDL_Surface SDL_Rect)) ;; Modifies its first argument. (define sdl-set-clip-rect! (foreign-lambda bool "SDL_SetClipRect" SDL_Surface SDL_Rect)) ;; Modifies its first argument. (define sdl-set-color-key! (foreign-lambda int "SDL_SetColorKey" SDL_Surface unsigned-integer unsigned-integer)) ;; Modifies its first argument. (define sdl-set-alpha! (foreign-lambda int "SDL_SetAlpha" SDL_Surface unsigned-integer unsigned-byte)) (define sdl-display-format (foreign-lambda SDL_Surface "SDL_DisplayFormat" SDL_Surface)) (define sdl-display-format-alpha (foreign-lambda SDL_Surface "SDL_DisplayFormatAlpha" SDL_Surface)) (define sdl-convert-surface (foreign-lambda SDL_Surface "SDL_ConvertSurface" SDL_Surface SDL_PixelFormat unsigned-integer)) ;--------------------------------------------------------------------------- ;; NOTE: sdl-init does not work on MacOS X when called from a ;; dynamically-loaded extension. Something internal to Quartz seems to ;; get confused. You must call SDL_Init *directly* from your main ;; program - if your main program is written in Scheme, you need to ;; say something like: ;; ;; (declare (foreign-declare "#include \n")) ;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);") ;; (define (sdl-init flags) (zero? ((foreign-lambda int "SDL_Init" unsigned-integer) flags))) ;; Note: guile-sdl names these 'sdl-init-subsystem' and ;; 'sdl-quit-subsystem', respectively. (define (sdl-init-sub-system flags) (zero? ((foreign-lambda int "SDL_InitSubSystem" unsigned-integer) flags))) (define (sdl-quit-sub-system flags) ((foreign-lambda void "SDL_QuitSubSystem" unsigned-integer) flags)) (define (sdl-quit) ((foreign-lambda void "SDL_Quit"))) (define (sdl-was-init flags) ((foreign-lambda unsigned-integer "SDL_WasInit" unsigned-integer) flags)) (define sdl-set-error! (foreign-lambda* void ((c-string str)) "SDL_SetError(\"%s\", str);")) (define sdl-get-error (foreign-lambda c-string "SDL_GetError")) (define sdl-clear-error! (foreign-lambda void "SDL_ClearError")) ;--------------------------------------------------------------------------- (define (sdl-wm-set-caption title icon) ((foreign-lambda void "SDL_WM_SetCaption" c-string c-string) title icon)) (define (sdl-wm-get-caption-title) ((foreign-lambda* c-string () "char *t, *i;" "SDL_WM_GetCaption(&t, &i);" "return(t);"))) (define (sdl-wm-get-caption-icon) ((foreign-lambda* c-string () "char *t, *i;" "SDL_WM_GetCaption(&t, &i);" "return(i);"))) (define (sdl-wm-get-caption) (values (sdl-wm-get-caption-title) (sdl-wm-get-caption-icon))) (define (sdl-wm-set-icon icon mask) ((foreign-lambda void "SDL_WM_SetIcon" SDL_Surface blob) icon mask)) (define (sdl-wm-iconify-window) (not (zero? ((foreign-lambda integer "SDL_WM_IconifyWindow"))))) (define (sdl-wm-toggle-full-screen surf) (not (zero? ((foreign-lambda integer "SDL_WM_ToggleFullScreen" SDL_Surface) surf)))) (define (sdl-wm-grab-input m) ((foreign-lambda integer "SDL_WM_GrabInput" integer) m)) ;--------------------------------------------------------------------------- ; Milliseconds. (define sdl-get-ticks (foreign-lambda unsigned-integer "SDL_GetTicks")) (define sdl-delay (foreign-lambda void "SDL_Delay" unsigned-integer)) (cond-expand (mingw32 (define get-time-of-day current-seconds)) (else (define get-time-of-day (foreign-lambda* double () "struct timeval tv;" "gettimeofday(&tv, NULL);" "return((double) tv.tv_sec + ((double) tv.tv_usec / 1000000.0));")))) (define-values (sdl-add-absolute-timer! sdl-process-timer-queue!) (make-timer-queue get-time-of-day)) (define (sdl-add-relative-timer! time callback) (sdl-add-absolute-timer! (+ time (get-time-of-day)) callback)) ;--------------------------------------------------------------------------- (define-foreign-variable sizeof-sdl-event int "sizeof(SDL_Event)") (define-record sdl-event buffer) (let ((maker make-sdl-event)) (set! make-sdl-event (lambda () (let ((bv (blob->u8vector (make-blob sizeof-sdl-event)))) (u8vector-set! bv 0 SDL_NOEVENT) (maker (u8vector->blob bv)))))) (define-record-printer (sdl-event s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (-sdl-unbox-event e) (let ((p (##sys#make-pointer))) (##core#inline "C_pointer_to_block" p (sdl-event-buffer e)) p)) (define-foreign-type SDL_Event (c-pointer "SDL_Event") -sdl-unbox-event) (define sdl-event-type (foreign-lambda* unsigned-byte ((SDL_Event e)) "return(e->type);")) (define sdl-event-type-set! (foreign-lambda* void ((SDL_Event e) (unsigned-byte t)) "e->type = t;")) (define-syntax --sdl-event-getter-setter (lambda (f r c) (let ((name (cadr f)) (rest (cddr f))) (let* ((strapp (lambda s (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) (else x))) s)))) (symapp (lambda s (string->symbol (apply strapp s))))) `(,(r 'begin) (,(r 'define) (,(symapp "sdl-event-" name) e) (,(r 'let) ((,(r 't) (,(r 'sdl-event-type) e))) (,(r 'cond) ,@(map (lambda (clause) (apply (lambda (etype mem1 kind) `((,(r '=) ,(r 't) ,etype) ((,(r 'foreign-lambda*) ,kind ((SDL_Event e)) ,(strapp "return(e->"mem1"."name");")) e))) clause)) rest) (,(r 'else) (,(r 'error) ,(string-append "sdl-event-" (symbol->string name) ": cannot extract value from this type of event") (,(r 'sdl-event-type) e)))))) (,(r 'define) (,(symapp "set-sdl-event-" name "!") e v) (,(r 'let) ((t (,(r 'sdl-event-type) e))) (,(r 'cond) ,@(map (lambda (clause) (apply (lambda (etype mem1 kind) `((,(r '=) t ,etype) ((,(r 'foreign-lambda*) void ((SDL_Event e) (,kind v)) ,(strapp "e->"mem1"."name"=v;")) e v))) clause)) rest) (,(r 'else) (,(r 'error) ,(string-append "set-sdl-event-" (symbol->string name) "!" ": cannot update value for this type of event") (,(r 'sdl-event-type) e))))))))))) (--sdl-event-getter-setter gain (SDL_ACTIVEEVENT active bool)) (--sdl-event-getter-setter which (SDL_KEYDOWN key unsigned-byte) (SDL_KEYUP key unsigned-byte) (SDL_MOUSEMOTION motion unsigned-byte) (SDL_MOUSEBUTTONDOWN button unsigned-byte) (SDL_MOUSEBUTTONUP button unsigned-byte) (SDL_JOYAXISMOTION jaxis unsigned-byte) (SDL_JOYBALLMOTION jball unsigned-byte) (SDL_JOYHATMOTION jhat unsigned-byte) (SDL_JOYBUTTONDOWN jbutton unsigned-byte) (SDL_JOYBUTTONUP jbutton unsigned-byte)) (--sdl-event-getter-setter state (SDL_ACTIVEEVENT active unsigned-byte) (SDL_KEYDOWN key unsigned-byte) (SDL_KEYUP key unsigned-byte) (SDL_MOUSEMOTION motion unsigned-byte) (SDL_MOUSEBUTTONDOWN button unsigned-byte) (SDL_MOUSEBUTTONUP button unsigned-byte) (SDL_JOYBUTTONDOWN jbutton unsigned-byte) (SDL_JOYBUTTONUP jbutton unsigned-byte)) (--sdl-event-getter-setter scancode (SDL_KEYDOWN key.keysym unsigned-byte) (SDL_KEYUP key.keysym unsigned-byte)) (--sdl-event-getter-setter sym (SDL_KEYDOWN key.keysym integer) (SDL_KEYUP key.keysym integer)) (--sdl-event-getter-setter mod (SDL_KEYDOWN key.keysym integer) (SDL_KEYUP key.keysym integer)) (--sdl-event-getter-setter unicode (SDL_KEYDOWN key.keysym short) (SDL_KEYUP key.keysym short)) (--sdl-event-getter-setter x (SDL_MOUSEMOTION motion unsigned-short) (SDL_MOUSEBUTTONDOWN button unsigned-short) (SDL_MOUSEBUTTONUP button unsigned-short)) (--sdl-event-getter-setter y (SDL_MOUSEMOTION motion unsigned-short) (SDL_MOUSEBUTTONDOWN button unsigned-short) (SDL_MOUSEBUTTONUP button unsigned-short)) (--sdl-event-getter-setter xrel (SDL_MOUSEMOTION motion short) (SDL_JOYBALLMOTION jball short)) (--sdl-event-getter-setter yrel (SDL_MOUSEMOTION motion short) (SDL_JOYBALLMOTION jball short)) (--sdl-event-getter-setter axis (SDL_JOYAXISMOTION jaxis unsigned-byte)) (--sdl-event-getter-setter ball (SDL_JOYBALLMOTION jball unsigned-byte)) (--sdl-event-getter-setter hat (SDL_JOYHATMOTION jhat unsigned-byte)) (--sdl-event-getter-setter value (SDL_JOYAXISMOTION jaxis short) (SDL_JOYHATMOTION jhat unsigned-byte)) (--sdl-event-getter-setter button (SDL_MOUSEBUTTONDOWN button unsigned-byte) (SDL_MOUSEBUTTONUP button unsigned-byte) (SDL_JOYBUTTONDOWN jbutton unsigned-byte) (SDL_JOYBUTTONUP jbutton unsigned-byte)) (--sdl-event-getter-setter w (SDL_VIDEORESIZE resize integer)) (--sdl-event-getter-setter h (SDL_VIDEORESIZE resize integer)) (define sdl-pump-events (foreign-lambda void "SDL_PumpEvents")) (define (sdl-poll-event! . e) (if (null? e) (not (zero? ((foreign-lambda int "SDL_PollEvent" c-pointer) #f))) (not (zero? ((foreign-lambda int "SDL_PollEvent" SDL_Event) (car e)))))) ;; Now, (sdl-wait-event!) is implemented internally to SDL_event.c as: ;; ;; while (1) { ;; SDL_PumpEvents(); ;; switch(SDL_PeepEvents(event, 1, SDL_GETEVENT, SDL_ALLEVENTS)) { ;; case -1: return 0; ;; case 1: return 1; ;; case 0: SDL_Delay(10); ;; } ;; } ;; ;; Since the SDL implementation of timers uses setitimer(2), and we ;; have trouble with setitimer and chicken - see the README - we ;; reimplement (sdl-wait-event!) here calling out to our timer queue ;; processing function. (define (sdl-wait-event!* delay-function . e) (let loop () (sdl-pump-events) (let ((peep-result ((foreign-lambda* int ((SDL_Event eptr)) "return(SDL_PeepEvents(eptr, 1, SDL_GETEVENT, SDL_ALLEVENTS));") (if (null? e) #f (car e))))) (case peep-result ((-1) #f) ;; error. ((1) #t) ;; present event. ((0) ;; No event, yet. Check our timer queue, wait, and retry. (let* ((delay-seconds (or (sdl-process-timer-queue!) 0.01)) (sleep-time (min delay-seconds 0.01)) (fix-sleep-time (inexact->exact (truncate (* 1000 sleep-time))))) (delay-function fix-sleep-time) (loop))) (else (error "sdl-wait-event!: unexpected result from SDL_PeepEvents" peep-result)))))) (define (sdl-wait-event! . e) (apply sdl-wait-event!* sdl-delay e)) ;; Here's the implementation of (sdl-wait-event!) that calls the ;; SDL-provided routine: ;; ;; (define (sdl-wait-event! . e) ;; (if (null? e) ;; (not (zero? ((foreign-lambda int "SDL_WaitEvent" c-pointer) #f))) ;; (not (zero? ((foreign-lambda int "SDL_WaitEvent" SDL_Event) (car e)))))) (define (sdl-push-event e) (zero? ((foreign-lambda int "SDL_PushEvent" SDL_Event) e))) (define sdl-event-state! (foreign-lambda int "SDL_EventState" unsigned-int integer)) ; You can pass NULL for the args if you just want the button state (define sdl-get-mouse-state (foreign-lambda int "SDL_GetMouseState" s32vector s32vector)) (define sdl-enable-unicode (foreign-lambda bool "SDL_EnableUNICODE" bool)) ;--------------------------------------------------------------------------- (define sdl-get-video-surface (foreign-lambda SDL_Surface "SDL_GetVideoSurface")) (define (sdl-video-driver-name) (let ((bv (make-blob 128 0))) (and ((foreign-lambda bool "SDL_VideoDriverName" blob integer) bv (blob-size bv)) (string-trim-right (blob->string bv) (integer->char 0))))) (define sdl-set-video-mode (foreign-lambda SDL_Surface "SDL_SetVideoMode" integer ; width integer ; height integer ; bpp unsigned-integer ; flags )) (define (sdl-video-mode-ok w h bpp flags) (let ((result ((foreign-lambda integer "SDL_VideoModeOK" integer integer integer unsigned-integer) w h bpp flags))) (and (not (zero? result)) result))) (define (sdl-show-cursor . toggle) (if (null? toggle) ((foreign-lambda int "SDL_ShowCursor" int) -1) ((foreign-lambda int "SDL_ShowCursor" int) (if (car toggle) 1 0)))) (define sdl-map-rgb (foreign-lambda unsigned-integer "SDL_MapRGB" SDL_PixelFormat unsigned-byte unsigned-byte unsigned-byte)) (define sdl-map-rgba (foreign-lambda unsigned-integer "SDL_MapRGBA" SDL_PixelFormat unsigned-byte unsigned-byte unsigned-byte unsigned-byte)) ;--------------------------------------------------------------------------- (define (sdl-fill-rect s r c) (if (sdl-color? c) ((foreign-lambda* int ((SDL_Surface s) (SDL_Rect r) (scheme-pointer cbuf)) "SDL_Color *c = (SDL_Color *) cbuf;" "unsigned int c2 = SDL_MapRGB(s->format, c->r, c->g, c->b);" "return(SDL_FillRect(s, r, c2));") s r (sdl-color-buffer c)) ((foreign-lambda int "SDL_FillRect" SDL_Surface SDL_Rect unsigned-integer) s r c))) (define sdl-flip (foreign-lambda int "SDL_Flip" SDL_Surface)) (define sdl-create-rgb-surface (foreign-lambda SDL_Surface "SDL_CreateRGBSurface" unsigned-integer ; flags integer ; width integer ; height integer ; depth unsigned-integer ; rmask unsigned-integer ; gmask unsigned-integer ; bmask unsigned-integer)) ; amask (define sdl-free-surface (foreign-lambda void "SDL_FreeSurface" SDL_Surface)) (define sdl-blit-surface (foreign-lambda integer "SDL_BlitSurface" SDL_Surface SDL_Rect ; src, srcrect SDL_Surface SDL_Rect)) ; dst, dstrect (define (sdl-with-clip-rect s r thunk) (let ((orig-clip-rect (make-sdl-rect 0 0 0 0))) (dynamic-wind (lambda () (sdl-get-clip-rect! s orig-clip-rect) (sdl-set-clip-rect! s r)) thunk (lambda () (sdl-set-clip-rect! s orig-clip-rect))))) ;--------------------------------------------------------------------------- (define-foreign-variable sizeof-sdl-color int "sizeof(SDL_Color)") (define-record sdl-color buffer) (let ((maker make-sdl-color)) (set! make-sdl-color (lambda (r g b) (let ((bv (make-blob sizeof-sdl-color))) (fill-sdl-color! (maker bv) r g b))))) (define-record-printer (sdl-color s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (-sdl-unbox-color e) (let ((p (##sys#make-pointer))) (##core#inline "C_pointer_to_block" p (sdl-color-buffer e)) p)) (define-foreign-type SDL_Color (c-pointer "SDL_Color") -sdl-unbox-color) (define (fill-sdl-color! c r g b) ((foreign-lambda* void ((SDL_Color c) (unsigned-byte r) (unsigned-byte g) (unsigned-byte b)) "c->r = r; c->g = g; c->b = b;") c r g b) c) (define sdl-color-r (foreign-lambda* unsigned-byte ((SDL_Color c)) "return(c->r);")) (define sdl-color-g (foreign-lambda* unsigned-byte ((SDL_Color c)) "return(c->g);")) (define sdl-color-b (foreign-lambda* unsigned-byte ((SDL_Color c)) "return(c->b);")) ;--------------------------------------------------------------------------- (define-record sdl-joystick pointer) (define-record-printer (sdl-joystick p out) (for-each (lambda (x) (display x out)) (list "#"))) (define-foreign-type SDL_Joystick (c-pointer "SDL_Joystick") sdl-joystick-pointer make-sdl-joystick) (define sdl-joystick-event-state (foreign-lambda int "SDL_JoystickEventState" int)) (define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate")) (define sdl-num-joysticks (foreign-lambda int "SDL_NumJoysticks")) (define sdl-joystick-name (foreign-lambda c-string "SDL_JoystickName" int)) (define sdl-joystick-open (foreign-lambda SDL_Joystick "SDL_JoystickOpen" int)) (define sdl-joystick-opened (foreign-lambda int "SDL_JoystickOpened" int)) (define sdl-joystick-index (foreign-lambda int "SDL_JoystickIndex" SDL_Joystick)) (define sdl-joystick-num-axes (foreign-lambda int "SDL_JoystickNumAxes" SDL_Joystick)) (define sdl-joystick-num-balls (foreign-lambda int "SDL_JoystickNumBalls" SDL_Joystick)) (define sdl-joystick-num-hats (foreign-lambda int "SDL_JoystickNumHats" SDL_Joystick)) (define sdl-joystick-num-buttons (foreign-lambda int "SDL_JoystickNumButtons" SDL_Joystick)) (define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate")) (define sdl-joystick-get-axis (foreign-lambda short "SDL_JoystickGetAxis" SDL_Joystick int)) (define sdl-joystick-get-hat (foreign-lambda unsigned-char "SDL_JoystickGetHat" SDL_Joystick int)) (define sdl-joystick-get-button (foreign-lambda unsigned-char "SDL_JoystickGetButton" SDL_Joystick int)) ;TODO: sdl-joystick-get-ball (define sdl-joystick-close (foreign-lambda void "SDL_JoystickClose" SDL_Joystick)) ;--------------------------------------------------------------------------- ; ; OpenGL stuff: (--sdl-flags "SDL_GL_RED_SIZE" "SDL_GL_GREEN_SIZE" "SDL_GL_BLUE_SIZE" "SDL_GL_ALPHA_SIZE" "SDL_GL_BUFFER_SIZE" "SDL_GL_DOUBLEBUFFER" "SDL_GL_DEPTH_SIZE" "SDL_GL_STENCIL_SIZE" "SDL_GL_ACCUM_RED_SIZE" "SDL_GL_ACCUM_GREEN_SIZE" "SDL_GL_ACCUM_BLUE_SIZE" "SDL_GL_ACCUM_ALPHA_SIZE" "SDL_GL_STEREO" "SDL_GL_MULTISAMPLEBUFFERS" "SDL_GL_MULTISAMPLESAMPLES" "SDL_GL_SWAP_CONTROL" "SDL_GL_ACCELERATED_VISUAL") (define sdl-gl-swap-buffers (foreign-lambda void "SDL_GL_SwapBuffers")) (define sdl-gl-set-attribute (foreign-lambda int "SDL_GL_SetAttribute" unsigned-int int)) (define sdl-gl-get-attribute (let ((get (foreign-lambda int "SDL_GL_GetAttribute" unsigned-int (c-pointer int)))) (lambda (attr) (let-location ((ptr int)) (let ((r (get attr (location ptr)))) (and (zero? r) ptr)))))) ;--------------------------------------------------------------------------- (define-record ttf-font pointer) (define-record-printer (ttf-font f out) (for-each (lambda (x) (display x out)) (list "#"))) (define (make-ttf-font* pointer) (and pointer (make-ttf-font pointer))) (define-foreign-type TTF_Font (c-pointer "TTF_Font") ttf-font-pointer make-ttf-font*) (define ttf-init (foreign-lambda integer "TTF_Init")) (define ttf-was-init (foreign-lambda integer "TTF_WasInit")) (define ttf-quit (foreign-lambda void "TTF_Quit")) (define ttf-open-font (foreign-lambda TTF_Font "TTF_OpenFont" c-string integer)) (define ttf-open-font-index (foreign-lambda TTF_Font "TTF_OpenFontIndex" c-string integer long)) (define ttf-close-font (foreign-lambda void "TTF_CloseFont" TTF_Font)) (--sdl-flags "TTF_STYLE_NORMAL" "TTF_STYLE_BOLD" "TTF_STYLE_ITALIC" "TTF_STYLE_UNDERLINE") (define ttf-get-font-style (foreign-lambda integer "TTF_GetFontStyle" TTF_Font)) (define ttf-set-font-style (foreign-lambda void "TTF_SetFontStyle" TTF_Font integer)) (define ttf-font-height (foreign-lambda integer "TTF_FontHeight" TTF_Font)) (define ttf-font-ascent (foreign-lambda integer "TTF_FontAscent" TTF_Font)) (define ttf-font-descent (foreign-lambda integer "TTF_FontDescent" TTF_Font)) (define ttf-font-line-skip (foreign-lambda integer "TTF_FontLineSkip" TTF_Font)) (define ttf-font-faces (foreign-lambda long "TTF_FontFaces" TTF_Font)) (define ttf-font-face-is-fixed-width? (foreign-lambda bool "TTF_FontFaceIsFixedWidth" TTF_Font)) (define ttf-font-face-family-name (foreign-lambda c-string "TTF_FontFaceFamilyName" TTF_Font)) (define ttf-font-face-style-name (foreign-lambda c-string "TTF_FontFaceStyleName" TTF_Font)) (define ttf-size-text! (foreign-lambda* bool ((TTF_Font font) (c-string text) (SDL_Rect rect)) "int ww, hh;" "int status = TTF_SizeText(font, text, &ww, &hh);" "if (status == 0) { rect->w = ww; rect->h = hh; }" "return((status == 0));")) (define ttf-size-utf8! (foreign-lambda* bool ((TTF_Font font) (c-string text) (SDL_Rect rect)) "int ww, hh;" "int status = TTF_SizeUTF8(font, text, &ww, &hh);" "if (status == 0) { rect->w = ww; rect->h = hh; }" "return((status == 0));")) (define ttf-render-text-solid (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "return(TTF_RenderText_Solid(font,text,*fg));")) (define ttf-render-utf8-solid (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "return(TTF_RenderUTF8_Solid(font,text,*fg));")) (define ttf-render-text-shaded (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg) (SDL_Color bg)) "return(TTF_RenderText_Shaded(font,text,*fg,*bg));")) (define ttf-render-utf8-shaded (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg) (SDL_Color bg)) "return(TTF_RenderUTF8_Shaded(font,text,*fg,*bg));")) (define ttf-render-text-blended (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "return(TTF_RenderText_Blended(font,text,*fg));")) (define ttf-render-utf8-blended (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "return(TTF_RenderUTF8_Blended(font,text,*fg));")) ;--------------------------------------------------------------------------- (define img-load (foreign-lambda SDL_Surface "IMG_Load" c-string)) ;--------------------------------------------------------------------------- (define rotozoom-surface (foreign-lambda SDL_Surface "rotozoomSurface" SDL_Surface ; src double ; angle double ; zoom bool)) ; smooth (define zoom-surface (foreign-lambda SDL_Surface "zoomSurface" SDL_Surface ; src double ; zoomx double ; zoomy bool)) ; smooth ;--------------------------------------------------------------------------- (define-foreign-variable sizeof-sdl-ip-address int "sizeof(IPaddress)") (define-record sdl-ip-address buffer) (let ((maker make-sdl-ip-address)) (set! make-sdl-ip-address (lambda (a b c d p) (let* ((bv (make-blob sizeof-sdl-ip-address)) (addr (maker bv))) ((foreign-lambda* void ((blob bv) (unsigned-integer host) (unsigned-short port)) "IPaddress *ipa = (IPaddress *) bv;" "ipa->host = host;" "ipa->port = htons(port);") bv (+ (* a 16777216) (* b 65536) (* c 256) d) p) addr)))) (define-record-printer (sdl-ip-address s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (-sdl-unbox-ip-address e) (let ((p (##sys#make-pointer))) (if e (##core#inline "C_pointer_to_block" p (sdl-ip-address-buffer e))) p)) (define-foreign-type IPaddress (c-pointer "IPaddress") -sdl-unbox-ip-address) (define sdl-ip-address-a (foreign-lambda* unsigned-byte ((IPaddress a)) "return(((char *)&(a->host))[0]);")) (define sdl-ip-address-b (foreign-lambda* unsigned-byte ((IPaddress a)) "return(((char *)&(a->host))[1]);")) (define sdl-ip-address-c (foreign-lambda* unsigned-byte ((IPaddress a)) "return(((char *)&(a->host))[2]);")) (define sdl-ip-address-d (foreign-lambda* unsigned-byte ((IPaddress a)) "return(((char *)&(a->host))[3]);")) (define sdl-ip-address-port (foreign-lambda* unsigned-short ((IPaddress a)) "return(ntohs(a->port));")) (define sdl-ip-address-port-set! (foreign-lambda* void ((IPaddress a) (unsigned-short p)) "a->port = htons(p);")) ;--------------------------------------------------------------------------- (define-record sdl-tcp-socket pointer) (define-record-printer (sdl-tcp-socket s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (make-sdl-tcp-socket* pointer) (and pointer (make-sdl-tcp-socket pointer))) (define-foreign-type TCPsocket (c-pointer (struct "_TCPsocket")) sdl-tcp-socket-pointer make-sdl-tcp-socket*) ;--------------------------------------------------------------------------- (define sdl-net-init (foreign-lambda int "SDLNet_Init")) (define sdl-net-quit (foreign-lambda void "SDLNet_Quit")) (define sdl-net-resolve-host! (foreign-lambda int "SDLNet_ResolveHost" IPaddress c-string unsigned-short)) (define sdl-net-resolve-ip (foreign-lambda c-string "SDLNet_ResolveIP" IPaddress)) (define (sdl-net-resolve-host hostname port) (let ((ipa (make-sdl-ip-address 0 0 0 0 0))) (and (zero? (sdl-net-resolve-host! ipa hostname port)) ipa))) (define (-sdl-register-socket sock) (and sock (begin (set-finalizer! sock sdl-net-tcp-close) sock))) (define (sdl-net-tcp-open ipa) (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Open" IPaddress) ipa))) (define (sdl-net-tcp-accept serv) (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Accept" TCPsocket) serv))) (define (sdl-net-tcp-get-peer-address sock) (let ((ipa (make-sdl-ip-address 0 0 0 0 0))) (if ((foreign-lambda* bool ((TCPsocket sock) (IPaddress ipa)) "IPaddress *result = SDLNet_TCP_GetPeerAddress(sock);" "if (result != NULL) {" " *ipa = *result;" " return(1);" "} else {" " return(0);" "}") sock ipa) ipa #f))) (define (sdl-net-tcp-send sock bv) ((foreign-lambda int "SDLNet_TCP_Send" TCPsocket blob integer) sock bv (blob-size bv))) (define sdl-net-tcp-recv (foreign-lambda int "SDLNet_TCP_Recv" TCPsocket blob integer)) (define (sdl-net-tcp-close sock) (if (sdl-tcp-socket-pointer sock) (begin ((foreign-lambda void "SDLNet_TCP_Close" TCPsocket) sock) (sdl-tcp-socket-pointer-set! sock #f)))) (define (sdl-net-tcp-send-string sock str) (sdl-net-tcp-send sock (string->blob str))) (define (sdl-net-tcp-recv-string sock buflen) (let* ((bv (make-blob buflen)) (result (sdl-net-tcp-recv sock bv buflen))) (if (positive? result) (substring (blob->string bv) 0 result) result))) ;--------------------------------------------------------------------------- (define-record sdl-net-socket-set pointer) (define-record-printer (sdl-net-socket-set s out) (for-each (lambda (x) (display x out)) (list "#"))) (define (make-sdl-net-socket-set* pointer) (and pointer (make-sdl-net-socket-set pointer))) (define-foreign-type SDLNet_SocketSet (c-pointer (struct "_SDLNet_SocketSet")) sdl-net-socket-set-pointer make-sdl-net-socket-set*) ;--------------------------------------------------------------------------- (define sdl-net-alloc-socket-set (foreign-lambda SDLNet_SocketSet "SDLNet_AllocSocketSet" int)) (define sdl-net-free-socket-set (foreign-lambda void "SDLNet_FreeSocketSet" SDLNet_SocketSet)) (define sdl-net-tcp-add-socket! (foreign-lambda int "SDLNet_TCP_AddSocket" SDLNet_SocketSet TCPsocket)) (define sdl-net-tcp-del-socket! (foreign-lambda int "SDLNet_TCP_DelSocket" SDLNet_SocketSet TCPsocket)) (define (sdl-net-check-sockets socket-set timeout) ;; timeout in milliseconds (let ((result ((foreign-lambda int "SDLNet_CheckSockets" SDLNet_SocketSet unsigned-integer) socket-set timeout))) (if (= result -1) #f result))) (define sdl-net-socket-ready? (foreign-lambda bool "SDLNet_SocketReady" TCPsocket)) ;--------------------------------------------------------------------------- (define sdl-net-write-16 (foreign-lambda* void ((blob bv) (int offset) (unsigned-short value)) "SDLNet_Write16(value, &bv[offset]);")) (define sdl-net-write-32 (foreign-lambda* void ((blob bv) (int offset) (unsigned-integer value)) "SDLNet_Write32(value, &bv[offset]);")) (define sdl-net-read-16 (foreign-lambda* unsigned-short ((blob bv) (int offset)) "return(SDLNet_Read16(&bv[offset]));")) (define sdl-net-read-32 (foreign-lambda* unsigned-integer ((blob bv) (int offset)) "return(SDLNet_Read32(&bv[offset]));")) )