#lang racket
(require
ffi/unsafe
"base.rkt")
(define libiup-gl
(case (system-type 'os)
[(windows)
(ffi-lib "iupgl")]
[else
(ffi-lib "libiupgl")]))
(define glcanvas
(make-constructor-procedure
(get-ffi-obj
"IupGLCanvas" libiup-gl
(_fun ([action #f]) :: [action : _iname/upcase] -> [handle : _ihandle]))))
(define call-with-glcanvas
(letrec ([glcanvas-make-current
(get-ffi-obj
"IupGLMakeCurrent" libiup-gl
(_fun [handle : _ihandle] -> _void))]
[glcanvas-swap-buffers
(get-ffi-obj
"IupGLSwapBuffers" libiup-gl
(_fun [handle : _ihandle] -> _void))]
[glcanvas-wait
(get-ffi-obj
"IupGLWait" libiup-gl
(_fun [gl? : _bool] -> _void))])
(λ (handle proc #:swap? [swap? #f] #:sync? [sync? #f])
(dynamic-wind
(λ ()
(glcanvas-make-current handle)
(when sync? (glcanvas-wait #f)))
(λ ()
(proc handle))
(λ ()
(when swap? (glcanvas-swap-buffers handle))
(when sync? (glcanvas-wait #t)))))))
(define glcanvas-is-current?
(get-ffi-obj
"IupGLIsCurrent" libiup-gl
(_fun [handle : _ihandle] -> _bool)))
(define glcanvas-palette-set!
(get-ffi-obj
"IupGLPalette" libiup-gl
(_fun [handle : _ihandle] [index : _int] [r : _float] [g : _float] [b : _float] -> _void)))
(define glcanvas-font-set!
(get-ffi-obj
"IupGLUseFont" libiup-gl
(_fun [handle : _ihandle] [first : _int] [count : _int] [list-base : _int] -> _void)))
(letrec ([open
(get-ffi-obj
"IupGLCanvasOpen" libiup-gl
(_fun -> _void))])
(open))
(provide
glcanvas
call-with-glcanvas glcanvas-is-current?
glcanvas-palette-set! glcanvas-font-set!)