ffi-sdl.k (6505B)
1 ;; 2 ;; Dynamic FFI example. 3 ;; Interfacing Simple DirectMedia Layer Library. 4 ;; 5 ;; Tested with SDL 1.2 on Debian Squeeze, x86. 6 ;; It is quite likely that this program will not work 7 ;; with other versions and other operating systems. 8 ;; 9 ;; Dynamic FFI is inherently unsafe. The user is responsible 10 ;; for specifying correct argument types, data structure 11 ;; layout, alignment, etc. even though it is platform dependent. 12 ;; 13 ;; usage: 14 ;; .../src$ make posix USE_LIBFFI=1 15 ;; .../src$ ./klisp examples/ffi-sdl.k 16 ;; 17 ;; The program shall create a window and responding 18 ;; to mouse click. 19 ;; 20 21 ($define! sdl-import 22 ($let 23 ( (libsdl (ffi-load-library "libSDL.so")) 24 (abi "FFI_DEFAULT_ABI")) 25 ($lambda (rtype name . args) 26 (ffi-make-applicative libsdl name 27 (ffi-make-call-interface abi rtype args))))) 28 29 ($define! SDL_INIT_TIMER #x00000001) 30 ($define! SDL_INIT_AUDIO #x00000010) 31 ($define! SDL_INIT_VIDEO #x00000020) 32 ($define! SDL_INIT_NOPARACHUTE #x01000000) 33 34 ($define! sdl-init (sdl-import "sint" "SDL_Init" "uint32")) 35 ($define! sdl-quit (sdl-import "void" "SDL_Quit")) 36 37 ($define! SDL_SWSURFACE #x00000000) 38 ($define! SDL_HWSURFACE #x00000001) 39 40 ($define! sdl-set-video-mode (sdl-import "pointer" "SDL_SetVideoMode" "sint" "sint" "sint" "uint32")) 41 ($define! sdl-wm-set-caption (sdl-import "void" "SDL_WM_SetCaption" "string" "pointer")) 42 43 ($define! sdl-wait-event 44 ($let 45 ((SDL_WaitEvent (sdl-import "sint" "SDL_WaitEvent" "pointer"))) 46 ($lambda () 47 ($let* 48 ( (buffer (make-bytevector 512)) 49 (ok (SDL_WaitEvent buffer))) 50 ($if (zero? ok) 51 (error "SDL_WaitEvent signalled error") 52 buffer))))) 53 54 ($define! align 55 ($lambda (offset alignment) 56 (+ offset (mod (- alignment (mod offset alignment)) alignment)))) 57 58 ($define! $quote 59 ($vau (x) denv x)) 60 61 ($define! $define-struct-projectors! 62 ($letrec* 63 ( (aux 64 ($lambda (fields offset denv) 65 ($if (null? fields) 66 () 67 ($let* 68 ( (((projector-name type-string) . tail) fields) 69 ((size alignment ref set!) (ffi-type-suite type-string)) 70 (aligned-offset (align offset alignment)) 71 (projector-function ($lambda (blob) (ref (list blob aligned-offset))))) 72 (write (list projector-name size alignment aligned-offset)) 73 (newline) 74 (eval 75 (list 76 ($quote $define!) 77 projector-name 78 (list ($quote $quote) projector-function)) 79 denv) 80 (aux tail (+ size aligned-offset) denv)))))) 81 ($vau fields denv 82 (aux fields 0 denv)))) 83 84 ($define! SDL_QUIT 12) 85 ($define! SDL_MOUSEMOTION 4) 86 ($define! SDL_MOUSEBUTTONDOWN 5) 87 ($define! SDL_MOUSEBUTTONUP 6) 88 89 ($define-struct-projectors! 90 (event-type "uint8")) 91 92 ($define-struct-projectors! 93 (MouseMotionEvent.type "uint8") 94 (MouseMotionEvent.state "uint8") 95 (MouseMotionEvent.which "uint8") 96 (MouseMotionEvent.x "uint16") 97 (MouseMotionEvent.y "uint16") 98 (MouseMotionEvent.xrel "sint16") 99 (MouseMotionEvent.yrel "sint16")) 100 101 ($define-struct-projectors! 102 (MouseButtonEvent.type "uint8") 103 (MouseButtonEvent.which "uint8") 104 (MouseButtonEvent.button "uint8") 105 (MouseButtonEvent.state "uint8") 106 (MouseButtonEvent.x "uint16") 107 (MouseButtonEvent.y "uint16")) 108 109 ($define! with-sdl 110 ($lambda (window-title worker) 111 (display "Initializing SDL...") 112 ($let ((status (sdl-init SDL_INIT_VIDEO))) 113 (write status) 114 (newline) 115 ($if (<? status 0) 116 (error "error initializing SDL") 117 ($sequence 118 (guard-dynamic-extent 119 () 120 ($lambda () 121 ($let* ((screen (sdl-set-video-mode 640 480 32 SDL_HWSURFACE))) 122 ($if (null? screen) 123 (error "unable to set video mode") 124 ($sequence 125 (sdl-wm-set-caption window-title ()) 126 (worker screen))))) 127 (list 128 (list 129 error-continuation 130 ($lambda (v divert) 131 (display "Error. Deinitializing SDL...") 132 (sdl-quit) 133 (display "done.") 134 (newline) 135 v)))) 136 (display "Finished. Deinitializing SDL...") 137 (sdl-quit) 138 (display "done.") 139 (newline)))))) 140 141 ($define-struct-projectors! 142 (SDL_Surface.flags "uint32") 143 (SDL_Surface.format "pointer") 144 (SDL_Surface.w "sint") 145 (SDL_Surface.h "sint") 146 (SDL_Surface.pitch "uint16") 147 (SDL_Surface.pixels "pointer") 148 (SDL_Surface.offset "sint")) 149 150 ($define! draw-pixel 151 ($let 152 ( ((pixel-size pixel-alignment pixel-ref pixel-set!) (ffi-type-suite "uint32")) 153 (SDL_MapRGB (sdl-import "uint32" "SDL_MapRGB" "pointer" "uint8" "uint8" "uint8")) 154 (SDL_LockSurface (sdl-import "sint" "SDL_LockSurface" "pointer")) 155 (SDL_UnlockSurface (sdl-import "void" "SDL_UnlockSurface" "pointer")) 156 (SDL_Flip (sdl-import "sint" "SDL_Flip" "pointer"))) 157 ($lambda (screen (x y) (r g b)) 158 ($if (<? (SDL_LockSurface screen) 0) 159 (error "SDL_LockSurface failed") 160 ()) 161 ($let 162 ( (pixels (SDL_Surface.pixels screen)) 163 (pitch (SDL_Surface.pitch screen)) 164 (color (SDL_MapRGB (SDL_Surface.format screen) r g b))) 165 ;(display (list color x y pixel-size pitch (SDL_Surface.flags screen))) 166 (pixel-set! 167 (list pixels (+ (* x pixel-size) (* y pitch))) 168 color)) 169 (SDL_UnlockSurface screen) 170 (SDL_Flip screen)))) 171 172 ($define! event-loop 173 ($lambda (screen drawing) 174 ($let* 175 ( (ev (sdl-wait-event)) 176 (t (event-type ev))) 177 ($cond 178 ( (equal? t SDL_QUIT) 179 ()) 180 ( (and? drawing (equal? t SDL_MOUSEMOTION)) 181 (draw-pixel 182 screen 183 (list (MouseMotionEvent.x ev) (MouseMotionEvent.y ev)) 184 (list 0 255 0)) 185 (event-loop screen #t)) 186 ( (equal? t SDL_MOUSEBUTTONDOWN) 187 (draw-pixel 188 screen 189 (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev)) 190 (list 255 0 0)) 191 (event-loop screen #t)) 192 ( (equal? t SDL_MOUSEBUTTONUP) 193 (draw-pixel 194 screen 195 (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev)) 196 (list 0 0 255)) 197 (event-loop screen #f)) 198 (#t 199 (event-loop screen drawing)))))) 200 201 (with-sdl "klisp ffi demo" 202 ($lambda (screen) (event-loop screen #f))) 203