;
;
; Демонстрационная реализация ТЕТРИС для YLISP
;
; Авторское право (С) 2010 Слободюк А.Б.
;


(defconstant *delay* 0.03) ;задержка между опросами кл-ры
(defvar *remstep* 10) ; через сколько шагов опроса кл-ры продвигать фигуру

(defvar *bgcolor* #x70)

(defvar *win* nil) ; окно, где падают фигуры 

(setf *print-pretty* nil)

(defvar *score* 0)

;пара координат - позиция или размер
(defstruct pos y x) ; используется порядок координат,
                    ; принятый в матричном исчислении 

;преобразование список -> позиция
(defun convert-pos (l)
  (make-pos :y (first l) :x (second l)))

;список списков -> список позиций
(defun make-figtype (l)
    (mapcar #'convert-pos l))

;тип фигуры - это список из 4х позиций относительно ее центра
(defconstant *figure-types* 
  (make-array 3 :initial-contents 
    (mapcar #'make-figtype '(((0 0) (-1 0) (1 0) (-2 0))
                             ((0 0) (-1 0) (0 -1) (1 0))
                             ((0 0) (-1 0) (1 0) (1 1))))))

;для сокращения записи
(defmacro p (y x)
  `(make-pos :y ,y :x ,x))

;место, откуда стартует новая фигура
(defconstant *start-pos* (p 2 5))

(defun rot-clock (pos) ;повернуть точку относительно 0, 0 по часовой
  (make-pos :y (pos-x pos) :x (- (pos-y pos))))

(defun rot-aclock (pos) ;повернуть точку относительно 0, 0 против час
  (make-pos :y (- (pos-x pos)) :x (pos-y pos)))

(defstruct figure type color)
(defvar *figure*)

(defvar *cupsize* (p 24 11)) ; 4 линии не видны

;стакан
(defvar *cup* (make-array (list (pos-y *cupsize*) 
                                (pos-x *cupsize*)) 
                          :initial-element *bgcolor*))

(defvar *strings* (make-hash-table))
;заведем ХТ, чтобы не сильно мусорить
;похоже, это не работает, как задумано
(defun get-sop (length)
  (multiple-value-bind (val found) (gethash length *strings*)
    (if found val
      (setf (gethash length *strings*) 
            (make-string length :initial-element #\Space)))))

(defun draw-cup ()
  (dotimes (i (pos-y *cupsize*))
    (when (> i 3) ; первые 4 строки не отображаются, там появляются фигуры
      (do  ((end 1) (start 0) 
            (starcol (aref *cup* i 0)) (ecol))
           ((= start (pos-x *cupsize*)))
        (if (and (< end (pos-x *cupsize*))
                 (= starcol (setf ecol (aref *cup* i end))))
          (incf end)
          (progn
            (setf (window-color *win*) starcol
                  (cursor-position *win*) (vector (- i 4) (* 2 start)))
            (princ #++ (make-string (- end start) :initial-element #\Space) 
                       (get-sop (* 2 (- end start))) *win*)
            (setf start end end (1+ end) starcol ecol)))))))

(defun pos-add (p1 p2)
  (make-pos :y (+ (pos-y p1) (pos-y p2)) 
            :x (+ (pos-x p1) (pos-x p2))))

(defmacro cup-elt (pos)
  `(aref *cup* (pos-y ,pos) (pos-x ,pos)))

(defun put-point (point color)
  (setf (aref *cup* (pos-y point) (pos-x point)) color))

(defun draw-point (point color)
  (when (>= (pos-y point) 4)
    (setf (cursor-position *win*) 
          (vector (- (pos-y point) 4) (* 2 (pos-x point)))
          (window-color *win*) color)
    (princ "  " *win*)))

(defun diff-draw-figure (posl1 posl2 drawfunc color)
;чтобы не было мелькания перерисовываем только те позиции в posl2, 
;которых нет в posl1 (а те убираем)
;
;"posl" - position list
  (dolist (p posl1)
    (unless (member p posl2 :test #'equal)
      (funcall drawfunc p *bgcolor*)))
  (dolist (p posl2)
    (unless (member p posl1 :test #'equal)
      (funcall drawfunc p color))))

;эта ф-я не исп-ся
(defun draw-figure (figure position drawfunc erasep)
  (dolist (elt (figure-type figure))
    (funcall drawfunc (pos-add position elt) 
      (if erasep *bgcolor* (figure-color figure)))))

;столкновение?
(defun fig-collidep (figure position)
   (do* ;первую итерацию пропускаем, чтобы меньше писать
       ((typelist (cons nil (figure-type figure)) (cdr typelist))
        (coll-this nil (and typelist 
                            (not (= (cup-elt (pos-add (car typelist) 
                                                      position)) 
                                    *bgcolor*)))))
     ((or (null typelist) coll-this) coll-this)))

;за границей?
(defun fig-outbound (figure position)
  (do* ((typelist (cons nil (figure-type figure)) (cdr typelist))
        (new-pos nil (and typelist 
                          (pos-add position (car typelist))))
        (outbound nil (and new-pos
                          (or (< (pos-x new-pos) 0)
                          (>= (pos-x new-pos) (pos-x *cupsize*))
                          (< (pos-y new-pos) 0)
                          (>= (pos-y new-pos) (pos-y *cupsize*))))))
    ((or (null typelist) outbound) outbound)))

;нет столкновения, не за границей?
(defun fig-fit (figure position)
  (not (or (fig-outbound figure position)
           (fig-collidep figure position))))

(defun drop-all () ; всё летит вниз сквозь дно
  (dotimes (ii (pos-y *cupsize*))
    (let ((i (- (pos-y *cupsize*) ii 1)))
      (if (zerop i) 
        (dotimes (j (pos-x *cupsize*))
          (setf (aref *cup* i j) *bgcolor*))
        (dotimes (j (pos-x *cupsize*))
            (setf (aref *cup* i j) (aref *cup* (1- i) j)))))))


(defun drop-straight (i j) ; опустить столбец
  (setf (aref *cup* i j)
    (if (zerop i) *bgcolor*
      (let ((ucell (aref *cup* (1- i) j))) 
        (drop-straight (1- i) j)
        ucell))))

(defun drop-col (i j) ; опустить на одну, если есть 
  (unless (zerop i)   ; пустая ячейка в столбце (0..i j), иначе NIL
    (if (= (aref *cup* i j) (aref *cup* (1- i) j))
      (drop-col (1- i) j)
      (if (= (aref *cup* i j) *bgcolor*)
        (drop-straight i j)  ;всегда не NIL
        (drop-col (1- i) j)))))


(defun drop-bricks () ; каждый кирпич падает отдельно
  (do ()
    ((zerop 
       (loop for j from 0 to (1- (pos-x *cupsize*))
         count (drop-col (1- (pos-y *cupsize*)) j)))) (draw-cup)))

(defun cut-line (i)
  (dotimes (j (1- (pos-x *cupsize*)))
    (drop-straight i j)))

;1. стереть заполненные линии
;2. анимировать в стакане падение на нее
(defun check-n-drop ()
  ;сотрем полные линии
  (loop for i from (1- (pos-y *cupsize*)) downto 0
        do (when (loop for j from 0 to (1- (pos-x *cupsize*)) 
                       never (= (cup-elt (p i j)) *bgcolor*))
               (cut-line i) (incf *score*)
               (draw-cup))))

(defun new-figure()
   (setf *figure* (make-figure 
                      :type (aref *figure-types* (random 3)) 
                      :color (do ((color *bgcolor* 
                                      (* 16 (random 16))))
                                 ((/= *bgcolor* color) color)))
         *figure-pos* *start-pos*))

(defun cycle(i) 
  (let ((l (cons i nil)))
    (rplacd l l)))

(defun draw-score ()
  ;рисуем счет
  (setf (cursor-position *terminal-io*) (vector 5 40)
        (window-color *terminal-io*) #x60)
  (format t "Счет: ~D    " (* *score* 100)))

(defun tetris ()
  (let ((*win* (make-window (vector 2 10 (+ 2 -4 (pos-y *cupsize*)) 
                                     (+ 10 (* 2 (pos-x *cupsize*)))) 
                        *bgcolor*))
        (oldcolor (window-color *terminal-io*)))


    (setf (window-color *terminal-io*) #x16)
    (window-shot *terminal-io*)
    (clear-window *terminal-io*)
    (draw-cup) (draw-score)
    (new-figure)
    (format *status-output* "~% YLISP-Тетрис. Нажмите любую клавишу.")
    (read-char)
    (format *status-output* "~% YLISP-Тетрис. ")
    (do ((key nil (read-char-no-hang))
         (itno 0 (1+ itno))
         (gameover nil))
        ((or (eq key #\ESC) gameover))

      (when (eq key #\UP) ; повернуть фигуру
        (let* ((newtype (mapcar #'rot-aclock (figure-type *figure*)))
               ;новая фигура, чтобы проверить на столкновения
               (newfigure (make-figure :type newtype 
                                       :color (figure-color *figure*)))
               ;зацикленный список для mapcar
               (posl (cycle *figure-pos*)))
          (rplacd posl posl)
          (when (fig-fit newfigure *figure-pos*)
            (let ((oldposl (mapcar #'pos-add posl (figure-type *figure*)))
                  (newposl (mapcar #'pos-add posl newtype)))
            (diff-draw-figure oldposl newposl 
                     #'draw-point (figure-color *figure*))
            (setf *figure* newfigure)))))

      (when (eq key #\DOWN)
        (setf *remstep* 1))

      (let* ((movpos1 (if (zerop (rem itno *remstep*)) 
                         (pos-add *figure-pos* (p 1 0)) 
                                  *figure-pos*)) ;падение
             (movpos2 (pos-add ;двигаем под действием силы тяжести и мускульных усилий
                           (cond ((eq key #\LEFT) (p 0 -1))
                                 ((eq key #\RIGHT) (p 0 1))
                                 (t (p 0 0)))
                        movpos1))
             (ff1 (fig-fit *figure* movpos1))
             (ff2 (fig-fit *figure* movpos2))
             (sidecol (and ff1 (not ff2)))
             (nogo (and (not ff1) (not ff2)))
             (newpos (cond (nogo *figure-pos*)
                           (sidecol movpos1)
                           (t movpos2))))
         (setf (cursor-position *terminal-io*) (vector 20 0))
 ;        (format t "MP1 ~A FF1 ~5A ~T MP2 ~A FF2 ~5A C ~X BC ~X  " 
 ;          movpos1 ff1 movpos2 ff2 (figure-color *figure*) *bgcolor*)
 ;        (unless (and ff1 ff2) (sleep 0.5))
         (if nogo
           (if (eql *figure-pos* *start-pos*)
             (progn 
               (setf gameover t)
               (format *status-output* "~%Игра закончена! "))
             (progn ;фигура упала - рисуем кирпичи на ее месте
               (diff-draw-figure nil (mapcar #'pos-add 
                                           (figure-type *figure*) 
                                           (cycle *figure-pos*))
                            #'put-point (figure-color *figure*))
               ;проверяем полные линии
               (check-n-drop)
               ;запускаем новую фигуру
               (new-figure)
               ;рисуем счет
               (draw-score)
               ;если было активировано ускоренное падение
               (setf *remstep* 10)))
           ;нормальный полет
           (progn
             (diff-draw-figure (mapcar #'pos-add 
                                  (figure-type *figure*) 
                                  (cycle *figure-pos*))
                               (mapcar #'pos-add 
                                  (figure-type *figure*) 
                                  (cycle newpos))
                      #'draw-point (figure-color *figure*))
             (setf *figure-pos* newpos))))
         (sleep *delay*))
    (format *status-output* "Нажмите любую клавишу.")
    (read-char)
    (window-restore *terminal-io*)
    (setf (window-color *terminal-io*) oldcolor)
    (close *win*)))

(tetris)