#lang scheme
(require "point.ss")
(require "vector.ss")
(require "coordinates-new.ss")
(require "ad-hoc-typing.ss")
(require [except-in srfi/1 null?])
;; Primitives for VisualScheme

(provide (except-out (struct-out primitive) make-primitive))
(provide define-primitive)

(define-struct primitive
  ()
  #:transparent)

(define-syntax define-primitive
  (lambda (stx)
    (syntax-case stx ()
      [(_ name [slot type] ...)
       #`(begin
           (define-struct (name primitive)
             (slot ...)
             #:transparent)
           #,(with-syntax
                 ([make-name (datum->syntax
                              #'name
                              (string->symbol
                               (string-append "make-"
                                              (symbol->string
                                               (syntax->datum #'name)))))])
               #`(begin
                   (define (make-name* slot ...)
                     (assert-type make-name slot type) ...
                     (make-name slot ...))
                   (provide (except-out (struct-out name) make-name)
                            (rename-out [make-name* make-name])))))])))

(define-primitive null)

(define-syntax define-primitives
  (syntax-rules ()
    [(_ primitive ...)
     (begin (define-primitive . primitive) ...)]))

(define-primitives
  ;;;; 2D
  ;; lines
  (line [pts (list-of point?)])
;;  (polygon c radius sides)

  ;; curves
  (arc [c point?] [r positive?] [start-angle positive?] [end-angle positive?])
  ;(circle c r) ;; Use ellipse with r1=r2
  (ellipse [c point?] [r1 positive?] [r2 positive?])
  (spline [pts (list-of point?)] [start-tg gvector?] [end-tg gvector?]) ;; NURBS

  ;; Solid-filled areas
  (3dface [p1 point-3d?] [p2 point-3d?] [p3 point-3d?] [p4 point-3d?])
  (donut [c point?] [r1 positive?] [r2 positive?]) ;; circle with a hole...
  (poly [coeffs real?]) ;; polynomial surface: c_0*x^n + c_1*x^(n-1)*y + ... + c_m*x^n
  ;; parametric surf. f receives (u, v), returns (x,y,z). bounds is a list (m,M)
  (parametric [f procedure?] [bounds-u (pair-of real?)]
                             [bounds-v (pair-of real?)])
  (region [l primitive?])

  ;; misc
  (text [origin point?] [size (and integer? positive?)] [str string?])
  (xline [p1 point?] [p2 point?]) ;; infinite line in both directions
  (ray [p1 point?] [dir gvector?])  ;; semi-recta (infinite line with a beginning)

  ;;;; 3D
  ;; meshes
  (mesh [pts-array (list-of (list-of point-3d?))]) ;; MxN points
  ;; set of vertices + set of faces (vertex indices)
  (polyface-mesh [verts point-3d?] [faces (list-of (list-of (and positive? integer?)))])

  ;; standard shapes
  (box [c point-3d?] [w positive?] [l positive?] [h positive?])
  (e-cone [c1 point-3d?] [r1 positive?] [r1* positive?]
          [c2 point-3d?] [r2 positive?]) ;; r2 ~= r1 on the top base. Same ratio for both basis.

  (pyramid [c1 point-3d?] [r1 positive?] [s (and positive? integer?)]
           [c2 point-3d?] [r2 positive?]) ;; one of the sides will be perpendicular to x
  (sphere [c point-3d?] [r positive?])
  (superellipsoid [e number?] [n (and positive? integer?)]) ;; Superquadric ellipsoid, from POV-Ray
  (torus [c point-3d?] [r positive?] [t-r positive?])
  (wedge [c point-3d?] [l positive?] [w positive?] [h positive?]))



(type-fun (make-circle [c point?] [r positive?])
  (make-ellipse c r r))
(define circle-c ellipse-c)
(define circle-r ellipse-r1)
(provide make-circle circle-c circle-r)

(provide make-cone cone-c1 cone-c2 cone-r)
(type-fun (make-cone [c1 point?] [c2 point?] [r positive?])
  (make-e-cone c1 r r c2 0)) ;; r2=0
(define cone-c1 e-cone-c1)
(define cone-c2 e-cone-c2)
(define cone-r  e-cone-r1)

(provide make-cut-cone cut-cone-c1 cut-cone-c2 cut-cone-r1 cut-cone-r2)
(type-fun (make-cut-cone [c1 point?] [r1 positive?] [c2 point?] [r2 positive?])
  (make-e-cone c1 r1 r1 c2 r2))
(define cut-cone-c1 e-cone-c1)
(define cut-cone-c2 e-cone-c2)
(define cut-cone-r1 e-cone-r1)
(define cut-cone-r2 e-cone-r2)

(provide make-cylinder cylinder-c1 cylinder-c2 cylinder-r)
(type-fun (make-cylinder [c1 point-3d?] [c2 (or point-3d? positive?)] [r positive?])
  (if (point-3d? c2)
      (make-e-cone c1 r r c2 r)
      ;; Else, it's a number (height)
      (make-e-cone c1 r r (+z c1 c2) r)))
(define cylinder-c1 e-cone-c1)
(define cylinder-c2 e-cone-c2)
(define cylinder-r  e-cone-r1)

(provide polygon-points)
(type-fun (polygon-points [c point?] [radius positive?] [sides (and positive? integer?)])
  (let ([d-phi (/ 2*pi sides)])
    (define (point n)
      (+pol c radius (* d-phi n)))
    (cons (point -1) (build-list sides point))))

(provide make-polygon)
(type-fun (make-polygon [c point?] [radius positive?] [sides (and positive? integer?)])
  (make-region (make-line (polygon-points c radius sides))))


(define (vertices-poligono-regular p r fi n)
  (lista-vertices p r n fi (/ 2*pi n)))

(type-fun (lista-vertices [p point?] [raio positive?] [n positive?] [fi positive?] [d-fi positive?])
  (if (= n 0)
      (list)
      (cons (+pol p raio fi)
            (lista-vertices p
                            raio
                            (- n 1)
                            (+ fi d-fi)
                            d-fi))))


(provide make-prism)
(type-fun (make-prism [c1 point-3d?] [r positive?] [s (and positive? integer?)] [c2 point-3d?])
  (make-pyramid c1 r s c2 r))


;; Other definitions
(provide empty-region universal-region
         empty-region? universal-region?)
(define empty-region (make-region '(empty)))
(define universal-region (make-region '(universal)))
(define (empty-region? r)
  (and (region? r)
       (eqv? empty-region (region-l r))))
(define (universal-region? r)
  (and (region? r)
       (eqv? universal-region (region-l r))))