CHICKEN Scheme bindings to nuklear

nuklear-glfw-opengl2.scm 3.8KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106
  1. (module nuklear-glfw-opengl2
  2. (anti-alias? max-vertex-buffer max-element-buffer
  3. init! init-font! new-frame render! shutdown!)
  4. (import chicken scheme foreign)
  5. (use lolevel)
  6. #>
  7. #define NK_INCLUDE_FIXED_TYPES
  8. #define NK_INCLUDE_STANDARD_IO
  9. #define NK_INCLUDE_DEFAULT_ALLOCATOR
  10. #define NK_INCLUDE_VERTEX_BUFFER_OUTPUT
  11. #define NK_INCLUDE_FONT_BAKING
  12. #define NK_INCLUDE_DEFAULT_FONT
  13. #define NK_GLFW_GL2_IMPLEMENTATION
  14. #include "nuklear.h"
  15. #include "nuklear_glfw_gl2.h"
  16. <#
  17. ;;; parameters
  18. (define anti-alias? (make-parameter #t))
  19. (define max-vertex-buffer (make-parameter (* 512 1024)))
  20. (define max-element-buffer (make-parameter (* 128 1024)))
  21. ;;; auxiliary records
  22. (define-record context pointer)
  23. (define-record font filename size)
  24. ;;; errors
  25. (define (define-error location message #!rest condition)
  26. (let ((base (make-property-condition 'exn 'location location 'message message))
  27. (extra (apply make-property-condition condition)))
  28. (make-composite-condition base extra)))
  29. (define (nuklear-error message location)
  30. (define-error location message 'nuklear))
  31. ;;; enums
  32. ;; enum nk_glfw_init_state
  33. (define NK_GLFW3_DEFAULT (foreign-value "NK_GLFW3_DEFAULT" int))
  34. (define NK_GLFW3_INSTALL_CALLBACKS (foreign-value "NK_GLFW3_INSTALL_CALLBACKS" int))
  35. ;; enum nk_anti_aliasing
  36. (define NK_ANTI_ALIASING_OFF (foreign-value "NK_ANTI_ALIASING_OFF" int))
  37. (define NK_ANTI_ALIASING_ON (foreign-value "NK_ANTI_ALIASING_ON" int))
  38. ;;; foreign functions
  39. (define nk_glfw3_init (foreign-lambda (nonnull-c-pointer (struct "nk_context")) "nk_glfw3_init" (c-pointer (struct "GLFWwindow")) (enum "nk_glfw_init_state")))
  40. (define nk_glfw3_init_font (foreign-lambda* bool (((c-pointer (struct "nk_context")) ctx) (scheme-object data))
  41. "struct nk_font_atlas *atlas;"
  42. "struct nk_font *font = 0;"
  43. "int is_default = !C_truep(data);"
  44. "nk_glfw3_font_stash_begin(&atlas);"
  45. "if (!is_default) {"
  46. " C_word pair = (C_word) data;"
  47. " char *font_name = C_c_string(C_u_i_car(pair));"
  48. " int font_size = C_unfix(C_u_i_cdr(pair));"
  49. " font = nk_font_atlas_add_from_file(atlas, font_name, font_size, 0);"
  50. "}"
  51. "nk_glfw3_font_stash_end();"
  52. "if (font)"
  53. " nk_style_set_font(ctx, &font->handle);"
  54. "if (is_default || font)"
  55. " C_return(1);"
  56. "else"
  57. " C_return(0);"))
  58. (define nk_glfw3_new_frame (foreign-lambda void "nk_glfw3_new_frame"))
  59. (define nk_glfw3_render (foreign-lambda void "nk_glfw3_render" (enum "nk_anti_aliasing") int int))
  60. (define nk_glfw3_shutdown (foreign-lambda void "nk_glfw3_shutdown"))
  61. ;;; API
  62. ;; TODO: consider swapping meaning of second argument, make it optional
  63. (define (init! window install-callbacks?)
  64. (when window
  65. (let ((flag (if install-callbacks?
  66. NK_GLFW3_INSTALL_CALLBACKS
  67. NK_GLFW3_DEFAULT)))
  68. (make-context (nk_glfw3_init window flag)))))
  69. (define (init-font! #!optional context path size)
  70. (let ((ret (if (and context path size)
  71. (nk_glfw3_init_font (context-pointer context) (cons path size))
  72. (nk_glfw3_init_font #f #f))))
  73. (when (not ret)
  74. (signal (nuklear-error "Failed initializing font" 'init-font!)))))
  75. (define new-frame nk_glfw3_new_frame)
  76. (define (render!)
  77. (let ((flag (if (anti-alias?)
  78. NK_ANTI_ALIASING_ON
  79. NK_ANTI_ALIASING_OFF)))
  80. (nk_glfw3_render flag (max-vertex-buffer) (max-element-buffer))))
  81. (define shutdown! nk_glfw3_shutdown)
  82. )