#!/usr/local/bin/guile \
-e tetris -s
!#

;; Adapted from guile-ncurses 0.1.0 by Dmitry Morozhnikov
;; Copyright (c) 2001 Dmitry Morozhnikov
;; GPL 2

(use-modules (ncurses curses))
(use-modules (srfi srfi-8))

(define mainwin #f)

(define xorigin 5)
(define yorigin 5)

(define fg_char #f)
(define cap_char #f)
(define b1_char #f)
(define b2_char #f)
(define b3_char #f)
(define b4_char #f)
(define figattr #f)
(define capattr #f)
(define boxattr #f)

(define cap-height 22)
(define cap-width 10)

(define cap-correct #f)
(define fig-correct #f)

(define speed #f)
(define tlines #f)
(define figs #f)
(define score #f)

(define inport #f)

(define (tetris-init-screen)
  (start-color!)
  (noecho!)
  (cbreak!)
  (keypad! mainwin #t)
  (init-pair! 1 COLOR_BLUE COLOR_BLACK)
  (init-pair! 2 COLOR_BLUE COLOR_BLACK)
  (init-pair! 3 COLOR_WHITE COLOR_BLACK)
  (curs-set 0)
  (nodelay! mainwin #t)
  (set! fg_char (acs-block))
  (set! cap_char (acs-block))
  (set! b1_char (normal #\.))
  (set! b2_char (normal #\.))
  (set! b3_char (normal #\space))
  (set! b4_char (normal #\space))
  (set! figattr (logior (color-pair 1) A_BOLD))
  (set! capattr (color-pair 2))
  (set! boxattr (color-pair 3))
  (set! xorigin (- (quotient (cols) 2) (quotient (* cap-width 2) 2)))
  (set! yorigin (- (quotient (lines) 2) (quotient cap-height 2))))

(define (tetris-done-screen)
  (standend! mainwin)
  (clear mainwin)
  (refresh mainwin)
  (curs-set 1)
  (endwin))

(define (tetris args)
  (let ((w (initscr)))
    (set! mainwin w)
    (tetris-init-screen)
    (tetris-loop)
    (tetris-done-screen)))

(define figures `(("##"
		   "##")
		  
		  ("#."
		   "##"
		   ".#")
		  
		  (".#"
		   "##"
		   "#.")
		  
		  ("#"
		   "#"
		   "#"
		   "#")
		  
		  ("#."
		   "##"
		   "#.")
		  
		  ("##"
		   "#."
		   "#.")
		  
		  ("##"
		   ".#"
		   ".#")))

(define fig-rotation `((0 0 0 0)
		       (0 0 0 0)
		       (0 0 0 0)
		       (-2 2 -2 2)
		       (-1 0 0 1)
		       (0 0 0 0)
		       (0 0 0 0)))

(define (tetris-loop)
  (tetris-draw-box)
  (tetris-draw-help)
  (letrec ((key #f)
           (fig #f)
	   (cap #f)
	   (tics #f)
	   (speedtics #f)
	   (speedup #f)
	   (loop (lambda ()
		   (set! key (getch mainwin))
		   (cond
		    ((eq? key #\space)
		     (tetris-drop-fig fig cap)
		     (set! tics (tms:clock (times))))
		    ((eq? key KEY_UP)
		     (tetris-try-rotate fig cap)
		     (set! tics (tms:clock (times))))
		    ((eq? key KEY_LEFT)
		     (tetris-try-left fig cap)
		     (set! tics (tms:clock (times))))
		    ((eq? key KEY_RIGHT)
		     (tetris-try-right fig cap)
		     (set! tics (tms:clock (times))))
		    ((or (eq? key KEY_REFRESH)
			 (eq? key (- (char->integer #\L)
				     (char->integer #\@))))
		     (clear mainwin)
		     (tetris-draw-box)
		     (tetris-draw-help)
		     (tetris-draw-cap cap)
		     (tetris-draw-fig fig #t)))
		   (refresh mainwin)
		   (if (>= (- (tms:clock (times)) tics) (- 500 (* speed 5)))
		       (begin
			 (set! tics (tms:clock (times)))
			 (if (>= (- (tms:clock (times)) speedtics) speedup)
			     (begin
			       (set! speedtics (tms:clock (times)))
			       (set! speed (1+ speed))
			       (if (> speed 10)
				   (set! speed 10))))
			 (tetris-move-fig fig cap)
			 (if (eq? fig-correct #f)
			     (begin
			       (set! cap (tetris-check-cap cap))
			       (tetris-draw-cap cap)
			       (set! fig (tetris-generate-fig))
			       (tetris-place-fig fig cap)))
			 (tetris-draw-score speed)
			 (refresh mainwin)))
		   (if (not (or (eq? key #\q)
				(eq? cap-correct #f)))
		       (loop)))))
    (set! fig (tetris-generate-fig))
    (set! cap (tetris-generate-cap))
    (tetris-draw-cap cap)
    (tetris-place-fig fig cap)
    (set! tics (tms:clock (times)))
    (set! speed 0)
    (set! speedtics (tms:clock (times)))
    (set! speedup 10000)
    (set! tlines 0)
    (set! figs 0)
    (set! score 0)
    (tetris-draw-score speed)
    (refresh mainwin)
    (loop)))

(define (tetris-score-fig)
  (set! figs (1+ figs))
  (set! score (+ score speed)))

(define (tetris-score-line)
  (set! tlines (1+ tlines))
  (set! score (+ score (* 5 speed))))

(define (tetris-draw-score speed)
  (attr-set! mainwin boxattr)
  (move mainwin yorigin (- xorigin 18))
  (addstr mainwin "SPEED   : ")
  (addstr mainwin (number->string speed))
  (move mainwin (+ yorigin 1) (- xorigin 18))
  (addstr mainwin "FIGURES : ")
  (addstr mainwin (number->string figs))
  (move mainwin (+ yorigin 2) (- xorigin 18))
  (addstr mainwin "LINES   : ")
  (addstr mainwin (number->string tlines))
  (move mainwin (+ yorigin 3) (- xorigin 18))
  (addstr mainwin "SCORE   : ")
  (addstr mainwin (number->string score)))

(define (tetris-draw-box)
  (attr-set! mainwin boxattr)
  (move mainwin yorigin (1- xorigin))
  (vline mainwin (acs-vline) cap-height)
  (move mainwin (+ yorigin cap-height) (1- xorigin))
  (hline mainwin (acs-hline) (+ (* cap-width 2) 2))
  (addch mainwin (acs-llcorner))
  (move mainwin yorigin (+ xorigin (* cap-width 2)))
  (vline mainwin (acs-vline) cap-height)
  (move mainwin (+ yorigin cap-height) (+ xorigin (* cap-width 2)))
  (addch mainwin (acs-lrcorner)))

(define (tetris-draw-help) '())

(define (tetris-draw-fig fig on)
  (letrec ((figview (tetris-figview fig))
	   (x 0)
	   (y 0)
	   (fx (car fig))
	   (fy (cadr fig))
	   (draw (lambda (f)
		   (set! x 0)
		   (draw-x (car f))
		   (set! y (1+ y))
		   (if (not (null? (cdr f)))
		       (draw (cdr f)))))
	   (draw-x (lambda (f)
		     (move mainwin (+ yorigin fy y)
			   (+ xorigin (* (+ fx x) 2)))
		     (if (eq? (car f) #\#)
			 (if on
			     (begin
			       (attr-set! mainwin figattr)
			       (addch mainwin fg_char)
			       (addch mainwin fg_char))
			     (begin
			       (attr-set! mainwin capattr)
			       (let ((oy (odd? (+ fy y)))
				     (ox (odd? (+ fx x))))
				 (cond
				  ((or (and oy ox)
				       (and (not oy) 
					    (not ox)))
				   (addch mainwin b1_char)
				   (addch mainwin b2_char))
				  (#t
				   (addch mainwin b3_char)
				   (addch mainwin b4_char)))))))
		     (set! x (1+ x))
		     (if (not (null? (cdr f)))
			 (draw-x (cdr f))))))
    (draw figview)))

(define (tetris-draw-cap cap)
  (attr-set! mainwin capattr)
  (letrec ((y 0)
	   (x 0)
	   (draw (lambda (c)
		   (move mainwin (+ yorigin y) xorigin)
		   (set! x 0)
		   (draw-x (car c))
		   (set! y (1+ y))
		   (if (not (null? (cdr c)))
		       (draw (cdr c)))))
	   (draw-x (lambda (c)
		     (if (eq? (car c) #\%)
			 (begin
			   (addch mainwin cap_char)
			   (addch mainwin cap_char))
			 (begin
			   (cond
			    ((or (and (odd? y) (odd? x))
				 (and (even? y) (even? x)))
			     (addch mainwin b1_char)
			     (addch mainwin b2_char))
			    (#t
			     (addch mainwin b3_char)
			     (addch mainwin b4_char)))))
		     (set! x (1+ x))
		     (if (not (null? (cdr c)))
			 (draw-x (cdr c))))))
    (draw cap)))

(define (tetris-check-cap cap)
  (letrec ((dropped 0)
	   (pattern (make-list cap-width #\%))
	   (check (lambda (c)
		    (if (null? c)
			`()
			(if (equal? (car c) pattern)
			    (begin
			      (set! dropped (1+ dropped))
			      (tetris-score-line)
			      (append (check (cdr c))))
			    (append (list (car c)) (check (cdr c))))))))
    (letrec ((newcap (check cap))
	     (head (lambda ()
		     (if (<= dropped 0)
			 `()
			 (begin
			   (set! dropped (1- dropped))
			   (append (list (make-list cap-width #\.)) (head)))))))
      (append (head) newcap))))

(define (tetris-drop-fig fig cap)
  (letrec ((drop (lambda (d)
		   (let ((cap-tail (tetris-cap-tail fig cap 0 d)))
		     (if (or (eq? cap-tail #f)
			     (not (tetris-placeable? fig cap-tail)))
			 (begin
			   (if (> d 1)
			       (begin 
				 (tetris-draw-fig fig #f)
				 (set-car! (cdr fig) (+ (cadr fig) (1- d)))
				 (tetris-draw-fig fig #t))))
			 (drop (1+ d)))))))
    (drop 1)))

(define (tetris-generate-cap)
  (letrec ((h (- cap-height 1))
	   (cap (list (make-list cap-width #\.)))
	   (mkh (lambda ()
		  (append! cap (list (make-list cap-width #\.)))
		  (set! h (- h 1))
		  (if (not (= h 0))
		      (mkh)))))
    (mkh)
    (set! cap-correct #t)
    cap))

;;; Figure defined as (x y w h rot (rot0 ... rot3)
;;; 	   		   	    ((x1y1 x2y1 ... xny1)
;;;		   		   	  	 (x1y2 x2y2 ... xny2) ... ))
(define (tetris-generate-fig)
  (set! fig-correct #t)
  (let* ((fignum (random 7))
	 (figview (map string->list (car (list-tail figures fignum))))
	 (w (length (car figview)))
	 (h (length figview)))
    (list (- (quotient cap-width 2) (quotient w 2)) 0 w h 0
	  (car (list-tail fig-rotation fignum)) figview)))

(define (tetris-figview fig)
  (car (list-tail fig 6)))

(define (tetris-placeable? fig cap)
  (letrec ((figview (tetris-figview fig))
	   (placeable? (lambda (f c)
			 (if (or (not (placeable-x? (car f) (car c)))
				 (and (null? (cdr c))
				      (not (null? (cdr f)))))
			     #f
			     (if (null? (cdr f))
				 #t
				 (placeable? (cdr f) (cdr c))))))
	   (placeable-x? (lambda (f c)
			   (if (or (and (eq? (car f) #\#)
					(eq? (car c) #\%))
				   (and (null? (cdr c))
					(not (null? (cdr f)))))
			       #f
			       (if (null? (cdr f))
				   #t
				   (placeable-x? (cdr f) (cdr c)))))))
    (placeable? figview cap)))

(define (tetris-cap-tail fig cap xshift yshift)
  (if (or (< (+ (cadr fig) yshift) 0)
	  (< (+ (car fig) xshift) 0)
	  (>= (+ (cadr fig) yshift (- (cadddr fig) 1)) cap-height)
	  (>= (+ (car fig) xshift (- (caddr fig) 1)) cap-width))
      #f
      (letrec ((height 0)
	       (tail (lambda (t)
		       (if (or (= height (cadddr fig))
			       (null? (cdr t)))
			   (list (list-tail (car t) (+ (car fig) xshift)))
			   (begin
			     (set! height (1+ height))
			     (append (list (list-tail (car t)
						      (+ (car fig) xshift)))
				     (tail (cdr t))))))))
	(tail (list-tail cap (+ (cadr fig) yshift))))))

(define (tetris-place-fig fig cap)
  (let ((cap-tail (tetris-cap-tail fig cap 0 0)))
    (if (and (not (eq? cap-tail #f))
	     (tetris-placeable? fig cap-tail))
	(begin
	  (set! cap-correct #t)
	  (set! fig-correct #t)
	  (tetris-draw-fig fig #t))
	(begin
	  (set! cap-correct #f)
	  (set! fig-correct #f)))))

(define (tetris-fix fig cap)
  (letrec ((figview (tetris-figview fig))
	   (fix (lambda (f c)
		  (fix-x (car f) (car c))
		  (if (not (null? (cdr f)))
		      (fix (cdr f) (cdr c)))))
	   (fix-x (lambda (f c)
		    (if (eq? (car f) #\#)
			(set-car! c #\%))
		    (if (not (null? (cdr f)))
			(fix-x (cdr f) (cdr c))))))
    (fix figview cap)))

(define (tetris-move-fig fig cap)
  (let ((cap-tail (tetris-cap-tail fig cap 0 1)))
    (if (and (not (eq? cap-tail #f))
	     (tetris-placeable? fig cap-tail))
	(begin
	  (tetris-draw-fig fig #f)
	  (set-car! (cdr fig) (1+ (cadr fig)))
	  (tetris-draw-fig fig #t))
	(let ((cap-tail (tetris-cap-tail fig cap 0 0)))
	  (tetris-draw-fig fig #f)
	  (tetris-fix fig cap-tail)
	  (tetris-score-fig)
	  (set! fig-correct #f)))))

(define (tetris-try-left fig cap)
  (let ((cap-tail (tetris-cap-tail fig cap -1 0)))
    (if (and (not (eq? cap-tail #f))
	     (tetris-placeable? fig cap-tail))
	(begin
	  (tetris-draw-fig fig #f)
	  (set-car! fig (1- (car fig)))
	  (tetris-draw-fig fig #t)))))

(define (tetris-try-right fig cap)
  (let ((cap-tail (tetris-cap-tail fig cap 1 0)))
    (if (and (not (eq? cap-tail #f))
	     (tetris-placeable? fig cap-tail))
	(begin
	  (tetris-draw-fig fig #f)
	  (set-car! fig (1+ (car fig)))
	  (tetris-draw-fig fig #t)))))

(define (tetris-figrotation fig)
  (car (list-tail fig 5)))

(define (tetris-rotate fig)
  (letrec ((figview (tetris-figview fig))
	   (rotation (tetris-figrotation fig))
	   (rot (lambda (w x h)
		  (if (< w 0)
		      h
		      (rot (1- w) 
			   x
			   (append h (list (map (lambda (y) (list-ref y w))
						x))))))))
    (let* ((x (+ (car fig) (list-ref rotation (car (cddddr fig)))))
	   (newfig (list (if (< x 0)
			     0
			     (if (>= (+ x (cadddr fig)) cap-width)
				 (- x (- (+ x (cadddr fig)) cap-width))
				 x))
			 (cadr fig)
			 (cadddr fig)
			 (caddr fig)
			 (if (= (car (cddddr fig)) 3)
			     0
			     (1+ (car (cddddr fig))))
			 rotation
			 (rot (1- (caddr fig)) figview `()))))
      newfig)))

(define (tetris-try-rotate fig cap)
  (let* ((rotfig (tetris-rotate fig))
	 (cap-tail (tetris-cap-tail rotfig cap 0 0)))
    (if (and (not (eq? cap-tail #f))
	     (tetris-placeable? rotfig cap-tail))
	(begin
	  (tetris-draw-fig fig #f)
	  (set-car! fig (car rotfig))
	  (set-cdr! fig (cdr rotfig))
	  (tetris-draw-fig fig #t)))))