#| -*- Mode:LISP; Base:10;
       Package: (VISTA-DEMO :use (VISTA-LIBRARY LISP));
       Syntax: Common-lisp; Readtable: CL -*-
|#

;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright" for
;;; licensing and release information.


(in-package 'vista-demo :use '(vista-library lisp))

(defdemo "Tetra" 'tetra
  "Draws a fractal tetrahedron"
  "vista:demo;tetra")

(export '(TETRA					;Draws a fractal tetrahedron
         ))


; Fractal tetrahedron

(defconstant sqrt3 (sqrt 3))
(defconstant sqrt2/3 (sqrt 2/3))

;;; shade sa,sb,sc
(defconstant face-1
	     (make-polygon :3d-absolute
			   0 0 0
  			   1 0 0
  			   .5 (/ sqrt3 2) 0))
;;; shade sa,sb,sd
(defconstant face-2
	     (make-polygon :3d-absolute
  			   0 0 0
  			   1 0 0
  			   .5 (/ .5 sqrt3) sqrt2/3))

;;; sb,sc,sd
(defconstant face-3
	     (make-polygon :3d-absolute
			   1 0 0
			   .5 (/ sqrt3 2) 0
  			   .5 (/ .5 sqrt3) sqrt2/3))

;;;shade sc,sa,sd
(defconstant face-4
	     (make-polygon :3d-absolute
			   .5 (/ sqrt3 2) 0
 			   0 0 0
			   .5 (/ 0.5 sqrt3) sqrt2/3))


(defun draw-tetrahedron (sa sb sc sd)
  (set-color sd)
  (fill-polygon face-4)
  (set-color sc)
  (fill-polygon face-3)
  (set-color sb)
  (fill-polygon face-2)
  (set-color sa)
  (fill-polygon face-1))


;(defun draw-tetrahedron (sa sb sc sd)
;  (setshade sa)
;  (pmv 0.0 0.0 0.0)			 ;face 1
;  (setshade sb)
;  (pdr 1.0 0.0 0.0)
;  (setshade sc)
;  (pdr .5 (/ sqrt3 2) 0.0)
;  (spclose)
;
;  (setshade sa)
;  (pmv 0.0 0.0 0.0)			 ;face 2
;  (setshade sb)
;  (pdr 1.0 0.0 0.0)
;  (setshade sd)
;  (pdr 0.5 (/ 0.5 sqrt3) sqrt2/3)
;  (spclose)
;
;  (setshade sb)
;  (pmv 1.0 0.0 0.0)			 ;face 3
;  (setshade sc)
;  (pdr .5 (/ sqrt3 2) 0.0)
;  (setshade sd)
;  (pdr 0.5 (/ 0.5 sqrt3) sqrt2/3)
;  (spclose)
;
;  (setshade sc)
;  (pmv .5 (/ sqrt3 2) 0.0)		 ;face 4
;  (setshade sa)
;  (pdr 0.0 0.0 0.0)
;  (setshade sd)
;  (pdr 0.5 (/ 0.5 sqrt3) sqrt2/3)
;  (spclose))

(defun tetra (&key (levels 4))
  (initialize-device)
  (set-color 0)
  (set-map-color 0 .72 .72 .75)
  (set-map-color 1 1 1 1)
  (fill-viewport) 
  (shade-colors 2 (random 1.0s0) (random 1.0s0) (random 1.0s0)
		4 (random 1.0s0) (random 1.0s0) (random 1.0s0))
; Turn on zbuffering only if enough planes
;  (when (> (getplanes) 12)
;    (zbuffer t) (zclear))
  
  (perspective 40 1 0 10000)
  (set-color 1)
;  (fill-polygon
;    (make-polygon :3d-absolute
;	508 350 -1400
;	-512 -100 -1400
;	400  -150 -1400))
  (translate -25 50 -50)
  (polar-view 500 -130 -110 0)
  (with-transform
    (scale 300.0 300.0 300.0)
    (translate -.5 -.5 0)
    (tetra-1 levels
	     (make-segment (:colorablep nil :scalablep nil :translatablep nil
					:x-rotatablep nil :y-rotatablep nil :z-rotatablep nil)
	       (draw-tetrahedron 1 2 3 4))))   ;1 64 128 196
;  (zbuffer nil)
  (frob-colors 4))  ;196
    
(defun tetra-1 (level seg)
  (if (zerop level)
      (call-segment seg)
    (with-transform
      (scale .5 .5 .5)
      (tetra-1 (1- level) seg)
      (with-transform
	(translate 0.5 (/ 0.5 sqrt3) sqrt2/3)
  	(tetra-1 (1- level) seg))
      (with-transform
	(translate 0.5 (/ sqrt3 2) 0)
  	(tetra-1 (1- level) seg))
      (with-transform
	(translate 1 0 0)
  	(tetra-1 (1- level) seg)))))