#lang scheme

(require "../../common/main.ss")
(provide (all-from-out "../../common/main.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])

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

(require "../../utils.ss")
(require "acad-utils.ss"
         "operations.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!!!! ;;;;;;;


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