Changeset 27337 in project


Ignore:
Timestamp:
08/30/12 12:17:32 (9 years ago)
Author:
megane
Message:

sdl-ttf: - supports whatever the sdl egg supported + some functionality to extract glyph metrics

Location:
release/4/sdl-ttf/trunk
Files:
2 added
3 edited

Legend:

Unmodified
Added
Removed

  • release/4/sdl-ttf/trunk/sdl-ttf.meta

    r27336 r27337  
    1 ;;; sdl.meta -*- Hen -*-
     1;;; sdl-ttf.meta -*- scheme -*-
    22
    33((category graphics)
    4  (author "Tony Garnock-Jones")
    5  (synopsis "Basic SDL support")
     4 (author "")
     5 (synopsis "SDL-ttf support")
    66 (license "LGPL-2.1")
    7  (doc-from-wiki)
    8  (egg "sdl.egg")
    9  (files "COPYING" "Makefile" "timer.scm" "sdl.release-info" "test-sdl-body.scm" "sdl-csi.scm" "test-heap.scm" "sdl.meta" "sdl.scm" "heap.scm" "test-net.scm" "sdl.setup" "unknown2-scale8.jpg" "test-sdl.scm"))
     7 (egg "sdl-ttf.egg")
     8 (files "COPYING"
     9        "Makefile"
     10        "sdl-ttf.meta"
     11        "sdl-ttf.scm"
     12        "sdl-ttf.setup"))

  • release/4/sdl-ttf/trunk/sdl-ttf.scm

    r27336 r27337  
    1 ;;;; sdl.scm - Simple SDL binding for Chicken
    21; Copyright (C) 2002-2004 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
    32;
    … …  
    1615; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
    1716; USA
    18 
    19 ; ---------------------------------------------------------------------------
    20 
    21 (module sdl
    22 
    23 ( *sdl-egg-version*
    24 
    25   SDL_BUTTON
    26   sdl-version-major
    27   sdl-version-minor
    28   sdl-version-patch
    29   sdl-version-at-least
    30   sdl-compiled-version
    31   sdl-linked-version
    32   ; sdl gfx
    33   make-sdl-rect
    34   sdl-rect?
    35   sdl-rect-x
    36   sdl-rect-y
    37   sdl-rect-w
    38   sdl-rect-h
    39   make-sdl-pixel-format
    40   sdl-pixel-format?
    41   sdl-pixel-format-bytes-per-pixel
    42   sdl-pixel-format-rmask
    43   sdl-pixel-format-gmask
    44   sdl-pixel-format-bmask
    45   sdl-pixel-format-amask
    46   sdl-surface-flags
    47   sdl-surface-pixel-format
    48   sdl-surface-width
    49   sdl-surface-height
    50   sdl-surface-pitch
    51   sdl-surface-pixels
    52   sdl-surface-pixels-length
    53   sdl-get-video-info
    54   sdl-video-info-hw-available
    55   sdl-video-info-wm-available
    56   sdl-video-info-blit-hw
    57   sdl-video-info-blit-hw-cc
    58   sdl-video-info-blit-hw-a
    59   sdl-video-info-blit-sw
    60   sdl-video-info-blit-sw-cc
    61   sdl-video-info-blit-sw-a
    62   sdl-video-info-blit-fill
    63   sdl-video-info-video-mem
    64   sdl-video-info-vfmt
    65   sdl-video-info-current-w
    66   sdl-video-info-current-h
    67   sdl-get-clip-rect!
    68   sdl-set-clip-rect!
    69   sdl-set-color-key!
    70   sdl-set-alpha!
    71   sdl-display-format
    72   sdl-display-format-alpha
    73   sdl-convert-surface
    74 
    75   ; sdl system stuff
    76   sdl-init
    77   sdl-init-sub-system
    78   sdl-quit-sub-system
    79   sdl-quit
    80   sdl-was-init
    81   sdl-get-error
    82   sdl-clear-error!
    83   sdl-wm-set-caption
    84   sdl-wm-get-caption-title
    85   sdl-wm-get-caption-icon
    86   sdl-wm-get-caption
    87   sdl-wm-set-icon
    88   sdl-wm-iconify-window
    89   sdl-wm-toggle-full-screen
    90   sdl-wm-grab-input
    91   sdl-get-ticks
    92   sdl-delay
    93   timer?
    94   get-time-of-day
    95   get-time-of-day
    96   sdl-add-relative-timer!
    97   make-sdl-event
    98   sdl-event?
    99   sdl-event-type
    100   sdl-pump-events
    101   sdl-poll-event!
    102   sdl-wait-event!*
    103   sdl-wait-event!
    104   sdl-push-event
    105   sdl-event-state!
    106   sdl-get-mouse-state
    107   sdl-warp-mouse
    108   sdl-enable-unicode
    109   sdl-get-video-surface
    110   sdl-video-driver-name
    111   sdl-set-video-mode
    112   sdl-video-mode-ok
    113   sdl-show-cursor
    114   sdl-map-rgb
    115   sdl-map-rgba
    116   sdl-fill-rect
    117   sdl-flip
    118   sdl-surface?
    119   sdl-create-rgb-surface
    120   sdl-free-surface
    121   sdl-blit-surface
    122   sdl-with-clip-rect
    123   make-sdl-color
    124   sdl-color?
    125   sdl-color-r
    126   sdl-color-g
    127   sdl-color-b
    128 
    129   make-sdl-joystick
    130   sdl-joystick?
    131   sdl-joystick-event-state
    132   sdl-joystick-update
    133   sdl-num-joysticks
    134   sdl-joystick-name
    135   sdl-joystick-open
    136   sdl-joystick-opened
    137   sdl-joystick-index
    138   sdl-joystick-num-axes
    139   sdl-joystick-num-balls
    140   sdl-joystick-num-hats
    141   sdl-joystick-num-buttons
    142   sdl-joystick-update
    143   sdl-joystick-get-axis
    144   sdl-joystick-get-hat
    145   sdl-joystick-get-button
    146   sdl-joystick-close
    147   sdl-gl-swap-buffers
    148   sdl-gl-set-attribute
    149   sdl-gl-get-attribute
    150 
    151   ; SDL ttf
    152   ttf-init
     17(module sdl-ttf
     18
     19( ttf-init
    15320  ttf-was-init
    15421  ttf-quit
    … …  
    16229  ttf-get-font-style
    16330  ttf-set-font-style
     31  ttf-size-text!
     32  ttf-size-utf8!
     33 
    16434  ttf-font-height
    16535  ttf-font-ascent
    … …  
    17040  ttf-font-face-family-name
    17141  ttf-font-face-style-name
    172   ttf-size-text!
    173   ttf-size-utf8!
     42 
    17443  ttf-render-text-solid
    17544  ttf-render-utf8-solid
    … …  
    18251  ttf-render-glyph-blended
    18352
    184   ; SDL image
    185   img-init
    186   img-quit
    187   img-load
    188   rotozoom-surface
    189   zoom-surface
    190 
    191   ;SDL net
    192   make-sdl-ip-address
    193   sdl-ip-address?
    194   sdl-ip-address-a
    195   sdl-ip-address-b
    196   sdl-ip-address-c
    197   sdl-ip-address-d
    198   sdl-ip-address-port
    199   sdl-net-init
    200   sdl-net-quit
    201   sdl-net-resolve-host!
    202   sdl-net-resolve-ip
    203   sdl-net-resolve-host
    204   make-sdl-tcp-socket
    205   sdl-tcp-socket?
    206   sdl-net-tcp-open
    207   sdl-net-tcp-accept
    208   sdl-net-tcp-get-peer-address
    209   sdl-net-tcp-send
    210   sdl-net-tcp-recv
    211   sdl-net-tcp-close
    212   sdl-net-tcp-send-string
    213   sdl-net-tcp-recv-string
    214   sdl-net-tcp-add-socket!
    215   sdl-net-tcp-del-socket!
    216   sdl-net-check-sockets
    217   sdl-net-socket-ready?
    218   sdl-net-socket-set?
    219   sdl-net-socket-set-pointer-set!
    220   sdl-net-write-16
    221   sdl-net-write-32
    222   sdl-net-read-16
    223   sdl-net-read-32
    224 
    225   sdl-event?
    226   sdl-event-gain
    227   set-sdl-event-gain!
    228   sdl-event-which
    229   set-sdl-event-which!
    230   sdl-event-state
    231   set-sdl-event-state!
    232   sdl-event-scancode
    233   set-sdl-event-scancode!
    234   sdl-event-sym
    235   set-sdl-event-sym!
    236   sdl-event-mod
    237   set-sdl-event-mod!
    238   sdl-event-unicode
    239   set-sdl-event-unicode!
    240   sdl-event-x
    241   set-sdl-event-x!
    242   sdl-event-y
    243   set-sdl-event-y!
    244   sdl-event-xrel
    245   set-sdl-event-xrel!
    246   sdl-event-yrel
    247   set-sdl-event-yrel!
    248   sdl-event-axis
    249   set-sdl-event-axis!
    250   sdl-event-ball
    251   set-sdl-event-ball!
    252   sdl-event-hat
    253   set-sdl-event-hat!
    254   sdl-event-value
    255   set-sdl-event-value!
    256   sdl-event-button
    257   set-sdl-event-button!
    258   sdl-event-w
    259   set-sdl-event-w!
    260   sdl-event-h
    261   set-sdl-event-h!
    262   sdl-event-buffer-set!
    263   heap?
     53  make-ttf-glyph
     54  ttf-glyph-metrics
     55  ttf-glyph-minx
     56  ttf-glyph-maxx
     57  ttf-glyph-miny
     58  ttf-glyph-maxy
     59  ttf-glyph-advance
    26460 
    265 
    266   ; constants
    267 
    268   SDL_INIT_TIMER
    269   SDL_INIT_AUDIO
    270   SDL_INIT_VIDEO
    271   SDL_INIT_CDROM
    272   SDL_INIT_JOYSTICK
    273   SDL_INIT_EVERYTHING
    274   SDL_INIT_NOPARACHUTE
    275 
    276   ;; For sdl-creatergbsurface or sdl-setvideomode
    277   SDL_SWSURFACE
    278   SDL_HWSURFACE
    279   SDL_ASYNCBLIT
    280   ;; For sdl-setvideomode
    281   SDL_ANYFORMAT
    282   SDL_HWPALETTE
    283   SDL_DOUBLEBUF
    284   SDL_FULLSCREEN
    285   SDL_OPENGL
    286   SDL_OPENGLBLIT
    287   SDL_RESIZABLE
    288   SDL_NOFRAME
    289   ;; Read-only - internal
    290   SDL_HWACCEL
    291   SDL_SRCCOLORKEY
    292   SDL_RLEACCELOK
    293   SDL_RLEACCEL
    294   SDL_SRCALPHA
    295   SDL_PREALLOC
    296 
    297   SDL_BYTEORDER
    298   SDL_LIL_ENDIAN
    299   SDL_BIG_ENDIAN
    300 
    301   ;; For sdl-wm-grabinput
    302   SDL_GRAB_QUERY
    303   SDL_GRAB_OFF
    304   SDL_GRAB_ON
    305 
    306 
    307   SDL_NOEVENT                   ; Unused (do not remove)
    308   SDL_ACTIVEEVENT               ; Application loses/gains visibility
    309   SDL_APPMOUSEFOCUS             ; Mouse focus gained/lost
    310   SDL_APPINPUTFOCUS             ; Input focus gained/lost
    311   SDL_APPACTIVE                 ; Application iconified/restored
    312   SDL_KEYDOWN                   ; Keys pressed
    313   SDL_KEYUP                     ; Keys released
    314   SDL_MOUSEMOTION               ; Mouse moved
    315   SDL_MOUSEBUTTONDOWN           ; Mouse button pressed
    316   SDL_MOUSEBUTTONUP             ; Mouse button released
    317   SDL_JOYAXISMOTION             ; Joystick axis motion
    318   SDL_JOYBALLMOTION             ; Joystick trackball motion
    319   SDL_JOYHATMOTION              ; Joystick hat position change
    320   SDL_JOYBUTTONDOWN             ; Joystick button pressed
    321   SDL_JOYBUTTONUP               ; Joystick button released
    322   SDL_QUIT                      ; User-requested quit
    323   SDL_SYSWMEVENT                ; System specific event
    324   SDL_EVENT_RESERVEDA           ; Reserved for future use..
    325   SDL_EVENT_RESERVEDB           ; Reserved for future use..
    326   SDL_VIDEORESIZE               ; User resized video mode
    327   SDL_VIDEOEXPOSE               ; Screen needs to be redrawn
    328   SDL_EVENT_RESERVED2           ; Reserved for future use..
    329   SDL_EVENT_RESERVED3           ; Reserved for future use..
    330   SDL_EVENT_RESERVED4           ; Reserved for future use..
    331   SDL_EVENT_RESERVED5           ; Reserved for future use..
    332   SDL_EVENT_RESERVED6           ; Reserved for future use..
    333   SDL_EVENT_RESERVED7           ; Reserved for future use..
    334   SDL_USEREVENT                 ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
    335   SDL_NUMEVENTS
    336 
    337   SDL_ACTIVEEVENTMASK
    338   SDL_KEYDOWNMASK
    339   SDL_KEYUPMASK
    340   SDL_MOUSEMOTIONMASK
    341   SDL_MOUSEBUTTONDOWNMASK
    342   SDL_MOUSEBUTTONUPMASK
    343   SDL_MOUSEEVENTMASK
    344   SDL_JOYAXISMOTIONMASK
    345   SDL_JOYBALLMOTIONMASK
    346   SDL_JOYHATMOTIONMASK
    347   SDL_JOYBUTTONDOWNMASK
    348   SDL_JOYBUTTONUPMASK
    349   SDL_JOYEVENTMASK
    350   SDL_VIDEORESIZEMASK
    351   SDL_VIDEOEXPOSEMASK
    352   SDL_QUITMASK
    353   SDL_SYSWMEVENTMASK
    354   SDL_ALLEVENTS
    355                                         ; General button/key states
    356   SDL_PRESSED
    357   SDL_RELEASED
    358                                         ; Mouse button states
    359   SDL_BUTTON_LEFT
    360   SDL_BUTTON_MIDDLE
    361   SDL_BUTTON_RIGHT
    362   SDL_BUTTON_WHEELUP
    363   SDL_BUTTON_WHEELDOWN
    364   SDL_BUTTON_LMASK ; = SDL_BUTTON(SDL_BUTTON_LEFT)
    365   SDL_BUTTON_MMASK ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
    366   SDL_BUTTON_RMASK ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
    367   SDL_QUERY
    368   SDL_IGNORE
    369   SDL_DISABLE
    370   SDL_ENABLE
    371 
    372   SDL_GL_RED_SIZE
    373   SDL_GL_GREEN_SIZE
    374   SDL_GL_BLUE_SIZE
    375   SDL_GL_ALPHA_SIZE
    376   SDL_GL_BUFFER_SIZE
    377   SDL_GL_DOUBLEBUFFER
    378   SDL_GL_DEPTH_SIZE
    379   SDL_GL_STENCIL_SIZE
    380   SDL_GL_ACCUM_RED_SIZE
    381   SDL_GL_ACCUM_GREEN_SIZE
    382   SDL_GL_ACCUM_BLUE_SIZE
    383   SDL_GL_ACCUM_ALPHA_SIZE
    384   SDL_GL_STEREO
    385   SDL_GL_MULTISAMPLEBUFFERS
    386   SDL_GL_MULTISAMPLESAMPLES
    387   SDL_GL_SWAP_CONTROL
    388   SDL_GL_ACCELERATED_VISUAL
    389 
    39061  TTF_STYLE_NORMAL
    39162  TTF_STYLE_BOLD
    39263  TTF_STYLE_ITALIC
    39364  TTF_STYLE_UNDERLINE
    394 
    395   ;; SDL_image
    396   IMG_INIT_JPG
    397   IMG_INIT_PNG
    398   IMG_INIT_TIF
    399 
    400   ;; scancodes
    401 
    402   SDLK_UNKNOWN
    403   SDLK_FIRST
    404   SDLK_BACKSPACE
    405   SDLK_TAB
    406   SDLK_CLEAR
    407   SDLK_RETURN
    408   SDLK_PAUSE
    409   SDLK_ESCAPE
    410   SDLK_SPACE
    411   SDLK_EXCLAIM
    412   SDLK_QUOTEDBL
    413   SDLK_HASH
    414   SDLK_DOLLAR
    415   SDLK_AMPERSAND
    416   SDLK_QUOTE
    417   SDLK_LEFTPAREN
    418   SDLK_RIGHTPAREN
    419   SDLK_ASTERISK
    420   SDLK_PLUS
    421   SDLK_COMMA
    422   SDLK_MINUS
    423   SDLK_PERIOD
    424   SDLK_SLASH
    425   SDLK_0
    426   SDLK_1
    427   SDLK_2
    428   SDLK_3
    429   SDLK_4
    430   SDLK_5
    431   SDLK_6
    432   SDLK_7
    433   SDLK_8
    434   SDLK_9
    435   SDLK_COLON
    436   SDLK_SEMICOLON
    437   SDLK_LESS
    438   SDLK_EQUALS
    439   SDLK_GREATER
    440   SDLK_QUESTION
    441   SDLK_AT
    442   SDLK_LEFTBRACKET
    443   SDLK_BACKSLASH
    444   SDLK_RIGHTBRACKET
    445   SDLK_CARET
    446   SDLK_UNDERSCORE
    447   SDLK_BACKQUOTE
    448   SDLK_a
    449   SDLK_b
    450   SDLK_c
    451   SDLK_d
    452   SDLK_e
    453   SDLK_f
    454   SDLK_g
    455   SDLK_h
    456   SDLK_i
    457   SDLK_j
    458   SDLK_k
    459   SDLK_l
    460   SDLK_m
    461   SDLK_n
    462   SDLK_o
    463   SDLK_p
    464   SDLK_q
    465   SDLK_r
    466   SDLK_s
    467   SDLK_t
    468   SDLK_u
    469   SDLK_v
    470   SDLK_w
    471   SDLK_x
    472   SDLK_y
    473   SDLK_z
    474   SDLK_DELETE
    475   SDLK_WORLD_0
    476   SDLK_WORLD_1
    477   SDLK_WORLD_2
    478   SDLK_WORLD_3
    479   SDLK_WORLD_4
    480   SDLK_WORLD_5
    481   SDLK_WORLD_6
    482   SDLK_WORLD_7
    483   SDLK_WORLD_8
    484   SDLK_WORLD_9
    485   SDLK_WORLD_10
    486   SDLK_WORLD_11
    487   SDLK_WORLD_12
    488   SDLK_WORLD_13
    489   SDLK_WORLD_14
    490   SDLK_WORLD_15
    491   SDLK_WORLD_16
    492   SDLK_WORLD_17
    493   SDLK_WORLD_18
    494   SDLK_WORLD_19
    495   SDLK_WORLD_20
    496   SDLK_WORLD_21
    497   SDLK_WORLD_22
    498   SDLK_WORLD_23
    499   SDLK_WORLD_24
    500   SDLK_WORLD_25
    501   SDLK_WORLD_26
    502   SDLK_WORLD_27
    503   SDLK_WORLD_28
    504   SDLK_WORLD_29
    505   SDLK_WORLD_30
    506   SDLK_WORLD_31
    507   SDLK_WORLD_32
    508   SDLK_WORLD_33
    509   SDLK_WORLD_34
    510   SDLK_WORLD_35
    511   SDLK_WORLD_36
    512   SDLK_WORLD_37
    513   SDLK_WORLD_38
    514   SDLK_WORLD_39
    515   SDLK_WORLD_40
    516   SDLK_WORLD_41
    517   SDLK_WORLD_42
    518   SDLK_WORLD_43
    519   SDLK_WORLD_44
    520   SDLK_WORLD_45
    521   SDLK_WORLD_46
    522   SDLK_WORLD_47
    523   SDLK_WORLD_48
    524   SDLK_WORLD_49
    525   SDLK_WORLD_50
    526   SDLK_WORLD_51
    527   SDLK_WORLD_52
    528   SDLK_WORLD_53
    529   SDLK_WORLD_54
    530   SDLK_WORLD_55
    531   SDLK_WORLD_56
    532   SDLK_WORLD_57
    533   SDLK_WORLD_58
    534   SDLK_WORLD_59
    535   SDLK_WORLD_60
    536   SDLK_WORLD_61
    537   SDLK_WORLD_62
    538   SDLK_WORLD_63
    539   SDLK_WORLD_64
    540   SDLK_WORLD_65
    541   SDLK_WORLD_66
    542   SDLK_WORLD_67
    543   SDLK_WORLD_68
    544   SDLK_WORLD_69
    545   SDLK_WORLD_70
    546   SDLK_WORLD_71
    547   SDLK_WORLD_72
    548   SDLK_WORLD_73
    549   SDLK_WORLD_74
    550   SDLK_WORLD_75
    551   SDLK_WORLD_76
    552   SDLK_WORLD_77
    553   SDLK_WORLD_78
    554   SDLK_WORLD_79
    555   SDLK_WORLD_80
    556   SDLK_WORLD_81
    557   SDLK_WORLD_82
    558   SDLK_WORLD_83
    559   SDLK_WORLD_84
    560   SDLK_WORLD_85
    561   SDLK_WORLD_86
    562   SDLK_WORLD_87
    563   SDLK_WORLD_88
    564   SDLK_WORLD_89
    565   SDLK_WORLD_90
    566   SDLK_WORLD_91
    567   SDLK_WORLD_92
    568   SDLK_WORLD_93
    569   SDLK_WORLD_94
    570   SDLK_WORLD_95
    571   SDLK_KP0
    572   SDLK_KP1
    573   SDLK_KP2
    574   SDLK_KP3
    575   SDLK_KP4
    576   SDLK_KP5
    577   SDLK_KP6
    578   SDLK_KP7
    579   SDLK_KP8
    580   SDLK_KP9
    581   SDLK_KP_PERIOD
    582   SDLK_KP_DIVIDE
    583   SDLK_KP_MULTIPLY
    584   SDLK_KP_MINUS
    585   SDLK_KP_PLUS
    586   SDLK_KP_ENTER
    587   SDLK_KP_EQUALS
    588   SDLK_UP
    589   SDLK_DOWN
    590   SDLK_RIGHT
    591   SDLK_LEFT
    592   SDLK_INSERT
    593   SDLK_HOME
    594   SDLK_END
    595   SDLK_PAGEUP
    596   SDLK_PAGEDOWN
    597   SDLK_F1
    598   SDLK_F2
    599   SDLK_F3
    600   SDLK_F4
    601   SDLK_F5
    602   SDLK_F6
    603   SDLK_F7
    604   SDLK_F8
    605   SDLK_F9
    606   SDLK_F10
    607   SDLK_F11
    608   SDLK_F12
    609   SDLK_F13
    610   SDLK_F14
    611   SDLK_F15
    612   SDLK_NUMLOCK
    613   SDLK_CAPSLOCK
    614   SDLK_SCROLLOCK
    615   SDLK_RSHIFT
    616   SDLK_LSHIFT
    617   SDLK_RCTRL
    618   SDLK_LCTRL
    619   SDLK_RALT
    620   SDLK_LALT
    621   SDLK_RMETA
    622   SDLK_LMETA
    623   SDLK_LSUPER
    624   SDLK_RSUPER
    625   SDLK_MODE
    626   SDLK_COMPOSE
    627   SDLK_HELP
    628   SDLK_PRINT
    629   SDLK_SYSREQ
    630   SDLK_BREAK
    631   SDLK_MENU
    632   SDLK_POWER
    633   SDLK_EURO
    634   SDLK_UNDO
    63565
    63666)
    … …  
    64474(use srfi-18)
    64575(use lolevel)
     76(use sdl-base)
    64677
    64778(foreign-declare #<<EOF
    64879
    649 #ifdef _WIN32
    650 # if _MSC_VER > 1300
    651 #  include <winsock2.h>
    652 #  include <ws2tcpip.h>
    653 # else
    654 #  include <winsock.h>
    655 # endif
    656 #else
    657 # include <netinet/in.h>
    658 #endif
    659 
    660 #include <sys/time.h>
    661 
    662 #include "SDL.h"
    66380#include "SDL_ttf.h"
    664 #include "SDL_image.h"
    665 #include "SDL_rotozoom.h"
    666 #include "SDL_keysym.h"
    667 #include "SDL_endian.h"
    668 
    66981#include <string.h>
    670 #include "SDL_net.h"
    67182
    67283EOF
    67384)
    674 
    675 (include "heap.scm")
    676 (include "timer.scm")
    677 
    678 ;---------------------------------------------------------------------------
    679 
    680 ;; The first two components are arbitrary - the main version of the library.
    681 ;; The third is the date (YYMMDD, with leading zeros removed).
    682 ;; The fourth is a counter just in case we release more than one version in
    683 ;; one day.
    684 (define *sdl-egg-version* '(0 5 91025 0))
    68585
    68686;---------------------------------------------------------------------------
    … …  
    69696                   (cdr e)))))
    69797
    698 (define-record sdl-version pointer)
    699 (define-record sdl-rect buffer)
    700 (define-record sdl-pixel-format pointer)
    701 (define-record sdl-surface pointer)
    702 (define-record sdl-video-info pointer)
    703 (define-record sdl-event buffer)
    704 (define-record sdl-color buffer)
    705 (define-record sdl-joystick pointer)
    706 
    707 (include "sdl-foreign-types-include.scm")
    708 (include "keysym.scm")
    709 
    710 ; Subsystem definitions, for sdl-init etc.
    711 (--sdl-flags "SDL_INIT_TIMER"
    712              "SDL_INIT_AUDIO"
    713              "SDL_INIT_VIDEO"
    714              "SDL_INIT_CDROM"
    715              "SDL_INIT_JOYSTICK"
    716              "SDL_INIT_EVERYTHING"
    717              "SDL_INIT_NOPARACHUTE")
    718 
    719 (--sdl-flags
    720         ;; For sdl-creatergbsurface or sdl-setvideomode
    721         "SDL_SWSURFACE"
    722         "SDL_HWSURFACE"
    723         "SDL_ASYNCBLIT"
    724         ;; For sdl-setvideomode
    725         "SDL_ANYFORMAT"
    726         "SDL_HWPALETTE"
    727         "SDL_DOUBLEBUF"
    728         "SDL_FULLSCREEN"
    729         "SDL_OPENGL"
    730         "SDL_OPENGLBLIT"
    731         "SDL_RESIZABLE"
    732         "SDL_NOFRAME"
    733         ;; Read-only - internal
    734         "SDL_HWACCEL"
    735         "SDL_SRCCOLORKEY"
    736         "SDL_RLEACCELOK"
    737         "SDL_RLEACCEL"
    738         "SDL_SRCALPHA"
    739         "SDL_PREALLOC"
    740 )
    741 
    742 (--sdl-flags
    743  "SDL_BYTEORDER"
    744  "SDL_LIL_ENDIAN"
    745  "SDL_BIG_ENDIAN")
    746 
    747 ; For sdl-wm-grabinput
    748 (--sdl-flags "SDL_GRAB_QUERY"
    749              "SDL_GRAB_OFF"
    750              "SDL_GRAB_ON")
    751 
    752 (--sdl-flags
    753         "SDL_NOEVENT"                   ; Unused (do not remove)
    754         "SDL_ACTIVEEVENT"               ; Application loses/gains visibility
    755         "SDL_APPMOUSEFOCUS"             ; Mouse focus gained/lost
    756         "SDL_APPINPUTFOCUS"             ; Input focus gained/lost
    757         "SDL_APPACTIVE"                 ; Application iconified/restored
    758         "SDL_KEYDOWN"                   ; Keys pressed
    759         "SDL_KEYUP"                     ; Keys released
    760         "SDL_MOUSEMOTION"               ; Mouse moved
    761         "SDL_MOUSEBUTTONDOWN"           ; Mouse button pressed
    762         "SDL_MOUSEBUTTONUP"             ; Mouse button released
    763         "SDL_JOYAXISMOTION"             ; Joystick axis motion
    764         "SDL_JOYBALLMOTION"             ; Joystick trackball motion
    765         "SDL_JOYHATMOTION"              ; Joystick hat position change
    766         "SDL_JOYBUTTONDOWN"             ; Joystick button pressed
    767         "SDL_JOYBUTTONUP"               ; Joystick button released
    768         "SDL_QUIT"                      ; User-requested quit
    769         "SDL_SYSWMEVENT"                ; System specific event
    770         "SDL_EVENT_RESERVEDA"           ; Reserved for future use..
    771         "SDL_EVENT_RESERVEDB"           ; Reserved for future use..
    772         "SDL_VIDEORESIZE"               ; User resized video mode
    773         "SDL_VIDEOEXPOSE"               ; Screen needs to be redrawn
    774         "SDL_EVENT_RESERVED2"           ; Reserved for future use..
    775         "SDL_EVENT_RESERVED3"           ; Reserved for future use..
    776         "SDL_EVENT_RESERVED4"           ; Reserved for future use..
    777         "SDL_EVENT_RESERVED5"           ; Reserved for future use..
    778         "SDL_EVENT_RESERVED6"           ; Reserved for future use..
    779         "SDL_EVENT_RESERVED7"           ; Reserved for future use..
    780         "SDL_USEREVENT"                 ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
    781         "SDL_NUMEVENTS"
    782 )
    783 
    784 (--sdl-flags
    785         "SDL_ACTIVEEVENTMASK"
    786         "SDL_KEYDOWNMASK"
    787         "SDL_KEYUPMASK"
    788         "SDL_MOUSEMOTIONMASK"
    789         "SDL_MOUSEBUTTONDOWNMASK"
    790         "SDL_MOUSEBUTTONUPMASK"
    791         "SDL_MOUSEEVENTMASK"
    792         "SDL_JOYAXISMOTIONMASK"
    793         "SDL_JOYBALLMOTIONMASK"
    794         "SDL_JOYHATMOTIONMASK"
    795         "SDL_JOYBUTTONDOWNMASK"
    796         "SDL_JOYBUTTONUPMASK"
    797         "SDL_JOYEVENTMASK"
    798         "SDL_VIDEORESIZEMASK"
    799         "SDL_VIDEOEXPOSEMASK"
    800         "SDL_QUITMASK"
    801         "SDL_SYSWMEVENTMASK"
    802         "SDL_ALLEVENTS"
    803 )
    804 
    805 ; General button/key states
    806 (--sdl-flags
    807  "SDL_PRESSED"
    808  "SDL_RELEASED")
    809 
    810 ;; SDL_image constants
    811 (--sdl-flags
    812  "IMG_INIT_JPG"
    813  "IMG_INIT_PNG"
    814  "IMG_INIT_TIF")
    815 
    816 ; Mouse button states
    817 
    818 ; The macro SDL_BUTTON is parameterised, so we have to recreate it as
    819 ; a function
    820 
    821 (define (SDL_BUTTON x)
    822   (arithmetic-shift SDL_PRESSED (- x 1)))
    823 
    824 (--sdl-flags
    825         "SDL_BUTTON_LEFT"
    826         "SDL_BUTTON_MIDDLE"
    827         "SDL_BUTTON_RIGHT"
    828         "SDL_BUTTON_WHEELUP"
    829         "SDL_BUTTON_WHEELDOWN"
    830         "SDL_BUTTON_LMASK" ; = SDL_BUTTON(SDL_BUTTON_LEFT)
    831         "SDL_BUTTON_MMASK" ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
    832         "SDL_BUTTON_RMASK" ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
    833 )
    834 
    835 ; For sdl-eventstate
    836 (--sdl-flags "SDL_QUERY"
    837              "SDL_IGNORE"
    838              "SDL_DISABLE"
    839              "SDL_ENABLE")
     98(include "sdl-base-foreign-types-include.scm")
     99
     100(define-syntax pointer-to-record-lambda
     101  (ir-macro-transformer
     102   (lambda (e i c)
     103     (let ((record-name (cadr e)))
     104       `(lambda (pointer)
     105          (and pointer
     106               (,(i (symbol-append 'make- (i record-name))) pointer)))))))
    840107
    841108;---------------------------------------------------------------------------
    842109
    843 (define-record-printer (sdl-version o out)
    844   (for-each (lambda (x) (display x out))
    845             (list "#<sdl-version "
    846                   (sdl-version-major o) " "
    847                   (sdl-version-minor o) " "
    848                   (sdl-version-patch o)
    849                   ">")))
    850 
    851 (define sdl-version-major
    852   (foreign-lambda* unsigned-byte ((SDL_version v))
    853                    "C_return(v->major);"))
    854 
    855 (define sdl-version-minor
    856   (foreign-lambda* unsigned-byte ((SDL_version v))
    857                    "C_return(v->minor);"))
    858 
    859 (define sdl-version-patch
    860   (foreign-lambda* unsigned-byte ((SDL_version v))
    861                    "C_return(v->patch);"))
    862 
    863 ;; Returns #t if the first argument is at least what the rest of the
    864 ;; arguments indicate.
    865 (define (sdl-version-at-least sdl-version major minor patch)
    866   (cond
    867    ((> (sdl-version-major sdl-version) major) #t)
    868    ((< (sdl-version-major sdl-version) major) #f)
    869    ((> (sdl-version-minor sdl-version) minor) #t)
    870    ((< (sdl-version-minor sdl-version) minor) #f)
    871    ((>= (sdl-version-patch sdl-version) patch) #t)
    872    (#t #f)))
    873 
    874 (define sdl-compiled-version
    875   (foreign-lambda* SDL_version ()
    876                    "SDL_version v; SDL_VERSION(&v); C_return(&v);"))
    877 
    878 (define sdl-linked-version
    879   (foreign-lambda SDL_version "SDL_Linked_Version"))
    880 
    881 ;---------------------------------------------------------------------------
    882 
    883 (define-foreign-variable sizeof-sdl-rect int "sizeof(SDL_Rect)")
    884 
    885 (let ((maker make-sdl-rect))
    886   (set! make-sdl-rect
    887         (lambda (x y w h)
    888           (let ((r (maker (make-blob sizeof-sdl-rect))))
    889             (sdl-rect-x-set! r x)
    890             (sdl-rect-y-set! r y)
    891             (sdl-rect-w-set! r w)
    892             (sdl-rect-h-set! r h)
    893             r))))
    894 
    895 (define-record-printer (sdl-rect s out)
    896   (for-each (lambda (x) (display x out))
    897             (list "#<sdl-rect "
    898                   (sdl-rect-x s)" "
    899                   (sdl-rect-y s)" "
    900                   (sdl-rect-w s)" "
    901                   (sdl-rect-h s)">")))
    902 
    903 (define sdl-rect-x (foreign-lambda* short ((SDL_Rect c)) "C_return(c->x);"))
    904 (define sdl-rect-y (foreign-lambda* short ((SDL_Rect c)) "C_return(c->y);"))
    905 (define sdl-rect-w (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->w);"))
    906 (define sdl-rect-h (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->h);"))
    907 
    908 (define sdl-rect-x-set! (foreign-lambda* void ((SDL_Rect c) (short x)) "c->x = x;"))
    909 (define sdl-rect-y-set! (foreign-lambda* void ((SDL_Rect c) (short y)) "c->y = y;"))
    910 (define sdl-rect-w-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short w)) "c->w = w;"))
    911 (define sdl-rect-h-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short h)) "c->h = h;"))
    912 
    913 ;---------------------------------------------------------------------------
    914 
    915 (define-record-printer (sdl-pixel-format p out)
    916   (for-each (lambda (x) (display x out))
    917             (list "#<sdl-pixel-format "(sdl-pixel-format-pointer p)">")))
    918 
    919 (define sdl-pixel-format-bytes-per-pixel
    920   (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
    921                    "C_return(pf->BytesPerPixel);"))
    922 
    923 (define sdl-pixel-format-rmask
    924   (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
    925                    "C_return(pf->Rmask);"))
    926 (define sdl-pixel-format-gmask
    927   (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
    928                    "C_return(pf->Gmask);"))
    929 (define sdl-pixel-format-bmask
    930   (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
    931                    "C_return(pf->Bmask);"))
    932 (define sdl-pixel-format-amask
    933   (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
    934                    "C_return(pf->Amask);"))
    935 
    936 ;---------------------------------------------------------------------------
    937 
    938 (define-record-printer (sdl-surface s out)
    939   (for-each (lambda (x) (display x out))
    940             (list "#<sdl-surface "(sdl-surface-pointer s)">")))
    941 
    942 (define (sdl-surface-flags s)
    943   ((foreign-lambda* unsigned-integer ((SDL_Surface s))
    944                     "C_return(s->flags);") s))
    945 
    946 (define (sdl-surface-pixel-format s)
    947   ((foreign-lambda* SDL_PixelFormat ((SDL_Surface s))
    948                     "C_return(s->format);") s))
    949 
    950 (define (sdl-surface-width s)
    951   ((foreign-lambda* integer ((SDL_Surface s))
    952                     "C_return(s->w);") s))
    953 
    954 (define (sdl-surface-height s)
    955   ((foreign-lambda* integer ((SDL_Surface s))
    956                     "C_return(s->h);") s))
    957 
    958 (define (sdl-surface-pitch s)
    959   ((foreign-lambda* unsigned-short ((SDL_Surface s))
    960                     "C_return(s->pitch);") s))
    961 
    962 (define (sdl-surface-pixels s)
    963   ((foreign-lambda* (c-pointer byte) ((SDL_Surface s))
    964                     "C_return(s->pixels);") s))
    965 
    966 ;; Computes the number of bytes of storage pointed to by
    967 ;; sdl-surface-pixels.
    968 (define (sdl-surface-pixels-length s)
    969   (* (sdl-surface-height s)
    970      (sdl-surface-pitch s)))
    971 
    972 ;;
    973 ;; SDL_VideoInfo
    974 ;;
    975 
    976 (define-record-printer (sdl-video-info o out)
    977   (for-each (lambda (x) (display x out))
    978             (list "#<sdl-video-info "
    979                   (sdl-video-info-hw-available o) " "
    980                   (sdl-video-info-wm-available o) " "
    981                   (sdl-video-info-blit-hw o) " "
    982                   (sdl-video-info-blit-hw-cc o) " "
    983                   (sdl-video-info-blit-hw-a o) " "
    984                   (sdl-video-info-blit-sw o) " "
    985                   (sdl-video-info-blit-sw-cc o) " "
    986                   (sdl-video-info-blit-sw-a o) " "
    987                   (sdl-video-info-blit-fill o) " "
    988                   (sdl-video-info-video-mem o) " "
    989                   (sdl-video-info-vfmt o) " "
    990                   (sdl-video-info-current-w o) " "
    991                   (sdl-video-info-current-h o)
    992                   ">")))
    993 
    994 (define sdl-video-info-hw-available
    995   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    996                    "C_return(vi->hw_available);"))
    997 (define sdl-video-info-wm-available
    998   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    999                    "C_return(vi->wm_available);"))
    1000 (define sdl-video-info-blit-hw
    1001   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1002                    "C_return(vi->blit_hw);"))
    1003 (define sdl-video-info-blit-hw-cc
    1004   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1005                    "C_return(vi->blit_hw_CC);"))
    1006 (define sdl-video-info-blit-hw-a
    1007   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1008                    "C_return(vi->blit_hw_A);"))
    1009 (define sdl-video-info-blit-sw
    1010   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1011                    "C_return(vi->blit_sw);"))
    1012 (define sdl-video-info-blit-sw-cc
    1013   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1014                    "C_return(vi->blit_sw_CC);"))
    1015 (define sdl-video-info-blit-sw-a
    1016   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1017                    "C_return(vi->blit_sw_A);"))
    1018 (define sdl-video-info-blit-fill
    1019   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1020                    "C_return(vi->blit_fill);"))
    1021 (define sdl-video-info-video-mem
    1022   (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
    1023                    "C_return(vi->video_mem);"))
    1024 (define sdl-video-info-vfmt
    1025   (foreign-lambda* SDL_PixelFormat ((SDL_VideoInfo vi))
    1026                    "C_return(vi->vfmt);"))
    1027 (define sdl-video-info-current-w
    1028   (foreign-lambda* integer ((SDL_VideoInfo vi))
    1029                    "C_return(vi->current_w);"))
    1030 (define sdl-video-info-current-h
    1031   (foreign-lambda* integer ((SDL_VideoInfo vi))
    1032                    "C_return(vi->current_h);"))
    1033 
    1034 (define sdl-get-video-info
    1035   (foreign-lambda* SDL_VideoInfo ()
    1036                    "C_return(SDL_GetVideoInfo());"))
    1037 
    1038 
    1039 ;---------------------------------------------------------------------------
    1040 
    1041 ;; Modifies its second argument.
    1042 (define sdl-get-clip-rect! (foreign-lambda void "SDL_GetClipRect" SDL_Surface SDL_Rect))
    1043 
    1044 ;; Modifies its first argument.
    1045 (define sdl-set-clip-rect! (foreign-lambda bool "SDL_SetClipRect" SDL_Surface SDL_Rect))
    1046 
    1047 ;; Modifies its first argument.
    1048 (define sdl-set-color-key!
    1049   (foreign-lambda int "SDL_SetColorKey" SDL_Surface unsigned-integer unsigned-integer))
    1050 
    1051 ;; Modifies its first argument.
    1052 (define sdl-set-alpha!
    1053   (foreign-lambda int "SDL_SetAlpha" SDL_Surface unsigned-integer unsigned-byte))
    1054 
    1055 (define sdl-display-format
    1056   (foreign-lambda SDL_Surface "SDL_DisplayFormat" SDL_Surface))
    1057 (define sdl-display-format-alpha
    1058   (foreign-lambda SDL_Surface "SDL_DisplayFormatAlpha" SDL_Surface))
    1059 (define sdl-convert-surface
    1060   (foreign-lambda SDL_Surface "SDL_ConvertSurface" SDL_Surface SDL_PixelFormat unsigned-integer))
    1061 
    1062 ;---------------------------------------------------------------------------
    1063 
    1064 ;; NOTE: sdl-init does not work on MacOS X when called from a
    1065 ;; dynamically-loaded extension. Something internal to Quartz seems to
    1066 ;; get confused. You must call SDL_Init *directly* from your main
    1067 ;; program - if your main program is written in Scheme, you need to
    1068 ;; say something like:
    1069 ;;
    1070 ;; (declare (foreign-declare "#include <SDL.h>\n"))
    1071 ;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);")
    1072 ;;
    1073 (define (sdl-init flags)
    1074   (zero? ((foreign-lambda int "SDL_Init" unsigned-integer) flags)))
    1075 
    1076 ;; Note: guile-sdl names these 'sdl-init-subsystem' and
    1077 ;; 'sdl-quit-subsystem', respectively.
    1078 
    1079 (define (sdl-init-sub-system flags)
    1080   (zero? ((foreign-lambda int "SDL_InitSubSystem" unsigned-integer) flags)))
    1081 
    1082 (define (sdl-quit-sub-system flags)
    1083   ((foreign-lambda void "SDL_QuitSubSystem" unsigned-integer) flags))
    1084 
    1085 (define (sdl-quit)
    1086   ((foreign-lambda void "SDL_Quit")))
    1087 
    1088 (define (sdl-was-init flags)
    1089   ((foreign-lambda unsigned-integer "SDL_WasInit" unsigned-integer) flags))
    1090 
    1091 (define sdl-set-error! (foreign-lambda* void ((c-string str)) "SDL_SetError(\"%s\", str);"))
    1092 (define sdl-get-error (foreign-lambda c-string "SDL_GetError"))
    1093 (define sdl-clear-error! (foreign-lambda void "SDL_ClearError"))
    1094 
    1095 ;---------------------------------------------------------------------------
    1096 
    1097 (define (sdl-wm-set-caption title icon)
    1098   ((foreign-lambda void "SDL_WM_SetCaption" c-string c-string) title icon))
    1099 
    1100 (define (sdl-wm-get-caption-title)
    1101   ((foreign-lambda* c-string ()
    1102                     "char *t, *i;"
    1103                     "SDL_WM_GetCaption(&t, &i);"
    1104                     "C_return(t);")))
    1105 
    1106 (define (sdl-wm-get-caption-icon)
    1107   ((foreign-lambda* c-string ()
    1108                     "char *t, *i;"
    1109                     "SDL_WM_GetCaption(&t, &i);"
    1110                     "C_return(i);")))
    1111 
    1112 (define (sdl-wm-get-caption)
    1113   (values (sdl-wm-get-caption-title)
    1114           (sdl-wm-get-caption-icon)))
    1115 
    1116 (define (sdl-wm-set-icon icon mask)
    1117   ((foreign-lambda void "SDL_WM_SetIcon" SDL_Surface blob) icon mask))
    1118 
    1119 (define (sdl-wm-iconify-window)
    1120   (not (zero? ((foreign-lambda integer "SDL_WM_IconifyWindow")))))
    1121 
    1122 (define (sdl-wm-toggle-full-screen surf)
    1123   (not (zero? ((foreign-lambda integer "SDL_WM_ToggleFullScreen" SDL_Surface) surf))))
    1124 
    1125 (define (sdl-wm-grab-input m)
    1126   ((foreign-lambda integer "SDL_WM_GrabInput" integer) m))
    1127 
    1128 ;---------------------------------------------------------------------------
    1129 
    1130 ; Milliseconds.
    1131 (define sdl-get-ticks (foreign-lambda unsigned-integer "SDL_GetTicks"))
    1132 (define sdl-delay (foreign-lambda void "SDL_Delay" unsigned-integer))
    1133 
    1134 (cond-expand
    1135  (mingw32
    1136   (define get-time-of-day current-seconds))
    1137  (else
    1138   (define get-time-of-day
    1139     (foreign-lambda* double ()
    1140       "struct timeval tv;"
    1141       "gettimeofday(&tv, NULL);"
    1142       "C_return((double) tv.tv_sec + ((double) tv.tv_usec / 1000000.0));"))))
    1143 
    1144 (define-values (sdl-add-absolute-timer!
    1145                 sdl-process-timer-queue!)
    1146   (make-timer-queue get-time-of-day))
    1147 
    1148 (define (sdl-add-relative-timer! time callback)
    1149   (sdl-add-absolute-timer! (+ time (get-time-of-day)) callback))
    1150 
    1151 ;---------------------------------------------------------------------------
    1152 
    1153 (define-foreign-variable sizeof-sdl-event int "sizeof(SDL_Event)")
    1154 
    1155 (let ((maker make-sdl-event))
    1156   (set! make-sdl-event
    1157         (lambda ()
    1158           (let ((bv (blob->u8vector (make-blob sizeof-sdl-event))))
    1159             (u8vector-set! bv 0 SDL_NOEVENT)
    1160             (maker (u8vector->blob bv))))))
    1161 
    1162 (define-record-printer (sdl-event s out)
    1163   (for-each (lambda (x) (display x out))
    1164             (list "#<sdl-event "(sdl-event-type s)">")))
    1165 
    1166 (define sdl-event-type (foreign-lambda* unsigned-byte ((SDL_Event e)) "C_return(e->type);"))
    1167 (define sdl-event-type-set! (foreign-lambda* void ((SDL_Event e) (unsigned-byte t)) "e->type = t;"))
    1168 
    1169 (define-syntax --sdl-event-getter-setter
    1170   (lambda (f r c)
    1171     (let ((name (cadr f))
    1172           (rest (cddr f)))
    1173       (let* ((strapp (lambda s (apply string-append
    1174                                   (map (lambda (x) (cond
    1175                                                     ((symbol? x) (symbol->string x))
    1176                                                     (else x)))
    1177                                        s))))
    1178          (symapp (lambda s (string->symbol (apply strapp s)))))
    1179   `(,(r 'begin)
    1180      (,(r 'define) (,(symapp "sdl-event-" name) e)
    1181        (,(r 'let) ((,(r 't) (,(r 'sdl-event-type) e)))
    1182          (,(r 'cond)
    1183           ,@(map (lambda (clause)
    1184                    (apply (lambda (etype mem1 kind)
    1185                             `((,(r '=) ,(r 't) ,etype) ((,(r 'foreign-lambda*)
    1186                                              ,kind ((SDL_Event e))
    1187                                              ,(strapp "C_return(e->"mem1"."name");")) e)))
    1188                           clause))
    1189                  rest)
    1190           (,(r 'else) (,(r 'error) ,(string-append "sdl-event-" (symbol->string name)
    1191                                        ": cannot extract value from this type of event")
    1192                        (,(r 'sdl-event-type) e))))))
    1193      (,(r 'define) (,(symapp "set-sdl-event-" name "!") e v)
    1194        (,(r 'let) ((t (,(r 'sdl-event-type) e)))
    1195          (,(r 'cond)
    1196           ,@(map (lambda (clause)
    1197                    (apply (lambda (etype mem1 kind)
    1198                             `((,(r '=) t ,etype) ((,(r 'foreign-lambda*)
    1199                                              void ((SDL_Event e)
    1200                                                    (,kind v))
    1201                                              ,(strapp "e->"mem1"."name"=v;")) e v)))
    1202                           clause))
    1203                  rest)
    1204           (,(r 'else) (,(r 'error) ,(string-append "set-sdl-event-" (symbol->string name) "!"
    1205                                        ": cannot update value for this type of event")
    1206                        (,(r 'sdl-event-type) e)))))))))))
    1207 
    1208 (--sdl-event-getter-setter gain         (SDL_ACTIVEEVENT active bool))
    1209 (--sdl-event-getter-setter which        (SDL_KEYDOWN key unsigned-byte)
    1210                                         (SDL_KEYUP key unsigned-byte)
    1211                                         (SDL_MOUSEMOTION motion unsigned-byte)
    1212                                         (SDL_MOUSEBUTTONDOWN button unsigned-byte)
    1213                                         (SDL_MOUSEBUTTONUP button unsigned-byte)
    1214                                         (SDL_JOYAXISMOTION jaxis unsigned-byte)
    1215                                         (SDL_JOYBALLMOTION jball unsigned-byte)
    1216                                         (SDL_JOYHATMOTION jhat unsigned-byte)
    1217                                         (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
    1218                                         (SDL_JOYBUTTONUP jbutton unsigned-byte))
    1219 (--sdl-event-getter-setter state        (SDL_ACTIVEEVENT active unsigned-byte)
    1220                                         (SDL_KEYDOWN key unsigned-byte)
    1221                                         (SDL_KEYUP key unsigned-byte)
    1222                                         (SDL_MOUSEMOTION motion unsigned-byte)
    1223                                         (SDL_MOUSEBUTTONDOWN button unsigned-byte)
    1224                                         (SDL_MOUSEBUTTONUP button unsigned-byte)
    1225                                         (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
    1226                                         (SDL_JOYBUTTONUP jbutton unsigned-byte))
    1227 (--sdl-event-getter-setter scancode     (SDL_KEYDOWN key.keysym unsigned-byte)
    1228                                         (SDL_KEYUP   key.keysym unsigned-byte))
    1229 (--sdl-event-getter-setter sym          (SDL_KEYDOWN key.keysym integer)
    1230                                         (SDL_KEYUP   key.keysym integer))
    1231 (--sdl-event-getter-setter mod          (SDL_KEYDOWN key.keysym integer)
    1232                                         (SDL_KEYUP   key.keysym integer))
    1233 (--sdl-event-getter-setter unicode      (SDL_KEYDOWN key.keysym short)
    1234                                         (SDL_KEYUP   key.keysym short))
    1235 (--sdl-event-getter-setter x            (SDL_MOUSEMOTION motion unsigned-short)
    1236                                         (SDL_MOUSEBUTTONDOWN button unsigned-short)
    1237                                         (SDL_MOUSEBUTTONUP button unsigned-short))
    1238 (--sdl-event-getter-setter y            (SDL_MOUSEMOTION motion unsigned-short)
    1239                                         (SDL_MOUSEBUTTONDOWN button unsigned-short)
    1240                                         (SDL_MOUSEBUTTONUP button unsigned-short))
    1241 (--sdl-event-getter-setter xrel         (SDL_MOUSEMOTION motion short)
    1242                                         (SDL_JOYBALLMOTION jball short))
    1243 (--sdl-event-getter-setter yrel         (SDL_MOUSEMOTION motion short)
    1244                                         (SDL_JOYBALLMOTION jball short))
    1245 (--sdl-event-getter-setter axis         (SDL_JOYAXISMOTION jaxis unsigned-byte))
    1246 (--sdl-event-getter-setter ball         (SDL_JOYBALLMOTION jball unsigned-byte))
    1247 (--sdl-event-getter-setter hat          (SDL_JOYHATMOTION jhat unsigned-byte))
    1248 (--sdl-event-getter-setter value        (SDL_JOYAXISMOTION jaxis short)
    1249                                         (SDL_JOYHATMOTION jhat unsigned-byte))
    1250 (--sdl-event-getter-setter button       (SDL_MOUSEBUTTONDOWN button unsigned-byte)
    1251                                         (SDL_MOUSEBUTTONUP button unsigned-byte)
    1252                                         (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
    1253                                         (SDL_JOYBUTTONUP jbutton unsigned-byte))
    1254 (--sdl-event-getter-setter w            (SDL_VIDEORESIZE resize integer))
    1255 (--sdl-event-getter-setter h            (SDL_VIDEORESIZE resize integer))
    1256 
    1257 (define sdl-pump-events (foreign-lambda void "SDL_PumpEvents"))
    1258 
    1259 (define (sdl-poll-event! . e)
    1260   (if (null? e)
    1261       (not (zero? ((foreign-lambda int "SDL_PollEvent" c-pointer) #f)))
    1262       (not (zero? ((foreign-lambda int "SDL_PollEvent" SDL_Event) (car e))))))
    1263 
    1264 ;; Now, (sdl-wait-event!) is implemented internally to SDL_event.c as:
    1265 ;;
    1266 ;;  while (1) {
    1267 ;;    SDL_PumpEvents();
    1268 ;;    switch(SDL_PeepEvents(event, 1, SDL_GETEVENT, SDL_ALLEVENTS)) {
    1269 ;;      case -1: return 0;
    1270 ;;      case 1: return 1;
    1271 ;;      case 0: SDL_Delay(10);
    1272 ;;    }
    1273 ;;  }
    1274 ;;
    1275 ;; Since the SDL implementation of timers uses setitimer(2), and we
    1276 ;; have trouble with setitimer and chicken - see the README - we
    1277 ;; reimplement (sdl-wait-event!) here calling out to our timer queue
    1278 ;; processing function.
    1279 
    1280 (define (sdl-wait-event!* delay-function . e)
    1281   (let loop ()
    1282     (sdl-pump-events)
    1283     (let ((peep-result ((foreign-lambda*
    1284                          int ((SDL_Event eptr))
    1285                          "C_return(SDL_PeepEvents(eptr, 1, SDL_GETEVENT, SDL_ALLEVENTS));")
    1286                         (if (null? e) #f (car e)))))
    1287       (case peep-result
    1288         ((-1) #f) ;; error.
    1289         ((1) #t)  ;; present event.
    1290         ((0)
    1291          ;; No event, yet. Check our timer queue, wait, and retry.
    1292          (let* ((delay-seconds (or (sdl-process-timer-queue!) 0.01))
    1293                 (sleep-time (min delay-seconds 0.01))
    1294                 (fix-sleep-time (inexact->exact (truncate (* 1000 sleep-time)))))
    1295            (delay-function fix-sleep-time)
    1296            (loop)))
    1297         (else (error "sdl-wait-event!: unexpected result from SDL_PeepEvents" peep-result))))))
    1298 
    1299 (define (sdl-wait-event! . e)
    1300   (apply sdl-wait-event!* sdl-delay e))
    1301 
    1302 ;; Here's the implementation of (sdl-wait-event!) that calls the
    1303 ;; SDL-provided routine:
    1304 ;;
    1305 ;; (define (sdl-wait-event! . e)
    1306 ;;   (if (null? e)
    1307 ;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" c-pointer) #f)))
    1308 ;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" SDL_Event) (car e))))))
    1309 
    1310 (define (sdl-push-event e)
    1311   (zero? ((foreign-lambda int "SDL_PushEvent" SDL_Event) e)))
    1312 
    1313 (define sdl-event-state! (foreign-lambda int "SDL_EventState" unsigned-int integer))
    1314 
    1315 ; You can pass NULL for the args if you just want the button state
    1316 (define sdl-get-mouse-state (foreign-lambda int "SDL_GetMouseState" s32vector s32vector))
    1317 
    1318 (define sdl-warp-mouse (foreign-lambda void "SDL_WarpMouse" int int))
    1319  
    1320 (define sdl-enable-unicode (foreign-lambda bool "SDL_EnableUNICODE" bool))
    1321 
    1322 ;---------------------------------------------------------------------------
    1323 
    1324 (define sdl-get-video-surface (foreign-lambda SDL_Surface "SDL_GetVideoSurface"))
    1325 
    1326 (define (sdl-video-driver-name)
    1327   (let ((bv (make-blob 128)))
    1328     (and ((foreign-lambda bool "SDL_VideoDriverName" (c-pointer char) integer)
    1329           (make-locative bv)
    1330           (blob-size bv))
    1331          (substring (blob->string bv)
    1332                     0
    1333                     (string-index (blob->string bv)
    1334                                   (integer->char 0))))))
    1335 
    1336 (define sdl-set-video-mode (foreign-lambda SDL_Surface "SDL_SetVideoMode"
    1337                                            integer ; width
    1338                                            integer ; height
    1339                                            integer ; bpp
    1340                                            unsigned-integer ; flags
    1341                                            ))
    1342 
    1343 (define (sdl-video-mode-ok w h bpp flags)
    1344   (let ((result ((foreign-lambda integer "SDL_VideoModeOK"
    1345                                  integer integer
    1346                                  integer unsigned-integer)
    1347                  w h bpp flags)))
    1348     (and (not (zero? result))
    1349          result)))
    1350 
    1351 (define (sdl-show-cursor . toggle)
    1352   (if (null? toggle)
    1353       ((foreign-lambda int "SDL_ShowCursor" int) -1)
    1354       ((foreign-lambda int "SDL_ShowCursor" int) (if (car toggle) 1 0))))
    1355 
    1356 (define sdl-map-rgb (foreign-lambda unsigned-integer "SDL_MapRGB"
    1357                                     SDL_PixelFormat
    1358                                     unsigned-byte
    1359                                     unsigned-byte
    1360                                     unsigned-byte))
    1361 
    1362 (define sdl-map-rgba (foreign-lambda unsigned-integer "SDL_MapRGBA"
    1363                                      SDL_PixelFormat
    1364                                      unsigned-byte
    1365                                      unsigned-byte
    1366                                      unsigned-byte
    1367                                      unsigned-byte))
    1368 
    1369 ;---------------------------------------------------------------------------
    1370 
    1371 (define (sdl-fill-rect s r c)
    1372   (if (sdl-color? c)
    1373       ((foreign-lambda* int ((SDL_Surface s)
    1374                              (SDL_Rect r)
    1375                              (scheme-pointer cbuf))
    1376                         "SDL_Color *c = (SDL_Color *) cbuf;"
    1377                         "unsigned int c2 = SDL_MapRGB(s->format, c->r, c->g, c->b);"
    1378                         "C_return(SDL_FillRect(s, r, c2));")
    1379        s r (sdl-color-buffer c))
    1380       ((foreign-lambda int "SDL_FillRect" SDL_Surface SDL_Rect unsigned-integer)
    1381        s r c)))
    1382 
    1383 (define sdl-flip (foreign-lambda int "SDL_Flip" SDL_Surface))
    1384 
    1385 (define sdl-create-rgb-surface (foreign-lambda SDL_Surface "SDL_CreateRGBSurface"
    1386                                                unsigned-integer ; flags
    1387                                                integer ; width
    1388                                                integer ; height
    1389                                                integer ; depth
    1390                                                unsigned-integer ; rmask
    1391                                                unsigned-integer ; gmask
    1392                                                unsigned-integer ; bmask
    1393                                                unsigned-integer)) ; amask
    1394 (define (sdl-free-surface surf)
    1395   ((foreign-lambda void "SDL_FreeSurface" SDL_Surface) surf)
    1396   (sdl-surface-pointer-set! surf (address->pointer 0)))
    1397 
    1398 (define sdl-blit-surface (foreign-lambda integer "SDL_BlitSurface"
    1399                                          SDL_Surface SDL_Rect ; src, srcrect
    1400                                          SDL_Surface SDL_Rect)) ; dst, dstrect
    1401 
    1402 (define (sdl-with-clip-rect s r thunk)
    1403   (let ((orig-clip-rect (make-sdl-rect 0 0 0 0)))
    1404     (dynamic-wind
    1405         (lambda ()
    1406           (sdl-get-clip-rect! s orig-clip-rect)
    1407           (sdl-set-clip-rect! s r))
    1408         thunk
    1409         (lambda ()
    1410           (sdl-set-clip-rect! s orig-clip-rect)))))
    1411 
    1412 ;---------------------------------------------------------------------------
    1413 
    1414 (define-foreign-variable sizeof-sdl-color int "sizeof(SDL_Color)")
    1415 
    1416 (let ((maker make-sdl-color))
    1417   (set! make-sdl-color
    1418         (lambda (r g b)
    1419           (let ((bv (make-blob sizeof-sdl-color)))
    1420             (fill-sdl-color! (maker bv) r g b)))))
    1421 
    1422 (define-record-printer (sdl-color s out)
    1423   (for-each (lambda (x) (display x out))
    1424             (list "#<sdl-color "
    1425                   (sdl-color-r s)" "
    1426                   (sdl-color-g s)" "
    1427                   (sdl-color-b s)">")))
    1428 
    1429 (define (fill-sdl-color! c r g b)
    1430   ((foreign-lambda* void ((SDL_Color c) (unsigned-byte r) (unsigned-byte g) (unsigned-byte b))
    1431                     "c->r = r; c->g = g; c->b = b;")
    1432    c r g b)
    1433   c)
    1434 
    1435 (define sdl-color-r (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->r);"))
    1436 (define sdl-color-g (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->g);"))
    1437 (define sdl-color-b (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->b);"))
    1438 
    1439 ;---------------------------------------------------------------------------
    1440 (define-record-printer (sdl-joystick p out)
    1441   (for-each (lambda (x) (display x out))
    1442             (list "#<sdl-joystick "(sdl-joystick-pointer p)">")))
    1443 
    1444 (define sdl-joystick-event-state (foreign-lambda int "SDL_JoystickEventState"
    1445                                                  int))
    1446 (define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
    1447 (define sdl-num-joysticks (foreign-lambda int "SDL_NumJoysticks"))
    1448 (define sdl-joystick-name (foreign-lambda c-string "SDL_JoystickName" int))
    1449 (define sdl-joystick-open (foreign-lambda SDL_Joystick "SDL_JoystickOpen" int))
    1450 (define sdl-joystick-opened (foreign-lambda int "SDL_JoystickOpened" int))
    1451 (define sdl-joystick-index (foreign-lambda int "SDL_JoystickIndex"
    1452                                            SDL_Joystick))
    1453 (define sdl-joystick-num-axes (foreign-lambda int "SDL_JoystickNumAxes"
    1454                                               SDL_Joystick))
    1455 (define sdl-joystick-num-balls (foreign-lambda int "SDL_JoystickNumBalls"
    1456                                                SDL_Joystick))
    1457 (define sdl-joystick-num-hats (foreign-lambda int "SDL_JoystickNumHats"
    1458                                               SDL_Joystick))
    1459 (define sdl-joystick-num-buttons (foreign-lambda int "SDL_JoystickNumButtons"
    1460                                                  SDL_Joystick))
    1461 (define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
    1462 (define sdl-joystick-get-axis (foreign-lambda short "SDL_JoystickGetAxis"
    1463                                               SDL_Joystick int))
    1464 (define sdl-joystick-get-hat (foreign-lambda unsigned-char "SDL_JoystickGetHat"
    1465                                              SDL_Joystick int))
    1466 (define sdl-joystick-get-button (foreign-lambda unsigned-char
    1467                                                 "SDL_JoystickGetButton"
    1468                                                 SDL_Joystick int))
    1469 ;TODO: sdl-joystick-get-ball
    1470 (define sdl-joystick-close (foreign-lambda void "SDL_JoystickClose"
    1471                                            SDL_Joystick))
    1472 
    1473 ;---------------------------------------------------------------------------
    1474 ;
    1475 ; OpenGL stuff:
    1476 
    1477 (--sdl-flags "SDL_GL_RED_SIZE"
    1478              "SDL_GL_GREEN_SIZE"
    1479              "SDL_GL_BLUE_SIZE"
    1480              "SDL_GL_ALPHA_SIZE"
    1481              "SDL_GL_BUFFER_SIZE"
    1482              "SDL_GL_DOUBLEBUFFER"
    1483              "SDL_GL_DEPTH_SIZE"
    1484              "SDL_GL_STENCIL_SIZE"
    1485              "SDL_GL_ACCUM_RED_SIZE"
    1486              "SDL_GL_ACCUM_GREEN_SIZE"
    1487              "SDL_GL_ACCUM_BLUE_SIZE"
    1488              "SDL_GL_ACCUM_ALPHA_SIZE"
    1489              "SDL_GL_STEREO"
    1490              "SDL_GL_MULTISAMPLEBUFFERS"
    1491              "SDL_GL_MULTISAMPLESAMPLES"
    1492              "SDL_GL_SWAP_CONTROL"
    1493              "SDL_GL_ACCELERATED_VISUAL")
    1494 
    1495 (define sdl-gl-swap-buffers (foreign-lambda void "SDL_GL_SwapBuffers"))
    1496 (define sdl-gl-set-attribute (foreign-lambda int "SDL_GL_SetAttribute" unsigned-int int))
    1497 
    1498 (define sdl-gl-get-attribute
    1499   (let ((get (foreign-lambda int "SDL_GL_GetAttribute" unsigned-int (c-pointer int))))
    1500     (lambda (attr)
    1501       (let-location ((ptr int))
    1502         (let ((r (get attr (location ptr))))
    1503           (and (zero? r) ptr))))))
    1504 
    1505 ;---------------------------------------------------------------------------
    1506110
    1507111(define-record ttf-font pointer)
    1508112
    1509113(define-record-printer (ttf-font f out)
    1510   (for-each (lambda (x) (display x out))
    1511             (list "#<ttf-font "(ttf-font-pointer f)">")))
     114  (fprintf out "#<ttf-font ~S>"
     115           (ttf-font-pointer f)))
    1512116
    1513117(define-foreign-type TTF_Font (c-pointer "TTF_Font")
    … …  
    1613217                                                 "C_return(TTF_RenderGlyph_Blended(font,ch,*fg));"))
    1614218
    1615 ;---------------------------------------------------------------------------
    1616 
    1617 (define img-init (foreign-lambda unsigned-int "IMG_Init" unsigned-int))
    1618 (define img-quit (foreign-lambda void "IMG_Quit"))
    1619 (define img-load (foreign-lambda SDL_Surface "IMG_Load" c-string))
    1620 
    1621 ;---------------------------------------------------------------------------
    1622 
    1623 (define rotozoom-surface (foreign-lambda SDL_Surface "rotozoomSurface"
    1624                                          SDL_Surface ; src
    1625                                          double ; angle
    1626                                          double ; zoom
    1627                                          bool)) ; smooth
    1628 
    1629 (define zoom-surface (foreign-lambda SDL_Surface "zoomSurface"
    1630                                      SDL_Surface ; src
    1631                                      double ; zoomx
    1632                                      double ; zoomy
    1633                                      bool)) ; smooth
    1634 
    1635 ;---------------------------------------------------------------------------
    1636 
    1637 (define-foreign-variable sizeof-sdl-ip-address int "sizeof(IPaddress)")
    1638 (define-record sdl-ip-address buffer)
    1639 
    1640 (let ((maker make-sdl-ip-address))
    1641   (set! make-sdl-ip-address
    1642         (lambda (a b c d p)
    1643           (let* ((bv (make-blob sizeof-sdl-ip-address))
    1644                  (addr (maker bv)))
    1645             ((foreign-lambda* void ((blob bv)
    1646                                     (unsigned-integer host)
    1647                                     (unsigned-short port))
    1648                               "IPaddress *ipa = (IPaddress *) bv;"
    1649                               "ipa->host = host;"
    1650                               "ipa->port = htons(port);")
    1651              bv
    1652              (+ (* a 16777216)
    1653                 (* b 65536)
    1654                 (* c 256)
    1655                 d)
    1656              p)
    1657             addr))))
    1658 
    1659 (define-record-printer (sdl-ip-address s out)
    1660   (for-each (lambda (x) (display x out))
    1661             (list "#<IPaddress "
    1662                   (sdl-ip-address-a s)"."
    1663                   (sdl-ip-address-b s)"."
    1664                   (sdl-ip-address-c s)"."
    1665                   (sdl-ip-address-d s)" "
    1666                   (sdl-ip-address-port s)">")))
    1667 
    1668 (define (-sdl-unbox-ip-address e)
     219;;
     220;; GlyphMetrics
     221;;
     222
     223(define-record ttf-glyph buffer)
     224
     225(foreign-declare "typedef struct { int minx, maxx, miny, maxy, adv; } GlyphMetrics; ")
     226(define-foreign-variable sizeof-glyph-metrics int "sizeof(GlyphMetrics)")
     227
     228(let ((maker make-ttf-glyph))
     229  (set! make-ttf-glyph
     230        (lambda () (maker (make-blob sizeof-glyph-metrics)))))
     231
     232(define (-sdl-unbox-ttf-glyph e)
    1669233  (let ((p (##sys#make-pointer)))
    1670     (if e (##core#inline "C_pointer_to_block" p (sdl-ip-address-buffer e)))
     234    (if e (##core#inline "C_pointer_to_block" p (ttf-glyph-buffer e)))
    1671235    p))
    1672236
    1673 (define-foreign-type IPaddress (c-pointer "IPaddress")
    1674   -sdl-unbox-ip-address)
    1675 
    1676 (define sdl-ip-address-a
    1677   (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[0]);"))
    1678 (define sdl-ip-address-b
    1679   (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[1]);"))
    1680 (define sdl-ip-address-c
    1681   (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[2]);"))
    1682 (define sdl-ip-address-d
    1683   (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[3]);"))
    1684 
    1685 (define sdl-ip-address-port
    1686   (foreign-lambda* unsigned-short ((IPaddress a)) "C_return(ntohs(a->port));"))
    1687 
    1688 (define sdl-ip-address-port-set!
    1689   (foreign-lambda* void ((IPaddress a)
    1690                          (unsigned-short p))
    1691                    "a->port = htons(p);"))
    1692 
    1693 ;---------------------------------------------------------------------------
    1694 
    1695 (define-record sdl-tcp-socket pointer)
    1696 
    1697 (define-record-printer (sdl-tcp-socket s out)
    1698   (for-each (lambda (x) (display x out))
    1699             (list "#<sdl-tcp-socket "(sdl-tcp-socket-pointer s)">")))
    1700 
    1701 (define-foreign-type TCPsocket (c-pointer (struct "_TCPsocket"))
    1702   sdl-tcp-socket-pointer
    1703   (pointer-to-record-lambda sdl-tcp-socket))
    1704 
    1705 ;---------------------------------------------------------------------------
    1706 
    1707 (define sdl-net-init (foreign-lambda int "SDLNet_Init"))
    1708 (define sdl-net-quit (foreign-lambda void "SDLNet_Quit"))
    1709 
    1710 (define sdl-net-resolve-host!
    1711   (foreign-lambda int "SDLNet_ResolveHost" IPaddress c-string unsigned-short))
    1712 
    1713 (define sdl-net-resolve-ip (foreign-lambda c-string "SDLNet_ResolveIP" IPaddress))
    1714 
    1715 (define (sdl-net-resolve-host hostname port)
    1716   (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
    1717     (and (zero? (sdl-net-resolve-host! ipa hostname port))
    1718          ipa)))
    1719 
    1720 (define (-sdl-register-socket sock)
    1721   (and sock
    1722        (begin
    1723          (set-finalizer! sock sdl-net-tcp-close)
    1724          sock)))
    1725 
    1726 (define (sdl-net-tcp-open ipa)
    1727   (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Open" IPaddress) ipa)))
    1728 
    1729 (define (sdl-net-tcp-accept serv)
    1730   (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Accept" TCPsocket) serv)))
    1731 
    1732 (define (sdl-net-tcp-get-peer-address sock)
    1733   (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
    1734     (if ((foreign-lambda* bool ((TCPsocket sock)
    1735                                 (IPaddress ipa))
    1736                           "IPaddress *result = SDLNet_TCP_GetPeerAddress(sock);"
    1737                           "if (result != NULL) {"
    1738                           "  *ipa = *result;"
    1739                           "  C_return(1);"
    1740                           "} else {"
    1741                           "  C_return(0);"
    1742                           "}")
    1743          sock ipa)
    1744         ipa
    1745         #f)))
    1746 
    1747 (define (sdl-net-tcp-send sock bv)
    1748   ((foreign-lambda int "SDLNet_TCP_Send" TCPsocket blob integer)
    1749    sock bv (blob-size bv)))
    1750 
    1751 (define sdl-net-tcp-recv (foreign-lambda int "SDLNet_TCP_Recv" TCPsocket blob integer))
    1752 
    1753 (define (sdl-net-tcp-close sock)
    1754   (if (sdl-tcp-socket-pointer sock)
    1755       (begin
    1756         ((foreign-lambda void "SDLNet_TCP_Close" TCPsocket) sock)
    1757         (sdl-tcp-socket-pointer-set! sock #f))))
    1758 
    1759 (define (sdl-net-tcp-send-string sock str)
    1760   (sdl-net-tcp-send sock (string->blob str)))
    1761 
    1762 (define (sdl-net-tcp-recv-string sock buflen)
    1763   (let* ((bv (make-blob buflen))
    1764          (result (sdl-net-tcp-recv sock bv buflen)))
    1765     (if (positive? result)
    1766         (substring (blob->string bv) 0 result)
    1767         result)))
    1768 
    1769 ;---------------------------------------------------------------------------
    1770 
    1771 (define-record sdl-net-socket-set pointer)
    1772 
    1773 (define-record-printer (sdl-net-socket-set s out)
    1774   (for-each (lambda (x) (display x out))
    1775             (list "#<sdl-net-socket-set "(sdl-net-socket-set-pointer s)">")))
    1776 
    1777 (define-foreign-type SDLNet_SocketSet (c-pointer (struct "_SDLNet_SocketSet"))
    1778   sdl-net-socket-set-pointer
    1779   (pointer-to-record-lambda sdl-net-socket-set))
    1780 
    1781 ;---------------------------------------------------------------------------
    1782 
    1783 (define sdl-net-alloc-socket-set (foreign-lambda SDLNet_SocketSet "SDLNet_AllocSocketSet" int))
    1784 (define sdl-net-free-socket-set (foreign-lambda void "SDLNet_FreeSocketSet" SDLNet_SocketSet))
    1785 
    1786 (define sdl-net-tcp-add-socket!
    1787   (foreign-lambda int "SDLNet_TCP_AddSocket" SDLNet_SocketSet TCPsocket))
    1788 
    1789 (define sdl-net-tcp-del-socket!
    1790   (foreign-lambda int "SDLNet_TCP_DelSocket" SDLNet_SocketSet TCPsocket))
    1791 
    1792 (define (sdl-net-check-sockets socket-set timeout) ;; timeout in milliseconds
    1793   (let ((result ((foreign-lambda int "SDLNet_CheckSockets" SDLNet_SocketSet unsigned-integer)
    1794                  socket-set timeout)))
    1795     (if (= result -1)
    1796         #f
    1797         result)))
    1798 
    1799 (define sdl-net-socket-ready? (foreign-lambda bool "SDLNet_SocketReady" TCPsocket))
    1800 
    1801 ;---------------------------------------------------------------------------
    1802 
    1803 (define sdl-net-write-16
    1804   (foreign-lambda* void ((blob bv)
    1805                          (int offset)
    1806                          (unsigned-short value))
    1807                    "SDLNet_Write16(value, &bv[offset]);"))
    1808 
    1809 (define sdl-net-write-32
    1810   (foreign-lambda* void ((blob bv)
    1811                          (int offset)
    1812                          (unsigned-integer value))
    1813                    "SDLNet_Write32(value, &bv[offset]);"))
    1814 
    1815 (define sdl-net-read-16
    1816   (foreign-lambda* unsigned-short ((blob bv)
    1817                                    (int offset))
    1818                    "C_return(SDLNet_Read16(&bv[offset]));"))
    1819 
    1820 (define sdl-net-read-32
    1821   (foreign-lambda* unsigned-integer ((blob bv)
    1822                                      (int offset))
    1823                    "C_return(SDLNet_Read32(&bv[offset]));"))
    1824 
    1825 )
     237(define-foreign-type GlyphMetrics (c-pointer "GlyphMetrics")
     238  -sdl-unbox-ttf-glyph)
     239
     240(define-record-printer (ttf-glyph o out)
     241  (fprintf out "#<ttf-glyph minx: ~S maxx: ~S miny: ~S maxy: ~S adv: ~S>"
     242           (ttf-glyph-minx o)
     243           (ttf-glyph-maxx o)
     244           (ttf-glyph-miny o)
     245           (ttf-glyph-maxy o)
     246           (ttf-glyph-advance o)))
     247
     248(define ttf-glyph-minx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->minx);"))
     249(define ttf-glyph-maxx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxx);"))
     250(define ttf-glyph-miny (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->miny);"))
     251(define ttf-glyph-maxy (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxy);"))
     252(define ttf-glyph-advance (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->adv);"))
     253
     254(define ttf-glyph-metrics
     255  (foreign-lambda*
     256   bool ((TTF_Font font)
     257         (unsigned-int c)
     258         (GlyphMetrics gm))
     259   "C_return((0 == TTF_GlyphMetrics(font, c, &gm->minx, &gm->maxx, &gm->miny, &gm->maxy, &gm->adv)));")))

  • release/4/sdl-ttf/trunk/sdl-ttf.setup

    r27336 r27337  
    11;;;; sdl.setup -*- Scheme -*-
    2 
    3 
    4 (define (check-depends)
    5      
    6   (let* ((lib-fun-pack '(("SDL" "SDL_Init" "libsdl1.2-dev")
    7                          ("SDL_gfx" "polygonColor" "libsdl-gfx1.2-dev")
    8                          ("SDL_net" "SDLNet_Init" "libsdl-net1.2-dev")
    9                          ("SDL_ttf" "TTF_Init" "libsdl-ttf2.0-dev")
    10                          ("SDL_image" "IMG_Init" "libsdl-image1.2-dev")))
    11          (missing (filter (lambda (lib-fun)
    12                             (not (find-library (first lib-fun) (second lib-fun))))
    13                           lib-fun-pack)))
    14     (for-each
    15      (lambda (lib-fun)
    16        (print "\nWARNING: You seem to be missing the library " (first lib-fun) "!"))
    17      missing)
    18     (cond-expand
    19      (linux
    20       (unless (null? missing)
    21         (print "\nSuggested package(s) to install: " (map third missing))))
    22      (else #f))))
    23 
    24 (check-depends)
    252
    263(let* ((escape-flags (lambda (fs)
    … …  
    3512                          (escape-flags
    3613                           (with-input-from-pipe "sdl-config --cflags" read-line))))
    37        (sdl-lflags (apply string-append
    38                           ;; sdl-config doesn't give these
    39                           " -lSDL_gfx -lSDL_net -lSDL_ttf -lSDL_image"
    40                           (escape-flags
    41                            (with-input-from-pipe "sdl-config --libs" read-line))))
     14       
    4215       (types? (version>=? (chicken-version) "4.7.4"))
    43        (files (append '("sdl.so"
    44                         "sdl.import.so"
    45                         "sdl-foreign-types-include.scm")
    46                       (if types? '("sdl.types") '()))))
    47   (compile ,@(if types? '(-emit-type-file sdl.types) '())
    48            -s -O3 -d1 sdl.scm -j sdl -lSDL ,sdl-cflags ,sdl-lflags)
    49   (compile -s -O3 -d0 sdl.import.scm ,sdl-cflags ,sdl-lflags)
     16       (files (append '("sdl-ttf.so"
     17                        "sdl-ttf.import.so")
     18                      (if types? '("sdl-ttf.types") '()))))
     19  (compile ,@(if types? '(-emit-type-file sdl-ttf.types) '())
     20           -I ,(repository-path)
     21           -s -O3 -v -d1 sdl-ttf.scm -j sdl-ttf ,sdl-cflags -lSDL_ttf)
     22  (compile -s -O3 -d0 sdl-ttf.import.scm)
    5023
    51   (install-extension 'sdl files '((version "0.5.5"))))
     24  (install-extension 'sdl-ttf files '((version "0.1"))))
    5225
Note: See TracChangeset for help on using the changeset viewer.