#lang scheme

(require "../../common/main-new.ss")
(provide (all-from-out "../../common/main-new.ss")
         (all-from-out "acad-utils.ss")
         start-backend

         ;; The only export we need is draw...
         ;; And maybe some backend specific primitives...
         (rename-out [draw-top-level draw])
         command
         command-join ;; DEBUG

         com-stats
         ;opt-stats
         ;turn-off-caching
         ;turn-off-translation-opt
         )

(require "../../utils.ss")
(require "acad-utils.ss"
         "primitives.ss"

         ;; for debugging and com-stats
         "com-utils.ss")

;;;;;;;;;;;; DEBUG requires!!!! ;;;;;;;;;;
(require "base.ss")
(require "marshal.ss")
;(require "com-utils.ss")
;;;;;;;; end of DEBUG requires!!!! ;;;;;;;

(define command prim:command)
(define (command* . args)
  (apply prim:command args)
  (entlast))

;; For tagging drawn objects with their source
;; Helpful for debugging
(define tag list)
(define tagged-object first)
(define tagged-tag second)

(define cache #f)
(define (clean-cache)
  (hash-for-each cache
                 (lambda (key val)
                   (with-handlers
                       ((exn:fail?
                         (lambda (_) #t)))
                     (invoke Delete
                             val))))
  (set! cache #f))

(define make-hash* make-hash)
(define hash-ref* hash-ref)
(define hash-set!* hash-set!)
(define copy-entity* copy-entity)

;; For profiling purposes
(define (turn-off-caching)
  (let ([f (lambda args #f)])
    (set! make-hash* f)
    (set! clean-cache f)
    (set! hash-ref* f)
    (set! copy-entity* (lambda args (first args)))
    (set! hash-set!* f)))

(define (draw-new o)
  (case* o
    [list? => (lambda (o)
                (let ([os (map draw-new o)])
                  (apply command* "._UNION" (append os (list "\r")))
                  (car os)))]

    [arc? => draw-arc]
    [line? => draw-line]
    [ellipse? => draw-ellipse]
    [region? => draw-region]
    [spline? => draw-spline]

    [3dface? => draw-3dface]
    [box? => draw-box]
    [e-cone? => draw-e-cone]
    [pyramid? => draw-pyramid]
    [sphere? => draw-sphere]

    [subtraction? => apply-subtraction]
    [extrusion? => apply-extrusion]
    [intersection? => apply-intersection]

    [loft? => apply-loft]
    [guided-loft? => apply-guided-loft]
    [ruled-loft? => apply-ruled-loft]

    [array? => apply-array]
    [move? => apply-move]
    [revolution? => apply-revolution]
    [slice? => apply-slice]
    [sweep? => apply-sweep]
    [thicken? => apply-thicken]
    [union? => apply-union]
    [else
     (error "Not implemented: "
            (vector-ref (struct->vector o) 0))]
  ))
;(define draw draw-new)

(define (draw-top-level object)
  (set! cache (make-hash*))
  (init-layer-stack)
  (let ([res (draw object)])
    (clean-cache)
    (destroy-layer-stack)
    res))

(define (draw object)
  (let ([obj (hash-ref* cache object #f)])
    (if obj
        (set! obj (copy-entity* obj))
        (begin
          (set! obj (draw-new object))
          (when (operation? object)
            (hash-set!* cache
                        object
                        (copy-entity* obj)))))
    obj))

(define-syntax define-unimplemented-draw
  (lambda (stx)
    (syntax-case stx ()
      [(_ name)
       (with-syntax
           ([draw-name
             (datum->syntax
              #'name
              (string->symbol
               (string-append "draw-"
                              (symbol->string
                               (syntax->datum #'name)))))])
         #`(define (draw-name . args)
             (error "Drawing objects of type " 'name " is not implemented.")))]
      [(_ name names ...)
       #'(begin
           (define-unimplemented-draw name)
           (define-unimplemented-draw names ...))])))

(define-unimplemented-draw
  array-polar
  donut
  mesh
  parametric
  plane
  polar
  poly
  polyface-mesh
  polygon
  prism
  ray
  superellipsoid
  text
  torus
  ;;vector? point? (for debug... maybe with a switch to enable/disable)
  wedge
  xline)

(define-syntax define-unimplemented-apply
  (lambda (stx)
    (syntax-case stx ()
      [(_ name)
       (with-syntax
           ([draw-name
             (datum->syntax
              #'name
              (string->symbol
               (string-append "apply-"
                              (symbol->string
                               (syntax-e #'name)))))])
         #`(define (apply-name . args)
             (error "Can't apply functions of type " 'name " -- not implemented.")))]
      [(_ name names ...)
       #'(begin
           (define-unimplemented-apply name)
           (define-unimplemented-apply names ...))])))

(define-unimplemented-apply
  extrusion
  intersection
  region
  revolution
  subtraction
  union
)

(define (draw-3dface f)
  (command* "._3dface" (3dface-p1 f) (3dface-p2 f)
                       (3dface-p3 f) (3dface-p4 f) ""))

;;  (arc c radius start-angle end-angle)
(define (draw-arc a)
  (let ([c  (arc-c a)]
        [r  (arc-r a)]
        [sa (arc-start-angle a)]
        [ea (arc-end-angle a)])
    (command* "._ARC" (to-point-2d (+pol c r sa))
                      (to-point-2d (+pol c r (/ (abs (- ea sa)) 2)))
                      (to-point-2d (+pol c r ea)))))

(define (draw-box b)
  (command* "._BOX" "_C" (box-c b) "_L" ;; _Center, _Length
            (box-l b) (box-w b) (box-h b)))

(define (draw-e-cone c)
  (cond [(= (e-cone-r1 c) (e-cone-r2 c))
         (if (= (e-cone-r1 c) (e-cone-r1* c))
             (command* "._CYLINDER" (e-cone-c1 c) (e-cone-r1 c)
                       "_A" (e-cone-c2 c))
             (command* "._CYLINDER" "_E" "_C"
                       (e-cone-c1 c) (e-cone-r1 c)
                       "_T" (e-cone-c2 c)))]
        [else
         (if (= (e-cone-r1 c) (e-cone-r1* c))
             (command* "._CONE" (e-cone-c1 c) (e-cone-r1 c)
                       "_T" (e-cone-r2 c) ;; _Top
                       "_A" (e-cone-c2 c)) ;; _Axis
             (command* "._CONE" "_E" "_C" (e-cone-c1 c) ;; _Elliptical, _Center
                       (e-cone-r1 c)
                       (e-cone-r1* c)
                       "_T" (e-cone-r2 c) ;; _Top
                       (e-cone-c2 c)))]))

(define (draw-ellipse e)
  (if (= (ellipse-r1 e) (ellipse-r2 e))
      (command* "._CIRCLE" (ellipse-c e) (ellipse-r1 e))
      (command* "._ELLIPSE" "_C" (ellipse-c e) ;; _Center
                (ellipse-r1 e) (ellipse-r2 e))))

(define (draw-line l)
  (define (pts-list->vector l)
    (let* ([len (length l)]
           [3*len (* 3 len)]
           [v (make-vector 3*len)])
      (define (pts-list->vector-aux l i)
        (if (eq? l '())
            v
            (let ([p (first l)])
              (vector-set! v    i    (exact->inexact (cz p)))
              (vector-set! v (- i 1) (exact->inexact (cy p)))
              (vector-set! v (- i 2) (exact->inexact (cx p)))
              (pts-list->vector-aux (rest l) (- i 3)))))
      (pts-list->vector-aux l (sub1 3*len))))
  (let ([plv (pts-list->vector (line-pts l))])
    (invoke Add3Dpoly
            (acad-mspace)
            plv)))


(define (draw-pyramid p)
  (command* "._PYRAMID"
            "_S" (pyramid-s p)    ;; _Sides
            (pyramid-c1 p) (pyramid-r1 p)
            "_T" (pyramid-r2 p)   ;; _Top
            "_A" (pyramid-c2 p))) ;; _Axis

(define (draw-region r)
  (let ([res
         (if (list? (region-l r))
             (apply command* "._REGION" (append (map draw (region-l r)) (list "\r")))
             (command* "._REGION" (draw (region-l r)) "\r"))])
    (command* "._CONVTOSURFACE" res "\r")))

;(define (draw-spline s)
(define (draw-spline s)
  (define (pts-list->vector l)
    (let* ([len (length l)]
           [3*len (* 3 len)]
           [v (make-vector 3*len)])
      (define (pts-list->vector-aux l i)
        (if (eq? l '())
            v
            (let ([p (first l)])
              (vector-set! v    i    (exact->inexact (cz p)))
              (vector-set! v (- i 1) (exact->inexact (cy p)))
              (vector-set! v (- i 2) (exact->inexact (cx p)))
              (pts-list->vector-aux (rest l) (- i 3)))))
      (pts-list->vector-aux l (sub1 3*len))))
  (let ([plv (pts-list->vector (spline-pts s))])
    (invoke AddSpline
            (acad-mspace)
            plv
            (marshal (spline-start-tg s))
            (marshal (spline-end-tg s)))))
;  (apply command* "._SPLINE" (append (spline-pts s)
;                                     (list "\r"
;                                           (spline-start-tg s)
;                                           (spline-end-tg s)))))

(define (draw-sphere s)
  (command* "._SPHERE" (sphere-c s) (sphere-r s)))


(define (apply-array a)
  (let ([o (draw (array-obj a))])
    (command* "._3Darray" o ""
              "_R" ;; Rectangular
              (array-x a) (array-y a) (array-z a)
              (array-dx a) (array-dy a) (array-dz a))))

(define (apply-subtraction d)
  (let [(o (draw (subtraction-object d)))]
    (apply command* "._SUBTRACT"
           o "" (append (map draw (subtraction-objects d))
                        (list "\r")))
    o))

(define (apply-extrusion e)
  (if (point? (extrusion-path e))
      (command* "._EXTRUDE" (draw (extrusion-surf e)) "\r"
                "_D" (extrusion-path e) (extrusion-taper-angle e)) ;; FIXME: TODO: XXX: MUST CHANGE NAMES!
      (command* "._EXTRUDE" (draw (extrusion-surf e)) "\r"
                "_T" (graus<-radianos (extrusion-taper-angle e)) ;; _Taper
                "_P" (draw (extrusion-path e))))) ;; _Path

(define (apply-intersection i)
  (let [(os (map draw (intersection-objects i)))]
    (apply command* "._INTERSECT"
           (append os (list "\r")))
    (car os)))

(define (apply-layer l)
  (let ([obj '()])
    (with-layer
     (layer-name l)
     (set! obj (draw (layer-obj l))))
    obj))

;;  (loft objects a1 m1 a2 m2)
;;  (guided-loft objects guides path)
;;  (ruled-loft objects)
(define (apply-loft l)
  ;; Muda para loftnormals=6, angulos e magnitudes
  (command "._LOFTNORMALS" 6)
  (command "._LOFTMAG1" (loft-m1 l))
  (command "._LOFTANG1" (graus<-radianos (loft-a1 l)))
  (command "._LOFTMAG2" (loft-m2 l))
  (command "._LOFTANG2" (graus<-radianos (loft-a2 l)))
  (let ([cmd-str (command-join " "
                               (map marshal->string*
                                    (list* "._LOFT"
                                           (append (map draw (loft-objects l))
                                                   (list "" "")))))])
;;    (display* cmd-str) ;; DEBUG
    (command* (string-append "(command " cmd-str ")"))))

(define (apply-guided-loft l)
  (command "._LOFTNORMALS" 6)
  (apply command* "._LOFT"
         (append (map draw (guided-loft-objects l))
                 (list "\r")
                 (if (and (list? (guided-loft-guides l))
                          (not (null? (guided-loft-guides l)))
                          (zero? (length (guided-loft-guides l))))
                     (list "_P" (draw (guided-loft-path l)))
                     (list* "_G" (append (map draw (guided-loft-guides l)) ;; _Guides
                                         (list "\r")))))))

(define (apply-ruled-loft l)
  ;;(ruled-loft objects)
  ;; Mudar para loftnormals=0
  (command "._LOFTNORMALS" 0)
  (let* ([objs (map draw (ruled-loft-objects l))]
         [cmd-str (command-join " "
                                (map marshal->string*
                                     (list* "._LOFT"
                                            (append objs
                                                    (list "\r" "_C")))))])
;;    (display* cmd-str) ;; DEBUG
    (command* (string-append "(command " cmd-str ")"))))
;  (apply command* "._LOFT"
;         (append (map draw (ruled-loft-objects l))
;                 (list "\r"))))

(define (apply-move m)
  (display "moving...")(newline)
  (command* "._move" (draw (move-obj m)) ""
            "_D" (marshal->string (move-v m)))) ;; _Displacement

(define (apply-revolution r)
  ;;(revolution surf axis start-angle end-angle)
  (command* "._REVOLVE" (draw (revolution-surf r)) "\r"
            (axis-p (revolution-axis r)) ;; axis start-point
            (p+v (axis-p (revolution-axis r)) (axis-v (revolution-axis r))) ;; axis end-point
            "_ST" (graus<-radianos (revolution-start-angle r)) ;; _Start
            (graus<-radianos (revolution-end-angle r))))

(define (apply-slice s)
  (let [(o (draw (slice-obj s)))]
    (command* "._SLICE" o "\r" ;"_3P" ;; _3Points
              "_Zaxis"
              (plane-p (slice-plane s))
              (p+v (plane-p (slice-plane s)) (plane-n (slice-plane s)))
              (p+v (plane-p (slice-plane s)) (v*r (plane-n (slice-plane s)) -1)))))

(define (apply-sweep s)
  (command* "._SWEEP" (draw (sweep-surf s)) "\r"
            "_T" (graus<-radianos (sweep-twist s)) ;; _Twist
            "_S" (sweep-scale s) ;; _Scale
            (draw (sweep-path s))))

(define (apply-thicken t)
  (let ([obj (draw (thicken-surf t))])
    (command* "._THICKEN" obj "\r" (thicken-w t))))

(define (apply-union u)
  (let [(os (map draw (union-objects u)))]
    (apply command* "._UNION" (append os (list "\r")))
    (car os)))


;; Define a top-level-print-hook
;; For now, we just draw the object.
(define top-level-print-hook-initialized #f)
(register-top-level-print-hook
 'autocad
 (lambda (obj)
   (when (not top-level-print-hook-initialized)
     (set! top-level-print-hook-initialized #t)
     (erase-all))
   (if (or (primitive? obj) (operation? obj))
       (draw obj)
       ((current-print) obj))))

;; Activate AutoCAD's top-level-print-hook
(set-top-level-print-mode 'autocad)


;(define (draw-top-level object)
;  (set! cache (make-hash*))
;  (let ([res (draw object)])
;    (clean-cache)
;    res))
;
;(define (draw object)
;  (let ([obj (hash-ref* cache object #f)])
;    (if obj
;        (set! obj (copy-entity* obj))
;        (begin
;          (set! obj (tagged-object (draw* object)))
;          (unless (primitive? object)
;            (hash-set!* cache
;                        object
;                        (copy-entity* obj)))))
;    (tag obj object)))
;
;(define (draw* object)
;  (case* object
;    [primitive? => draw-primitive]
;    [csg? => apply-csg]
;    [operation? => apply-operation]
;
;    [else (error 'draw
;                 "Don't know how to draw objects of type ~a: ~a [~a]"
;                 (vector-ref (struct->vector object) 0)
;                 object (struct->vector object))]))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Primitives
;
;
;(define (draw-primitive primitive)
;  (assert (primitive? primitive))
;  (case* primitive
;    ;; 2D primitives
;    [circle? => draw-circle]
;;    [square? => draw-square]
;
;    ;; 3D primitives
;    [box? => draw-box]
;    [cone? => draw-cone]
;    [cylinder? => draw-cylinder]
;
;    [loft? => draw-loft]
;
;    [sphere? => draw-sphere] ;; (center sphere-radius)
;    [text? => draw-text]     ;; AddMText (multiline text) / AddText
;    [torus? => draw-torus]   ;; (center torus-radius tube-radius)
;
;    [wedge? => draw-wedge]   ;; Mete-se mesmo? (center length width height)
;
;    [else (error "Don't know how to draw primitives of type "
;                 (vector-ref (struct->vector primitive) 0))]))
;
;;; Adicionar extruded solid?
;;; Primitiva mais espressiva: AddExtrudedSolidAlongPath
;;; Revolved solid? E perto do outro acima... Menos geral...
;
;
;;(define-syntax draw-primitive
;;  (lambda (stx)
;;    (syntax-case stx ()
;;      [(_ name primitive slot ...)
;;       #`(begin (provide name)
;;                (define (draw-name object)
;;                  (
;
;(define-syntax define-prim-bridge
;  (syntax-rules ()
;    [(_ name prim arg prop ...)
;     (define (name arg)
;       (tag (prim (prop arg)
;                   ...)
;             arg))]))
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; 2D shapes
;;(define-prim-bridge draw-circle
;;  prim:circle circle
;;  circle-center circle-radius)
;(define (draw-circle circle)
;  (tag (vector-ref
;        (prim:region
;         (vector (prim:circle (circle-center circle)
;                              (circle-radius circle))))
;        0)
;       circle))
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; 3D shapes
;(define (draw-box box)
;  (tag (prim:box (box-center box)
;                  (box-length box)
;                  (box-width  box)
;                  (box-height box))
;        box))
;
;(define (draw-cone cone)
;  (tag (prim:cone (cone-center      cone)
;                   (cone-base-radius cone)
;                   (cone-cap         cone))
;        cone))
;
;(define (draw-cylinder cylinder)
;  (tag (prim:cylinder (cylinder-center cylinder)
;                       (cylinder-radius cylinder)
;                       (cylinder-height cylinder))
;        cylinder))
;
;(define-prim-bridge draw-sphere
;  prim:sphere sphere
;  sphere-center sphere-radius)
;
;(define (draw-loft loft)
;  (let* ([f (loft-f loft)]
;         [start (loft-start loft)]
;         [step (loft-step loft)]
;         [stop? (loft-stop? loft)]
;         [surfs (unfold stop? f step start)]
;         [drawn-surfs (map (compose tagged-object draw) surfs)])
;    ;; HACK: It should use command, but Acad doesn't let us dismiss the DiagBox
;    (apply prim:command* "._loft"
;           (append drawn-surfs
;                   (list "\r" "\r")))
;    (tag (entlast)
;          loft)))
;
;(define-prim-bridge draw-text
;  prim:text text
;  text-string text-lower-left text-height)
;
;(define-prim-bridge draw-torus
;  prim:torus torus
;  torus-center torus-radius torus-tube-radius)
;
;(define-prim-bridge draw-wedge
;  prim:wedge wedge
;  wedge-center wedge-length wedge-width wedge-height)
;
;
;;;;;;;;;;;;;;;;;;;;; CSG
;(define (apply-csg csg)
;  (assert (csg? csg))
;  (case* csg
;    [union? => apply-union]
;    [intersection? => apply-intersection]
;    [subtraction? => apply-subtraction]
;
;    [else (error "CSG ("
;                 (vector-ref (struct->vector csg) 0)
;                 ") not implemented")]))
;
;(define ac-union 0)
;(define ac-intersection 1)
;(define ac-subtraction 2)
;
;(require "com-utils.ss")
;(define aaa #f)
;(define fx (lambda (o1 o2)
;             (invoke Boolean
;                     (tagged-object o1)
;                     ac-union
;                     (tagged-object o2))
;             (tag (tagged-object o1) aaa)))
;(define (apply-union union)
;  (set! aaa union)
;  (let* ([o (first (union-objects union))]
;         [objs (rest (union-objects union))]
;         [o* (draw o)]
;         [objs* (map draw objs)])
;    (foldl fx
;           o* objs*)))
;
;
;
;(define ac-extend-none 0) ;; Does not extend either object.
;(define ac-extend-this-entity 1) ;; Extends the base object.
;(define ac-extend-other-entity 2)  ;; Extends the obj passed as argument.
;(define ac-extend-both 3) ;; Extends both objects.
;
;;(define (apply-intersection intersection)
;;  (let ([o (first (intersection-objects intersection))]
;;        [objs (rest (intersection-objects intersection))])
;;    (foldl (lambda (o1 o2)
;;             (invoke Boolean (tagged-object o1) ac-intersection (tagged-object o2))
;;             (tag (tagged-object o1) intersection))
;;           (draw o)
;;           (map draw objs))))
;(define (apply-intersection intersection)
;  (let ([o (first (intersection-objects intersection))]
;        [objs (rest (intersection-objects intersection))])
;    (foldl (lambda (o1 o2)
;             (invoke IntersectWith (tagged-object o1) (tagged-object o2) ac-extend-none)
;             (tag (tagged-object o1) intersection))
;           (draw o)
;           (map draw objs))))
;
;(define (apply-subtraction subtraction)
;  (let ([o (subtraction-main-object subtraction)]
;        [objs (subtraction-objects subtraction)])
;    (foldl (lambda (o2 o1)
;             (invoke Boolean (tagged-object o1) ac-subtraction (tagged-object o2))
;             (tag (tagged-object o1) subtraction))
;           (draw o)
;           (map draw objs))))
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;; Operations
;
;(define (apply-operation operation)
;  (assert (operation? operation))
;  (case* operation
;    [rotation? => apply-rotation]
;    [translation? => apply-translation]
;    [scale? => apply-scale]
;    [transform? => apply-transform]
;
;    [else (error "Operation ("
;                 (vector-ref (struct->vector operation) 0)
;                 ") not implemented")]))
;
;(define (apply-rotation rotation)
;  (let ([adder (case (rotation-coordinate rotation)
;                  [(x) +x]
;                  [(y) +y]
;                  [(z) +z]
;                  [else (error "Unknown coordinate: "
;                               (rotation-coordinate rotation))])]
;        [obj (draw (rotation-object rotation))])
;    (prim:rotate3d (tagged-object obj)
;                   origin
;                   (adder origin 1)
;                   (rotation-angle rotation))
;    (tag (tagged-object obj)
;          rotation)))
;
;(define optimize-translation #t)
;(define (turn-off-translation-opt)
;  (set! optimize-translation #f))
;(define opts 0)
;(define (opt-stats)
;  (display* opts " translation optimizations"))
;
;(define (apply-translation translation)
;  (if (and optimize-translation (cylinder? (translation-object translation)))
;      (draw (let ([cyl (translation-object translation)])
;              (set! opts (add1 opts))
;              (make-cylinder ((case (translation-coordinate translation)
;                                [(x) +x]
;                                [(y) +y]
;                                [(z) +z]
;                                [else (error "Unknown coordinate: "
;                                             (translation-coordinate translation))])
;                              (cylinder-center cyl) (translation-magnitude translation))
;                             (cylinder-radius cyl)
;                             (cylinder-height cyl))))
;      (let ([adder (case (translation-coordinate translation)
;                     [(x) +x]
;                     [(y) +y]
;                     [(z) +z]
;                     [else (error "Unknown coordinate: "
;                                  (translation-coordinate translation))])]
;            [obj (draw (translation-object translation))])
;        (prim:move (tagged-object obj)
;                   origin
;                   (adder origin (translation-magnitude translation)))
;        (tag (tagged-object obj)
;             translation))))
;
;(define (apply-scale scale)
;  (error 'apply-scale))
;
;(define (apply-transform transform)
;  (error 'apply-transform))