;; Tetris, but in -*- Scheme -*- this time.
;; Copyright 1995, Kenneth B. Russell. <kbrussel@media.mit.edu>

;; High score: 19,600. :-P

(load (in-vicinity (library-vicinity) "random" (scheme-file-suffix)))

(define pi 3.1415926585)
(define *current-piece* '())
(define *game-board* '())
(define *pieces* (make-vector 5 #f))
(define *game-viewer* (new-SoXtExaminerViewer))

;;; For seeding the random number generator

;(random (get-universal-time))

(define (randomize-loop i)
  (if (> (modulo i 173) 0)
      (begin
;	(display "Randomizing...\n")
	(random 5)
	(randomize-loop (- i 1)))))

;;; SICP-ish simple object system for dealing similarly
;;; with Scheme and C++ objects using "send"

(define (send object message . args)
  (if (C++-object? object)
      (eval `(-> ,object ',message ,@args))
      (let ((method (get-method object message)))
	(if (not (no-method? method))
	    (apply method (cons object args))
	    (error "No method named" message)))))

(define (get-method object message)
  (object message))

(define (no-method method)
  'no-method)

(define (no-method? method)
  (eq? method 'no-method))

;(define (make-object)
;  (lambda (message)
;    (cond ((eq? message 'hi)
;	   (lambda (self arg1 arg2)
;	     (format #t "arg1: ~a arg2: ~a~%" arg1 arg2)))
;	  (else (no-method message)))))

;;; Convenience functions used by piece (and sometimes board) objects.
;;; Some of these should probably be objects in their own right.

(define (color-lookup color)
  (cond ((eq? color 'red)
	 '#(1.0 0.5 0.5))
	((eq? color 'blue)
	 '#(0.5 0.5 1.0))
	((eq? color 'green)
	 '#(0.5 1.0 0.5))
	((eq? color 'aqua)
	 '#(0.5 1.0 1.0))
	((eq? color 'yellow)
	 '#(1.0 1.0 0.5))
	(else (error "Bad color" color))))

;; Builds Inventor geometry of a tetris piece into the "root" node,
;; of type "type" and color "color".

(define (build-tetris-piece root type color)
  (cond ((eq? type 's)   ;; S shaped piece
	 (begin
	   (define mat (new-SoMaterial))
	   (send (send mat 'diffuseColor) 'setValue (color-lookup color))
	   (send root 'addChild mat)

	   (send root 'addChild (new-SoCube))
	   
	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue -2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))
	   
	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 2.1 0.0)
	   (send root 'addChild (new-SoCube))
	   
	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))))
	((eq? type 'ls)   ;; Long straight piece
	 (begin
	   (define mat (new-SoMaterial))
	   (send (send mat 'diffuseColor) 'setValue (color-lookup color))
	   (send root 'addChild mat)

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 -2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
	   (send root 'addChild (new-SoCube))
	   (define xlate (new-SoTranslation))

	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
	   (send root 'addChild (new-SoCube))
	   (define xlate (new-SoTranslation))

	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
	   (send root 'addChild (new-SoCube))))

	((eq? type 't)   ;; T shaped piece
	 (begin
	   (define mat (new-SoMaterial))
	   (send (send mat 'diffuseColor) 'setValue (color-lookup color))
	   (send root 'addChild mat)

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue -2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 -2.1 0.0)
	   (send root 'addChild (new-SoCube))))

	((eq? type 'l)   ;; L shaped piece
	 (begin
	   (define mat (new-SoMaterial))
	   (send (send mat 'diffuseColor) 'setValue (color-lookup color))
	   (send root 'addChild mat)

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue -2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 -2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 -2.1 0.0)
	   (send root 'addChild (new-SoCube))))

	((eq? type 'c)   ;; cube shaped piece
	 (begin
	   (define mat (new-SoMaterial))
	   (send (send mat 'diffuseColor) 'setValue (color-lookup color))
	   (send root 'addChild mat)

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue -2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 0.0 -2.1 0.0)
	   (send root 'addChild (new-SoCube))

	   (define xlate (new-SoTranslation))
	   (send root 'addChild xlate)
	   (send (send xlate 'translation) 'setValue 2.1 0.0 0.0)
	   (send root 'addChild (new-SoCube))))
	(else (error "build-tetris-piece: wrong type" type))))

;; Scheme representation of the solid blocks making up a Tetris piece.

(define (build-piece-mask type)
  (cond ((eq? type 's)
	 '((-1 0) (0 0) (0 1) (1 1)))
	((eq? type 'ls)
	 '((0 -1) (0 0) (0 1) (0 2)))
	((eq? type 't)
	 '((-1 0) (0 0) (0 1) (1 0)))
	((eq? type 'c)
	 '((0 0) (1 0) (0 1) (1 1)))
	((eq? type 'l)
	 '((0 -1) (0 0) (0 1) (1 1)))
	(else (error "Wrong type:" type))))

;; Rotates coordinates from piece-mask about the absolute (0,0)
;; in 90-degree increments.

(define (rotate-coords coords rotation-amount)
  (cond ((eq? rotation-amount 0)
	 coords)
	((eq? rotation-amount 1)
	 (list (- (cadr coords))
		  (car coords)))
	((eq? rotation-amount 2)
	 (list (- (car coords))
	       (- (cadr coords))))
	((eq? rotation-amount 3)
	 (list (cadr coords)
	       (- (car coords))))
	(else (error "Bad rotation amount:" rotation-amount))))

;;; Constructor for making a Tetris piece object. 

(define (make-tetris-piece type)
  (if (not (memq type '(s ls t c l)))
      (error "make-tetris-piece: wrong type" type))
  (define piece-root (new-SoSeparator))
  (send piece-root 'ref)
  (define piece-xlate (new-SoTranslation))
  (define piece-rot (new-SoRotationXYZ))
  (send piece-root 'addChild piece-xlate)
  (send piece-root 'addChild piece-rot)
  (define current-rotation 0)
  (define current-translation '(0 0))
  (define rotation-max 0)
  (define parent-board '())
  (define piece-mask (build-piece-mask type))
  (define color 'none)
  (cond ((eq? type 'c)
	 (begin
	   (set! rotation-max 1)
	   (set! color 'yellow)))
	((eq? type 's)
	 (begin
	   (set! rotation-max 2)
	   (set! color 'blue)))
	((eq? type 'ls)
	 (begin
	   (set! rotation-max 2)
	   (set! color 'red)))
	((eq? type 't)
	 (begin
	   (set! rotation-max 4)
	   (set! color 'green)))
	((eq? type 'l)
	 (begin
	   (set! rotation-max 4)
	   (set! color 'aqua))))
  (send (send piece-rot 'axis) 'setValue SoRotationXYZ::Z)
  (build-tetris-piece piece-root type color)
  (lambda (message)
    (cond ((eq? message 'rotate)
	   (lambda (self)
	     (if (send parent-board 'checkCoordsPartial (send self 'getRotatedCoords 1))
		 (begin
		   (set! current-rotation (modulo (1+ current-rotation) rotation-max))
		   (send (send piece-rot 'angle) 'setValue (* pi (/ current-rotation 2.0)))
		   #t)
		 #f)))
	  ((eq? message 'getRotatedCoords)
	   (lambda (self relative-rotation)
	     (let ((new-rotation (modulo (+ relative-rotation current-rotation)
					 rotation-max)))
	       (map (lambda (coords)
		      (let ((rotated-coords (rotate-coords coords new-rotation)))
			(list (+ (car rotated-coords)
				 (car current-translation))
			      (+ (cadr rotated-coords)
				 (cadr current-translation)))))
		    piece-mask))))
	  ((eq? message 'setCurrentRotation)
	   (lambda (self new-rotation)
	     (set! current-rotation (modulo new-rotation rotation-max))
	     (send (send piece-rot 'angle) 'setValue (* pi (/ current-rotation 2.0)))))
	  ((eq? message 'getGeometry) 
	   (lambda (self)
	     piece-root))
	  ((eq? message 'getCurrentCoordinates)
	   (lambda (self)
	     (map (lambda (coords)
		    (let ((rotated-coords (rotate-coords coords current-rotation)))
		      (list (+ (car rotated-coords)
			       (car current-translation))
			    (+ (cadr rotated-coords)
			       (cadr current-translation)))))
		  piece-mask)))
	  ((eq? message 'setCurrentTranslation)
	   (lambda (self x y)
	     (set! current-translation (list x y))
	     (send (send piece-xlate 'translation) 
		   'setValue
		   (* 2.1 (car current-translation))
		   (* 2.1 (cadr current-translation))
		   0.0)))
	  ((eq? message 'getTranslatedCoords)
	   (lambda (self x y)
	     (let ((translated-coords (send self 'getCurrentCoordinates)))
	       (map (lambda (coords)
		      (list (+ (car coords) x)
			    (+ (cadr coords) y)))
		    translated-coords))))
	  ((eq? message 'setBoard)
	   (lambda (self board)
	     (set! parent-board board)))
	  ((eq? message 'moveDown)
	   (lambda (self)
	     (if (not (null? parent-board))
		 (if (send parent-board 'checkCoordsPartial (send self 'getTranslatedCoords 0 -1))
		     (begin
		       (send self 'setCurrentTranslation (car current-translation)
			     (- (cadr current-translation) 1))
		       #t)
		     #f)
		 (send self 'setCurrentTranslation (car current-translation)
		       (- (cadr current-translation) 1)))))
	  ((eq? message 'moveLeft)
	   (lambda (self)
	     (if (not (null? parent-board))
		 (if (send parent-board 'checkCoordsPartial (send self 'getTranslatedCoords -1 0))
		     (begin
		       (send self 'setCurrentTranslation (- (car current-translation) 1)
			     (cadr current-translation))
		       #t)
		     #f)
		 (send self 'setCurrentTranslation (- (car current-translation) 1)
		       (cadr current-translation) 1))))
	  ((eq? message 'moveRight)
	   (lambda (self)
	     (if (not (null? parent-board))
		 (if (send parent-board 'checkCoordsPartial (send self 'getTranslatedCoords 1 0))
		     (begin
		       (send self 'setCurrentTranslation (+ 1 (car current-translation))
			     (cadr current-translation))
		       #t)
		     #f)
		 (send self 'setCurrentTranslation (+ 1 (car current-translation))
		       (cadr current-translation) 1))))
	  ((eq? message 'getColor)
	   (lambda (self) color))
	  (else (no-method message)))))

;;; Convenience functions for dealing with the board object.
;;; Some of these should probably be objects in their own right.

;; Function for building the Scheme representation for the game board;
;; vector of vectors (organization: vector of columns. (0,0) is bottom
;; left of board).

(define (build-board x-size y-size)
  (let ((columns (make-vector x-size #f)))
    (define (iter i)
      (if (>= i 0)
	  (begin
	    (vector-set! columns i (make-vector y-size #t))
	    (iter (- i 1)))))
    (iter (- x-size 1))
    columns))

;; Makes a group which performs a translation

(define (make-empty-translation)
  (define root (new-SoGroup))
  (send root 'ref)
  (define xlate (new-SoTranslation))
  (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
  (send root 'addChild xlate)
  (send root 'unrefNoDelete)
  root)

;; Makes a group which performs a translation and contains a cube
;; whose color can be changed.

(define (make-board-cube)
  (define root (new-SoGroup))
  (send root 'ref)
  (define mat (new-SoMaterial))
  (send root 'addChild mat)
  (send root 'addChild (new-SoCube))
  (define xlate (new-SoTranslation))
  (send (send xlate 'translation) 'setValue 0.0 2.1 0.0)
  (send root 'addChild xlate)
  (send root 'unrefNoDelete)
  root)

;; Builds a switch for making a cube visible/invisible

(define (make-board-switch)
  (define root (new-SoSwitch))
  (send root 'ref)
  ;; First child is the empty translation
  (send root 'addChild (make-empty-translation))
  ;; second child is a cube with a translation after it
  (send root 'addChild (make-board-cube))
  (send (send root 'whichChild) 'setValue 0)
  (send root 'unrefNoDelete)
  root)
	
;; Builds Inventor representation of the tetris board.
;; Basically an addressable LED display; every cube can be turned
;; on and off.

(define (build-visual-board x-size y-size)
  (define (make-column-iter root i)
    (if (> i 0)
	(begin
	  (send root 'addChild (make-board-switch))
	  (make-column-iter root (- i 1)))))
  (define (make-columns-iter root i)
    (if (> i 0)
	(begin
	  (define col-root (new-SoSeparator))
	  (send root 'addChild col-root)
	  (if (> i 1)
	      (begin
		(define xlate (new-SoTranslation))
		(send (send xlate 'translation) 'setValue 2.1 0.0 0.0)
		(send root 'addChild xlate)))
	  (make-column-iter col-root y-size)
	  (make-columns-iter root (- i 1)))))
  (define board-root (new-SoSeparator))
  (send board-root 'ref)
  (make-columns-iter board-root x-size)
  board-root)

;; Builds the surrounding wireframe box for the board

(define (build-surrounding-box x-size y-size)
  (let ((scaled-x-size (* 2.1 x-size))
	(scaled-y-size (* 2.1 y-size)))
    (define root (new-SoSeparator))
    (send root 'ref)
    (define xlate (new-SoTranslation))
    (send (send xlate 'translation) 'setValue (- (/ 2.1 2.0)) (- (/ 2.1 2.0)) (- (/ 2.1 2.0)))
    (send root 'addChild xlate)
    (define lines `( ;;; front face
		     #(0 0 0)
		     #(,scaled-x-size 0 0)
		     #(0 0 0)
		     #(0 ,scaled-y-size 0)
		     #(,scaled-x-size 0 0)
		     #(,scaled-x-size ,scaled-y-size 0)
		     #(0 ,scaled-y-size 0)
		     #(,scaled-x-size ,scaled-y-size 0)
		     
		   ;;; back face
		     
		     #(0 0 2.1)
		     #(,scaled-x-size 0 2.1)
		     #(0 0 2.1)
		     #(0 ,scaled-y-size 2.1)
		     #(,scaled-x-size 0 2.1)
		     #(,scaled-x-size ,scaled-y-size 2.1)
		     #(0 ,scaled-y-size 2.1)
		     #(,scaled-x-size ,scaled-y-size 2.1)
		     
		   ;;; connecting pieces
		     
		     #(0 0 0)
		     #(0 0 2.1)
		     #(,scaled-x-size 0 0)
		     #(,scaled-x-size 0 2.1)
		     #(0 ,scaled-y-size 0)
		     #(0 ,scaled-y-size 2.1)
		     #(,scaled-x-size ,scaled-y-size 0)
		     #(,scaled-x-size ,scaled-y-size 2.1)
		     ))
    (define coords (new-SoCoordinate3))
    (set-mfield-values! (send coords 'point) 0 lines)
    (send root 'addChild coords)
    (define line-set (new-SoLineSet))
    (let loop
	((i 0))
      (if (< i (/ (length lines) 2))
	  (begin
	    (send (send line-set 'numVertices) 'set1Value i 2)
	    (loop (+ i 1)))))
    (send root 'addChild line-set)
    (send root 'unrefNoDelete)
    root))

;; Builds the text for displaying the current score

(define (build-score-text x-size y-size)
  (define root (new-SoSeparator))
  (send root 'ref)
  (define xlate (new-SoTranslation))
  (send (send xlate 'translation) 'setValue (* 1.2 (* 2.1 x-size))
	                                    (* 0.5 (* 2.1 y-size))
					    (- (/ 2.1 2.0)))
  (send root 'addChild xlate)
  (define font (new-SoFont))
  (send (send font 'size) 'setValue 5.0)
  (send root 'addChild font)
  (define text (new-SoText3))
  (send root 'addChild text)
  (send (send text 'string) 'set1Value 0 (new-SbString "Score:"))
  (send (send text 'string) 'set1Value 1 (new-SbString "0"))
  (send root 'unrefNoDelete)
  root)

;; Builds the text for allowing the user to start a new game and sets
;; up the required callbacks for doing so.

(define (build-new-game-text x-size y-size)
  (define root (new-SoSelection))
  (send root 'ref)
  (send (send root 'policy) 'setValue SoSelection::ENUM_TOGGLE)
  (define text-pick-style (new-SoPickStyle))
  (send (send text-pick-style 'style) 'setValue SoPickStyle::BOUNDING_BOX)
  (send root 'addChild text-pick-style)
  (define xlate (new-SoTranslation))
  (send (send xlate 'translation) 'setValue (* 1.2 (* 2.1 x-size))
	                                    (* 2.1 y-size)
					    (- (/ 2.1 2.0)))
  (send root 'addChild xlate)
  (define font (new-SoFont))
  (send (send font 'size) 'setValue 4.0)
  (send root 'addChild font)
  (define text-mat (new-SoMaterial))
  (send (send text-mat 'diffuseColor) 'setValue 0.0 0.2 1.0)
  (send root 'addChild text-mat)
  (define text (new-SoText3))
  (send root 'addChild text)
  (send (send text 'string) 'set1Value 0 (new-SbString "New Game"))
  (define cb-info (new-SchemeSoCBInfo))
  (send cb-info 'ref)
  (send (send cb-info 'callbackName) 'setValue "new-game-cb")
  (send root 'addSelectionCallback (get-scheme-selection-path-cb) (void-cast cb-info))
  (send root 'addDeselectionCallback (get-scheme-selection-path-cb) (void-cast cb-info))
  (send root 'unrefNoDelete)
  root)

;; Builds the text which says "Game Over". Can be turned on and off.

(define (build-game-over-text x-size y-size)
  (define root (new-SoSwitch))
  (send root 'ref)
  (define xlate (new-SoTranslation))
  (send (send xlate 'translation) 'setValue (* 1.2 (* 2.1 x-size))
	                                    (* 0.75 (* 2.1 y-size))
					    (- (/ 2.1 2.0)))
  (send root 'addChild xlate)
  (define font (new-SoFont))
  (send (send font 'size) 'setValue 6.0)
  (send root 'addChild font)
  (define text-mat (new-SoMaterial))
  (send (send text-mat 'diffuseColor) 'setValue 1.0 0.2 0.2)
  (send root 'addChild text-mat)
  (define text (new-SoText3))
  (send root 'addChild text)
  (send (send text 'string) 'set1Value 0 (new-SbString "Game Over"))
  (send root 'unrefNoDelete)
  root)

;; Convenience function which returns a pointer to one of the switches
;; in the visual representation of the game board.

(define (get-board-switch board-root x y)
  (SoSwitch-cast (send (SoSeparator-cast
			(send board-root 'getChild (* x 2)))
		       'getChild y)))

;; Convenience function which returns one value in the Scheme representation
;; of the board. This is always just a boolean value.

(define (get-board-slot board-slots x-size y-size x-pos y-pos)
  (if (and (>= x-pos 0)
	   (< x-pos x-size)
	   (>= y-pos 0)
	   (< y-pos y-size))
      (vector-ref (vector-ref board-slots x-pos) y-pos)
      #t))

;; Convenience function which calculates which rows have just been
;; completed and should be removed.

(define (get-board-rows-to-remove board-slots x-size y-size)
  (define (vert-iter y rows-to-remove)
    (define (horiz-iter x y)
      (if (>= x x-size)
	  #t
	  (and (not (get-board-slot board-slots x-size y-size x y))
	       (horiz-iter (1+ x) y))))
    (if (>= y y-size)
	(reverse rows-to-remove)
	(if (horiz-iter 0 y)
	    (vert-iter (1+ y) (cons y rows-to-remove))
	    (vert-iter (1+ y) rows-to-remove))))
  (vert-iter 0 '()))

;; Function which computes the downward movements of all the rows
;; in the game board given the output of the above procedure.

(define (get-row-movements rows-to-remove y-size)
  (define (get-row-movements-iter i j reduced-rows-to-remove)
    (if (null? reduced-rows-to-remove)
	(if (>= j y-size)
	    '()
	    (acons i
		   j
		   (get-row-movements-iter (1+ i)
					   (1+ j)
					   reduced-rows-to-remove)))
	(if (eq? j (car reduced-rows-to-remove))
	    (get-row-movements-iter i
				    (1+ j)
				    (cdr reduced-rows-to-remove))
	    (acons i
		   j
		   (get-row-movements-iter (1+ i)
					   (1+ j)
					   reduced-rows-to-remove)))))
  (if (null? rows-to-remove)
      '()
      (get-row-movements-iter (car rows-to-remove)
			      (1+ (car rows-to-remove))
			      (cdr rows-to-remove))))
		   
;; Sets a row in the Inventor representation of the game board to
;; either "all cubes visible" or "all cubes invisible".

(define (set-row-to board-root which-row x-size value)
  (define (horiz-iter x)
    (if (< x x-size)
	(begin
	  (let ((the-switch (get-board-switch board-root x which-row)))
	    (send (send the-switch 'whichChild) 'setValue value))
	  (horiz-iter (1+ x)))))
  (horiz-iter 0))

;; Blinks a list of rows in the visual board three times.

(define (blink-rows board-root rows x-size)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 0))
   rows)
  (send *game-viewer* 'render)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 1))
   rows)
  (send *game-viewer* 'render)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 0))
   rows)
  (send *game-viewer* 'render)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 1))
   rows)
  (send *game-viewer* 'render)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 0))
   rows)
  (send *game-viewer* 'render)
  (for-each
   (lambda (row)
     (set-row-to board-root row x-size 1))
   rows)
  (send *game-viewer* 'render)
)

;; Constructor for making a Tetris board object.

(define (make-tetris-board x-size y-size)
  (define board-slots (build-board x-size y-size))
  (define board-root (build-visual-board x-size y-size))
  (define game-root (new-SoSeparator))
  (define event-callback (new-SoEventCallback))
  (send game-root 'addChild event-callback)
  (define lines-root (build-surrounding-box x-size y-size))
  (send game-root 'addChild lines-root)
  (define cb-info (new-SchemeSoCBInfo))
  (send cb-info 'ref)
  (send (send cb-info 'callbackName) 'setValue "event-cb")
  (send event-callback 'addEventCallback
	(SoKeyboardEvent::getClassTypeId)
	(get-scheme-event-callback-cb)
	(void-cast cb-info))
  (define piece-root (new-SoSeparator))
  (send game-root 'addChild piece-root)
  (send game-root 'addChild board-root)
  (define score 0)
  (define score-root (build-score-text x-size y-size))
  (send game-root 'addChild score-root)
  (define new-game-text-root (build-new-game-text x-size y-size))
  (send game-root 'addChild new-game-text-root)
  (define game-over-text-root (build-game-over-text x-size y-size))
  (send game-root 'addChild game-over-text-root)
  (lambda (message)
    (cond ((eq? message 'clear)
	   (lambda (self)
	     (begin
	       (define (clear-slots-horiz-iter x)
		 (define (clear-slots-vert-iter v y)
		   (if (>= y 0)
		       (begin
			 (vector-set! v y #t)
			 (let ((the-switch (get-board-switch board-root x y)))
			   (send (send the-switch 'whichChild) 'setValue 0))
			 (clear-slots-vert-iter v (- y 1)))))
		 (if (>= x 0)
		     (begin
		       (clear-slots-vert-iter (vector-ref board-slots x)
					      (- y-size 1))
		       (clear-slots-horiz-iter (- x 1)))))
	       (clear-slots-horiz-iter (- x-size 1))
	       (set! score 0)
	       (send (send (SoText3-cast (send score-root 'getChild 2)) 'string) 'set1Value 1 (new-SbString (number->string score)))
	       (send (send game-over-text-root 'whichChild) 'setValue -1))))
	  ((eq? message 'gameOver)
	   (lambda (self)
	     (send (send game-over-text-root 'whichChild) 'setValue -3)))
	  ((eq? message 'inBoundsFull)
	   (lambda (self coords)
	     (let ((x (car coords))
		   (y (cadr coords)))
	       (and (< x x-size)
		    (< y y-size)
		    (>= x 0)
		    (>= y 0)))))
	  ((eq? message 'inBoundsPartial)
	   (lambda (self coords)
	     (let ((x (car coords))
		   (y (cadr coords)))
	       (and (< x x-size)
		    (>= x 0)
		    (>= y 0)))))
	  ((eq? message 'getSlot)
	   (lambda (self coords)
	     (if (or (>= (car coords) x-size)
		     (< (car coords) 0))
		 (error "getSlot: bad x reference" x-size)
		 (if (or (>= (cadr coords) y-size)
			 (< (cadr coords) 0))
		     (error "getSlot: bad y reference" y-size)
		     (vector-ref (vector-ref board-slots (car coords)) (cadr coords))))))
	  ((eq? message 'checkCoordsPartial)
	   (lambda (self coord-list)
	     (define (iter coord-list)
	       (if (null? coord-list)
		   #t
		   (if (and (send self 'inBoundsPartial (car coord-list))
			    (send self 'getSlot (car coord-list)))
		       (iter (cdr coord-list))
		       #f)))
	     (iter coord-list)))
	  ((eq? message 'checkCoordsFull)
	   (lambda (self coord-list)
	     (define (iter coord-list)
	       (if (null? coord-list)
		   #t
		   (if (and (send self 'inBoundsFull (car coord-list))
			    (send self 'getSlot (car coord-list)))
		       (iter (cdr coord-list))
		       #f)))
	     (iter coord-list)))
	  ((eq? message 'addPieceToBoard)
	   (lambda (self the-piece)
	     (let ((coord-list (send the-piece 'getCurrentCoordinates)))
	       (if (send self 'checkCoordsFull coord-list)
		   (begin
		     (for-each
		      (lambda (coords)
			(begin
			  (vector-set! (vector-ref board-slots (car coords))
				       (cadr coords)
				       #f)
			  (let* ((the-switch (get-board-switch board-root
							       (car coords)
							       (cadr coords)))
				 (the-cube-root (SoSeparator-cast (send the-switch
									'getChild
									1)))
				 (the-material (SoMaterial-cast (send the-cube-root
								      'getChild
								      0))))
			    (send (send the-material 'diffuseColor) 'setValue (color-lookup
									       (send the-piece 'getColor)))
			    (send (send the-switch 'whichChild) 'setValue 1))))
		      coord-list)
		     #t)
		   #f))))
	  ((eq? message 'setCurrentPiece)
	   (lambda (self new-piece)
	     (send piece-root 'removeAllChildren)
	     (send piece-root 'addChild (send new-piece 'getGeometry))))
	  ((eq? message 'getGeometry)
	   (lambda (self)
	     game-root))
	  ((eq? message 'updateState)
	   (lambda (self)
	     (let* ((rows-to-remove (get-board-rows-to-remove board-slots x-size y-size))
		    (row-movements (get-row-movements rows-to-remove y-size))
		    (number-of-rows (length rows-to-remove)))
	       (cond ((eq? number-of-rows 1)
		      (set! score (+ 100 score)))
		     ((eq? number-of-rows 2)
		      (set! score (+ 300 score)))
		     ((eq? number-of-rows 3)
		      (set! score (+ 700 score)))
		     ((eq? number-of-rows 4)
		      (set! score (+ 1500 score))))
	       (send (send (SoText3-cast (send score-root 'getChild 2)) 'string) 'set1Value 1 (new-SbString (number->string score)))
	       (if (not (null? row-movements))
		   (begin
		     (blink-rows board-root rows-to-remove x-size)
		     (for-each
		      (lambda (row-movement)
			(define (horiz-loop x)
			  (if (< x x-size)
			      (let* ((the-switch (get-board-switch board-root x (car row-movement)))
				     (next-switch (get-board-switch board-root x (cdr row-movement)))
				     (next-child (send (send next-switch 'whichChild) 'getValue))
				     (the-material
				      (SoMaterial-cast
				       (send (SoGroup-cast (send the-switch 'getChild 1)) 'getChild 0)))
				     (next-material
				      (SoMaterial-cast
				       (send (SoGroup-cast (send next-switch 'getChild 1)) 'getChild 0)))
				     (board-col (vector-ref board-slots x)))
				(send (send the-switch 'whichChild) 'setValue next-child)
				(if (= next-child 1)
				    (send (send the-material 'diffuseColor) 'setValue 
					  (SbVec3f-cast (send (send next-material 'diffuseColor) 'operator-brackets 0))))
				(vector-set! board-col (car row-movement)
					     (vector-ref board-col (cdr row-movement)))
				(horiz-loop (1+ x)))))
			(horiz-loop 0))
		      row-movements)
		     (define (clear-rows-starting-at y)
		       (define (horiz-loop x)
			 (if (< x x-size)
			     (let ((the-switch (get-board-switch board-root x y)))
			       (send (send the-switch 'whichChild) 'setValue 0)
			       (horiz-loop (1+ x)))))
		       (if (< y y-size)
			   (begin
			     (horiz-loop 0)
			     (clear-rows-starting-at (1+ y)))))
		     (clear-rows-starting-at (cdr (car (reverse row-movements)))))))))
	   (else (no-method message)))))

;;; Callbacks

(define (timer-sensor-cb user-data sensor)
  (if (not (send *current-piece* 'moveDown))
      (if (not (send *game-board* 'addPieceToBoard *current-piece*))
	  (begin
	    (send *game-board* 'gameOver)
;	    (format #t "Game over, man~%")
	    (send (SoTimerSensor-cast sensor) 'unschedule))
	  (begin
	    (let* ((new-piece-index (random 5))
		   (new-piece (vector-ref *pieces* new-piece-index)))
	      (send new-piece 'setCurrentTranslation 4 16)
	      (send new-piece 'setCurrentRotation 0)
	      (send *game-board* 'setCurrentPiece new-piece)
	      (set! *current-piece* new-piece)
	      (send *game-board* 'updateState))))))

(define (event-cb user-data node)
  (let ((ev (send node 'getEvent)))
    (if (or (= 1 (SO_KEY_PRESS_EVENT ev RIGHT_ARROW))
	    (= 1 (SO_KEY_PRESS_EVENT ev LEFT_ARROW))
	    (= 1 (SO_KEY_PRESS_EVENT ev DOWN_ARROW))
	    (= 1 (SO_KEY_PRESS_EVENT ev SPACE)))
	(begin
	  (if (= 1 (SO_KEY_PRESS_EVENT ev LEFT_ARROW))
	      (send *current-piece* 'moveLeft)
	      (if (= 1 (SO_KEY_PRESS_EVENT ev RIGHT_ARROW))
		  (send *current-piece* 'moveRight)
		  (if (= 1 (SO_KEY_PRESS_EVENT ev DOWN_ARROW))
		      (send *current-piece* 'rotate)
		      (let loop
			  ()
			(if (send *current-piece* 'moveDown)
			    (begin
			      (send *game-viewer* 'render)
			      (loop)))))))
	  (send node 'setHandled)))))

(define (close-window-cb user-data component)
  (exit))

(define (new-game-cb user-data path)
  (play-tetris))

;;; Convenience functions for setting up pieces and board

(define (make-pieces)
  (define piece (make-tetris-piece 's))
  (send piece 'setBoard *game-board*)
  (vector-set! *pieces* 0 piece)
  (define piece (make-tetris-piece 'ls))
  (send piece 'setBoard *game-board*)
  (vector-set! *pieces* 1 piece)
  (define piece (make-tetris-piece 't))
  (send piece 'setBoard *game-board*)
  (vector-set! *pieces* 2 piece)
  (define piece (make-tetris-piece 'c))
  (send piece 'setBoard *game-board*)
  (vector-set! *pieces* 3 piece)
  (define piece (make-tetris-piece 'l))
  (send piece 'setBoard *game-board*)
  (vector-set! *pieces* 4 piece))

(define (make-board)
  (set! *game-board* (make-tetris-board 10 20)))

;;; Set up timer sensor

(define cb-info (new-SchemeSoCBInfo))
(send cb-info 'ref)
(send (send cb-info 'callbackName) 'setValue "timer-sensor-cb")
(define *timer-sensor* (new-SoTimerSensor (get-scheme-sensor-cb) (void-cast cb-info)))

;;; Set up Examiner Viewer so that it exits the IvySCM executable
;;; when the viewer is closed.

(define cb-info (new-SchemeSoCBInfo))
(send cb-info 'ref)
(send (send cb-info 'callbackName) 'setValue "close-window-cb")
(send *game-viewer* 'setWindowCloseCallback (get-scheme-xt-component-cb) (void-cast cb-info))

;;; Initialization for the game (should only be called once)

(define (initialize-tetris)
  (make-board)
  (make-pieces)
  (send *game-viewer* 'setSceneGraph (send *game-board* 'getGeometry))
  (send *game-viewer* 'setTitle "SchemeTris")
  (send *game-viewer* 'show))

;;; Start a new game (may be called many times)

(define (play-tetris)
  (randomize-loop (get-universal-time))
  (send *game-board* 'clear)
  (send *game-viewer* 'setViewing 0)
  (let* ((new-piece-index (random 5))
	 (new-piece (vector-ref *pieces* new-piece-index)))
    (send new-piece 'setCurrentTranslation 4 16)
    (send new-piece 'setCurrentRotation 0)
    (send *game-board* 'setCurrentPiece new-piece)
    (set! *current-piece* new-piece)
    (send *timer-sensor* 'setInterval (new-SbTime 1.0))
    (send *timer-sensor* 'schedule)))

;;; Start it up

(initialize-tetris)
(play-tetris)