Initial commit

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. 

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"))

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))
+  

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))
+

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)))
+

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)))
+
+
+