;;
;; pinballgeom.al
;;
;; Lawson Wade
;;
;; geometric parts for a pinball scene
;;

(require 'colors.al)


;;;;;;;;;;;;;;;;;;;;
;; a largepatch patch

(define (largepatch)
  (patch "bilinear" 'P '(#<-10 0 -10>  #<-10 0 10>  #<10 0 -10>  #<10 0 10>)))

(define (smallpatch)
  (patch "bilinear" 'P '(#<-1 0 -1>  #<-1 0 1>  #<1 0 -1>  #<1 0 1>)))



;;-------------------
;; Extended-Patch-Edge
;;    adds a bicubic patch to the right
;;    of the bicubic curve with control
;;    points p0, p1, p2, p3, trying to
;;    make the patch <radius> units wide,
;;    and adding another bicubic patch as
;;    an overhanging lip on the far side
;;    from the p0, p1, p2, p3 curve.

(define (extended-patch-edge p0 p1 p2 p3 radius lip)
  (let* (
	 (v01 (normalize (- p1 p0)))
	 (v12 (normalize (- p2 p1)))
	 (v23 (normalize (- p3 p2)))
	 (norm0 (normalize (cross v01 y-axis)))
	 (norm1 (normalize (+ norm0 (cross v12 y-axis))))
	 (norm3 (normalize (cross v23 y-axis)))
	 (norm2 (normalize (+ norm3 (cross v12 y-axis))))
	 (q0 (+ p0 (* radius norm0)))
	 (q1 (+ p1 (* radius norm1)))
	 (q2 (+ p2 (* radius norm2)))
	 (q3 (+ p3 (* radius norm3)))
	 (third (/ radius 3))
	 (twothirds (* (/ radius 3) 2))
	 (b0 (+ p0 (* third norm0)))
	 (b1 (+ p1 (* third norm1)))
	 (b2 (+ p2 (* third norm2)))
	 (b3 (+ p3 (* third norm3)))
	 (c0 (+ p0 (* twothirds norm0)))
	 (c1 (+ p1 (* twothirds norm1)))
	 (c2 (+ p2 (* twothirds norm2)))
	 (c3 (+ p3 (* twothirds norm3)))
	 (lip1 (vec3 0 (/ lip 3) 0))
	 (lip2 (vec3 0 (* (/ lip 3) 2) 0))
	 (lip3 (vec3 0 lip 0))
	 )
    (begin
      ;; the flat edge patch
      (patch "bicubic" 'P
	     (list p0 p1 p2 p3 b0 b1 b2 b3 c0 c1 c2 c3 q0 q1 q2 q3))
      
      ;; the vertical lip patch
      (patch "bicubic" 'P
	     (list q0 q1 q2 q3
		   (- q0 lip1) (- q1 lip1) (- q2 lip1) (- q3 lip1)
		   (- q0 lip2) (- q1 lip2) (- q2 lip2) (- q3 lip2)
		   (- q0 lip3) (- q1 lip3) (- q2 lip3) (- q3 lip3)
		   ))
      )    
    ))


;;-------------------
;; Extended-Patch-Corner
;;    adds a partial disk and cylinder
;;    to the outside angle of the polyline
;;    angle at q2-p0-p1, so that the
;;    geometry will be flush with rectangular
;;    pieces along q2-p0 and p0-p1.

(define (extended-patch-corner q2 p0 p1 radius lip)
  (let* (
	 (v01 (normalize (- p1 p0)))
	 (v23 (normalize (- p0 q2)))
	 (norm0 (normalize (cross v01 y-axis)))
	 (norm3 (normalize (cross v23 y-axis)))
	 (ang3 (degrees (atan (xcomp norm3) (zcomp norm3))))
	 (ang0 (degrees (atan (xcomp norm0) (zcomp norm0))))
	 (ang30 (mod (+ (- ang0 ang3) 720) 360))
	 )
    (separator
      ;; the partial disks
      (translate p0)
      (rotate (- ang3 90) y-axis)
      (rotate -90 x-axis)
      (disk 'radius radius
	    'thetamax ang30)
      (cylinder 'zmin (- lip)
		'zmax 0
		'radius radius
		'thetamax ang30))
    ))


;;-------------------
;; Extended-Patch
;;    draw the geometry for a bezier
;;    bicubic patch and adds patches,
;;    partial disks, and partial cylinders
;;    around the outside to extend the
;;    patch, smooth the corners, and
;;    add a lip.  <radius> is the 
;;    extension amount; <lip> is the
;;    height of the lip.

(define (extended-patch ptlist radius lip surfpoly)
  (let (
	(p0 (list-ref ptlist 0))
	(p1 (list-ref ptlist 1))
	(p2 (list-ref ptlist 2))
	(p3 (list-ref ptlist 3))
	(p4 (list-ref ptlist 4))
	(p5 (list-ref ptlist 5))
	(p6 (list-ref ptlist 6))
	(p7 (list-ref ptlist 7))
	(p8 (list-ref ptlist 8))
	(p9 (list-ref ptlist 9))
	(p10 (list-ref ptlist 10))
	(p11 (list-ref ptlist 11))
	(p12 (list-ref ptlist 12))
	(p13 (list-ref ptlist 13))
	(p14 (list-ref ptlist 14))
	(p15 (list-ref ptlist 15))
	)
    (separator
      (color White)
      (if (eq? surfpoly #f)
	  (surface "backlit")
	  (surfpoly))
      (patch "bicubic" 'P ptlist)
      (surface "backlit")
      (extended-patch-edge p3 p2 p1 p0 radius lip) 
      (extended-patch-edge p12 p13 p14 p15 radius lip)
      (extended-patch-edge p0 p4 p8 p12 radius lip) 
      (extended-patch-edge p15 p11 p7 p3 radius lip) 
      (extended-patch-corner p8 p12 p13 radius lip)
      (extended-patch-corner p1 p0 p4 radius lip)
      (extended-patch-corner p7 p3 p2 radius lip)
      (extended-patch-corner p14 p15 p11 radius lip)
      )
    ))


;;-------------------
;; Pinball

(define (pinball)
  (separator
    (color White)
    (surface "metallic"
	     'texturemap "environ.tex"
	     'Ka Ka
	     'Ks Ks
	     'Kr Kr)
    (uscale 0.5)
    (translate 0 1 0)
    (sphere)
    ))


;;-------------------
;; An Open Cone (no point)

(define (open-cone height topradius bottomradius)
  (separator
    (hyperboloid 'point1 (vec3 bottomradius 0 0)
		 'point2 (vec3 topradius 0 height))
    ))


;;-------------------
;; Circular Bumper

(define (bumper lit)
  (separator

    ;; the light inside

    (if lit
	(light "pointlight"
	       'from (vec3 0 0.99 0)
	       'intensity 0.15)
;; 	(light "spotlight"
;; 	       'from (vec3 0 0.99 0)
;; 	       'to (vec3 0 2 0)
;; 	       'coneangle (radians 89)
;; 	       'conedeltaangle (radians 4)
;; 	       'beamdistribution 0.01
;; 	       'intensity 0.15)
	)

    ;; the core 

    (separator
      (surface "backlit")
      (color White)

      ;; the cylinder

      (separator
	(translate 0 1.1 0)
	(scale 0.6 0.1 0.6)
	(translate 0 1 0)
	(rotate 90 x-axis)
	(cylinder))

      (separator
	(scale 0.6 1.0 0.6)
	(translate 0 1 0)
	(rotate 90 x-axis)
	(cylinder))

      ;; the top
      
      (separator
	(translate 0 1.2 0)
	(scale 0.6 1 0.6)
	(rotate -90 x-axis)
	(disk))
      )

    ;; the bumper(s)

    (separator
      (surface "rubber")
      (color Red3)
      (translate 0 0.2 0)
      (scale 0.8 0.4 0.8)
      (rotate 90 x-axis)
      (torus 'minorrad 0.2))

    (separator
      (surface "rubber")
      (color AntiqueWhite3)
      (translate 0 0.6 0)
      (scale 0.7 0.3 0.7)
      (rotate 90 x-axis)
      (torus 'minorrad 0.2))

    ;; the fan
    
    (separator
      (color White)
      (surface "backlit_triangles"
 	       'baseline -0.1)
      (translate 0 1 0)
      (scale 1.2 1 1.2)
      (rotate -90 x-axis)
      (open-cone 0.1 0.5 1.0))
    ))


;;-------------------
;; Minipost
;;   a stand alone metal peg with a bumper

(define (minipost)
  (separator

    ;; the metal post

    (separator
      (color White)
      (surface "metallic"
	       'texturemap "environ.tex"
	       'Ka Ka
	       'Ks Ks
	       'Kr Kr)
      
      (separator
	(scale 0.2 0.8 0.2)
	(translate 0 1 0)
	(rotate 90 x-axis)
	(cylinder))
      
      (separator
	(translate 0 0.8 0)
	(scale 0.2 0.3 0.2)
	(translate 0 1 0)
	(rotate 90 x-axis)
	(paraboloid))
      )
    
    ;; the bumper
    
    (separator
      (surface "rubber")
      (color AntiqueWhite3)
      (translate 0 0.6 0)
      (rotate 90 x-axis)
      (torus 'majorrad 0.2
	     'minorrad 0.13))
    ))


;;-------------------
;; Disk Target
;;   centered at origin, facing z-axis

(define (disk-target)
  (separator

    ;; the plastic disk & metal ball

    (separator
      (color AntiqueWhite3)
      (surface "plastic")
      (translate 0 0.45 0.12)
      (uscale 0.4)

      ;; front & back of disk

      (separator
	(translate 0 0 0.1)
	(disk))

      (separator
	(translate 0 0 -0.1)
	(disk))

      ;; curved edge

      (separator
	(torus 'minorrad 0.1
	       'phimin -90
	       'phimax 90))

      ;; the little metal ball

      (separator
	(color White)
	(surface "metallic"
		 'texturemap "environ.tex"
		 'Ka Ka
		 'Ks Ks
		 'Kr Kr)
	(uscale 0.325)
	(sphere))
      )

    ;; the support bar
    
    (separator
      (color White)
      (surface "metallic"
	       'texturemap "environ.tex"
	       'Ka Ka
	       'Ks Ks
	       'Kr Kr)
      (scale 0.1 0.5 0.025)
      (translate 0 0.1 0)
      (box))
    ))


;;-------------------
;; Popup Target
;;   centered at origin, facing z-axis

(define (popup-target)
  (separator
    
    ;; the plastic piece
    
    (separator
      (surface "plastic")
      (color White)
      (scale 0.5 0.6 0.13)
      (translate 0 1 0)
      (box))

    ;; the target
    
    (separator
      (color Red3)
      (surface "target")
      (uscale 0.48)
      (translate 0 1.2 -0.3265)
      (rotate 90 x-axis)
      (smallpatch))
    ))


;;-------------------
;; Row of Popup Targets
;;   extends along z-axis

(define (popup-target-row numtargets)
  (separator

    (translate 0 0 0.6)
    (let ((i 0))
      (while (< i numtargets)
	(separator
	  (translate 0 0 (* i 1.2))
	  (rotate 90 y-axis)
	  (popup-target))
	(set! i (+ i 1))
	))
    ))


;;-------------------
;; Post
;;   a post for poly-bumpers

(define (post)
  (separator
    (color White)
    (surface "plastic")
    (scale 0.2 1 0.2)
    (rotate -90 x-axis)
    (cylinder)
    ))


;;-------------------
;; Post Screw
;;    the metal screw/ball on top of the post

(define (post-screw)
  (separator
    (color White)
    (surface "metallic"
	     'texturemap "environ.tex"
	     'Ka Ka
	     'Ks Ks
	     'Kr Kr)
    (translate 0 1.05 0)
    (scale 0.12 0.06 0.12)
    (sphere)
    ))


;;-------------------
;; Post Bumper
;;    bumper for a stand-alone post

(define (post-bumper)
  (let (
	(majorrad 0.3)
	(minorrad 0.11)
	)
    (separator
      (color AntiqueWhite3)
      (surface "rubber")
      (translate 0 0.6 0)
      (rotate -90 x-axis)
      (torus 'majorrad majorrad
	     'minorrad minorrad))     
    ))


;;-------------------
;; Stand-Alone Post
;;    a stand-alone post with bumper & screw

(define (post-standalone)
  (separator
    (post)
    (post-screw)
    (post-bumper)
    ))


;;-------------------
;; Polybumper
;;   a polygonally shaped bumper
;;   <top?> = #t if a top should be created

(define (poly-bumper postcenters kickers top? surfpoly)
  (separator
    (define numposts (length postcenters))
    (define numkickers (length kickers))
    (define postrad 0.19)
    (define minorrad 0.11)
    (define majorrad (+ postrad minorrad))

    (for j 0 (- numposts 1) 1
	 (let* (
		(i (if (= j 0) (- numposts 1) (- j 1)))
		(k (if (= j (- numposts 1)) 0 (+ j 1)))
		(icent (list-ref postcenters i))
		(jcent (list-ref postcenters j))
		(kcent (list-ref postcenters k))
		(xi (xcomp icent))
		(zi (zcomp icent))
		(xj (xcomp jcent))
		(zj (zcomp jcent))
		(xk (xcomp kcent))
		(zk (zcomp kcent))
		(bumplen (sqrt (+ (sqr (- xk xj)) (sqr (- zk zj)))))
		(angjk (degrees (atan (- xk xj) (- zk zj))))
		(angji (degrees (atan (- xi xj) (- zi zj))))
		(angPj (mod (+ (- angjk angji) 360) 180))
		(angOj (- 180 angPj))
		(angjk90 (+ angjk 90))
		)
	   (begin

	     ;; the post and the metal screw/ball on top of the post
	     (separator
	       (translate xj 0 zj)
	       (post)
	       (post-screw))

	     ;; partial circular pieces around post
	     (separator
	       (translate xj 0.6 zj)
	       (rotate angjk90 y-axis)
	       (rotate -90 z-axis)
	       (rotate -90 y-axis)
	       
	       ;; post bumper
	       (separator
		 (surface "rubber")
		 (color AntiqueWhite3)
		 (torus 'majorrad majorrad
			'minorrad minorrad
			'thetamax angOj))
	       
	       ;; post plastic cap (the z-trans functions as a y-trans)
	       (if top?
		   (separator
		     (color White)
		     (surface "backlit")
		     (translate 0 0 0.45)
		     (disk 'radius majorrad
			   'thetamax angOj)
		     (translate 0 0 -0.075)
		     (cylinder 'radius majorrad
			       'thetamax angOj
			       'zmax 0.075)))
	       )

	     ;; linear items from post j to post k
	     (separator
	       (translate xj 0.6 zj)
	       (translate (* majorrad (sin (radians angjk90))) 0
			  (* majorrad (cos (radians angjk90))))
	       (rotate angjk y-axis)

	       ;; the linear bumper
	       (separator
		 (surface "rubber")
		 (color AntiqueWhite3)
		 (cylinder 'radius minorrad
			   'zmax bumplen))

	       ;; the linear plastic edge of the cap
	       (if top?
		   (separator
		     (color White)
		     (surface "backlit")
		     (translate 0 0.45 0)
		     
		     ;; the top part
		     (separator
		       (scale majorrad 1 bumplen)
		       (uscale 0.5)
		       (translate -1 0 1)
		       (smallpatch))
		     
		     ;; the side edge (vertical part)
		     (separator
		       (scale 1 0.075 bumplen)
		       (rotate -90 z-axis)
		       (uscale 0.5)
		       (translate 1 0 1)
		       (smallpatch))
		     ))
	       ))
	   ))


    ;; the polygon cap
    (if (and top? (> numposts 2))
	(separator
	  (color White)
	  (if (eq? surfpoly #f)
	      (surface "backlit")
	      (surfpoly))
	  (translate 0 1.05 0)
	  (cond ((= numposts 4)
		 (patch "bilinear" 'P
			(list (list-ref postcenters 0)
			      (list-ref postcenters 1)
			      (list-ref postcenters 3)
			      (list-ref postcenters 2))))
		((= numposts 3)  
		 (patch "bilinear" 'P
			(cons (* 0.5 (+ (list-ref postcenters 1)
					(list-ref postcenters 0)))
			      postcenters )))
		(else
		 (polygon 'P postcenters)))
	  ))


    ;; the kickers
    (if (> numkickers 0)
	(for i 0 (- numkickers 1) 1
	     (let* (
		    (j (list-ref kickers i))
		    (k (if (= j (- numposts 1)) 0 (+ j 1)))
		    (jcent (list-ref postcenters j))
		    (kcent (list-ref postcenters k))
		    (xj (xcomp jcent))
		    (zj (zcomp jcent))
		    (xk (xcomp kcent))
		    (zk (zcomp kcent))
		    (bumplen (sqrt (+ (sqr (- xk xj)) (sqr (- zk zj)))))
		    (angjk (degrees (atan (- xk xj) (- zk zj))))
		    (angjk90 (+ angjk 90))
		    )
	       (begin
		 
		 ;; two metal kickers
		 (separator
		   (color White)
		   (surface "metallic"
			    'texturemap "environ.tex"
			    'Ka Ka
			    'Ks Ks
			    'Kr Kr)
		   
		   (translate xj 0 zj)
		   (rotate angjk y-axis)
		   
		   (separator
		     (translate 0 0 (* 0.33 bumplen))
		     (scale 0.04 0.85 0.08)
		     (box))
		   
		   (separator
		     (translate 0 0 (* 0.67 bumplen))
		     (scale 0.04 0.85 0.08)
		     (box))
		   )
	     ))))
    ))


;;-------------------
;; Rollover
;;   centered at origin, aligned with z-axis

(define (rollover radius)
  (separator
    (define majorrad 0.12)
    (define minorrad radius)
    (define angle 65)

    (translate 0 0.2 0)
    (rotate (* 0.5 (- 180 angle)) x-axis)

    (color White)
    (surface "metallic"
	     'texturemap "environ.tex"
	     'Ka Ka
	     'Ks Ks
	     'Kr Kr)

    (separator
      (rotate angle x-axis)
      (translate 0 0 (- majorrad))
      (rotate -90 x-axis)
      (cylinder 'radius minorrad
		'zmax 1.5))

    (separator
      (translate 0 0 (- majorrad))
      (rotate 90 x-axis)
      (cylinder 'radius minorrad
		'zmax 1.5))

    (separator
      (rotate 90 y-axis)
      (torus 'minorrad minorrad
	     'majorrad majorrad
	     'thetamax angle))
    ))


;;-------------------
;; Flipper-Shape
;;   flipper geometry with major post is at the origin,
;;   pointing down the positive z-axis

(define (flipper-shape majorrad minorrad flipperlen height)
  (separator
    (define raddiff (- majorrad minorrad))
    (define sidelen (sqrt (+ (sqr flipperlen) (sqr raddiff))))
    (define ang1 (degrees (atan sidelen raddiff)))
    (define ang1rads (atan sidelen raddiff))
    (define ang90 (- ang1 90))
    (define thetamax2 (+ ang1 ang1))
    (define thetamax1 (- 360 thetamax2))

    ;; major cylindrical piece with disk caps 
    (separator
      (rotate ang90 y-axis)
      (rotate -90 x-axis)
      (cylinder 'thetamax thetamax1
		'radius majorrad
		'zmax height)
      (disk 'thetamax thetamax1
	    'radius majorrad)
      (disk 'thetamax thetamax1
	    'radius majorrad
	    'height height))

    ;; minor cylindrical piece with disk caps
    (separator
      (translate 0 0 flipperlen)
      (rotate (- 270 ang1) y-axis)
      (rotate -90 x-axis)
      (cylinder 'thetamax thetamax2
		'radius minorrad
		'zmax height)
      (disk 'thetamax thetamax2
	    'radius minorrad)
      (disk 'thetamax thetamax2
	    'radius minorrad
	    'height height))

    ;; side patches
    (separator
      (rotate ang90 y-axis)
      (translate majorrad 0 0)
      (patch "bilinear"
	     'P (list (vec3 0 0 0) (vec3 0 0 sidelen)
		      (vec3 0 height 0) (vec3 0 height sidelen))))
    (separator
      (rotate (- ang90) y-axis)
      (translate (- majorrad) 0 0)
      (patch "bilinear"
	     'P (list (vec3 0 0 0) (vec3 0 0 sidelen)
		      (vec3 0 height 0) (vec3 0 height sidelen))))

    ;; trapezoidal patches
    (define (trapezoidpatch height reflect?)
      (patch "bilinear"
	     'P 
	     (if reflect?
		 (list (vec3 0 height 0) (vec3 0 height flipperlen)
		       (vec3 (* -1 (sin ang1rads) majorrad) height
			     (* (cos ang1rads) majorrad))
		       (vec3 (* -1 (sin ang1rads) minorrad) height
			     (+ (* (cos ang1rads) minorrad) flipperlen)))
		 (list (vec3 0 height 0) (vec3 0 height flipperlen)
		       (vec3 (* (sin ang1rads) majorrad) height
			     (* (cos ang1rads) majorrad))
		       (vec3 (* (sin ang1rads) minorrad) height
			     (+ (* (cos ang1rads) minorrad) flipperlen))))
	     ))

    (trapezoidpatch 0.0 #f)
    (trapezoidpatch 0.0 #t)
    (trapezoidpatch height #f)
    (trapezoidpatch height #t)
    ))


;;-------------------
;; Flipper
;;   a flipper whose major post is at the origin,
;;   pointing down the positive z-axis

(define (flipper majorrad minorrad bumperrad flipperlen)
  (separator
    (translate 0 0.05 0)

    ;; the flipper
    (color White)
    (surface "plastic")
    (flipper-shape majorrad minorrad flipperlen 0.75)
    
    ;; the bumper on the flipper
    (color AntiqueWhite3)
    (surface "rubber")
    (translate 0 0.125 0)
    (flipper-shape (+ majorrad bumperrad) (+ minorrad bumperrad) 
		   flipperlen 0.5)
    ))


;;-------------------
;; Railing 
;;    From the origin along positive z-axis

(define (railing raillen radius height)
  (separator
    (define torusrad (* radius 3))
    (define mainlen (- raillen torusrad torusrad))

    (translate 0 (- height torusrad) 0)

    ;; main railing
    (separator
      (translate 0 torusrad torusrad)
      (cylinder 'radius radius
		'zmax mainlen))

    ;; support rails
    (separator
      (rotate 90 x-axis)
      (cylinder 'radius radius
		'zmax 1.0)
      (translate 0 raillen 0)
      (cylinder 'radius radius
		'zmax 1.0)
      )

    ;; curves at corners
    (separator
      (translate 0 0 torusrad)
      (rotate 90 y-axis)
      (torus 'minorrad radius
	     'majorrad torusrad
	     'thetamax 90))
    (separator
      (translate 0 0 (+ mainlen torusrad))
      (rotate -90 y-axis)
      (torus 'minorrad radius
	     'majorrad torusrad
	     'thetamax 90))
    ))