#lang racket

;(require ffi/com)
(require "base/com.rkt")

(require "base/coord.rkt"
         "base/bounding-box.rkt")

(provide com-exn
         def-com
         debug-com
         step-com
         expected
         check-expected
         void
         non-void
         string
         real
         positive-real
         boolean
         boolean-true
         integer
         number
         numbers
         arr-booleans
         arr-ints
         arr-longs
         arr-reals
         arr-realss
         point
         point-string
         point-or-real
         arr-points
         arr-pointss
         coord<-vector
         coords<-vector
         coords<-flat-vector
         bbox<-vector

         ;;Aliases
         radius
         angle
         tolerance
         name
         delete?
         normal
         com
         arr-coms
         coms
         
         raise-com-exn
         )


;; exception

(struct com-exn exn:fail ())

(define (raise-com-exn . msg)
  (raise (com-exn (apply format msg) (current-continuation-marks))))


(provide try-exn-connection
         try-void-connection
         
         list<vector<real>><-list<coord>
         ;; list<coord><-vector<vector<real>>
         
         ;; real<-number
         ;; vector<real><-coord

         ;; scale-matrix<-coord
         com<-matrix
         
         ;; vector<real><-list<number>

         flat-vector<real><-list<coord>
         vector<-bbox
         )


; edit: worst possible hack; change MysterX exceptions
(define exn-re (regexp "code = 80010001"))

(define (try-exn-connection msg fn (count 5))
  (define (try-connection-handler e)
    (cond ((and (regexp-match exn-re (exn-message e)) (> count 0))
           (displayln msg)
           (sleep 1)
           (try-exn-connection msg fn (- count 1)))
          (else
           (raise e))))
  (with-handlers ((exn:fail? try-connection-handler))
    (fn)))

(define (try-void-connection msg fn (count 3))
  (let ((result (fn)))
    (if (void? result)
        (cond ((> count 0)
               (sleep 1)
               (try-void-connection msg fn (- count 1)))
              (else
               (error 'try-void-connection msg)))
        result)))


(define (list<vector<real>><-list<coord> ps)
  (map vector<real><-coord ps))

(define real<-number exact->inexact)

(define (vector<real><-coord c)
  (let ((x (real<-number (xyz-x c)))
        (y (real<-number (xyz-y c)))
        (z (real<-number (xyz-z c))))
    (vector x y z)))

(define (scale-matrix<-coord p)
  (let ((x (real<-number (xyz-x p)))
        (y (real<-number (xyz-y p)))
        (z (real<-number (xyz-z p))))
    (vector
     (vector  x  0.0 0.0 0.0)
     (vector 0.0  y  0.0 0.0)
     (vector 0.0 0.0  z  0.0)
     (vector 0.0 0.0 0.0 1.0))))

(define (com<-matrix m)
;  (type-describe
   (vector
    (vector-map! real<-number (m-line m 0))
    (vector-map! real<-number (m-line m 1))
    (vector-map! real<-number (m-line m 2))
    (vector-map! real<-number (m-line m 3)))
;   '(array (4 4) double)))
)
;;This is what AutoCAD wants. Maybe move this
;;to that file
#;(define (com<-matrix m)
  (vector-map real<-number (matrix-vals m)))

(define (vector<real><-list<number> l)
  (list->vector (map real<-number l)))

(define (flat-vector<real><-list<coord> cs)
  (let ((v (make-vector (* (length cs) 3)))
        (i 0))
    (for ((c cs))
      (let ((x (real<-number (xyz-x c)))
            (y (real<-number (xyz-y c)))
            (z (real<-number (xyz-z c))))
        (vector-set! v (+ i 0) x)
        (vector-set! v (+ i 1) y)
        (vector-set! v (+ i 2) z)
        (set! i (+ i 3))))
    v))

(define (coords<-flat-vector v)
  (for/list ((i (in-range 0 (vector-length v) 3)))
    (xyz
     (vector-ref v (+ i 0))
     (vector-ref v (+ i 1))
     (vector-ref v (+ i 2)))))

(provide coords<-vector-xy)
(define (coords<-vector-xy v)
  (for/list ((i (in-range 0 (vector-length v) 2)))
    (xyz
     (vector-ref v (+ i 0))
     (vector-ref v (+ i 1))
     0)))

(provide coords<-flat-vector-or-false)
(define (coords<-flat-vector-or-false v)
  (and v (coords<-flat-vector v)))


;;methods

#|
Syntax:

(def-com (name "name") ((param0 converter0) ... #:opt (param-opt0 converter-opt0) ...) converter)

By default:

(def-com name ...) -> (def-com (name "name") ...)
(def-com name (converter ...) ...) -> (def-com name ((param converter) ...) ...)

|#

(define-syntax (def-com stx)
  (syntax-case stx ()
    ((_ com name ins out)
     (quasisyntax/loc stx
       (def-com-methods com name
         #,@(reverse
             (let separate-params ((mandatory (list)) (args (syntax->list #'ins)))
               (cond ((null? args)
                      (list #`(#,(reverse mandatory) out)))
                     ((eq? (syntax->datum (car args)) '#:opt)
                      (let ((mandatory (reverse mandatory)))
                        (let signatures ((optionals (reverse (cdr args))))
                          (if (null? optionals)
                              (list #`(#,mandatory out))
                              (cons #`(#,(append mandatory (reverse optionals)) out)
                                    (signatures (cdr optionals)))))))
                     (else
                      (separate-params (cons (car args) mandatory) (cdr args)))))))))))

(define debug-com (make-parameter #f))
(define step-com (make-parameter #f))

(define-syntax (def-com-methods stx)
  (syntax-case stx ()
    ((_ com (name com-name) signatures ...)
     (quasisyntax/loc stx
       (begin
         (provide name)
         (define name
           (case-lambda
             #,@(map (lambda (signature-stx)
                       (syntax-case signature-stx ()
                         (((in ...) out)
                          (let* ((ins (syntax->list #'(in ...)))
                                 (target-is-param?
                                  (and (not (null? ins))
                                       (let ((p (syntax-e (car ins))))
                                         (and (pair? p)
                                              (free-identifier=? (car p) #'com)))))
                                 (ins (if target-is-param? (cdr ins) ins)))
                            (with-syntax (((param ...)
                                           (map (lambda (param)
                                                  (if (identifier? param)
                                                      (car (generate-temporaries (list param)))
                                                      (car (syntax->list param))))
                                                ins))
                                          ((converter ...)
                                           (map (lambda (param)
                                                  (if (identifier? param)
                                                      param
                                                      (cadr (syntax->list param))))
                                                ins)))
                              #`((#,@(if target-is-param? #'(com) #'()) param ...)
                                 ;;DEBUG
                                 (if (debug-com)
                                     (begin
                                       (printf "COM CALL: ~A" com-name)
                                       (printf "~A" (list (if (eq? com-omit param) param (converter param)) ...))
                                       (let ((res (com-invoke com com-name (if (eq? com-omit param) param (converter param)) ...)))
                                         (printf " -> ~A~%" res)
                                         (when (step-com)
                                           (read-char))
                                         (out res)))
                                     (out
                                      (com-invoke com com-name (if (eq? com-omit param) param (converter param)) ...)))))))))
                     (syntax->list #'(signatures ...))))))))
    ((def com name signatures ...)
     (quasisyntax/loc stx
       (def com (name #,(UpperCamelCase (symbol->string (syntax->datum #'name))))
         signatures ...)))))

(provide def-com-property)
(define-syntax (def-com-property stx)
  (syntax-case stx ()
    ((_ (name com-name) (in out))
     (quasisyntax/loc stx
       (begin
         (provide name)
         (define name
           (case-lambda
             ((com) (out (com-get-property com com-name)))
             ((com arg) (com-set-property! com com-name (in arg))))))))
    ((_ (name com-name) out)
     (quasisyntax/loc stx
       (begin
         (provide name)
         (define name
           (lambda (com) (out (com-get-property com com-name)))))))
    ((def name inout)
     (quasisyntax/loc stx
       (def (name #,(UpperCamelCase (symbol->string (syntax->datum #'name)))) inout)))
    ((def name)
     (quasisyntax/loc stx
       (def (name #,(UpperCamelCase (symbol->string (syntax->datum #'name)))) identity)))))

(define-for-syntax (UpperCamelCase str)
  (regexp-replace* #rx"-" (string-titlecase str) ""))

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

#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Converters: the idea is that each argument must
be of a given type or must be convertable to the 
given type.

Each converter should try to do that or throw
an exception.
|#

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

;;HACK: Improve
(define (numbers val)
  (vector->list val))

;;HACK: Improve
(define (arr-booleans v)
  (check-expected vector? "vector" v))

(define (arr-ints v)
  (check-expected vector? "vector" v))
 
(provide arr-ints2)
(define (arr-ints2 v) ;;HACK: improve this when the new ffi/com is out
  (for/vector ([e (check-expected vector? "vector" v)])
    (type-describe e 'short-int)))

(define (arr-longs v)
  (type-describe
   (check-expected vector? "vector" v)
   `(variant (array ,(vector-length v) int))))

(define (arr-reals v)
  (check-expected vector? "vector" v))

(define (arr-realss vss)
  (list->vector (foldl append (list) vss)))

(define (point c)
  (let ((c (as-world c)))
    (vector (exact->inexact (xyz-x c))
            (exact->inexact (xyz-y c))
            (exact->inexact (xyz-z c)))))

(define (point-string c)
  (let ((c (as-world c)))
    (format "~A,~A,~A" (xyz-x c) (xyz-y c) (xyz-z c))))

(define (point-or-real c/r)
  (if (real? c/r)
      c/r
      (point c/r)))

;;array of points
(define (arr-points cs)
  (let ((v (make-vector (* (length cs) 3)))
        (i 0))
    (for ((c cs))
      (let ((c (as-world c)))
        (let ((x (exact->inexact (xyz-x c)))
              (y (exact->inexact (xyz-y c)))
              (z (exact->inexact (xyz-z c))))
          (vector-set! v (+ i 0) x)
          (vector-set! v (+ i 1) y)
          (vector-set! v (+ i 2) z)
          (set! i (+ i 3)))))
    v))

#;#;
(provide arr-points2)
(define (arr-points2 cs)
  (type-describe
   (arr-points cs)
   `(variant (array ,(* 3 (length cs)) double))))

(define (arr-pointss pointss)
  (arr-points (foldl append (list) pointss)))


(define (coord<-vector v)
  (xyz (vector-ref v 0)
       (vector-ref v 1)
       (vector-ref v 2)))

(define (coords<-vector v)
  (map coord<-vector (vector->list v)))

(define (bbox<-vector v)
  (make-bbox
   (coords<-vector v)))

;;Aliases
(define radius real)
(define angle real)
;Without units, there is no way to distinguish between degrees and radians (define degrees radians->degrees)
(define tolerance real)
(define name string)
(define delete? boolean)
;;HACK: revise
(define layer string)
(define normal point)


;;For com objects, we only check the type
(define (com val)
  (check-expected com-object? "com object" val))

(define (arr-coms v)
  (cond ((com-object? v)
         (vector v))
        ((pair? v)
         (let ((vl (flatten v)))
           (if (andmap com-object? vl)
               (list->vector vl)
               (expected "com object or tree of com objects" v))))
        (else
         (expected "com object or tree of com objects" v))))

(define (coms val)
  (vector->list val))