Tetris implementation in Clojure

tetris.clj

(ns tetris.core
  (:import (java.awt Color Dimension BorderLayout)
    (javax.swing JPanel JFrame JOptionPane JButton JLabel)
    (java.awt.event KeyListener))
  (:use clojure.contrib.import-static deflayout.core
        clojure.contrib.swing-utils)
  (:gen-class))

(import-static java.awt.event.KeyEvent VK_LEFT VK_RIGHT VK_DOWN VK_UP VK_SPACE)

(def empty-cell 0)
(def filled-cell 2)
(def moving-cell 1)
(def glass-width 10)
(def glass-height 20)
(def zero-coords [3 0])

(def stick [[0 0 0 0] 
            [1 1 1 1] 
            [0 0 0 0] 
            [0 0 0 0]])

(def square [[1 1]
             [1 1]])

(def tblock [[0 0 0]
             [1 1 1] 
             [0 1 0]])

(def sblock [[0 1 0] 
             [0 1 1] 
             [0 0 1]])

(def zblock [[0 0 1] 
             [0 1 1] 
             [0 1 0]])

(def lblock [[1 1 0] 
             [0 1 0] 
             [0 1 0]])

(def jblock [[0 1 1] 
             [0 1 0] 
             [0 1 0]])

(def figures [stick square tblock sblock zblock lblock jblock])

(def create-vector (comp vec repeat))
  
(defn create-glass []
  (create-vector glass-height
                 (create-vector glass-width empty-cell)))

(defn pick-cell [figure x y]
  (get-in figure [y x]))

(defn mapmatrix [func matrix]
  (into [] (map-indexed (fn [y vect]
                          (into [] (map-indexed (fn [x el]
                                                  (func el x y))
                                                vect)))
                        matrix)))
           
(defn rotate-figure [fig]
  (let [fsize (count fig)]
    (mapmatrix #(pick-cell fig (- fsize %3 1) %2) fig)))

(defn apply-fig [glass fig [figx figy]]
  (let [fsize (count fig)]
    (mapmatrix (fn[el gx gy]
                 (if (and
                       (<= figx gx (+ figx fsize -1))
                       (<= figy gy (+ figy fsize -1)))
                   (+ el (pick-cell fig (- gx figx) (- gy figy)))
                   el))
      glass)))

(defn destroy-filled [glass]
  (let [clear-glass
        (remove (fn[vect] 
                  (not-any? #(= % empty-cell) vect)) glass)
        destroyed (- glass-height (count clear-glass))]
    [(into (vec (repeat 
                 destroyed
                 (create-vector glass-width empty-cell)))
           (vec clear-glass)) destroyed]))

(defn fix-figure [glass-with-fig]
  (mapmatrix (fn [el & _]
               (if (= el moving-cell)
                  filled-cell
                  el))
    glass-with-fig))

(defn count-cells [glass value]
  (reduce + (map (fn [vect]
                   (count (filter #{value} vect)))
                 glass)))

(defn legal? [glass]
  (= (count-cells glass moving-cell) 4))

(defn move 
  ([glass fig [figx figy] shiftx shifty]
     (let [newx (+ figx shiftx)
           newy (+ figy shifty)
           newglass (apply-fig glass fig [newx newy])]
       (when (legal? newglass) [newx newy])))
  ([glass fig coords direction]
     (condp = direction
         :down (move glass fig coords 0 1)
         :left (move glass fig coords -1 0)
         :right (move glass fig coords 1 0))))

(def score-per-line 10)
 
(defmacro defatoms [& atoms]
  `(do
     ~@(map (fn[a#] `(def ~a# (atom nil))) atoms)))

(defatoms *glass* *fig-coords* *current-fig* *next-fig* *score*)

(defn complete-glass []
  (apply-fig @*glass* @*current-fig* @*fig-coords*))

(defn done-callback [n]
  (swap! *score* #(+ % (* n score-per-line))))
 
(defn move-to-side [side]
  (let [newcoords
        (move @*glass* @*current-fig* @*fig-coords* side)]
    (if newcoords
      (reset! *fig-coords* newcoords))))

(defn move-down []
  (let [newcoords
        (move @*glass* @*current-fig* @*fig-coords* :down)]
    (if newcoords
      (reset! *fig-coords* newcoords)
      (let [[newglass d-count] (-> (complete-glass) 
                                   fix-figure
                                   destroy-filled)]
        (reset! *glass* newglass)
        (reset! *fig-coords* zero-coords)
        (reset! *current-fig* @*next-fig*)
        (reset! *next-fig* (rand-nth figures))
        (done-callback d-count)
        (when-not (legal? (complete-glass)) :lose)))))

(defn move-all-down []
  (move-down)
  (let [newcoords
        (move @*glass* @*current-fig* @*fig-coords* :down)]
    (when newcoords (recur))))
  
(defn rotate-current []
  (let [rotated (rotate-figure @*current-fig*)]
    (if (legal? (apply-fig @*glass* rotated @*fig-coords*))
      (swap! *current-fig* rotate-figure))))

(defn new-game []
  (reset! *glass* (create-glass))
  (reset! *fig-coords* zero-coords)
  (reset! *current-fig* (rand-nth figures))
  (reset! *next-fig* (rand-nth figures))
  (reset! *score* 0))

(def cell-size 20)
(def border-size 3)
(def timer-interval 300)
(def game-running (atom false))

(defn fill-point [g [x y] color]
  (.setColor g color)
  (.fillRect g 
    (* x cell-size) (* y cell-size)
    cell-size cell-size)
  (when-not (= color (Color/gray))
    (.setColor g (.brighter color))
    (.fillRect g
      (* x cell-size) (* y cell-size)
      border-size cell-size)
    (.fillRect g
      (* x cell-size) (* y cell-size)
      cell-size border-size)
    (.setColor g (.darker color))
    (.fillRect g
      (- (* (inc x) cell-size) border-size) (* y cell-size)
      border-size cell-size)
    (.fillRect g
      (* x cell-size) (- (* (inc y) cell-size) border-size)
      cell-size border-size)))
  
(defn get-color [cell]
  (condp = cell
      empty-cell (Color/gray)
      filled-cell (Color. 128 0 0)
      moving-cell (Color. 0 128 0)
      (Color/black)))

(defn paint-glass [g glass]
  (mapmatrix (fn[cell x y]
               (fill-point g [x y] (get-color cell)))
    glass))
  
(defn game-panel []
  (proxy [JPanel KeyListener] []
    (paintComponent [g]
                    (proxy-super paintComponent g)
                    (doall (paint-glass g (complete-glass))))
    (keyPressed [e]
                (let [keycode (.getKeyCode e)]
                  (do (condp = keycode
                          VK_LEFT (move-to-side :left)
                          VK_RIGHT (move-to-side :right)
                          VK_DOWN (move-down)
                          VK_UP (rotate-current)
                          VK_SPACE (move-all-down))
                      (.repaint this))))
    (getPreferredSize []
                      (Dimension. (* glass-width cell-size)
                                  (* glass-height cell-size)))
    (keyReleased [e])
    (keyTyped [e])))

(defn next-panel []
  (proxy [JPanel] []
    (paintComponent [g]
      (proxy-super paintComponent g)
      (doall (paint-glass g @*next-fig*)))
    (getPreferredSize []
      (Dimension. (* 4 cell-size)
        (* 4 cell-size)))))

(defn game[]
  (new-game)
  (reset! game-running true)
  (let [gamepanel (game-panel)
        sidepanel (JPanel.)
        nextpanel (next-panel)
        scorelabel (JLabel. "Score: 0")
        exitbutton (JButton. "Exit")
        frame (JFrame. "Tetris")]
    (deflayout
      frame (:border)
      {:WEST gamepanel
       :EAST (deflayout (JPanel.) (:border)
               {:NORTH (deflayout sidepanel (:flow :TRAILING)
                         [nextpanel scorelabel])
                :SOUTH exitbutton})})
    (doto gamepanel
      (.setFocusable true)
      (.addKeyListener gamepanel)
      (.repaint))
    (doto frame
      (.pack)
      (.setVisible true))
    (doto exitbutton
      (add-action-listener #(reset! game-running false)))
    (loop []
      (when @game-running
        (let [res (move-down)]
          (if (= res :lose)
            (JOptionPane/showMessageDialog frame "You lose!" )
            (do               
              (.repaint gamepanel)
              (.repaint nextpanel)
              (.setText scorelabel (str "Score: " @*score*))
              (. Thread sleep timer-interval)
              (recur))))))))

(defn -main [& args]
  (game))