From 5924a47d27da8e30e313c95e7866fe46c680ca2b Mon Sep 17 00:00:00 2001 From: Quentin Dufour Date: Thu, 2 Jul 2020 17:27:52 +0200 Subject: [PATCH] Initial commit --- README.md | 6 ++ bindings/glib.scm | 8 ++ bindings/gobject.scm | 12 +++ bindings/gstreamer1.scm | 55 ++++++++++ bindings/gtk3.scm | 23 ++++ bindings/sdl.scm | 229 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 333 insertions(+) create mode 100644 README.md create mode 100644 bindings/glib.scm create mode 100644 bindings/gobject.scm create mode 100644 bindings/gstreamer1.scm create mode 100644 bindings/gtk3.scm create mode 100644 bindings/sdl.scm diff --git a/README.md b/README.md new file mode 100644 index 0000000..9b0d0ec --- /dev/null +++ b/README.md @@ -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. diff --git a/bindings/glib.scm b/bindings/glib.scm new file mode 100644 index 0000000..edfb49e --- /dev/null +++ b/bindings/glib.scm @@ -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")) diff --git a/bindings/gobject.scm b/bindings/gobject.scm new file mode 100644 index 0000000..cf13bc9 --- /dev/null +++ b/bindings/gobject.scm @@ -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)) + diff --git a/bindings/gstreamer1.scm b/bindings/gstreamer1.scm new file mode 100644 index 0000000..0ab3aa5 --- /dev/null +++ b/bindings/gstreamer1.scm @@ -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)) + diff --git a/bindings/gtk3.scm b/bindings/gtk3.scm new file mode 100644 index 0000000..fbfdc7f --- /dev/null +++ b/bindings/gtk3.scm @@ -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))) + diff --git a/bindings/sdl.scm b/bindings/sdl.scm new file mode 100644 index 0000000..2e5770a --- /dev/null +++ b/bindings/sdl.scm @@ -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))) + + +