#lang racket/base
(require racket/class
         racket/promise
         racket/string
         ffi/unsafe
         ffi/unsafe/define
         ffi/unsafe/alloc
         ffi/cvector
         (prefix-in draw: racket/draw/private/gl-context)
         racket/draw/private/gl-config
         "../../lock.rkt"
         "types.rkt"
         "utils.rkt"
         "window.rkt"
         "x11.rkt")

(provide
 (protect-out prepare-widget-gl-context
              create-widget-gl-context

              create-and-install-gl-context
              get-gdk-pixmap
              install-gl-context))

(define (ffi-lib/complaint-on-failure name vers)
  (ffi-lib name vers
           #:fail (lambda ()
                    (log-warning "could not load library ~a ~a"
                                 name vers)
                    #f)))

;; ===================================================================================================
;; X11/GLX FFI

(define gl-lib (ffi-lib/complaint-on-failure "libGL" '("1" "")))

(define-ffi-definer define-glx gl-lib
  #:default-make-fail make-not-available)

;; X #defines/typedefs/enums
(define _Display (_cpointer 'Display))
(define _XErrorEvent (_cpointer 'XErrorEvent))
(define _XID _ulong)
(define True 1)
(define False 0)
(define None 0)
(define Success 0)

;; GLX #defines/typedefs/enums
(define _GLXFBConfig (_cpointer 'GLXFBConfig))
(define _GLXContext (_cpointer/null 'GLXContext))
(define _XVisualInfo (_cpointer 'XVisualInfo))
;; Attribute tokens for glXGetConfig variants (all GLX versions):
(define GLX_DOUBLEBUFFER     5)
(define GLX_STEREO           6)
(define GLX_DEPTH_SIZE       12)
(define GLX_STENCIL_SIZE     13)
(define GLX_ACCUM_RED_SIZE   14)
(define GLX_ACCUM_GREEN_SIZE 15)
(define GLX_ACCUM_BLUE_SIZE  16)
(define GLX_ACCUM_ALPHA_SIZE 17)
;; GLX 1.3 and later:
(define GLX_X_RENDERABLE     #x8012)
(define GLX_RGBA_TYPE        #x8014)
;; GLX 1.4 and later:
(define GLX_SAMPLES          #x186a1)
(define GLX_SAMPLE_BUFFERS   #x186a0)
;; Attribute tokens for glXCreateContextAttribsARB (also GLX 1.4 and later):
(define GLX_CONTEXT_MAJOR_VERSION_ARB #x2091)
(define GLX_CONTEXT_MINOR_VERSION_ARB #x2092)
(define GLX_CONTEXT_FLAGS_ARB         #x2094)
(define GLX_CONTEXT_PROFILE_MASK_ARB  #x9126)
;; GLX_CONTEXT_FLAGS_ARB bits
(define GLX_CONTEXT_DEBUG_BIT_ARB              #x1)
(define GLX_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB #x2)
;; GLX_CONTEXT_PROFILE_MASK_ARB bits
(define GLX_CONTEXT_CORE_PROFILE_BIT_ARB          #x1)
(define GLX_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB #x2)

(define-x11 XFree (_fun _pointer -> _int)
  #:wrap (deallocator))

(define-x11 XSetErrorHandler
  (_fun _fpointer -> _fpointer))

(define-x11 XSync
  (_fun _Display _int -> _void))

(define-glx glXQueryVersion
  (_fun _Display (major : (_ptr o _int)) (minor : (_ptr o _int))
        -> (ret : _bool)
        -> (values ret major minor)))

(define-glx glXQueryExtensionsString
  (_fun _Display _int -> _string/utf-8))

(define-glx glXChooseFBConfig
  (_fun _Display _int (_list i _int) (len : (_ptr o _int))
        -> (_cvector o _GLXFBConfig len))
  #:wrap (allocator (λ (v) (XFree (cvector-ptr v)))))

(define-glx glXGetFBConfigAttrib
  (_fun _Display _GLXFBConfig _int (out : (_ptr o _int))
        -> (ret : _int)
        -> (values ret out)))

(define-glx glXCreateNewContext
  (_fun _Display _GLXFBConfig _int _GLXContext _bool -> _GLXContext))

(define-glx glXDestroyContext
  (_fun _Display _GLXContext -> _void))

(define-glx glXMakeCurrent
  (_fun _Display _XID _GLXContext -> _bool))

(define-glx glXSwapBuffers
  (_fun _Display _XID -> _void))

(define-glx glXIsDirect
  (_fun _Display _GLXContext -> _bool))

(define-glx glXGetVisualFromFBConfig
  (_fun _Display _GLXFBConfig -> _XVisualInfo)
  #:wrap (allocator XFree))

(define-glx glXCreateGLXPixmap
  (_fun _Display _XVisualInfo _XID -> _XID))

(define-glx glXDestroyGLXPixmap
  (_fun _Display _XID -> _void))

(define-glx glXGetProcAddressARB
  (_fun _string -> _pointer))

(define lazy-glXCreateContextAttribsARB
  (delay
    (function-ptr (glXGetProcAddressARB "glXCreateContextAttribsARB")
                  (_fun _Display _GLXFBConfig _GLXContext _bool (_list i _int)
                        -> _GLXContext))))

(define (glXCreateContextAttribsARB . args)
  (apply (force lazy-glXCreateContextAttribsARB) args))

(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay))
(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))

(define-glx glXSwapIntervalEXT (_fun _Display _XID _int -> _void)
  #:fail (lambda () void))

;; ===================================================================================================
;; GLX versions and extensions queries

(define lazy-get-glx-version
  (delay
    (define-values (worked? glx-major glx-minor)
      (glXQueryVersion (gdk_x11_display_get_xdisplay (gdk_display_get_default))))
    
    (unless worked?
      (error 'get-glx-version "can't get GLX version using default display"))
    
    (define glx-version (+ glx-major (/ glx-minor 10)))
    
    (when (< glx-version #e1.3)
      (error 'get-glx-version "need GLX version 1.3 or greater; given version ~a.~a"
             glx-major glx-minor))
    
    glx-version))

;; -> positive-exact-rational
(define (get-glx-version)
  (force lazy-get-glx-version))

(define lazy-glx-extensions
  (delay
    (define str
      (glXQueryExtensionsString (gdk_x11_display_get_xdisplay (gdk_display_get_default))
                                (gdk_x11_screen_get_screen_number (gdk_screen_get_default))))
    (string-split str)))

(define lazy-GLX_ARB_create_context?
  (delay (member "GLX_ARB_create_context"
                 (force lazy-glx-extensions))))

(define lazy-GLX_ARB_create_context_profile?
  (delay (member "GLX_ARB_create_context_profile"
                 (force lazy-glx-extensions))))

;; ===================================================================================================
;; Wrapper for the _GLXContext (if we can get one from GLX)

(define gl-context% 
  (class draw:gl-context%
    (init-field gl display drawable pixmap)
    
    (define/override (get-handle) gl)
    
    (define/public (get-gtk-display) display)
    (define/public (get-gtk-drawable) drawable)
    (define/public (get-glx-pixmap) pixmap)
    
    (define (get-drawable-xid)
      (if pixmap pixmap (gdk_x11_drawable_get_xid drawable)))
    
    (define/override (draw:do-call-as-current t)
      (define xdisplay (gdk_x11_display_get_xdisplay display))
      (dynamic-wind
       (lambda ()
         (glXMakeCurrent xdisplay (get-drawable-xid) gl))
       t
       (lambda ()
         (glXMakeCurrent xdisplay 0 #f))))
    
    (define/override (draw:do-swap-buffers)
      (glXSwapBuffers (gdk_x11_display_get_xdisplay display)
                      (get-drawable-xid)))
    
    (super-new)))

;; ===================================================================================================
;; Getting OpenGL contexts

;; STUPIDITY ALERT

;; Apparently, the designers of glXCreateNewContext and glXCreateContextAttribsARB didn't trust us to
;; check return values or output arguments, so when these functions fail, they raise an X error and
;; send an error code to the X error handler. X errors, by default, *terminate the program* and print
;; an annoyingly vague, barely helpful error message.

;; This is especially bad with glXCreateContextAttribsARB, which always fails (i.e. crashes the
;; program) if we ask for an unsupported OpenGL version. Worse, this is the only way to find out
;; which OpenGL versions are available!

;; So we override the X error handler to silently fail, and sync right after the calls to make sure
;; the errors are processed immediately. With glXCreateContextAttribsARB, we then try the next lowest
;; OpenGL version. If all attempts to get a context fail, we return #f.

(define create-context-error? #f)
(define (flag-x-error-handler xdisplay xerrorevent)
  (set! create-context-error? #t)
  0)

;; _Display _GLXFBConfig _GLXContext -> _GLXContext
(define (glx-create-new-context xdisplay cfg share-gl)
  ;; Sync right now, or the sync further on could crash Racket with an [xcb] error about events
  ;; happening out of sequence
  (XSync xdisplay False)

  (define old-handler #f)
  (define gl
    (dynamic-wind
     (λ ()
       (set! old-handler
	     (XSetErrorHandler (cast flag-x-error-handler
				     (_fun #:atomic? #t _Display _XErrorEvent -> _int)
				     _fpointer))))
     (λ ()
       (set! create-context-error? #f)
       (glXCreateNewContext xdisplay cfg GLX_RGBA_TYPE share-gl #t))
     (λ ()
       ;; Sync to ensure errors are processed
       (XSync xdisplay False)
       (XSetErrorHandler old-handler))))

  (cond
    [(and gl create-context-error?)
     (log-error (string-append
		 "gl-context: glXCreateNewContext raised an error but (contrary to standards)"
		 " returned a non-NULL context; ignoring possibly corrupt context"))
     #f]
    [else
     (unless gl
       (log-warning "gl-context: glXCreateNewContext was unable to get an OpenGL context"))
     gl]))

;; OpenGL core versions we'll try to get, in order
(define core-gl-versions '((4 5) (4 4) (4 3) (4 2) (4 1) (4 0) (3 3) (3 2) (3 1) (3 0)))

;; _Display _GLXFBConfig _GLXContext (List Byte Byte) -> _GLXContext
(define (glx-create-context-attribs xdisplay cfg share-gl gl-version)
  ;; Sync right now, or the sync further on could crash Racket with an [xcb] error about events
  ;; happening out of sequence
  (XSync xdisplay False)

  (define gl-major (car gl-version))
  (define gl-minor (cadr gl-version))
  (define context-attribs
    (list GLX_CONTEXT_MAJOR_VERSION_ARB gl-major
          GLX_CONTEXT_MINOR_VERSION_ARB gl-minor
          GLX_CONTEXT_PROFILE_MASK_ARB GLX_CONTEXT_CORE_PROFILE_BIT_ARB
          None))
  
  (define old-handler #f)
  (define gl
    (dynamic-wind
     (λ ()
       (set! old-handler (XSetErrorHandler flag-x-error-handler)))
     (λ ()
       (set! create-context-error? #f)
       (glXCreateContextAttribsARB xdisplay cfg share-gl #t context-attribs))
     (λ ()
       ;; Sync to ensure errors are processed
       (XSync xdisplay False)
       (XSetErrorHandler old-handler))))
  
  (cond
    [(and gl create-context-error?)
     (log-error (string-append
		 "gl-context: glXCreateContextAttribsARB raised an error for version ~a.~a but"
		 " (contrary to standards) returned a non-NULL context;"
		 " ignoring possibly corrupt context")
                gl-major gl-minor)
     #f]
    [else
     (unless gl
       (log-info "gl-context: glXCreateContextAttribsARB returned NULL for version ~a.~a"
                 gl-major gl-minor))
     gl]))

;; _Display _GLXFBConfig _GLXContext -> _GLXContext
(define (glx-create-core-context xdisplay cfg share-gl)
  (let/ec return
    (for ([gl-version  (in-list core-gl-versions)])
      (define gl (glx-create-context-attribs xdisplay cfg share-gl gl-version))
      (when gl (return gl)))
    (log-warning "gl-context: unable to get core context; falling back")
    (glx-create-new-context xdisplay cfg share-gl)))

;; ===================================================================================================

;; (or/c #f _GtkWidget) -> _GdkDisplay
(define (gtk-maybe-widget-get-display widget)
  (cond [widget  (gtk_widget_get_display widget)]
        [else    (gdk_display_get_default)]))

;; (or/c #f _GtkWidget) -> _GdkScreen
(define (gtk-maybe-widget-get-screen widget)
  (cond [widget  (gtk_widget_get_screen widget)]
        [else    (gdk_screen_get_default)]))

;; _Display _GLXFBConfig int int -> int
(define (glx-get-fbconfig-attrib xdisplay cfg attrib bad-value)
  (define-values (err value) (glXGetFBConfigAttrib xdisplay cfg attrib))
  (if (= err Success) value bad-value))

;; (or/c #f _GtkWidget) _GdkDrawable gl-config% boolean? -> gl-context%
;;   where _GdkDrawable = (or/c _GtkWindow _GdkPixmap)
(define (make-gtk-drawable-gl-context widget drawable conf wants-double?)
  (define glx-version (get-glx-version))
  
  ;; If widget isn't #f, use its display and screen
  (define display (gtk-maybe-widget-get-display widget))
  (define screen (gtk-maybe-widget-get-screen widget))
  
  ;; Get the X objects wrapped by the GDK objects
  (define xdisplay (gdk_x11_display_get_xdisplay display))
  (define xscreen (gdk_x11_screen_get_screen_number screen))
  
  ;; Create an attribute list using the GL config
  (define xattribs
    (append
     ;; Be aware: we may get double buffering even if we don't ask for it
     (if wants-double?
         (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null)
         null)
     (if (send conf get-stereo) (list GLX_STEREO True) null)
     ;; Finish out with standard GLX 1.3 attributes
     (list
      GLX_X_RENDERABLE True  ; yes, we want to use OpenGL to render today
      GLX_DEPTH_SIZE (send conf get-depth-size)
      GLX_STENCIL_SIZE (send conf get-stencil-size)
      GLX_ACCUM_RED_SIZE (send conf get-accum-size)
      GLX_ACCUM_GREEN_SIZE (send conf get-accum-size)
      GLX_ACCUM_BLUE_SIZE (send conf get-accum-size)
      GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size)
      ;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it
      ;; too easy for user programs to fail to get a context
      None)))
  
  (define multisample-size (send conf get-multisample-size))
  
  ;; Get all framebuffer configs for this display and screen that match the requested attributes,
  ;; then sort them to put the best in front
  ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment
  (define cfgs
    (let* ([cfgs  (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))]
           ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an
           ;; abolute upper bound)
           [cfgs  (if (< glx-version #e1.4)
                      cfgs
                      (filter (λ (cfg)
                                (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
                                (<= m multisample-size))
                              cfgs))]
           ;; Sort all configs by multisample size, decreasing
           [cfgs  (if (< glx-version #e1.4)
                      cfgs
                      (sort cfgs >
                            #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0))
                            #:cache-keys? #t))])
      cfgs))
  
  (cond
    [(null? cfgs)  #f]
    [else
     ;; The framebuffer configs are sorted best-first, so choose the first
     (define cfg (car cfgs))
     (define share-gl
       (let ([share-ctxt  (send conf get-share-context)])
         (and share-ctxt (send share-ctxt get-handle))))
     
     ;; Get a GL context
     (define gl
       (if (and (>= glx-version #e1.4)
                (not (send conf get-legacy?))
                (force lazy-GLX_ARB_create_context?)
                (force lazy-GLX_ARB_create_context_profile?))
           ;; If the GLX version is high enough, legacy? is #f, and GLX has the right extensions,
           ;; try to get a core-profile context
           (glx-create-core-context xdisplay cfg share-gl)
           ;; Otherwise use the old method
           (glx-create-new-context xdisplay cfg share-gl)))
     ;; The above will return a direct rendering context when it can
     ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with
     ;; proprietary extensions (NVIDIA's drivers sometimes do this)

     (when (and widget (send conf get-sync-swap))
       (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1))
     
     ;; Now wrap the GLX context in a gl-context%
     (cond
       [gl
        ;; If there's no widget, this is for a pixmap, so get the stupid GLX wrapper for it or
        ;; indirect rendering may crash on some systems (notably mine)
        (define pixmap
          (if widget #f (glXCreateGLXPixmap xdisplay
                                            (glXGetVisualFromFBConfig xdisplay cfg)
					    (if gtk3?
						(cast drawable _Pixmap _ulong)
						(gdk_x11_drawable_get_xid drawable)))))
        
        (define ctxt (new gl-context% [gl gl] [display display] [drawable drawable] [pixmap pixmap]))
        ;; Refcount these so they don't go away until the finalizer below destroys the GLXContext
        (g_object_ref display)
        (unless (and gtk3? (not widget)) (g_object_ref drawable))
        (register-finalizer
         ctxt
         (λ (ctxt)
           (define gl (send ctxt get-handle))
           (define display (send ctxt get-gtk-display))
           (define drawable (send ctxt get-gtk-drawable))
           (define pixmap (send ctxt get-glx-pixmap))
           (define xdisplay (gdk_x11_display_get_xdisplay display))
           (when pixmap (glXDestroyGLXPixmap xdisplay pixmap))
           (glXDestroyContext xdisplay gl)
           (unless (and gtk3? (not widget)) (g_object_unref drawable))
           (g_object_unref display)))
        ctxt]
       [else  #f])]))

(define (make-gtk-widget-gl-context widget conf)
  (atomically
   (make-gtk-drawable-gl-context widget (widget-window widget) conf #t)))

(define (make-gtk-pixmap-gl-context pixmap conf)
  (atomically
   (make-gtk-drawable-gl-context #f pixmap conf #f)))

;; ===================================================================================================

(define widget-config-hash (make-weak-hasheq))

(define (prepare-widget-gl-context widget conf)
  (hash-set! widget-config-hash widget (if conf conf (make-object gl-config%))))

(define (create-widget-gl-context widget)
  (define conf (hash-ref widget-config-hash widget #f))
  (and conf (make-gtk-widget-gl-context widget conf)))

(define-local-member-name
  get-gdk-pixmap
  install-gl-context)

(define (create-and-install-gl-context bm conf)
  (define ctxt (make-gtk-pixmap-gl-context (send bm get-gdk-pixmap) conf))
  (and ctxt (send bm install-gl-context ctxt)))