Initial commit
This commit is contained in:
commit
5924a47d27
6 changed files with 333 additions and 0 deletions
6
README.md
Normal file
6
README.md
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
# schemelib
|
||||
|
||||
SchemeLib is my own swiss knife when coding with scheme, it helps code reuse across my projects.
|
||||
Code is tailored to my needs, so from an external point of view it's probably the worst imaginable standard library imaginable (just after the one of PHP 4 and less).
|
||||
|
||||
Of course, there is no documentation.
|
||||
8
bindings/glib.scm
Normal file
8
bindings/glib.scm
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
(define (g-main-loop-new context is-running)
|
||||
((foreign-procedure "g_main_loop_new" (void* boolean) void*) context is-running))
|
||||
(define (g-main-loop-run loop)
|
||||
((foreign-procedure "g_main_loop_run" (void*) void) loop))
|
||||
(define (g-main-loop-quit loop)
|
||||
((foreign-procedure "g_main_loop_quit" (void*) void) loop))
|
||||
|
||||
(load-shared-object "libglib-2.0.so"))
|
||||
12
bindings/gobject.scm
Normal file
12
bindings/gobject.scm
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
(load-shared-object "libgobject-2.0.so"))
|
||||
|
||||
(define (g-object-set object property value)
|
||||
((foreign-procedure "g_object_set" (void* string string void*) void) object property value 0))
|
||||
(define (g-signal-connect-data instance detailed-signal handler data destroy-data connect-flag)
|
||||
((foreign-procedure "g_signal_connect_data" (void* string void* void* void* int) void)
|
||||
instance detailed-signal handler data destroy-data connect-flag))
|
||||
(define (g-signal-connect instance detailed-signal handler data)
|
||||
(g-signal-connect-data instance detailed-signal handler data 0 0))
|
||||
(define (g-object-unref object)
|
||||
((foreign-procedure "g_object_unref" (void*) void) object))
|
||||
|
||||
55
bindings/gstreamer1.scm
Normal file
55
bindings/gstreamer1.scm
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
(load-shared-object "libgstreamer-1.0.so.0"))
|
||||
|
||||
; Data structures
|
||||
(define (gst-message->symbol int)
|
||||
(case int
|
||||
((1) 'eos)
|
||||
((2) 'error)))
|
||||
|
||||
(define (gst-state->int symbol)
|
||||
(case symbol
|
||||
((void-pending) 0)
|
||||
((null) 1)
|
||||
((ready) 2)
|
||||
((paused) 3)
|
||||
((playing) 4)))
|
||||
|
||||
(define-ftype gst-mini-object
|
||||
(struct
|
||||
[type unsigned-long]
|
||||
[refcount int]
|
||||
[lockstate int]
|
||||
[flags unsigned-int]
|
||||
[copy void*]
|
||||
[dispose void*]
|
||||
[free void*]
|
||||
[n-qdata unsigned-int]
|
||||
[qdata void*]))
|
||||
|
||||
(define-ftype gst-message
|
||||
(struct
|
||||
[mini-object gst-mini-object]
|
||||
[type int]
|
||||
[timestamp unsigned-64]
|
||||
[src void*]
|
||||
[seqnum unsigned-32]
|
||||
[lock void*]
|
||||
[cond void*]))
|
||||
|
||||
(define (gst-init argc argv)
|
||||
((foreign-procedure "gst_init" (ptr void*) void) argc argv))
|
||||
(define (gst-element-factory-make factory-name name)
|
||||
((foreign-procedure "gst_element_factory_make" (string string) void*) factory-name name))
|
||||
(define (gst-pipeline-get-bus pipeline)
|
||||
((foreign-procedure "gst_pipeline_get_bus" (void*) void*) pipeline))
|
||||
(define (gst-bus-add-watch bus func user-data)
|
||||
((foreign-procedure "gst_bus_add_watch" (void* void* void*) int) bus func user-data))
|
||||
(define (gst-bus-add-signal-watch bus)
|
||||
((foreign-procedure "gst_bus_add_signal_watch" (void*) void) bus))
|
||||
(define (gst-object-unref object)
|
||||
((foreign-procedure "gst_object_unref" (void*) void) object))
|
||||
(define (gst-element-set-state element state)
|
||||
((foreign-procedure "gst_element_set_state" (void* int) int) element state))
|
||||
(define (gst-filename-to-uri filename err)
|
||||
((foreign-procedure "gst_filename_to_uri" (string void*) string) filename err))
|
||||
|
||||
23
bindings/gtk3.scm
Normal file
23
bindings/gtk3.scm
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
(load-shared-object "libgtk-3.so.0"))
|
||||
|
||||
(define (gtk-init argc argv)
|
||||
((foreign-procedure "gtk_init" (ptr void*) void) argc argv))
|
||||
(define (gtk-builder-new)
|
||||
((foreign-procedure "gtk_builder_new" () void*)))
|
||||
(define (gtk-builder-add-from-file builder filename err)
|
||||
((foreign-procedure "gtk_builder_add_from_file" (void* string void*) void) builder filename err))
|
||||
(define (gtk-builder-get-object builder name)
|
||||
((foreign-procedure "gtk_builder_get_object" (void* string) void*) builder name))
|
||||
(define (gtk-builder-connect-signals builder user-data)
|
||||
((foreign-procedure "gtk_builder_connect_signals" (void* void*) void) builder user-data))
|
||||
(define (gtk-builder-add-callback-symbol builder cb-name cb-symbol)
|
||||
((foreign-procedure "gtk_builder_add_callback_symbol" (void* string void*) void) builder cb-name cb-symbol))
|
||||
(define (gtk-widget-show widget)
|
||||
((foreign-procedure "gtk_widget_show" (void*) void) widget))
|
||||
(define (gtk-widget-set-visible widget visibility)
|
||||
((foreign-procedure "gtk_widget_set_visible" (void* boolean) void) widget visibility))
|
||||
(define (gtk-main)
|
||||
((foreign-procedure "gtk_main" () void)))
|
||||
(define (gtk-main-quit)
|
||||
((foreign-procedure "gtk_main_quit" () void)))
|
||||
|
||||
229
bindings/sdl.scm
Normal file
229
bindings/sdl.scm
Normal file
|
|
@ -0,0 +1,229 @@
|
|||
(load-shared-object "/usr/lib64/libSDL2-2.0.so.0")
|
||||
(load-shared-object "/usr/lib64/libSDL2_image-2.0.so.0")
|
||||
|
||||
; A quick example:
|
||||
; https://stackoverflow.com/questions/20579658/how-to-draw-pixels-in-sdl-2-0
|
||||
;
|
||||
; Header files to write bindings:
|
||||
; https://github.com/SDL-mirror/SDL/tree/master/include
|
||||
; https://github.com/SDL-mirror/SDL_image/blob/master/SDL_image.h
|
||||
|
||||
;--- binding utils
|
||||
(define (check-err out)
|
||||
(assert (= 0 out)))
|
||||
|
||||
;--- SDL.h
|
||||
(define (SDL_INIT-flag->int flag)
|
||||
(case flag
|
||||
((VIDEO) #x00000020)
|
||||
))
|
||||
|
||||
(define (SDL_Init flag)
|
||||
(check-err ((foreign-procedure "SDL_Init" (unsigned-32) int) (SDL_INIT-flag->int flag))))
|
||||
|
||||
(define (SDL_Quit)
|
||||
((foreign-procedure "SDL_Quit" () void)))
|
||||
|
||||
;--- SDL_video.h
|
||||
(define (SDL_WINDOW-flag->int flag)
|
||||
(case flag
|
||||
((SHOW) #x00000004)
|
||||
((FOREIGN) #x00000800)
|
||||
((HIDDEN) #x00000008)
|
||||
))
|
||||
|
||||
(define (SDL_CreateWindow name x y w h flags)
|
||||
(let*
|
||||
[(fx (foreign-procedure
|
||||
"SDL_CreateWindow"
|
||||
(string int int int int unsigned-32)
|
||||
void*))
|
||||
(win (fx name x y w h (SDL_WINDOW-flag->int flags)))]
|
||||
(assert (> win 0))
|
||||
win))
|
||||
|
||||
(define (SDL_SetWindowSize win w h)
|
||||
((foreign-procedure
|
||||
"SDL_SetWindowSize"
|
||||
(void* int int)
|
||||
void) win w h))
|
||||
|
||||
(define (SDL_DestroyWindow window)
|
||||
((foreign-procedure
|
||||
"SDL_DestroyWindow"
|
||||
(void*)
|
||||
void) window))
|
||||
|
||||
;--- SDL_render.h
|
||||
(define-ftype
|
||||
[SdlRect
|
||||
(struct
|
||||
(x int) (y int)
|
||||
(w int) (h int)
|
||||
)])
|
||||
|
||||
(define (SDL_Rect x y w h)
|
||||
(let [
|
||||
(rect
|
||||
(make-ftype-pointer
|
||||
SdlRect
|
||||
(foreign-alloc (ftype-sizeof SdlRect))))]
|
||||
(ftype-set! SdlRect (x) rect x)
|
||||
(ftype-set! SdlRect (y) rect y)
|
||||
(ftype-set! SdlRect (w) rect w)
|
||||
(ftype-set! SdlRect (h) rect h)
|
||||
rect
|
||||
))
|
||||
|
||||
(define (SDL_RenderSetLogicalSize rend w h)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_RenderSetLogicalSize"
|
||||
(void* int int)
|
||||
int) rend w h)))
|
||||
|
||||
(define (SDL_RenderSetScale rend scaleX scaleY)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_RenderSetScale"
|
||||
(void* float float)
|
||||
int) rend scaleX scaleY)))
|
||||
|
||||
(define (SDL_RENDERER-flag->int flag)
|
||||
(case flag
|
||||
((SOFTWARE) #x00000001)
|
||||
((ACCELERATED) #x00000002)
|
||||
))
|
||||
|
||||
(define (SDL_CreateRenderer window index flags)
|
||||
(let*
|
||||
[(fx (foreign-procedure
|
||||
"SDL_CreateRenderer"
|
||||
(void* int unsigned-32)
|
||||
void*))
|
||||
(rend (fx window index (SDL_RENDERER-flag->int flags)))]
|
||||
(assert (> rend 0))
|
||||
rend))
|
||||
|
||||
(define (SDL_RenderReadPixels rend rect format pix pitch)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_RenderReadPixels"
|
||||
(void* (* SdlRect) unsigned-32 void* int)
|
||||
int) rend rect format pix pitch)))
|
||||
|
||||
(define (SDL_SetRenderDrawColor rend r g b a)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_SetRenderDrawColor"
|
||||
(void* unsigned-8 unsigned-8 unsigned-8 unsigned-8)
|
||||
int) rend r g b a)))
|
||||
|
||||
(define (SDL_RenderGetViewport rend rect)
|
||||
((foreign-procedure
|
||||
"SDL_RenderGetViewport"
|
||||
(void* (* SdlRect))
|
||||
void) rend rect))
|
||||
|
||||
(define (SDL_RenderClear rend)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_RenderClear"
|
||||
(void*)
|
||||
int) rend)))
|
||||
|
||||
(define (SDL_RenderDrawPoint rend x y)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"SDL_RenderDrawPoint"
|
||||
(void* int int)
|
||||
int) rend x y)))
|
||||
|
||||
(define (SDL_RenderPresent rend)
|
||||
((foreign-procedure
|
||||
"SDL_RenderPresent"
|
||||
(void*)
|
||||
void) rend))
|
||||
|
||||
(define (SDL_DestroyRenderer rend)
|
||||
((foreign-procedure
|
||||
"SDL_DestroyRenderer"
|
||||
(void*)
|
||||
void) rend))
|
||||
|
||||
;--- SDL_surface.h
|
||||
(define-ftype
|
||||
[SdlPixelFormat
|
||||
(struct
|
||||
(format unsigned-32)
|
||||
;-- not safe to allocate, missing fields
|
||||
)]
|
||||
|
||||
[SdlSurface
|
||||
(struct
|
||||
(flags unsigned-32)
|
||||
(format (* SdlPixelFormat))
|
||||
(w int)
|
||||
(h int)
|
||||
(pitch int)
|
||||
(pixels void*)
|
||||
;-- not safe to allocate, missing fields
|
||||
)])
|
||||
|
||||
(define (SDL_CreateRGBSurface flags w h depth Rm Gm Bm Am)
|
||||
((foreign-procedure
|
||||
"SDL_CreateRGBSurface"
|
||||
(unsigned-32 int int int unsigned-32 unsigned-32 unsigned-32 unsigned-32)
|
||||
(* SdlSurface)) flags w h depth Rm Gm Bm Am))
|
||||
|
||||
; inspired by https://stackoverflow.com/a/20070273
|
||||
(define (SDLb_SetPixel surface x y r g b a)
|
||||
(map
|
||||
(lambda (e)
|
||||
(let [(color (car e)) (intensity (cadr e))]
|
||||
(foreign-set!
|
||||
'unsigned-8
|
||||
(ftype-ref SdlSurface (pixels) surface)
|
||||
(+
|
||||
(* y (ftype-ref SdlSurface (pitch) surface))
|
||||
(* x (ftype-sizeof unsigned-32))
|
||||
color)
|
||||
intensity
|
||||
)))
|
||||
`((0 ,b) (1 ,g) (2 ,r) (3 ,a))
|
||||
))
|
||||
|
||||
;--- SDL_events.h
|
||||
(define-ftype
|
||||
[SdlEvent
|
||||
(union
|
||||
(type unsigned-32)
|
||||
(padding (array 56 unsigned-8)))]
|
||||
)
|
||||
|
||||
(define (SDL_Event)
|
||||
(make-ftype-pointer
|
||||
SdlEvent
|
||||
(foreign-alloc (ftype-sizeof SdlEvent))))
|
||||
|
||||
(define (SDL_PollEvent event)
|
||||
((foreign-procedure
|
||||
"SDL_PollEvent"
|
||||
((* SdlEvent))
|
||||
int) event))
|
||||
|
||||
(define (SDL_EVENT-int->flag i)
|
||||
(case i
|
||||
((#x100) 'QUIT)
|
||||
))
|
||||
|
||||
;--- SDL_image.h
|
||||
(define (IMG_SavePNG surface file)
|
||||
(check-err
|
||||
((foreign-procedure
|
||||
"IMG_SavePNG"
|
||||
((* SdlSurface) string)
|
||||
int) surface file)))
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in a new issue