#lang racket
(require profile)
(require racket/gui/base)
(require sgl/gl)
(require ffi/unsafe
         ffi/unsafe/define)
(require (for-syntax syntax/parse))

(require (for-syntax racket/string))

(provide (all-defined-out))

;;; --- NATIVE LIBRARY -------------------------------------------------
(require racket/runtime-path)

(define-runtime-path vl-base-path (build-path "VL" "vlwrapper" "x64" "Release"))

(define vl-core-path (build-path vl-base-path "VLCore"))
(define vl-graphics-path (build-path vl-base-path "VLGraphics"))
(define vl-wrapper-path (build-path vl-base-path "vlwrapper"))

(define (void-ffi-lib path)
  path)

(define vlcore-lib (void-ffi-lib vl-core-path))
(define vlgraphics-lib (void-ffi-lib vl-graphics-path))
(define wrapper-lib (void-ffi-lib vl-wrapper-path))


(define-syntax (void-define-ffi-definer stx)
  (syntax-parse stx
    [(_ define-:id ffi-lib:expr
        (~seq (~or (~optional (~seq #:provide provide-form:id)
                              #:defaults ([provide-form #'#f])
                              #:name "#:provide keyword")
                   (~optional (~seq #:define define-form:id)
                              #:defaults ([define-form #'define])
                              #:name "#:define keyword")
                   (~optional (~seq #:default-make-fail default-make-fail:expr)
                              #:defaults ([default-make-fail #'(lambda (id) #f)])
                              #:name "#:default-make-fail keyword"))
              ...))
     #`(begin
         (define-syntax define- 
           (with-syntax ([provide #'provide-form])
             (lambda (stx)
               (syntax-parse stx
                 [(_ s-id:id type:expr (~seq (~or (~optional (~seq #:c-id c-id:id)
                                                             #:defaults ([c-id #'s-id])
                                                             #:name "#:c-id keyword")
                                                  (~optional (~seq #:wrap wrapper:expr)
                                                             #:defaults ([wrapper #'values])
                                                             #:name "#:wrap keyword")
                                                  (~optional (~or (~seq #:make-fail make-fail:expr)
                                                                  (~seq #:fail fail:expr))
                                                             #:defaults ([make-fail #'default-make-fail])))
                                             (... ...)))
                  (with-syntax ([fail (if (attribute fail)
                                          #'fail
                                          #'(make-fail 's-id))])
                    (with-syntax ([def (syntax/loc stx
                                         (define s-id #f))])
                      (if (syntax-e #'provide)
                          (syntax/loc stx
                            (begin
                              (provide s-id)
                              def))
                          #'def)))])))))]))

(void-define-ffi-definer define-vl wrapper-lib)

;;; --- TO DEFINE FFI API ----------------------------------------------

(define-for-syntax (ffi-type-from-type type)
  (case type
    ((void) '_void)
    ((int) '_int)
    ((short) '_short)
    ((bool) '_bool)
    ((double) '_double)
    ((float) '_float)
    ((uint) '_uint)
    ((string) '_string)
    (else '_pointer)))

(define-for-syntax (convert-type name param type)
  (case type
    ((void) #`(void #,param))
    ((int short uint ushort long ulong) #`(integer #,param)) ;;Requires extra checks
    ((bool) #`(boolean #,param))
    ((float double) #`(real #,param))
    ((string) #`(string #,param))
    (else #`(if (cpointer-has-tag? #,param '#,type)
                #,param
                (error '#,name
                       "ffi error: expected ~a type in argument ~a but got ~a"
                       '#,type
                       '#,param
                       #,param)))))

(define-for-syntax (ffi-sig-from-type in out)
  `(_fun ,@(map ffi-type-from-type in) -> ,(ffi-type-from-type out)))

#;
(define-syntax (ffi stx)
  (syntax-case stx ()
    ((_ (name ffi-name) (in ...) out)
     (let ((ins (syntax->list #'(in ...))))
       (with-syntax (((param ...)
                      (map (lambda (param)
                             (if (identifier? param)
                                 (car (generate-temporaries (list param)))
                                 (car (syntax->list param))))
                           ins))
                     ((type ...)
                      (map (lambda (param)
                             (if (identifier? param)
                                 param
                                 (cadr (syntax->list param))))
                           ins)))
         (quasisyntax/loc stx
           (begin
             (provide name)
             (define name
               (let ((ffi-func 
                      (get-ffi-obj ffi-name
                                   wrapper-lib
                                   #,(ffi-sig-from-type (syntax->datum #'(in ...))
                                                        (syntax->datum #'out)))))
                 (lambda (param ...)
                   (let #,(map (lambda (param type)
                                 (list param
                                       (convert-type #'name param type)))
                               (syntax->list #'(param ...))
                               (syntax->datum #'(type ...)))
                     (call-in-opengl
                         (thunk
                     #,(if (eq? (ffi-type-from-type (syntax->datum #'out)) '_pointer)
                           #`(let ((result (ffi-func param ...)))
                               (cpointer-push-tag! result '#,(syntax->datum #'out))
                               result)
                           #`(ffi-func param ...)))))))))))))
    ((def name (in ...) out)
     (quasisyntax/loc stx
       (def (name #,(lowerCamelCase (symbol->string (syntax->datum #'name))))
         (in ...) out)))))


(define-syntax (ffi stx)
  (syntax-case stx ()
    ((_ (name ffi-name) (in ...) out)
     (let ((ins (syntax->list #'(in ...))))
       (with-syntax (((param ...)
                      (map (lambda (param)
                             (if (identifier? param)
                                 (car (generate-temporaries (list param)))
                                 (car (syntax->list param))))
                           ins))
                     ((type ...)
                      (map (lambda (param)
                             (if (identifier? param)
                                 param
                                 (cadr (syntax->list param))))
                           ins)))
         (quasisyntax/loc stx
           (begin
             (provide name)
             (define name
               (let ((ffi-func #f))
                 (lambda (param ...)
                   (let #,(map (lambda (param type)
                                 (list param
                                       (convert-type #'name param type)))
                               (syntax->list #'(param ...))
                               (syntax->datum #'(type ...)))
                     (call-in-opengl
                         (thunk
                     #,(if (eq? (ffi-type-from-type (syntax->datum #'out)) '_pointer)
                           #`(let ((result (ffi-func param ...)))
                               (cpointer-push-tag! result '#,(syntax->datum #'out))
                               result)
                           #`(ffi-func param ...)))))))))))))
    ((def name (in ...) out)
     (quasisyntax/loc stx
       (def (name #,(lowerCamelCase (symbol->string (syntax->datum #'name))))
         (in ...) out)))))

(define-for-syntax (lowerCamelCase str)
  (let ((words (regexp-split #rx"-" str)))
    (string-append* (car words) (map string-titlecase (cdr words)))))

(define (expected type-str v)
  (raise-type-error 'wrong-type type-str v))

(define (check-expected type type-str v)
  (if (type v)
      v
      (expected type-str v)))

(define (void val)
  (check-expected void? "void" val))

(define (non-void val)
  (check-expected (lambda (v) (not (void? v))) "non void" val))

(define (string val)
  (check-expected string? "string" val))

(define (real val)
  (exact->inexact (check-expected number? "number" val)))

(define (positive-real val)
  (exact->inexact
   (check-expected
    (lambda (v) (and (number? v) (> v 0)))
    "positive number" val)))

(define (boolean val)
  (check-expected boolean? "boolean" val))

(define (boolean-true val)
  (check-expected identity "true" val))

(define (integer val)
  (check-expected integer? "integer" val))

(define (number val)
  (check-expected number? "number" val))


(define _vlcallback
  (_fun -> _int))

(define-vl vlInit
  (_fun (swapBuffers : _vlcallback)
        (makeCurrent : _vlcallback)
        (getFrameX : _vlcallback)
        (getFrameY : _vlcallback)
        (getFrameWidth : _vlcallback)
        (getFrameHeight : _vlcallback)
        (setCursorPosition : (_fun _int _int -> _void))
        (enableIdleCallback : (_fun _int -> _void))
        -> _void))

(ffi vl-resize (int int) int)
(ffi vl-mouse-down (short int int) void)
(ffi vl-mouse-up (short int int) void)
(ffi vl-mouse-move (int int) void)
(ffi vl-mouse-wheel (int) void)
(ffi vl-update-modifiers (bool bool bool bool) void)
(ffi vl-key-press (short int) void)
(ffi vl-key-release (short int) void)
(ffi vl-run () void)
(ffi vl-destroy () void)
(ffi vl-idle () void)

(define _actor-ptr (_cpointer 'actor))

(ffi erase-all-actors () void)
(ffi erase-actor (actor) void)

(ffi actor-count () int)
(ffi actor-at (int) actor)

(ffi add-point (float float float) actor)
(ffi add-circle (float float float float int) actor)
(ffi add-arc (float float float float float float int) actor)
(ffi add-rectangle (float float float float float) actor)
(define-vl add-polyline (_fun (closed? : _bool) (n : _int) (vs : (_list i _float)) -> _actor-ptr)
  #:c-id addPolyline)
(define-vl add-spline (_fun (closed? : _bool) 
                            (generate-ends? : _bool)
                            (interpol : _int) 
                            (n : _int)
                            (vs : (_list i _float))
                            -> _actor-ptr)
  #:c-id addSpline)
(define-vl add-grid-surface (_fun _int _bool _bool _int _bool _bool (vs : (_list i _float)) -> _actor-ptr)
  #:c-id addGridSurface)
(define-vl join-curves (_fun (actors : (_list i _actor-ptr)) (n : _int) -> _actor-ptr)
  #:c-id joinCurves)

(ffi add-sphere (float float float float) actor)
(ffi add-cylinder (float float float float float) actor)
(ffi add-cone (float float float float float) actor)
(ffi add-cone-frustum (float float float float float float) actor)
(ffi add-pyramid (float float float float float float int) actor)
(ffi add-pyramid-frustum (float float float float float float float int) actor)
(ffi add-box (float float float float float float) actor)

(ffi add-torus (float float float float float) actor)
(ffi add-text (float float float float string) actor)
(ffi add-sweep (actor actor bool bool) actor)
(ffi add-loft-curve-point (actor actor bool bool) actor)
(ffi add-extrusion (actor float float float bool bool bool bool) actor)
(define-vl %add-loft (_fun (actors : (_list i _actor-ptr)) 
                          (n : _int)
                          (ruled : _bool)
                          (closed : _bool)
                          (bottom : _bool)
                          (top : _bool)
                          (smooth : _bool)
                          -> _actor-ptr)
  #:c-id addLoft)

(define (add-loft actors n ruled closed bottom top smooth)
  (call-in-opengl (thunk (%add-loft actors n ruled closed bottom top smooth))))

(define-vl add-surface-from-curves (_fun (actors : (_list i _actor-ptr)) (n : _int) -> _actor-ptr)
  #:c-id addSurfaceFromCurves)
(ffi add-surface-circle (float float float float int) actor)
(ffi add-surface-arc (float float float float float float int) actor)
(ffi add-surface-from-curve (actor) actor)

(provide add-surface-from-points)
(define-vl add-surface-from-points (_fun (n : _int) (vs : (_list i _float)) -> _actor-ptr)
  #:c-id addSurfaceFromPoints)
(define-vl add-surface-from-points-pivot (_fun (n : _int) (vs : (_list i _float)) _float _float _float -> _actor-ptr)
  #:c-id addSurfaceFromPointsPivot)

(ffi set-view (float float float float float float float) void)
(ffi set-view-top () void)
(ffi zoom-extents () void)

(ffi transform 
     (actor 
      float float float float
      float float float float
      float float float float
      float float float float) 
     void)
(ffi move (actor float float float) void)
(ffi rotate (actor float float float float) void)
(ffi scale (actor float float float) void)

(define-vl bounding-box (_fun _actor-ptr
                              (min-x : (_ptr o _float))
                              (min-y : (_ptr o _float))
                              (min-z : (_ptr o _float))
                              (max-x : (_ptr o _float))
                              (max-y : (_ptr o _float))
                              (max-z : (_ptr o _float))
                              -> _void -> (values min-x min-y min-z max-x max-y max-z))
  #:c-id boundingBox)

(define-vl point-coordinates (_fun _actor-ptr
                                   (x : (_ptr o _float))
                                   (y : (_ptr o _float))
                                   (z : (_ptr o _float))
                              -> _void -> (values x y z))
  #:c-id pointCoordinates)

#|
(define-for-syntax (check-type param type)
  (case type
    ((void) #`(void? #,param))
    ((int short) #`(integer? #,param)) ;;Requires extra checks
    ((bool) #`(boolean? #,param))
    ((double) #`(flonum? #,param))
    ((float) #`(flonum? #,param))
    ((uint) #`(integer? #,param))
    ((string) #`(string? #,param))
    (else #`(cpointer-has-tag? #,param '#,type))))

(define-syntax (define-typed-ffi stx) ; by AML
  (syntax-case stx ()
    ((_ name ffi-name in out)
     (let ((params (generate-temporaries (syntax->datum #'in))))
       #`(begin
           (provide name)
           (define name
             (let ((ffi-func (get-ffi-obj #,(symbol->string (syntax->datum #'ffi-name))
                                          wrapper-lib
                                          #,(ffi-sig-from-type (syntax->datum #'in) (syntax->datum #'out)))))
               (lambda #,params
                 #,@(map (lambda (param type)
                           #,@(map (lambda (param type)
                                     #`(set! param #,(convert-type param type)))
                                   params (syntax->datum #'in))

                           #`(unless #,(check-type param type)
                               (error '#,#'name
                                      "ffi error: expected ~a type in argument ~a but got ~a"
                                      '#,type
                                      '#,param
                                      #,param)))
                         params (syntax->datum #'in))
                 #,(if (eq? (ffi-type-from-type (syntax->datum #'out)) '_pointer)
                       #`(let ((result (ffi-func #,@params)))
                           (cpointer-push-tag! result '#,(syntax->datum #'out))
                           result)
                       #`(ffi-func #,@params))))))))))
  
(define-syntax (ffi stx)
  (syntax-case stx ()
    ((_ name in out)
     (syntax/loc stx
       (define-typed-ffi name name in out)))))
|#

(define gl-context-on? (make-parameter #f))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;The canvas
(define opengl-canvas%
  (class* canvas% ()
    
    (inherit get-parent
             get-top-level-window
             refresh
             swap-gl-buffers
             with-gl-context)
        
    (define grid? #t)
    (define wireframe? #f)
    
    (define/public (with-gl thunk)
      (parameterize ((gl-context-on? #t))
        (with-gl-context thunk)))
        
;    (define/public (destroy)
;      (with-gl
;          vl-destroy))
    
    (define/override (on-char event)
      (with-gl
        (thunk
         (let ((key (send event get-key-code)))
           (let-values ([(action key) 
                         (if (eq? key 'release) 
                             (values vl-key-release (send event get-key-release-code))
                             (values vl-key-press key))])
             (if (symbol? key)
                 (case key
                   ((wheel-up)
                    (vl-mouse-wheel 1))
                   ((wheel-down)
                    (vl-mouse-wheel -1))
                   (else
                    'do-nothing-for-now))
                 (let ((code (char->integer key)))
                   (update-modifiers event)
                   (action
                    code
                    (cond ((<= 33 code 37) ; !...%
                           (+ code 10))
                          ;missing &
                          ((<= 39 code 47) ; '.../
                           (+ code 11))
                          ((<= 48 code 57) ; 0...9
                           (- code 47))
                          ((<= 58 code 64) ; :...@
                           (- code 1))
                          ((<= 65 code 90) ; A...Z
                           (- code 54))
                          ((<= 91 code 96) ; [...`
                           (- code 27))
                          ((<= 97 code 122); a...z
                           (- code 86))
                          ;((<= 123 code 126)
                          ;missing { } | ~
                          (else 
                           0))))))))))
    
    (define/override (on-event event)
      (with-gl
        (thunk
         (update-modifiers event)
         (cond ((is-a? event mouse-event%)
                (let ((type (send event get-event-type))
                      (x (send event get-x))
                      (y (send event get-y)))
                  (case type
                    ((left-down) (vl-mouse-down 1 x y))
                    ((right-down) (vl-mouse-down 2 x y))
                    ((middle-down) (vl-mouse-down 4 x y))
                    ((left-up) (vl-mouse-up 1 x y))
                    ((right-up) (vl-mouse-up 2 x y))
                    ((middle-up) (vl-mouse-up 4 x y))
                    ((motion) (vl-mouse-move x y))
                    ((enter leave) (refresh))
                    (else (printf "Unknown mouse button type:~A~%" type)))))
               (else
                (printf "Unknown event type:~A~%" event))))))
    
    (define/override (on-size width height)
      ;(displayln "on-size")
      (with-gl
       (thunk
        (vl-resize width height))))
    
    (define/override (on-paint)
      ;(displayln "on-paint")
      (with-gl vl-run))

    
    (define/public (init)
      ;;Prepare env
      (putenv "VL_DATA_PATH" (path->string (simplify-path (build-path vl-base-path "data"))))
      (putenv "VL_LOGFILE_PATH" (path->string (simplify-path (build-path vl-base-path "log.txt"))))
      ;(putenv "VL_VERBOSITY_LEVEL" "DEBUG")
      (putenv "VL_CHECK_GL_STATES" "YES")
      (with-gl
        (thunk
         (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
         (vlInit swap-buffers-cb
                 make-current-cb
                 get-frame-x
                 get-frame-y
                 get-frame-width
                 get-frame-height
                 set-mouse-position
                 enable-idle-loop))))
    
;    (define/override (on-superwindow-show show?)
;      (displayln show?)
;      (when (and opengl-frame (not show?))
;        (destroy)
;        (set! opengl-frame #f)
;        (set! opengl-canvas #f))
;      (super on-superwindow-show show?))
    
    (super-instantiate () (style '(gl no-autoclear)))))


(define opengl-canvas #f)
(define opengl-frame #f)

(define (get-frame-x)
  (send opengl-frame get-x))

(define (get-frame-y)
  (send opengl-frame get-y))

(define (get-frame-width)
  (send opengl-frame get-width))

(define (get-frame-height)
  (send opengl-frame get-height))

(define set-cursor-pos (get-ffi-obj 'SetCursorPos #f (_fun _int _int -> _void)))

(define (set-mouse-position x y)
  (let-values ([(x y) (send opengl-canvas client->screen x y)])
    (set-cursor-pos x y)))

(define (update-modifiers event)
  (vl-update-modifiers
   (send event get-shift-down)
   (send event get-control-down) 
   (send event get-meta-down)
   (send event get-alt-down)))

(define (swap-buffers-cb)
  (send opengl-canvas swap-gl-buffers)
  0)

(define (make-current-cb)
  (unless (gl-context-on?)
    (displayln #;error #;'make-current-cb "ERROR: Opengl context is not current"))
  0)

(define idle-loop-enabled? #f)

(define (enable-idle-loop enable?)
  (set! idle-loop-enabled? enable?)
  (idle-loop))

(define (idle-loop)
  (when idle-loop-enabled?
    (vl-idle)
    (queue-callback idle-loop #f)))

;;The frame

;(define opengl-frame%
;  (class* frame% ()
;#;    (define/augment (on-close)
;      (when opengl-frame
;        ;(send opengl-canvas destroy)
;        (set! opengl-frame #f)
;        (set! opengl-canvas #f)))
;   
;;    (define/augment (on-exit)
;;      (displayln 'on-exit)
;;      (send opengl-canvas destroy)
;;      (set! opengl-frame #f)
;;      (set! opengl-canvas #f))
;
;    (super-new)))
;



;;Remove after upgrading to 5.4, and use simply (require ffi/unsafe/custodian)

;;BEGINNING of stuff to remove
(require ffi/unsafe)

(define _Scheme_Custodian_Reference-pointer
  (_gcable (_cpointer 'Scheme_Custodian_Reference)))

(define scheme_add_managed
  (get-ffi-obj 'scheme_add_managed #f
               (_fun _racket _racket _fpointer _racket _int
                     -> _Scheme_Custodian_Reference-pointer)))

(define (shutdown-callback impl proc+self) 
  ((car proc+self) impl))
(define shutdown_callback
  (cast shutdown-callback (_fun #:atomic? #t _racket _racket -> _void) _fpointer))

(define (register-custodian-shutdown obj proc [custodian (current-custodian)])
  (define proc+self (cons proc
                          shutdown-callback)) ; proc as data -> ffi callback retained
  (scheme_add_managed custodian
                      obj shutdown_callback proc+self
                      1))
;;END of stuff to remove



(define (load-opengl)
  (if opengl-frame
    (send opengl-frame show #t)
    (parameterize ([current-eventspace (make-eventspace)])      
      (set! opengl-frame (new frame% [label "Rosetta - OpenGL"]
                              (width 800) (height 600)))
      (let ((gl-config (new gl-config%)))
        (send gl-config set-double-buffered #t)
        ;(send gl-config set-accum-size 8)
        (send gl-config set-depth-size 24)
        (send gl-config set-multisample-size 16) ;;Humm?
        (send gl-config set-stencil-size 8)
        (set! opengl-canvas (new opengl-canvas% (parent opengl-frame)
                                 (min-width 100) (min-height 80)
                                 (gl-config gl-config)))
        (send opengl-canvas init)
        (send opengl-frame show #t)
;        (register-custodian-shutdown
;         opengl-canvas
;         (lambda (c) (send c with-gl vl-destroy)))
        (idle-loop)))))

(provide call-in-opengl)
(define (call-in-opengl thunk)
  (send opengl-canvas with-gl thunk))

(provide refresh)
(define (refresh)
  (send opengl-canvas refresh))