#lang scheme

(define (fformat . args)
  (display (apply format args)))

(require "../../common/main.ss")
(provide (all-from-out "../../common/main.ss")
         ;; The only export we need is draw...
         ;; And maybe some backend specific primitives...
         (rename-out [draw-top-level draw]))


(require "../../utils.ss")



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

(define c 0)
(define (next-c!)
  (let ((cc c))
    (set! c (add1 c))
    (format "o~a" c)))

(define (draw-top-level o)
  (fformat "object { ~a }~n"
          (draw* o)))

(define (draw* object)
  (case* object
    [primitive? => draw-primitive]
    [operation? => apply-operation]
    [union? => apply-union]

    [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]

    [cylinder? => draw-cylinder]

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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 3D shapes
(define (draw-box box)
  (let ((cccc (next-c!)))
    (define (a n) (/ n 2))
    (define b box)
    (define c (box-center b))(define l box-length)(define w box-width)(define h box-height)
    (fformat "#declare ~a = box { < ~a, ~a, ~a>, <~a, ~a, ~a> }~n" cccc
            (- (cx c) (a (l box)))
            (- (cy c) (a (w box)))
            (- (cz c) (a (h box)))
            (+ (cx c) (a (l box)))
            (+ (cy c) (a (w box)))
            (+ (cz c) (a (h box))))
    cccc))



(define (draw-cylinder cylinder)
  (let ((cccc (next-c!)))
    (define c cylinder-center)(define h cylinder-height)(define r cylinder-radius)
    (define p1 (+z (c cylinder) (- (h cylinder) 2)))
    (define p2 (+z (c cylinder) (+ (h cylinder) 2)))
    (fformat "#declare ~a = cylinder { <~a,~a,~a>, <~a,~a,~a>, ~a }~n" cccc
            (cx p1)(cy p1)(cz p1)
            (cx p2)(cy p2)(cz p2)
            (r cylinder))
    cccc))


;;;;;;;;;;;;;;;;;;;;;;;;;; Operations

(define (apply-operation operation)
  (assert (operation? operation))
  (case* operation
    [rotation? => apply-rotation]
    [translation? => apply-translation]

    [else (error "Operation ("
                 (vector-ref (struct->vector operation) 0)
                 ") not implemented")]))

(define (apply-translation t)
  (let ((cccc (next-c!)))
    (fformat "#declare ~a = object { ~a translate ~a*~a }~n" cccc
            (draw* (translation-object t))
            (translation-magnitude t) (translation-coordinate t))
    cccc))

(define (apply-rotation t)
  (let ((cccc (next-c!)))
    (fformat "#declare ~a = object { ~a translate ~a*~a }~n" cccc
            (draw* (rotation-object t))
            (rotation-angle t) (rotation-coordinate t))
    cccc))

(define (apply-union u)
  (let ((cccc (next-c!)))
    (fformat "#declare ~a = union {~n~a~n}~n" cccc
            (apply string-append (map (lambda (x)
                                        (format "object { ~a }~n" (draw* x)))
                                      (union-objects u))))
    cccc))