#lang scheme

(require "point.ss"
         "vector.ss"
         "plane.ss"                     ; And axis
         "coordinates-new.ss"

         "operations-new.ss"
         "primitives-new.ss"

         "scheme-functions.ss"

         "ad-hoc-typing.ss")



(provide (all-from-out "point.ss"
                       "vector.ss"
                       "plane.ss"
                       "coordinates-new.ss"

                       "scheme-functions.ss"

                       "ad-hoc-typing.ss" ;; Should we provide this for the outside world?
                                          ;; maybe some backend developers will want it...
                       )

         ;; "primitives-new.ss"
         (except-out (all-from-out "primitives-new.ss")
                     make-arc
                     make-line
                     make-spline
                     make-parametric
                     make-pyramid

                     make-box
                     make-wedge
                     )

         (rename-out [make-arc* make-arc]
                     [make-line* make-line]
                     [make-spline* make-spline]
                     [make-parametric* make-parametric]
                     [make-pyramid* make-pyramid]
                     [make-box* make-box]
                     [make-wedge* make-wedge]
                     ;; See make-cone, etc. should we provide one that receives
                     ;; the height instead of a point?
                     )

         ;; "operations-new.ss"
         (except-out (all-from-out "operations-new.ss")
                     subtract

                     make-loft
                     make-guided-loft
                     make-ruled-loft

                     make-sweep

                     make-mirror
                     make-move
                     make-offset
                     make-rotate
                     make-scale
                     make-slice
                     make-thicken
                     make-transform
                     make-edges
                     )
         (rename-out [subtract* do-subtract])
         do-loft
         do-guided-loft
         do-ruled-loft

         do-extrude
         do-revolve
         do-sweep

         do-mirror
         do-move
         do-offset
         do-rotate
         do-scale
         do-slice
         do-thicken
         do-transform
         do-edges
         )

;; For top-level printing...
(provide register-top-level-print-hook
         current-top-level-print-mode
         set-top-level-print-mode)

;; Curry (or give default arguments to) some functions

;; primitives.ss

(define make-arc*
  (type-case-lambda
    [([c point?] [r positive?] [angle real?])
     (make-arc c r 0 angle)]
    [([c point?] [r positive?] [sa real?] [ea real?])
     (make-arc c r sa ea)]))

(define make-line*
  (type-case-lambda
    ;; Only one argument falls here
    [([pts (list-of point?)])
     (make-line pts)]
    ;; More than one argument
    [([p1 point?] [p2 point?]) ;; TODO: Correct this!!!! FILCAB!
     (lambda (pts)
       (assert-type 'case-lambda pts (list-of point?))
       (apply make-line p1 p2 pts))]))

(define make-spline*
  (type-case-lambda
    [([pts (list-of point?)] [start-tg gvector?] [end-tg gvector?])
     (make-spline pts start-tg end-tg)]
    [([pts (list-of point?)])
     (make-spline pts (vxyz 0 0 0) (vxyz 0 0 0))]
    [[pts point?]
     (make-spline pts (vxyz 0 0 0) (vxyz 0 0 0))]))

(define make-parametric*
  (let ([combine (lambda (fx fy fz)
                   (lambda (u v)
                     (xyz (fx u v) (fy u v) (fz u v))))])
    (type-case-lambda
      [([f procedure?])
       (lambda (u-min u-max v-min v-max)
         (make-parametric* f (cons u-min u-max) (cons v-min v-max)))]
      [([f procedure?] [u-min real?] [u-max real?] [v-min real?] [v-max real?])
       (make-parametric f (cons u-min u-max) (cons v-min v-max))]
      [([fx procedure?] [fy procedure?] [fz procedure?]
                       [u-min real?] [u-max real?] [v-min real?] [v-max real?])
       (make-parametric* (combine fx fy fz)
                         (cons u-min u-max) (cons v-min v-max))]
      [([fx procedure?] [fy procedure?] [fz procedure?])
       (lambda (u-min u-max v-min v-max)
         (make-parametric* (combine fx fy fz)
                           (cons u-min u-max) (cons v-min v-max)))])))

(define make-pyramid*
  (type-case-lambda
    [([c1 point?] [r positive?] [s (and integer? positive?)] [c2 point?])
     (make-pyramid c1 r s c2 0)]
    [([c1 point?] [r positive?] [s (and integer? positive?)] [c2 point?] [r2 positive?])
     (make-pyramid c1 r s c2 r2)]))

(define make-box*
  (type-case-lambda
    [([p1 point?] [p2 point?])
     (let [(p1p2 (p->q p1 p2))]
       (make-box (p+v p1 (v*r p1p2 1/2))
                 (abs (vy p1p2))
                 (abs (vx p1p2))
                 (abs (vz p1p2))))]
    [([center point?] [w positive?] [l positive?] [h positive?])
     (make-box center w l h)]))

(define make-wedge*
  (type-case-lambda
    [([p1 point?] [p2 point?])
     (let [(p1p2 (p->q p1 p2))]
       (make-wedge (p+v p1 (v*r p1p2 1/2))
                 (abs (vy p1p2))
                 (abs (vx p1p2))
                 (abs (vz p1p2))))]
    [([center point?] [w positive?] [l positive?] [h positive?])
     (make-wedge center w l h)]))


;; operations.ss
;; CURRY
(define subtract*
  (case-lambda
    [(object)
     (lambda args
       (subtract object args))]
    [(object . args)
     (apply subtract object args)]))

(define do-loft
  (type-case-lambda
    [([objects (list-of primitive?)])
     (make-loft objects 0 0 0 0)]
    [([objects (list-of primitive?)] [a1 real?] [m1 positive?] [a2 real?] [m2 positive?])
     (make-loft objects a1 m1 a2 m2)]))

(define (do-guided-loft objects path-or-guides)
  (if (list? path-or-guides)
      (make-guided-loft objects path-or-guides 0) ;; guides
      (make-guided-loft objects (list) path-or-guides)))

(define do-ruled-loft make-ruled-loft)


(define do-extrude
  (type-case-lambda
    [([surf primitive?] [p (or primitive? vector-3d? positive?)])
     (cond [(real? p)
            (do-extrude surf (vxyz 0 0 p))]
           [(vector-3d? p)
            (do-extrude surf (make-line (list origin (p+v origin p))))]
           [else
            (make-extrusion surf p 0)])]
    [([surf primitive?] [p (or primitive? vector-3d? positive?)] [taper real?])
     (make-extrusion surf p taper)]))

(define do-sweep
  (type-case-lambda
    [([surface primitive?] [path primitive?])
     (make-sweep surface path 0 1)]
    [([surface primitive?] [path primitive?] [twist real?] [scale positive?])
     (make-sweep surface path twist scale)]))

(define do-revolve
  (type-case-lambda
    [([surface primitive?] [axis axis?])
     (make-revolution surface axis 0 (* 2 pi))]
    [([surface primitive?] [axis axis?] [start-angle real?] [end-angle real?])
     (make-revolution surface axis start-angle end-angle)]))

(define do-mirror make-mirror)
(define do-move make-move)
(define do-offset make-offset)
(define do-rotate make-rotate)
(define do-scale make-scale)
(define do-slice make-slice)
(define do-thicken make-thicken)
(define do-transform make-transform)
(define do-edges make-edges)

;;;; If desired, print the result of top-level forms.
;; I don't think we need parameters, here...

;; Default: use default Scheme behaviour
(define top-level-print-mode 'raw)
(define (current-top-level-print-mode)
  top-level-print-mode)
(define (set-top-level-print-mode name)
  (if (assq name top-level-print-hooks)
      (set! top-level-print-mode name)
      (error 'set-top-level-print-mode
             "Top level printing mode named ~s does not exist. Available names: ~s."
             name (map car top-level-print-hooks))))

;; top-level-print-hooks: To override default behaviour
;; list of ( (mode . function) )
;; raw mode: current top-level print
(define top-level-print-hooks
  `((raw . ,(current-print))))

;; DEBUG:
(provide top-level-print-hooks
         top-level-printer)


(define (top-level-printer object)
  (define (top-level-printer-aux hooks)
    (if (null? hooks)
        (error "Catastrophic failure: No top-level-printer-hooks registered!")
        (let ([hook (first hooks)])
          (if (eq? (car hook) top-level-print-mode)
              ((cdr hook) object)
              (top-level-printer-aux (rest hooks))))))
  (top-level-printer-aux top-level-print-hooks))

;; Register a new print-hook. this hook overrides any previously registered
;; hooks with the same name.
(define (register-top-level-print-hook name function)
  (set! top-level-print-hooks (cons (cons name function)
                                    top-level-print-hooks)))