#| -*- Mode:LISP; Base: 10;
       Package:(VISTA-DEMO :use (VISTA OBJ 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 obj vista-library lisp))

(defdemo "Hand" 'hand-demo
  "An animated hand"
  "VISTA:DEMO;HAND")

(export '(HAND-DEMO
	  SETUP-HAND
          ROYAL-WAVE
	  COME-HITHER
	  SPOCK
	  WOOPIE))
	  

#+lispm	            
(defun HAND-DEMO ()
  "An animated hand"
  (setup-hand)
  (do ((return-flag nil))
      (return-flag)
    (setq return-flag
	  (not (tv:menu-choose '(("Royal Wave" :funcall royal-wave
				  :documentation "Wave good bye or hello"	
				  :font fonts:tr12b)
				 ("Come Hither" :funcall come-hither
				  :documentation "Come here"
				  :font fonts:tr12b)
				 ("Spock" :funcall spock
				  :documentation "Live long and prosper"
				  :font fonts:tr12b)
				 ("Whoopie" :funcall woopie
				  :documentation "Try it you'll like it"
				  :font fonts:tr12b)
				 ("Exit" :value nil
				  :documentation "Quit hand demo"
				  :font fonts:tr12bi))
			       '(:string "Hand Demos" :centered :font fonts:tr12b))))))



#-lispm
(defun HAND-DEMO ()
  "An animated hand"
  (setup-hand)
  (royal-wave)
  (come-hither)
  (spock)
  (whoopie))


(defkind HAND)

(defparameter upper-arm nil)
(defparameter palm nil)
(defparameter little-finger-1 nil)
(defparameter little-finger-2 nil)
(defparameter little-finger-3 nil)
(defparameter ring-finger-1 nil)
(defparameter ring-finger-2 nil)
(defparameter ring-finger-3 nil)
(defparameter middle-finger-1 nil)
(defparameter middle-finger-2 nil)
(defparameter middle-finger-3 nil)
(defparameter fore-finger-1 nil)
(defparameter fore-finger-2 nil)
(defparameter fore-finger-3 nil)
(defparameter thumb-finger-1 nil)
(defparameter thumb-finger-2 nil)

(defkind BODY-PART 3d-visob)

(definstancevars BODY-PART
  (x-length 0)
  (y-length 0)
  (z-length 0)
  (piped-color 3)
  (bone-length 0)
  (bone-radius 0)
  (bone-color (1+ (random 7))))

(defobfun DRAW-BASIC-FUNNY-BONE ()
  "Base is the origin of the bone. Apex is the end of the bone" 
;  (loop with dtheta = (/ pi 3.)
;	with y-min = 0.0s0
;	with y-max = bone-length
;	with rad = bone-radius
;	for angle from 0 to (* 2 pi) by dtheta
;	as x-c = (* (sin angle) rad)
;	as z-c = (* (cos angle) rad)
;	with old-x-c and old-z-c
;	do
;	(when old-x-c
;	  (color bone-color)
;	  (polygon (make-polygon :3d-absolute
;				 x-c y-min z-c
;				 x-c y-max z-c
;				 old-x-c y-max old-z-c
;				 old-x-c y-min old-z-c))

;;	  (pmv x-c y-min z-c)			       ;move
;;	  (pdr x-c y-max z-c)			       ;draw
;;	  (pdr old-x-c y-max old-z-c)		       ;draw
;;	  (pdr old-x-c y-min old-z-c)		       ;draw
;;	  (pclose))				       ; old-x-c y-min old-z-c)	       ;draw

;	  (setq old-x-c x-c old-z-c z-c)
;	  )
;	)
  (draw-a-box bone-color (/ bone-radius -2) 0 (/ bone-radius -2)  (/ bone-radius 2) bone-length (/ bone-radius 2))
  )


(defun DRAW-A-BOX (color x1 y1 z1 x2 y2 z2)
  (set-color color)
  (move x1 y1 z1)
  (line x1 y1 z2)
  (line x1 y2 z2)
  (line x1 y2 z1)
  (line x1 y1 z1)

  (move x2 y1 z1)
  (line x2 y1 z2)
  (line x2 y2 z2)
  (line x2 y2 z1)
  (line x2 y1 z1)

  (line x1 y1 z1)

  (move x1 y2 z1)
  (line x2 y2 z1)

  (move x1 y2 z2)
  (line x2 y2 z2)

  (move x1 y1 z2)
  (line x2 y1 z2))

(defobfun DRAW-PIPED ()
  (draw-a-box piped-color 
	      (round (/ x-length -2)) 0 (round (/ z-length -2))
	      (round (/ x-length 2)) (round y-length) (round (/ z-length 2))))
  
;(defobfun (EXIST BODY-PART) (&rest args)
;  (apply 'shadowed-exist args))

(defobfun BUILD-HAND-PARTS ()
  (setq upper-arm (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 200.0s0 'bone-length 1000.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep nil 'y-rotatablep t 'z-rotatablep nil 
			 'obj-name 'upper-arm 'bone-color 1)
	palm (oneof body-part 'shape 'draw-piped 'component-of upper-arm
			 'translatablep t 'scalablep nil 'x-rotatablep nil 'y-rotatablep nil 'z-rotatablep t
		    'x-length 700.0s0 'y-length 700.0s0 'z-length 200.0s0 'obj-name 'palm 'piped-color 127.)
	little-finger-1 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 175.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep t
			       'component-of palm 'obj-name  'little-finger-1 'bone-color 255.)
	little-finger-2 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 175.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			       'component-of little-finger-1 'obj-name 'little-finger-2 'bone-color 381.)
	little-finger-3 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 175.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			       'component-of little-finger-2 'obj-name 'little-finger-3 'bone-color 511.)
	ring-finger-1 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep t
			     'component-of palm 'obj-name 'ring-finger-1 'bone-color 255.)
	ring-finger-2 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			     'component-of ring-finger-1 'obj-name 'ring-finger-2 'bone-color 381.)	
	ring-finger-3 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			     'component-of ring-finger-2 'obj-name 'ring-finger-3 'bone-color 511.)
	middle-finger-1 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 275.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep t
			       'component-of palm 'obj-name 'middle-finger-1 'bone-color 255.)
	middle-finger-2 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 275.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			       'component-of middle-finger-1 'obj-name 'middle-finger-2 'bone-color 381.)
	middle-finger-3 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 275.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			       'component-of middle-finger-2 'obj-name 'middle-finger-3 'bone-color 511.)
	fore-finger-1 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep t 'z-rotatablep t 
			     'component-of palm 'obj-name 'fore-finger-1 'bone-color 255.)
	fore-finger-2 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			     'component-of fore-finger-1 'obj-name 'fore-finger-2 'bone-color 381.)
	fore-finger-3 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 225.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep t 'y-rotatablep nil 'z-rotatablep nil 
			     'component-of fore-finger-2 'obj-name 'fore-finger-3 'bone-color 511.)
	thumb-finger-1 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 300.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep nil 'y-rotatablep nil 'z-rotatablep t 
			      'component-of palm 'obj-name 'thumb-finger-1 'bone-color 255.)
	thumb-finger-2 (oneof body-part 'shape 'draw-basic-funny-bone 'bone-radius 75.0s0 'bone-length 300.0s0
			 'translatablep t 'scalablep nil 'x-rotatablep nil 'y-rotatablep nil 'z-rotatablep t 
			      'component-of thumb-finger-1 'obj-name 'thumb-finger-2 'bone-color 381.)
	)
  )

(defobfun SETUP-HAND ()
  (initialize-device)
  (double-buffer t)
  (set-color 0)
  (fill-viewport)
  (format t "~%Downloading the hand object now")
  (build-hand-parts)
  (perspective 90 1.0 1.0 -100000.0)
  (polar-view 2000.0 0 0 0)
  (ask upper-arm (setq y -1000.0s0))
  (let ((palm-height (ask palm y-length))
	(palm-width  (ask palm (/ x-length 2))))
    (ask palm (setq z 0.0
		     y (ask upper-arm bone-length)
		     x 0.0))
    (ask little-finger-1 (setq z 0.0s0 x (+ (- palm-width) bone-radius) y palm-height))
    (ask little-finger-2 (setq z 0.0s0 x 0.0s0 y (ask little-finger-1 bone-length)))
    (ask little-finger-3 (setq z 0.0s0 x 0.0s0 y (ask little-finger-2 bone-length)))
    (ask ring-finger-1 (setq z 0.0s0 x (- (/ (- palm-width bone-radius) 3.)) y palm-height))
    (ask ring-finger-2 (setq z 0.0s0 x 0.0s0 y (ask ring-finger-1 bone-length)))
    (ask ring-finger-3 (setq z 0.0s0 x 0.0s0 y (ask ring-finger-2 bone-length)))
    (ask middle-finger-1 (setq z 0.0s0 x (/ (- palm-width bone-radius) 3.) y palm-height))
    (ask middle-finger-2 (setq z 0.0s0 x 0.0s0 y (ask middle-finger-1 bone-length)))
    (ask middle-finger-3 (setq z 0.0s0 x 0.0s0 y (ask middle-finger-2 bone-length)))
    (ask fore-finger-1 (setq z 0.0s0 x (- palm-width bone-radius) y palm-height))
    (ask fore-finger-2 (setq z 0.0s0 x 0.0s0 y (ask fore-finger-1 bone-length)))
    (ask fore-finger-3 (setq z 0.0s0 x 0.0s0 y (ask fore-finger-2 bone-length)))
    (ask thumb-finger-1 (setq z 0.0s0 x palm-width y (- palm-height bone-length)))
    (ask thumb-finger-2 (setq z 0.0s0 x 0.0s0 y (ask thumb-finger-1 bone-length)))
    (ask thumb-finger-1 (set-z-rotation -40))
    (ask upper-arm (compile-self-flexible))
    (ask upper-arm (draw-self))
    (swap-buffers))
  (format t "......done")
  (format t "~%"))


(defobfun SPIN-HAND ()
  (dotimes (i 36)
    (ask upper-arm
      (set-y-rotation (+ 10. y-rotation))
      (set-color 0) (fill-viewport) (draw-self)
      (swap-buffers))))

  
(defobfun ROYAL-WAVE ()
  (ask palm
    (dotimes (i 10)
      (set-z-rotation 0)
      (dotimes (j 5)
	(set-z-rotation (+ z-rotation -5))
	(set-color 0)
	(fill-viewport)
	(ask upper-arm (draw-self))
	(swap-buffers)
	)
      (dotimes (j 7)
	(set-z-rotation (+ z-rotation 5))
	(set-color 0)
	(fill-viewport)
	(ask upper-arm (draw-self))
	(swap-buffers)
	)
      (dotimes (j 2)
	(set-z-rotation (+ z-rotation -5 j))
	(set-color 0)
	(fill-viewport)
	(ask upper-arm (draw-self))
	(swap-buffers)
	)
      )
    )
  t)

(defobfun (CURL BODY-PART) (bend-per-part)
  (set-x-rotation (+ x-rotation bend-per-part))
  (dolist (p components)
    (ask p (curl bend-per-part))))


(defobfun (CURL-Z BODY-PART) (bend-per-part)
  (set-z-rotation (+ bend-per-part z-rotation))
  (dolist (p components)
    (ask p (curl-z bend-per-part))))



(defobfun COME-HITHER ()
  (ask thumb-finger-1 (set-z-rotation 70))
  (ask little-finger-1 (curl 60))
  (ask ring-finger-1 (curl 60))
  (ask middle-finger-1 (curl 60))
  (ask thumb-finger-1 (curl-z 20))
  (dotimes (j 10)
    (dotimes (i 12)
      (ask fore-finger-2 (curl 5))
      (set-color 0)
      (fill-viewport)
      (ask upper-arm (draw-self))
      (swap-buffers)
      )
    (dotimes (i 12)
      (ask fore-finger-2 (curl -5))
      (set-color 0)
      (fill-viewport)
      (ask upper-arm (draw-self))
      (swap-buffers)
      ))
  (ask little-finger-1 (curl -60))
  (ask ring-finger-1 (curl -60))
  (ask middle-finger-1 (curl -60))
  (ask thumb-finger-1 (curl-z -20))
  t)


(defobfun WOOPIE ()
  (ask little-finger-1 (curl 60))
  (ask ring-finger-1 (curl 60))
  (ask middle-finger-1 (curl 60))
  (ask thumb-finger-1 (curl-z 20))
  (ask fore-finger-1 (set-z-rotation 10))
  (dotimes (j 3)
    (dotimes (i 36)
      (ask fore-finger-1 (set-y-rotation (+ y-rotation 10)))
      (set-color 0)
      (fill-viewport)
      (ask upper-arm (draw-self))
      (swap-buffers)))
  (ask fore-finger-1 (set-x-rotation 0))
  (ask fore-finger-1 (set-y-rotation 0))
  (ask fore-finger-1 (set-z-rotation 0))
  (ask little-finger-1 (curl -60))
  (ask ring-finger-1 (curl -60))
  (ask middle-finger-1 (curl -60))
  (ask thumb-finger-1 (curl-z -20))
  t)

(defobfun SPOCK ()
  (ask thumb-finger-1 (set-z-rotation 0))
  (dotimes (i 20)
    (ask little-finger-1 (set-z-rotation (+ 1 z-rotation)))
    (ask ring-finger-1 (set-z-rotation (+ 1 z-rotation)))
    (ask middle-finger-1 (set-z-rotation (- z-rotation 1)))
    (ask fore-finger-1 (set-z-rotation (- z-rotation 1)))
    (set-color 0)
    (fill-viewport)
    (ask upper-arm (draw-self))
    (swap-buffers)
    )
  (dotimes (i 20)
    (ask little-finger-1 (set-z-rotation (- z-rotation 1)))
    (ask ring-finger-1 (set-z-rotation (- z-rotation 1)))
    (ask middle-finger-1 (set-z-rotation (+ 1 z-rotation)))
    (ask fore-finger-1 (set-z-rotation (+ 1 z-rotation)))
    (set-color 0)
    (fill-viewport)
    (ask upper-arm (draw-self))
    (swap-buffers)
    )
  t)