#!/usr/bin/guile -s
!#
;; myTetris src code
;;

(use-modules (gnome gtk))
(use-modules (oop goops))

  ;; cells, rows & cols:
  ;;
(define ROWS 20)      ;; height of screen in blocks
(define COLS 12)      ;; width of screen in blocks

  ;; starting & ending points for pieces:
  ;;
(define yINIT 1)                        ;; one row away from top,
;;(define xINIT (- (floor (/ COLS 2)) 1)) ;; midway between left & right
(define xINIT 5)

  ;;number of lines 
  ;;
(define lines 0)

  ;; currently falling piece
  ;;
(define current 'NONE)  

  ;; global variable: (used for clearing the piece as its falling)
  ;;
(define tiles (vector))

;;
;; tile class definition
(define-class <tile> ()
 (row #:accessor tile-row #:init-keyword #:row)
 (col #:accessor tile-col #:init-keyword #:col)
 (type #:accessor tile-type #:init-keyword #:type #:init-value 'TETRIS))


;; to set/clear tiles (on screen):
(define minimtrx '())
(define check0 (gtk-image-new-from-file "check0.xpm"))
(define check1 (gtk-image-new-from-file "check1.xpm"))
(define minimtrx-ref (lambda (i j) (list-ref (list-ref minimtrx i) j)))
(define draw-square (lambda (i j color) (gtk-image-set-from-pixbuf (minimtrx-ref i j) (gtk-image-get-pixbuf check1))))
(define clear-square (lambda (i j) (gtk-image-set-from-pixbuf (minimtrx-ref i j) (gtk-image-get-pixbuf check0))))

;; drawing a vector of tiles:
;;
(define 
draw-piece
(lambda (P)
(do ((i 0 (+ i 1)))
    ((= i (vector-length P)))
  (let ((t (vector-ref P i)))
    (draw-square (tile-row t) (tile-col t) 0)))))


;; clearing a vector of tiles:
;;
(define (clear-piece P)
  (do ((i 0 (+ i 1)))
    ((= i (vector-length P)))
    (let ((t (vector-ref P i)))
      (clear-square (tile-row t) (tile-col t)))))

;; ALL PIECES:
;;
(define 
make-tiles 
(lambda (R C dir type)
  (cond ((eqv? type 'I) (make-i-tiles R C dir))
        ((eqv? type 'O) (make-o-tiles R C dir))
        ((eqv? type 'T) (make-t-tiles R C dir))
        ((eqv? type 'L) (make-l-tiles R C dir))
        ((eqv? type 'J) (make-j-tiles R C dir))
        ((eqv? type 'S) (make-s-tiles R C dir))
        ((eqv? type 'Z) (make-z-tiles R C dir))
        (else (error 'make-tiles "No such type!")))))

;; I-PIECE:
;;
(define 
make-i-tiles
(lambda (R C dir)
(let ((x dir)
      (y (- 1 dir)))
  (vector
   (make <tile> #:row R #:col C #:type 'I_TYPE)
   (make <tile> #:row (- R y) #:col (- C x) #:type 'I_TYPE)
   (make <tile> #:row (+ R y) #:col (+ C x) #:type 'I_TYPE)
   (make <tile> #:row (+ R y y) #:col (+ C x x) #:type 'I_TYPE)))))

;; O-PIECE:
;;
(define 
make-o-tiles 
(lambda (R C dir)
  (vector
   (make <tile> #:row R #:col C #:type 'O_TYPE)
   (make <tile> #:row R #:col (- C 1) #:type 'O_TYPE)
   (make <tile> #:row (- R 1) #:col C #:type 'O_TYPE)
   (make <tile> #:row (- R 1) #:col (- C 1) #:type 'O_TYPE))))

;; T-PIECE:
;;
(define 
make-t-tiles 
(lambda (R C dir)
  (let* ((mod (modulo dir 4))
         (hspan (if (or (= mod 3) (= mod 1)) 1 0))
         (vspan (if (= hspan 0) 1 0))
         (x (if (= hspan 0) (- mod 1) 0))
         (y (if (= vspan 0) (- 2 mod) 0)))
    (vector
    (make <tile> #:row R #:col C #:type 'T_TYPE)
    (make <tile> #:row (+ R vspan) #:col (+ C hspan) #:type 'T_TYPE)
    (make <tile> #:row (- R vspan) #:col (- C hspan) #:type 'T_TYPE)
    (make <tile> #:row (+ R y) #:col (- C x) #:type 'T_TYPE)))))

;; L-PIECE
;;
(define 
make-l-tiles 
(lambda (R C dir)
(let* ((mod (modulo dir 4))
         (hspan (if (or (= mod 3) (= mod 1)) 1 0))
         (vspan (if (= hspan 0) 1 0))
         (y (if (= hspan 0) (- mod 1) 0))
         (x (if (= vspan 0) (- 2 mod) 0)))
    (vector
     (make <tile> #:row R #:col C #:type 'L_TYPE)
     (make <tile> #:row (+ R vspan) #:col (+ C hspan) #:type 'L_TYPE)
     (make <tile> #:row (- R vspan) #:col (- C hspan) #:type 'L_TYPE)
     (make <tile> #:row (+ R (- y) x) #:col (- C y x) #:type 'L_TYPE)))))

;; J-PIECE
;;
(define 
make-j-tiles 
(lambda (R C dir)
(let* ((mod (modulo dir 4))
         (hspan (if (or (= mod 3) (= mod 1)) 1 0))
         (vspan (if (= hspan 0) 1 0))
         (x (if (= hspan 0) (- mod 1) 0))
         (y (if (= vspan 0) (- 2 mod) 0)))
    (vector
     (make <tile> #:row R #:col C #:type 'L_TYPE)
     (make <tile> #:row (- R vspan) #:col (- C hspan) #:type 'L_TYPE)
     (make <tile> #:row (+ R vspan) #:col (+ C hspan) #:type 'L_TYPE)
     (make <tile> #:row (- R y x) #:col (- C (- x) y) #:type 'L_TYPE)))))

;; S-PIECE:
;;
(define 
make-s-tiles 
(lambda (R C dir)
  (let ((x dir)
        (y (- 1 dir)))
    (vector
     (make <tile> #:row R #:col C #:type 'S_TYPE)
     (make <tile> #:row (+ R y) #:col (- C x) #:type 'S_TYPE)
     (make <tile> #:row (- R x) #:col (- C y) #:type 'S_TYPE)
     (make <tile> #:row (- R y x) #:col (+ C (- y) x) #:type 'S_TYPE)))))

;; Z-PIECE:
;;
(define 
make-z-tiles 
(lambda (R C dir)
  (let ((x dir)
        (y (- 1 dir)))
    (vector
     (make <tile> #:row R #:col C #:type 'Z_TYPE)
     (make <tile> #:row (+ R y) #:col (+ C x) #:type 'Z_TYPE)
     (make <tile> #:row (- R x) #:col (+ C y) #:type 'Z_TYPE)
     (make <tile> #:row (- R y x) #:col (+ C y (- x)) #:type 'Z_TYPE)))))

;;
;;Purpose: check if a tile-vector is in-bounds
(define
in-bounds?
(lambda (P)
  (let ((check #t))  (do ((i 0 (+ i 1)))
			 ((or (not check) (= i 4)) check);test expr
		         (set! check (and check 
					  (< -1 (tile-row (vector-ref P i)) ROWS)
					  (< -1 (tile-col (vector-ref P i)) COLS)))))))


;; ============================================
;; == THE MATRIX
;; ============================================
;;;;;;;;;;;;;
;; MATRIX: ;;
;;;;;;;;;;;;;
;;;;;;;;;;;;;
;; MATRIX: ;;
;;;;;;;;;;;;;

;; game matrix:
;;
(define matrix
  (make-vector ROWS))

;; filling rows:
;;
(do ((i 0 (+ i 1)))
  ((= i ROWS) #t)
  (vector-set! matrix i (make-vector COLS 'NONE)))

;;
;; Purpose: matrix ops:
(define 
matrix-set! 
(lambda (i j X)
  (vector-set! (vector-ref matrix i) j X)))

(define 
matrix-ref 
(lambda (i j)
  (vector-ref (vector-ref matrix i) j)))

;;
;; Purpose: traversing entire matrix with a function:
(define 
matrix-map 
(lambda (func)
  (do ((i 0 (+ i 1)))
    ((= i ROWS) #t)
    (do ((j 0 (+ j 1)))
      ((= j COLS) #t)
      (func i j)))))
;;
;;
(define
draw-tile
(lambda (i j) (if (equal? (matrix-ref i j) 'NONE)
(clear-square i j )
(draw-square i j 0))))

;;
;; Purpose: drawing the game board:
(define 
draw-screen
(lambda () (matrix-map draw-tile)))

;;
;; Purpose: clearing the game matrix (but not the screen!):
(define 
clear-matrix
(lambda ()
  (matrix-map (lambda (i j) (matrix-set! i j 'NONE)))))

;;
;; Purpose: randomizing the matrix (for tests):
(define 
randomize
  (lambda ()
    (matrix-map 
     (lambda (i j)
       (matrix-set! i j (random 8))))))

;;
;; Purpose: making sure spot is clear for piece:
(define 
clear? 
(lambda (P)
  (let ((check #t))
    (do ((i 0 (+ i 1)))
      ((or (not check)
           (= i 4)) check)
      (set! check
            (and check
                 (equal? (matrix-ref (tile-row (vector-ref P 
i))
                                    (tile-col (vector-ref P i))) 'NONE)))))))

;;
;; Purpose: adding piece to matrix grid:

(define 
add-to-matrix 
(lambda (P)
  (do ((i 0 (+ i 1)))
    ((= i 4))
    (matrix-set! (tile-row (vector-ref P i))
                 (tile-col (vector-ref P i))
                 (tile-type (vector-ref P i))))))

;;
;; Purpose: bounds checking
(define 
in-bounds? 
(lambda (P)
  (let ((check #t))
    (do ((i 0 (1+ i)))
      ((or (not check)
           (= i 4)) check)
      (set! check
            (and check
                 (< -1 (tile-row (vector-ref P i)) ROWS)
                 (< -1 (tile-col (vector-ref P i)) COLS) )) ))))

;; Purpose: filling a row with zeros:
;;
(define 
clear-row 
(lambda (v)
  (do ((i 0 (+ i 1)))
    ((= i (vector-length v)))
    (vector-set! v i 'NONE))))

;; eliminating rows that are complete:
;;
(define 
eliminate-row 
(lambda (x)
  (do ((i x (- i 1)))
    ((= i 0) (clear-row (vector-ref matrix 0)))
    (do ((j 0 (+ j 1))
         (row (vector-ref matrix i)))
      ((= j (vector-length row)))
      (vector-set! row j 
                   (vector-ref (vector-ref matrix (- i 1)) j))) )))

;; checking one row for horizontal fill:
;;
(define 
check-row 
(lambda (v)
  (let ((flag #t))
    (do ((i 0 (+ i 1)))
      ((= i (vector-length v)) flag)
      (set! flag
            (and flag
                 (not (equal? (vector-ref v i) 'NONE))))))))

;;(define check-rows (lambda () #t))

;; checking all rows of matrix:
;;
(define 
check-rows
(lambda ()
  (let ((i (- ROWS 1)))
    (do ()
      ((< i 0))
      (if (check-row (vector-ref matrix i))
          (begin             
            (eliminate-row i)
            (set! lines (1+ lines))
            (display (string-append "you have " (number->string lines) " lines\n"))
            (draw-screen)
            #t)
          (set! i (- i 1)) )) )))


;;this is for the piece objects (ie. not tile-vectors)
;;

(define-class <piece> ()
  (row #:accessor piece-row #:init-keyword #:row)
  (col #:accessor piece-col #:init-keyword #:col)
  (dir #:accessor piece-dir #:init-value 0 #:init-keyword #:dir)
  (status #:accessor piece-status #:init-value #t #:init-keyword #:status)
  (type #:accessor piece-type #:init-value 'NONE #:init-keyword #:type))

;; Purposes:  These functions rotate the direction.
(define-method (piece-rotate-right (this <piece>))
  (slot-set! this 'dir (1+ (piece-dir this))))

(define-method (piece-rotate-left (this <piece>))
  (slot-set! this 'dir (1- (piece-dir this))))

;;oops i thought it would "down-class" it...
(define-method (piece-rotate-right2 (this <piece>))
  (slot-set! this 'dir (1+ (piece-dir this))))

(define-method (piece-rotate-left2 (this <piece>))
  (slot-set! this 'dir (1- (piece-dir this))))

;; Purpose:  These functions change the col value.
(define-method (piece-move-right (this <piece>))
  (slot-set! this 'col (1+ (piece-col this))))

(define-method (piece-move-left (this <piece>))
  (slot-set! this 'col (1- (piece-col this))))

;; Purpose:  To drop the piece (increase row by 1)
(define-method (piece-fall (this <piece>))
  (slot-set! this 'row (1+ (piece-row this))))

;; Purpose:  To signal that the piece has landed.
(define-method (piece-land (this <piece>))
  (slot-set! this 'status #f))

;; OTHER METHODS:  
;;
;; Contract: rotate:  (void) --> (void)
;; Purpose:  Rotates only between 0 and 1 directions.
;;           (Handles both left & right rotations)
;;
(define-method (piece-rotate (this <piece>))
  (if (zero? (piece-dir this))
      (piece-rotate-right2 this)  ;;true form
      (piece-rotate-left2 this))) ;; false form

;; Purpose:
(define-method (write (this <piece>) port)
  (display (format #f "<~S,~S> (~S)" (piece-row this) (piece-col this) (piece-dir this)) port))

;; Purpose:   To make an "I" shaped piece, subclass of TETRIS-piece.
;;
(define-class <i-piece> (<piece>))

;; OVERRIDING METHODS:  
;;
;; Contract: rotate:  (void) --> (void)
;; Purpose:  Rotates only between 0 and 1 directions.
;;           (Handles both left & right rotations)
;;
(define-method (piece-rotate-left (this <i-piece>))
  (piece-rotate this))
(define-method (piece-rotate-right (this <i-piece>))
  (piece-rotate this))

;;
;;
;;
;; Purpose:   To make a block "O" shaped piece, subclass of TETRIS-piece
;;
(define-class <o-piece> (<piece>))


;; OVERRIDING METHODS:  
;;
;; Contract: rotate:  (void) --> (void)
;; Purpose:  
;;           
;;
(define-method (piece-rotate (<this <o-piece>))
  #f)

;;
;;
;;
;; Purpose:   To make an "S" shaped piece, subclass of TETRIS-piece.
;;
(define-class <s-piece> (<piece>))

;; OVERRIDING METHODS:  
;;
;; Contract: rotate:  (void) --> (void)
;; Purpose:  Rotates only between 0 and 1 directions.
;;           (Handles both left & right rotations)
;;
(define-method (piece-rotate-left (this <s-piece>))
  (piece-rotate this))
(define-method (piece-rotate-right (this <s-piece>))
  (piece-rotate this))

;
;;
;;
;;
;; Purpose:   To make an "Z" shaped piece, subclass of TETRIS-piece.
;;
(define-class <z-piece> (<piece>))

;; OVERRIDING METHODS:  
;;
;; Contract: rotate:  (void) --> (void)
;; Purpose:  Rotates only between 0 and 1 directions.
;;           (Handles both left & right rotations)
;;
(define-method (piece-rotate-left (this <z-piece>))
  (piece-rotate this))
(define-method (piece-rotate-right (this <z-piece>))
  (piece-rotate this))

;; initializing current piece:
;;
(define 
new-piece
(lambda ()
  (let ((num (1+ (random 7))))
    (cond ((= num 1) (set! current (make <i-piece> #:row yINIT #:col xINIT #:type 'I)))
	  ((= num 2) (set! current (make <o-piece> #:row yINIT #:col xINIT #:type 'O)))
	  ((= num 3) (set! current (make <piece> #:row yINIT #:col xINIT #:type 'T)))
	  ((= num 4) (set! current (make <s-piece> #:row yINIT #:col xINIT #:type 'S)))
	  ((= num 5) (set! current (make <z-piece> #:row yINIT #:col xINIT #:type 'Z)))
	  ((= num 6) (set! current (make <piece> #:row yINIT #:col xINIT #:type 'L)))
	  ((= num 7) (set! current (make <piece> #:row yINIT #:col xINIT #:type 'J)))))))
	 

;;
;; Purpose: making new set of tiles:
(define 
new-tiles
(lambda ()
  (make-tiles (piece-row current)
	      (piece-col current)
	      (piece-dir current)
	      (piece-type current))))

;;
;; Purpose: making a new set of tiles:
(define 
fall-tiles
(lambda ()
  (make-tiles (1+ (piece-row current))
	      (piece-col current)
	      (piece-dir current)
	      (piece-type current))))


;;
;; Purpose: movement:
(define 
move-left
(lambda()
  (piece-move-left current)
  (let ((T (new-tiles)))
    (if (and (in-bounds? T)
	     (clear? T))
	(begin
	  (clear-piece tiles)
	  (draw-piece T)
	  (set! tiles T))
	(piece-move-right current)))))

;;
;; Purpose: movement:
(define
move-right
(lambda ()
  (piece-move-right current)
  (let ((T (new-tiles)))
    (if (and (in-bounds? T)
	     (clear? T))
	(begin
	  (clear-piece tiles)
	  (draw-piece T)
	  (set! tiles T))
	(piece-move-left current)))))
	 
;; rotation:
;;
(define 
rotate-left
(lambda ()
  (begin
    (piece-rotate-left current)
    (let ((T (new-tiles)))
      (if (and (in-bounds? T)
               (clear? T))
          (begin
            (clear-piece tiles)
            (draw-piece T)
            (set! tiles T))
          (piece-rotate-right current))))))



;;
;; Purpose: falling
;; pieces falling perpetually:
(define 
fall
(lambda ()
  (if (equal? current 'NONE) #t
      ;;otherwise...
      (let ((T (fall-tiles)))
        (if (and (in-bounds? T)
                 (clear? T))
            (begin
              (clear-piece tiles)
              (draw-piece T)
              (piece-fall current)
              (set! tiles T) #t)  ;; <-- signal continue

            ;; else:
            (begin
             (add-to-matrix tiles)
             (check-rows)
              (new-piece)
              (set! tiles (new-tiles))
              ;;end of game checking
              (if (not (clear? tiles))
                (begin
                  (display (string-append "game over. you had  " (number->string lines) " lines \n"))
                  (gtk-main-quit)))
             ; (draw-screen) 
             #f)) )))) ;; <-- signal stop


;;
;; Purpose: read the key from the gtk-entry and process it
(define
keyboard-dispatcher
(lambda (e)
  (let* ((l1 (string->list (get-text e)))
	 (key (if (zero? (length l1)) #\nul (list-ref l1 (1- (length l1))))))
    (cond ((char=? key #\nul) #f)
          ((char=? key #\w) (display "w pressed\n") (rotate-left))
	  ((char=? key #\a) (display "a pressed\n") (move-left))
	  ((char=? key #\s) (display "s pressed\n") (fall))
	  ((char=? key #\d) (display "d pressed\n") (move-right)))
    (set-text e ;(string-append "lines = " (number->string lines)))
              "")
    )))

;;
;;
;; MAIN PROGRAMME CODE:
(let* ((window (make <gtk-window> #:type 'toplevel))
       (vbox (make <gtk-vbox> #:homogeneous #f))
       (entry (make <gtk-entry> #:max-length 2 #:has-frame #f #:width-chars 1))
       (obj1 '()))


       ;;make the tiles and add them to the window (and also to the minimtrx)
       (do  ((i 0 (1+ i)))  ((= i ROWS)) 
	 (let ((hbox (make <gtk-hbox> #:homogeneous #t))
	       (list2 '()))
	   (do ((j 0 (1+ j)))  ((= j COLS))
	     (let ((item (make <gtk-image> #:pixbuf (gtk-image-get-pixbuf check0))))
	       (add hbox item)
	       (set! list2 (append list2 (list item)))))
	   (add vbox hbox)
	   (set! minimtrx (append minimtrx (list list2)))))
       ;;add the entry field

       (add vbox entry)

       (add window vbox)	 


   
	 (new-piece) ;;sets current to random piece


	(g-timeout-add 250 (lambda () (fall) #t))

       ;; add some signals
       ;; (connect window 'delete-event (lambda (w e) (gtk-widget-destroy w) #f))
       (connect window 'delete-event (lambda (w e) (gtk-main-quit) #f))
       (connect entry 'changed keyboard-dispatcher)
       ;;do it
       (gtk-widget-show-all window)
       (gtk-main)))