#lang racket
(require
 ffi/unsafe
 "base.rkt")

(define libiup-gl
  (case (system-type 'os)
    [(windows)
     (ffi-lib "iupgl")]
    [else
     (ffi-lib "libiupgl")]))

;; GLCanvas control

(define glcanvas
  (make-constructor-procedure
   (get-ffi-obj
    "IupGLCanvas" libiup-gl
    (_fun ([action #f]) :: [action : _iname/upcase] -> [handle : _ihandle]))))

;; OpenGL context functions

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

;; Library setup

(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!)