;;;
;;;                  JabkaDefs.scm
;;;
;;; Predefined Jabka Routines, Donald H. House July. 1990
;;; Most defined constants added by F. Sebastian Grassia in 91
;;; Updates by Donald House, 1995
;;;

;; uncomment one of these if you're running on a mac or iris
(define iris #t)
;(define mac #t)

;
; extend numeric relationships
;
(define (<= x y)
  (or (< x y) (= x y)))

(define (>= x y)
  (or (> x y) (= x y)))

;
; build some of the standard built-in functions that are not
; implemented in c code
;

(define list (lambda n n))

(define append
  (lambda args
    (define (app arg1 rest)
      (if (null? arg1)
                (if (null? rest)
                    '()
                    (app (car rest) (cdr rest)))
                (cons (car arg1) (app (cdr arg1) rest))))
    (if (null? args)
              '()
              (app (car args) (cdr args)))))

(define (length object)
  (if (null? object)
      0
      (+ 1 (length (cdr object)))))

(define (last object)
  (if (or (not (pair? object)) (null? object))
      '()
      (if (null? (cdr object))
          (car object)
          (last (cdr object)))))
          
(define (last-pair object)
  (last object))

(define (list-tail object index)
  (if (or (< index 0) (not (pair? object)) (null? object))
      '()
      (if (= index 0)
          object
          (list-tail (cdr object) (- index 1)))))

(define (list-ref object index)
  (if (or (< index 0) (not (pair? object)) (null? object))
      '()
      (car (list-tail object index))))

(define (apply fctn arg-list)
  (eval (append (list fctn) arg-list) (the-environment)))

(define (map fctn object)
  (if (or (not (pair? object)) (null? object))
      '()
      (cons (fctn (car object)) (map fctn (cdr object)))))

(define (for-each fctn object)
  (if (or (not (pair? object)) (null? object))
      '()
      (begin (fctn (car object)) (for-each fctn (cdr object)))))

(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))

(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))

(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))

(define (equal? x y)
   (if (eqv? x y)
       #t
       (and (pair? x) (pair? y) (equal? (car x) (car y)) (equal? (cdr x) (cdr y)))))

(define (memq x lst)
               (if (not (pair? lst))
      #f
      (if (eq? x (car lst))
          lst
          (memq x (cdr lst)))))

(define (memv x lst)
               (if (not (pair? lst))
      #f
      (if (eqv? x (car lst))
          lst
          (memv x (cdr lst)))))

(define (member x lst)
               (if (not (pair? lst))
      #f
      (if (equal? x (car lst))
          lst
          (member x (cdr lst)))))

(define (assv x alist)
  (if (not (pair? alist))
      #f
      (if (and (pair? (car alist)) (eqv? x (caar alist)))
          (car alist)
                                                                               (assv x (cdr alist)))))

(define (assoc x alist)
  (if (not (pair? alist))
      #f
      (if (and (pair? (car alist)) (equal? x (caar alist)))
          (car alist)
                                                                               (assv x (cdr alist)))))

;
; Handy Mathematical Routines and Constants
;

(define (tan theta)
  (/ (sin theta) (cos theta)))

(define pi 3.1415926536)

(define (radians angle)  ; degrees to radians
  (* angle 0.0174533))
  
(define (degrees angle)  ; radians to degrees
  (* angle 57.2958))
  
;
; build some simple functions to operate on Jabka objects
;

(define (x-coord triple) (car triple))
(define (y-coord triple) (cadr triple))
(define (z-coord triple) (caddr triple))

(define (2to3d 2d-list)
  (map (lambda (point) (append point '(0))) 2d-list))

(define (polyxform xform polygon)  ; transform pgon by applying xform to its vertices
  (map (lambda (vertex) (vertxform xform vertex)) polygon))

;;;
;;; Advanced Modeling Routines
;;;

;
; Create a PolySurface by sweeping an outline in x-y plane about the y-axis
;
(define (sweep outline numsamples)
  (define surf (create-obj polysurface))
  (define (very-near-zero x)
    (< (abs x) 1e-3))
  (define (tile-sweep oldoutline newoutline original)
    (if (null? (cdr oldoutline))
        '()
        (begin
          (if (very-near-zero (x-coord (car original)))
            (if (not (very-near-zero (x-coord (cadr original))))
              (surf (insertpoly (list (car oldoutline) (cadr newoutline)
                    (cadr oldoutline)))))
            (if (very-near-zero (x-coord (cadr original)))
              (surf (insertpoly (list (car oldoutline) (car newoutline)
                    (cadr oldoutline))))
              (surf (insertpoly (list (car oldoutline) (car newoutline)
                                      (cadr newoutline) (cadr oldoutline))))))
          (tile-sweep (cdr oldoutline) (cdr newoutline) (cdr original)))))
  (define (continue-sweep oldoutline d-angle count)
    (if (= count numsamples)
        (tile-sweep oldoutline outline outline)
        (let ((newoutline (polyxform (y-rot d-angle) oldoutline)))
          (tile-sweep oldoutline newoutline outline)
          (continue-sweep newoutline d-angle (+ count 1)))))
  (if (< numsamples 3)
      '()
      (continue-sweep outline (/ 360 numsamples) 1))
      surf)

;
; produce a tiling between two faces of equal number of vertices
;
(define (tile-faces face1 face2)
  (define tiling (create-obj polysurface))
  (define (continue-tile face1 face2)
    (if (null? (cdr face1))
        '()
        (begin
           (tiling (insertpoly (list (car face1) (car face2)
                                     (cadr face2) (cadr face1))))
           (continue-tile (cdr face1) (cdr face2)))))
  (if (or (not (= (length face1) (length face2))) (null? face1) (null? (cdr face1)))
      '()
      (begin
         (continue-tile face1 face2)
         (tiling (insertpoly (list (last face1) (last face2) (car face2) (car face1))))
         tiling)))

;
; extrude face by applying xform to its vertices, doing a tiling between
; the face and its transformed copy and then capping the resulting figure
; if a third argument is passed, it is a uvlist to be used on the caps
;
(define extrude 
  (lambda args
        (define extrusion (create-obj polysurface))
        (let ((xform (car args))
              (face (cadr args))
              (uvs (cddr args)))
          (let ((transformed-face (polyxform xform face)))
            (if (null? uvs)
                (extrusion (insertpoly face)
                           (insertpoly (reverse transformed-face)))
                (extrusion (insertuvpoly face (car uvs))
                           (insertuvpoly (reverse transformed-face)
                                         (reverse (car uvs)))))
            (extrusion (insertpolysurface (tile-faces face transformed-face)))
            extrusion))))

;
; produce a triangulated tiling between two faces of equal number
; of vertices
;
(define (tri-tile-faces face1 face2)
  (define tiling (create-obj polysurface))
  (define (continue-tile face1 face2)
    (if (null? (cdr face1))
        '()
        (begin
           (tiling (insertpoly (list (car face1) (car face2) (cadr face2))))
           (tiling (insertpoly (list (car face1) (cadr face2) (cadr face1))))
           (continue-tile (cdr face1) (cdr face2)))))
  (if (or (not (= (length face1) (length face2))) (null? face1) (null? (cdr face1)))
      '()
      (begin
         (continue-tile face1 face2)
         (tiling (insertpoly (list (last face1) (last face2) (car face2))))
         (tiling (insertpoly (list (last face1) (car face2) (car face1))))
         tiling)))

;
; extrude face by applying xform to its vertices, doing a triangulated
; tiling between face and its transformed copy and then capping the
; resulting figure
;
(define (tri-extrude xform face)
  (define extrusion (create-obj polysurface))
  (let ((transformed-face (polyxform xform face)))
    (extrusion (insertpoly face))
    (extrusion (insertpoly (reverse transformed-face)))
    (extrusion (insertpolysurface (tri-tile-faces face transformed-face)))
    extrusion))

;
; loft object by doing a triangulated tiling between adjacent
; polygons in face-list, and then capping the resulting figure
;
(define (loft face-list)
  (define lofted-surface (create-obj polysurface))
  (define (continue-loft face-list)
    (if (null? (cdr face-list))
      '()
      (begin
        (lofted-surface (insertpolysurface (tri-tile-faces (car face-list)
                                                           (cadr face-list))))
        (continue-loft (cdr face-list)))))
  (if (or (null? face-list) (null? (cdr face-list)))
      '()
      (begin
         (lofted-surface (insertpoly (car face-list)))
         (continue-loft face-list)
         (lofted-surface (insertpoly (reverse (last face-list))))
         lofted-surface)))

(define (reflect-yz vertex-list)  ; mirror vertices in vertex-list about y-z plane
  (define (negx vertex-list)
    (map (lambda (vertex) (cons (- (car vertex)) (cdr vertex))) vertex-list))
  (reverse (negx vertex-list)))

;
; create polysurf object from a list of vertices and its mirror
; image about the y-z plane
;
(define (mirror-yz vertex-list)
  (define mirror (create-obj polysurface))
  (mirror (insertpoly vertex-list))
  (mirror (insertpoly (reflect-yz vertex-list)))
  mirror)

(define (reflect-xz vertex-list)  ; mirror vertices in vertex-list about x-z plane
  (define (negy vertex-list)
    (map (lambda (vertex) (list (car vertex) (- (cadr vertex)) (caddr vertex)))
       vertex-list))
  (reverse (negy vertex-list)))

;
; create polysurf object from a list of vertices and its mirror
; image about the x-z plane
;
(define (mirror-xz vertex-list)
  (define mirror (create-obj polysurface))
  (mirror (insertpoly vertex-list))
  (mirror (insertpoly (reflect-xz vertex-list)))
  mirror)

(define (reflect-xy vertex-list)  ; mirror vertices in vertex-list about x-y plane
  (define (negz vertex-list)
    (map (lambda (vertex) (list (car vertex) (cadr vertex) (- (caddr vertex))))
       vertex-list))
  (reverse (negz vertex-list)))

;
; create polysurf object from a list of vertices and its mirror
; image about the x-y plane
;
(define (mirror-xy vertex-list)
  (define mirror (create-obj polysurface))
  (mirror (insertpoly vertex-list))
  (mirror (insertpoly (reflect-xy vertex-list)))
  mirror)

;
; create a 2D circle in x-y plane centered about the origin
;
(define (circle radius numsamples)
  (define (continue-circle radius count vertices)
    (let ((angle (* (/ 360 numsamples) count)))
      (if (= count 0)
        vertices
              (continue-circle radius (- count 1) 
                 (append vertices
                   (list (list (* radius (cos (radians angle)))
                               (* radius (sin (radians angle))))))))))
  (if (< numsamples 3)
    '()
    (continue-circle radius numsamples '())))

;
; create a 2D semi-circle in x-y plane centered about the origin,
; and extending from -90 to +90 degrees
;
(define (semi-circle radius numsamples)
  (define (continue-semi radius count vertices)
    (let ((angle (- 90 (* (/ 180 (- numsamples 1)) count))))
      (if (= count numsamples)
        vertices
              (continue-semi radius (+ count 1) 
                 (cons (list (* radius (cos (radians angle)))
                       (* radius (sin (radians angle))))
                 vertices)))))
  (if (< numsamples 3)
    '()
    (continue-semi radius 1 (list (list 0 radius)))))

;
; Predefined Constants for Defining Camera Rotation Mode and Projection
;
(define FREE 1)
(define FIXED 2)

(define PERSPECTIVE 1)
(define PARALLEL 2)

;
; Predefined Constants for Defining Types of poly_surf_approx's
;
(define FLAT 1)
(define SMOOTH 2)

;
; Predefined Constants for Defining CSG Operations
;
(define UNION        1)
(define DIFFERENCE   2)
(define INTERSECTION 3)

;
; visibility states
;
(define VISIBLE   1)
(define INVISIBLE 0)

;
; types of lights
;
(define LIGHT-BULB  1)
(define STRIP-LIGHT 2)

;
; ray-casting patterns
;
(define Adaptive-Grid    1)
(define Stochastic-Box   2)

;
; Predefined Constants for Defining Superquadrics
;
(define ELLIPSOID    1)
(define PARABOLIC    2)
(define HYPERBOLIC   3)
(define TOROID       4)

;
; Some more for just for Quadrics
;
(define CONIC       3)
(define CYLINDRIC   4)
(define FRUSTRIC    5)

;
; Predefined Constants for Defining Texture and BumpMaps
;
(define  SINGLE-SHOT     1)
(define  REPEATED        2)
(define  UNBOUNDED       4)

(define  SOLID-CIRCLE    1)
(define  SOLID-ELLIPSE   2)
(define  SOLID-BOX       3)
(define  SOLID-POLYGON   4)
(define  LINEARFADE      5)
(define  CIRCULARFADE    6)
(define  IMAGEMAP        7)

(define  HSV            10)
(define  RGB            11)

(define  RETURNNULL      0)
(define  RETURNDEFAULT   1)

(define  NONE            0)
(define  ROUND-RIPPLES   1)

;
; Predefined Constants for Configuring the Shader object
;
(define AMBIENT                0)
(define DEFAULT                1)
(define DIFFUSE                2)
(define PHONG                  3)
(define FUZZY                  4)  

(define TRANSPARENCY           1)
(define SCATTERING             4)

; types of attenuation
(define NONE                   0)
(define LINEAR                 1)
(define SQUARED                2)
(define EXPONENTIAL            3)


;;; Some constants for bsp flags
(define NO-SHADOWS             1)
(define SHOW-BACKS             2)
(define NO-CSG                 4)

;;;
;;; Basic Set of Pure Colors
;;;
(define black '(0 0 0))
(define dkgray '(0.25 0.25 0.25))
(define dkgrey dkgray)
(define gray '(0.5 0.5 0.5))
(define grey gray)
(define ltgray '(0.75 0.75 0.75))
(define ltgrey ltgray)
(define white '(1 1 1))
(define red '(1 0 0))
(define green '(0 1 0))
(define blue '(0 0 1))
(define cyan '(0 1 1))
(define magenta '(1 0 1))
(define yellow '(1 1 0))
(define silver '(.93 .9 .86))
(define gold '(.90 .84 .37))
(define copper '(.71 .49 .09))

;;;
;;; Basic Material types into which most materials should fall
;;;
(define PLASTER-MAT        1)
(define PLASTIC-MAT        2)
(define GLASS-MAT          3)
(define METALLIC           4)
(define WOOD-MAT           5)
(define MARBLE-MAT         6)
(define WATER-MAT          7)

;;;
;;; A few prototypical materials for users to base their materials on
;;;
(object plaster material
       (settype plaster-mat))
(object plastic material
       (settype plastic-mat))
(object glass material
       (settransmissivecolor white)
       (settype glass-mat))

;;;
;;; Materials Corresponding to the Basic Set of Pure Colors, having the
;;; optical properties of plaster or dull rubber (ie. they are Lambertian)
;;;

(object black-plaster plaster
       (setcolor black))
(define black-mat black-plaster)

(object dkgrey-plaster plaster
       (setcolor dkgrey))
(define dkgray-plaster dkgrey-plaster)
(define dkgray-mat dkgray-plaster)

(object grey-plaster plaster
       (setcolor grey))
(define gray-plaster grey-plaster)
(define gray-mat gray-plaster)

(object ltgrey-plaster plaster
       (setcolor ltgrey))
(define ltgray-plaster ltgrey-plaster)
(define ltgray-mat ltgray-plaster)

(object white-plaster plaster
       (setcolor white))
(define white-mat white-plaster)

(object red-plaster plaster
       (setcolor red))
(define red-mat red-plaster)

(object yellow-plaster plaster
       (setcolor yellow))
(define yellow-mat yellow-plaster)

(object green-plaster plaster
       (setcolor green))
(define green-mat green-plaster)

(object cyan-plaster plaster
       (setcolor cyan))
(define cyan-mat cyan-plaster)

(object blue-plaster plaster
       (setcolor blue))
(define blue-mat blue-plaster)

(object magenta-plaster plaster
       (setcolor magenta))
(define magenta-mat magenta-plaster)

;;;
;;; some metals
;;;
(object copper-metal material
       (setcolor copper)
       (setspecularspectrum
            '((.71 .49 .09) (.71 .49 .09) (.71 .49 .09) (.71 .49 .09) 
             (.71 .49 .09) (.71 .49 .09) (.67 .52 .14) (.63 .55 .2)
             (.60 .59 .4) (1 1 1)))
       (settype METALLIC))

(object gold-metal material
       (setcolor gold)
       (setspecularspectrum
            '((.90 .84 .37) (.90 .84 .37) (.90 .84 .37) (.90 .84 .37) 
             (.90 .84 .37) (.90 .84 .37) (.89 .8 .39) (.88 .79 .42)
             (.87 .78 .46) (1 1 1)))
       (settype METALLIC))

(object silver-metal material
       (setcolor silver)
       (setspecularspectrum
           '((.93 .9 .86) (.93 .9 .86) (.93 .9 .86) (.93 .9 .86)
             (.93 .9 .86) (.93 .9 .86) (.93 .91 .88) (.94 .93 .9)
             (.95 .95 .935) (1 1 1)))
       (settype METALLIC))

;;;
;;; Define a Basic Set of Modeling, Rendering, Image, and Device Objects 
;;;

(object scene part)         ; part that should be parent to all CSG objects

(if (or iris mac)          ; machines with hardware gamma correction
    (pixmapdev (gammacorrectoff)))

(object colordev pixmapdev) ; color pixmap device for use by color rasters

(raster (setdevice colordev)) ; by default, all rasters can use colordev

(object colorimage raster   ; 300 x 200 color raster image
       (setimagesize 300 200))

(object cdev pixmapdev)     ; color pixmap device for use by color pictures

(picture (setdevice cdev))  ; by default, all pictures can use cdev

(object colorpicture picture  ; 300 x 200 color picture image
       (setimagesize 300 200))

(object monodev bitmapdev)  ; 300 x 200 monochrome pixmap device

(object bwpicture  picture  ; 300 x 200 monochrome picture image
       (setimagesize 300 200)
       (setdevice monodev))

(object shade shader        ; a general shader for the renderers to use
       (setshadelevel DEFAULT)     ; use default shading
       (setambientratio 0.2)       ; 20% ambient light
       (setbackcolor grey)         ; middle-grey background
       (setattenuation 100))       ; some distance attenuation 

;
; by default, renderers will use the color raster for output,
; and the default general shader
;
(renderer (setshader shade)
         (setoutputimage colorimage))
         
(object bsp bsprenderer               ; BSP renderer renders to a color picture
       (setoutputimage colorpicture))

(object scanner scanline)      ; scanline renderer

(object ray raytracer)         ; raytracing renderer

(object wire wireframe              ; wireframe renderer
        (setoutputimage bwpicture)) ;  that renders to a monochrome picture

;
; Set up some defaults for all new cameras
;
(camera
       (setcameraalt '(0 0 -700) '(0 0 0) 0) ; pointing at the origin
       (setpreviewer wire)          ;   previews in wireframe,
       (setrenderer scanner)        ;   renders using the scanline-renderer
       (setrefroot 'scene))         ;   and looks at scene

(object default-camera camera)      ; the default camera

(object default-light light         ; a handy default light
        (setlightcoords '(0 0 0)    ;   located at the origin
                        '(0 0 1)    ;   points down the z axis
                        360)        ;   shines in all directions, 360 degs.
        (setcolor '(0.95 0.95 0.95))) ;  color is 95% full white

(object dbulb light                ; a raised sidelight
       (setlightcoords '(-400 350 -500) ; located above, to left & in front
                       '(4 -3.5 5) ;   points back at the origin
                       300)        ;   shines in 300 deg. arc
       (setcolor '(0.95 0.95 0.95))) ;  color is 95% full white

;;;
;;; A Minimal Set of Predefined Geometric Objects
;;; All objects are upright, and of maximum extent that can be centered
;;; in a 200x200x200 cube with center at the origin
;;;
(object cube polysurface    ; 200x200x200
       (insertpolysurface
        (let ((squarevtx '((100 100 -100) (100 -100 -100)
                           (-100 -100 -100) (-100 100 -100)))
              (squareuv '((1 1) (1 0) (0 0) (0 1)))
              (cubesurf (create-obj polysurface)))
          (cubesurf
           (insertuvpoly squarevtx squareuv)                        ; front
           (insertuvpoly (polyxform (y-rot 90) squarevtx) squareuv) ; left
           (insertuvpoly (polyxform (y-rot 180) squarevtx) squareuv); back
           (insertuvpoly (polyxform (y-rot -90) squarevtx) squareuv); right
           (insertuvpoly (polyxform (x-rot 90) squarevtx) squareuv) ; top
           (insertuvpoly (polyxform (x-rot -90) squarevtx) squareuv));bttm
          cubesurf)))

(object pyramid polysurface ; 200x200 base, height 200, corners aligned axes
       (insertpolysurface
        (let ((trivtx '((100 -100 0) (0 100 0) (0 -100 100)))
              (triuv '((0 0) (0.5 1) (1 0)))
              (basevtx '((100 -100 0) (0 -100 100) (-100 -100 0)
                          (0 -100 -100)))
              (pyrsurf (create-obj polysurface)))
          (pyrsurf
           (insertuvpoly trivtx triuv)                        ; right-back
           (insertuvpoly (polyxform (y-rot 90) trivtx) triuv) ; right-front
           (insertuvpoly (polyxform (y-rot 180) trivtx) triuv); left-front
           (insertuvpoly (polyxform (y-rot -90) trivtx) triuv); left-back
           (insertpoly basevtx))                              ; bottom
          pyrsurf)))

(object sphere quadric ; radius 100, center at origin
       (setuvcoords '((0 0) (0 1) (2 1) (2 0)))
       (setsampleinc 6))

(object cylinder quadric ; upright, radius 100, height 200, axis is y axis
       (setuvcoords '((0 0) (0 1) (2 1) (2 0)))
       (setsampleinc 8)
       (settype CYLINDRIC))

(object paraboloid quadric ; upright, radius 100, height 200, axis is y axis
       (setuvcoords '((0 0) (0 1) (2 1) (2 0)))
       (setsampleinc 6)
       (settype PARABOLIC))
       
(object cone quadric ; upright, radius 100, height 200, axis is y axis
       (setuvcoords '((0 0) (0 1) (2 1) (2 0)))
       (setsampleinc 8)
       (settype CONIC))

(object frustrum quadric ; upright, base 200x200, height 200, axis is y axis
       (setuvcoords '((0 0) (0 1) (2 1) (2 0)))
       (setsampleinc 6)
       (settype FRUSTRIC))