klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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