#lang typed/racket
(require (for-syntax racket/syntax))

(define-type Loc (List Real Real Real))
(define-type Vec (List Real Real Real))
(define-type Locs (Listof Loc))

(define immediate-mode? : (Parameter Boolean)
  (make-parameter #t))

(define-type (Base-Shape R)
  (U (empty-shape-shape R)
#|
     (universal-shape-shape R)
     (text-shape R)
     (text-centered-shape R)
     (rectangle-shape R)
     (closed-line-shape R)
     (line-shape R)
     (polygon-shape R)
     (spline-shape R)
     (closed-spline-shape R)
     (circle-shape R)
     (ellipse-shape R)
     (arc-shape R)
     (surface-circle-shape R)
     (surface-arc-shape R)
     (surface-rectangle-shape R)
     (surface-polygon-shape R)
     (surface-grid-shape R)
     (surface-shape R)
     (cylinder-shape R)
     (cone-shape R)
     (cone-frustum-shape R)
     (right-cuboid-shape R)
     (box-shape R)
     (sphere-shape R)
     (torus-shape R)
     (regular-pyramid-shape R)
     (regular-pyramid-frustum-shape R)
     (irregular-pyramid-shape R)
     (regular-prism-shape R)
     (irregular-prism-shape R)
     (union-shape R)
     (intersection-shape R)
     (subtraction-shape R)
     (extrusion-shape R)
     (sweep-shape R)
     (slice-shape R)
     (revolve-shape R)
     (unknown-shape R)
|#
     ))

(define-type (Extrudable-Shape R) (Base-Shape R))
(define-type (Curve-Shape R) (Base-Shape R))
(define-type (Surface-Shape R) (Base-Shape R))

(provide Base-Shapes)
(define-type (Base-Shapes R) (Listof (Base-Shape R)))

;;The shared shape part
(struct (R) shape
  ([name : Symbol]
   [id : Integer]
   [realizer : (-> R)]
   [deleter : (-> Void)]
   [realized? : (-> Boolean)])
  #:property prop:custom-write (lambda (s port mode)
                                 (fprintf port "#<~A~A ~A>" 
                                          (if ((shape-realized? s)) "" "virtual ")
                                          (shape-name s)
                                          (shape-id s))))

(: mark-deleted! (All (R) (-> (shape R) (shape R))))
(define (mark-deleted! sh)
  ((shape-deleter sh))
  sh)

(: shape-reference (All (R) ((shape R) -> R)))
(define (shape-reference sh)
  ((shape-realizer sh)))

(: realized? (All (R) (-> (shape R) Boolean)))
(define (realized? sh)
  ((shape-realized? sh)))

(: incr-shape-counter (-> Integer))
(define incr-shape-counter
  (let ((counter -1))
    (lambda ()
      (set! counter (+ counter 1))
      counter)))

(define #:forall (R) (create-realizer-deleter [realize : (-> R)]) : (Values (-> R) (-> Void) (-> Boolean))
  (let ((ref : (Option R) #f)
        (created : Integer 0)
        (deleted : Integer 0))
    (define (realizer)
      (cond ((= created deleted) ;;Not realized
             (let ((r : R (realize)))
               (set! ref r)
               (set! created (add1 created))
               r))
            ((= created (add1 deleted))
             (or ref
                 (error "The shape was created but doesn't have a reference")))
            (else
             (error "Inconsistent creation (~A) and deletion (~A)!" created deleted))))
    (define (deleter) : Void
      (cond ((= created (add1 deleted))
             (set! ref #f)
             (set! deleted (add1 deleted)))
            (else
             (error "Inconsistent creation (~A) and deletion (~A)!" created deleted))))
    (define (realized?)
      (= created (add1 deleted)))
    (values realizer deleter realized?)))

(define-syntax (def-base-shape stx)
  (syntax-case stx ()
    [(_ ((name func-name shape-name) param ...) body ...)
     (with-syntax* ([R (datum->syntax stx 'R)]
                    [([param-name param-type] ...)
                     (map (lambda (p)
                            (syntax-case p (:)
                              [[name : type default] #'[name type]]
                              [[name : type] #'[name type]]))
                          (syntax->list #'(param ...)))])
       (syntax/loc stx
         (begin
           (provide (struct-out shape-name))
           (struct (R) shape-name shape ([param-name : param-type] ...))
           (provide func-name)
           (define #:forall (R) (func-name [realize : (-> R)] [param-name : param-type] ...) : (shape-name R)
             (let-values ([(realizer deleter realized?) (create-realizer-deleter realize)])
               (let ((s (shape-name 'name
                                    (incr-shape-counter)
                                    realizer
                                    deleter
                                    realized?
                                    param-name ...)))
                 (when (immediate-mode?)
                   (realizer))
                 s))))))]
    [(def (name param ...) body ...)
     (with-syntax ([shape-name (build-name #'name "~A-shape")]
                   [func-name (build-name #'name "~A-func")])
       (syntax/loc stx
         (def ((name func-name shape-name) param ...) body ...)))]))

(define-for-syntax (build-name id fmt)
  (format-id id #:source id fmt (syntax-e id)))

(define-type LocOrZ (U Loc Real))
(define-type VecOrZ (U Vec Real))

(def-base-shape (empty-shape))
(def-base-shape (universal-shape))

(def-base-shape (point [location : Loc (u0)]))
(def-base-shape (circle [center : Loc (u0)] [radius : Real 1]))
(def-base-shape (surface-circle [center : Loc (u0)] [radius : Real 1]))
(def-base-shape (arc [center : Loc (u0)] [radius : Real 1] [start-angle : Real 0] [amplitude : Real pi]))
(def-base-shape (surface-arc [center : Loc (u0)] [radius : Real 1] [start-angle : Real 0] [amplitude : Real pi]))
(def-base-shape (elliptic-arc [center : Loc (u0)] [radius-x : Real 1] [radius-y : Real 1] [start-angle : Real 0] [amplitude : Real pi]))
(def-base-shape (ellipse [center : Loc (u0)] [radius-x : Real 1] [radius-y : Real 1]))
(def-base-shape (line [pts : (Listof Loc) (list (u0) (ux))]))
(def-base-shape (closed-line [pts : (Listof Loc) (list (u0) (ux) (uy))]))
(def-base-shape (spline [pts : (Listof Loc) (list (u0) (ux) (uy))] [v0 : (U Boolean Vec) #f] [v1 : (U Boolean Vec) #f]))
(def-base-shape (closed-spline [pts : (Listof Loc)]))
(def-base-shape (polygon [pts : (Listof Loc) (list (u0) (ux) (uy))]))
(def-base-shape (surface-polygon [pts : (Listof Loc) (list (u0) (ux) (uy))]))
(def-base-shape (regular-polygon [edges : Integer 3]
                                 [center : Loc (u0)]
                                 [radius : Real 1]
                                 [angle : Real 0]
                                 [inscribed? : Boolean #f]))
(def-base-shape (rectangle [c : Loc (u0)] [dx/c1 : (U Real Loc) 1] [dy : Real 1]))
(def-base-shape (surface-rectangle [c : Loc (u0)] [dx/c1 : (U Real Loc) 1] [dy : Real 1]))
(def-base-shape (text [str : String ""] [c : Loc (u0)] [h : Real 1]))
(def-base-shape (text-centered [str : String ""] [c : Loc (u0)] [h : Real 1]))
(def-base-shape (sphere [c : Loc (u0)] [r : Real 1]))
(def-base-shape (torus [c : Loc (u0)] [re : Real 1] [ri : Real 1/2]))
(def-base-shape (regular-pyramid-frustum [edges : Integer 4] [cb : Loc (u0)] [rb : Real 1] [a : Real 0] [h/ct : (U Real Loc) 1] [rt : Real 1] [inscribed? : Boolean #f]))
(def-base-shape (regular-pyramid [edges : Integer 3] [cb : Loc (u0)] [rb : Real 1] [a : Real 0] [h/ct : LocOrZ 1] [inscribed? : Boolean #f]))
(def-base-shape (irregular-pyramid [cbs : Locs (list (ux) (uy) (uxy))] [ct : Loc (uz)]))
(def-base-shape (regular-prism [edges : Integer 3] [cb : Loc (u0)] [r : Real 1] [a : Real 0] [h/ct : LocOrZ 1] [inscribed? : Boolean #f]))
(def-base-shape (irregular-prism [cbs : Locs (list (ux) (uy) (uxy))] [h/ct : LocOrZ 1] [solid? : Boolean #t]))
(def-base-shape (right-cuboid [cb : Loc (u0)] [width : Real 1] [height : Real 1] [h/ct : LocOrZ 1]))
(def-base-shape (box [c : Loc (u0)] [dx/c1 : LocOrZ 1] [dy : Real (if (number? dx/c1) dx/c1 1)] [dz : Real dy]))
(def-base-shape (cone [cb : Loc (u0)] [r : Real 1] [h/ct : LocOrZ 1]))
(def-base-shape (cone-frustum [cb : Loc (u0)] [rb : Real 1] [h/ct : LocOrZ 1] [rt : Real 1]))
(def-base-shape (cylinder [cb : Loc (u0)] [r : Real 1] [h/ct : LocOrZ 1]))

(def-base-shape (extrusion [profile : (Extrudable-Shape R)] [dir : VecOrZ 1]))
(def-base-shape (move [shape : (shape R)] [v : Vec]))
(def-base-shape (revolve [shape : (shape R)] [p0 : Loc (u0)] [p1 : Loc (+z p0 1)] [start-angle : Real 0] [amplitude : Real 2*pi]))
(def-base-shape (join-curves [shapes : (Listof (Curve-Shape R))]))
(def-base-shape (surface [profile : (Curve-Shape R)]))
(def-base-shape (surface-grid [points : (Listof (Listof Loc))] [closed-u? : Boolean #f] [closed-v? : Boolean #f]))
(def-base-shape (sweep [path : (Curve-Shape R)] [profile : (Extrudable-Shape R)] [rotation : Real 0] [scale : Real 1]))
(def-base-shape (slice [shape : (shape R)] [p : Loc (u0)] [n : Vec (vz 1)]))
(def-base-shape (union [shapes : (Base-Shapes R)]))
(def-base-shape (intersection [shapes : (Base-Shapes R)]))
(def-base-shape (subtraction [shapes : (Base-Shapes R)]))
(def-base-shape (unknown))