#lang racket/base
(require ffi/unsafe
         ffi/unsafe/objc
         ffi/unsafe/define
         "utils.rkt"
         "types.rkt")

(provide 
 (protect-out scheme_add_gc_callback
              scheme_remove_gc_callback
              make-gc-action-desc
              make-gl-install
              make-gl-uninstall
              do-gl-action))

;; ----------------------------------------
;; 10.10 and earlier: change window opacity

(define objc-lib (ffi-lib "libobjc"))

(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer))

(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))

(define (make-gc-action-desc win sel val)
  (vector
   (vector (if (= (ctype-sizeof _CGFloat) 4)
               'ptr_ptr_float->void
               'ptr_ptr_double->void)
           msg-send-proc 
           win
           sel
           val)))

;; ----------------------------------------
;; 10.11 and later: OpenGL texture

(define gl-lib (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL"))
(define-ffi-definer define-gl gl-lib)

(import-class NSOpenGLContext)

(define _GLsizei _int)
(define _GLint _int)
(define _GLuint _uint)
(define _GLenum _int)
(define _GLbitfield _int)
(define _GLfloat _float)
(define _GLclampf _float)

(define-gl glGenTexture (_fun (_GLsizei = 1) (v : (_ptr o _GLuint)) -> _void -> v)
  #:c-id glGenTextures)
(define-gl glGenLists (_fun _GLsizei -> _GLuint))
(define-gl glNewList (_fun _GLuint _GLenum -> _void))
(define-gl glEndList (_fun -> _void))

(define-gl glBindTexture (_fun _GLenum _GLuint -> _void))
(define-gl glTexParameteri (_fun _GLenum _GLenum _GLint -> _void))
(define-gl glTexImage2D (_fun _GLenum _GLint _GLint _GLsizei _GLsizei _GLint _GLenum _GLenum _pointer -> _void))

(define-gl glBegin (_fun _GLenum -> _void))
(define-gl glEnd (_fun -> _void))
(define-gl glEnable (_fun _GLenum -> _void))
(define-gl glDisable (_fun _GLenum -> _void))

(define-gl glMaterialfv (_fun _GLenum _GLenum (_vector i _GLfloat) -> _void))
(define-gl glTexCoord2f (_fun _GLfloat _GLfloat -> _void))
(define-gl glVertex3f (_fun _GLfloat _GLfloat _GLfloat -> _void))

(define-gl glViewport (_fun _GLint _GLint _GLsizei _GLsizei -> _void))
(define-gl glMatrixMode (_fun _GLenum -> _void))
(define-gl glLoadIdentity (_fun -> _void))
(define-gl glOrtho (_fun _double  _double _double  _double  _double  _double -> _void))
(define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void))
(define-gl glClear (_fun _GLbitfield -> _void))

(define-gl glCallList (_fun _GLint -> _void))
(define-gl glFlush (_fun -> _void))

(define-gl glClear-pointer _fpointer
  #:c-id glClear)
(define-gl glCallList-pointer _fpointer
  #:c-id glCallList)
(define-gl glFlush-pointer _fpointer
  #:c-id glFlush)

(define GL_TEXTURE_2D #x0DE1)
(define GL_TEXTURE_MAG_FILTER #x2800)
(define GL_TEXTURE_MIN_FILTER #x2801)
(define GL_TEXTURE_WRAP_S #x2802)
(define GL_TEXTURE_WRAP_T #x2803)

(define GL_LINEAR #x2601)
(define GL_CLAMP  #x2900)

(define GL_RGBA #x1908)

(define GL_UNSIGNED_BYTE #x1401)

(define GL_COMPILE #x1300)

(define GL_FRONT #x0404)
(define GL_AMBIENT_AND_DIFFUSE #x1602)

(define GL_POLYGON #x0009)

(define GL_PROJECTION #x1701)
(define GL_MODELVIEW #x1700)

(define GL_COLOR_BUFFER_BIT #x00004000)

(define (make-gl-square argb uw uh backing-scale)
  (define w (inexact->exact (ceiling (* backing-scale uw))))
  (define h (inexact->exact (ceiling (* backing-scale uh))))
  (define size (* w h 4))
  (define size-4 (- size 4))
  (define rgba (make-bytes size))
  (for ([x (in-range w)])
    (for ([y (in-range h)])
      (define i (* (+ x (* w y)) 4))
      (define j (* (+ x (* w (- h y 1))) 4))
      (bytes-set! rgba (+ i 3) (bytes-ref argb j))
      (bytes-set! rgba i (bytes-ref argb (+ j 1)))
      (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2)))
      (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3)))))
  
  (define tex (glGenTexture))
  
  (glBindTexture GL_TEXTURE_2D tex)
  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
  (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
  (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA
                w h 0
                GL_RGBA GL_UNSIGNED_BYTE rgba)
  
  (define wi (exact->inexact uw))
  (define hi (exact->inexact uh))
  
  (define list-id (glGenLists 1))
  (glNewList list-id GL_COMPILE)
  (glEnable GL_TEXTURE_2D)
  (glBindTexture GL_TEXTURE_2D tex)
  (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (vector 1.0 1.0 1.0 1.0))
  (glBegin GL_POLYGON)
  (glTexCoord2f 0.0 0.0)
  (glVertex3f 0.0 0.0 0.0)
  (glTexCoord2f 1.0 0.0)
  (glVertex3f wi 0.0 0.0)
  (glTexCoord2f 1.0 1.0)
  (glVertex3f wi hi 0.0)
  (glTexCoord2f 0.0 1.0)
  (glVertex3f 0.0 hi 0.0)
  (glEnd)
  (glDisable GL_TEXTURE_2D)
  (glEndList)
  
  list-id)

(define (make-gl-install win glv w h argb backing-scale)
  (define gl (tell glv openGLContext))
  
  (define old-gl (tell NSOpenGLContext currentContext))
  (tell gl makeCurrentContext)
  (glViewport 0 0 w h)
  (glMatrixMode GL_PROJECTION)
  (glLoadIdentity)
  (glOrtho 0.0 (exact->inexact w) 0.0 (exact->inexact h) -1.0 1.0)
  (glMatrixMode GL_MODELVIEW)
  (glClearColor 1.0 1.0 1.0 1.0)
  (glClear GL_COLOR_BUFFER_BIT)

  (define list-id (make-gl-square argb w h backing-scale))
  
  (if old-gl
      (tellv old-gl makeCurrentContext)
      (tellv NSOpenGLContext clearCurrentContext))
  
  ;; The shape of this vector is parsed back out by
  ;; `do-gl-action`, below:
  (vector
   (vector 'ptr_ptr->save
           msg-send-proc
           NSOpenGLContext
           (selector currentContext))
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           gl
           (selector makeCurrentContext)
           #f)
   (vector 'int->void
           glClear-pointer
           GL_COLOR_BUFFER_BIT)
   (vector 'int->void
           glCallList-pointer
           list-id)
   (vector 'int->void
           glFlush-pointer
           0)
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           gl
           (selector flushBuffer)
           #f)
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           NSOpenGLContext
           (selector clearCurrentContext)
           #f)
   (vector 'save!_ptr->void
           msg-send-proc
           (selector makeCurrentContext))))

(define (make-gl-uninstall win glv w h)
  (define gl (tell glv openGLContext))
    
  (vector
   (vector 'ptr_ptr->save
           msg-send-proc
           NSOpenGLContext
           (selector currentContext))
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           gl
           (selector makeCurrentContext)
           #f)
   (vector 'int->void
           glClear-pointer
           GL_COLOR_BUFFER_BIT)
   (vector 'int->void
           glFlush-pointer
           0)
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           gl
           (selector flushBuffer)
           #f)
   (vector 'ptr_ptr_ptr->void
           msg-send-proc
           NSOpenGLContext
           (selector clearCurrentContext)
           #f)
   (vector 'save!_ptr->void
           msg-send-proc
           (selector makeCurrentContext))))

(define (do-gl-action vec)
  (when (= 8 (vector-length vec))
    (define gl (vector-ref (vector-ref vec 1) 2))
    (define list-id (vector-ref (vector-ref vec 3) 2))

    (define old-ctx (tell NSOpenGLContext currentContext))
    (tellv gl makeCurrentContext)
    (glClear GL_COLOR_BUFFER_BIT)
    (glCallList list-id)
    (glFlush)
    (tellv gl flushBuffer)
    (tellv NSOpenGLContext clearCurrentContext)
    (when old-ctx
      (tellv old-ctx makeCurrentContext))))
