Clojure Falling Blocks Game

A game with falling blocks in Clojure :-)

load it in the repl and start with

(game)

This code is loosely based on the Snake example in the excellent book Programming Clojure by Stuart Halloway.

(ns titres
(:import (java.awt Color Dimension)
         (javax.swing JPanel JFrame Timer JOptionPane)
         (java.awt.event ActionListener KeyListener WindowAdapter)) )

(def frame-millis 60)
(def cell-size 40)
(def width 10)
(def height 15)
(def dirs { java.awt.event.KeyEvent/VK_LEFT [-1 0]
            java.awt.event.KeyEvent/VK_RIGHT [1 0] })
(def frames-to-drop 6)

(def blocks  [ '([0 0] [1 0] [0 1] [1 1]) '([0 0] [1 0] [2 0] [0 1])
               '([0 0] [1 0] [2 0] [2 1]) '([0 0] [1 0] [1 1] [2 1]) 
               '([0 0] [1 0] [2 0] [1 1]) '([1 0] [2 0] [0 1] [1 1])
               '([0 0] [1 0] [2 0] [3 0]) ] )
(def colors [(Color. 15 160 70)  (Color. 160 15 70) (Color. 15 70 160)
             (Color. 70 160 15) (Color. 70 15 160) (Color. 160 70 15) (Color. 160 70 160)] )

(defn make-block 
 ([n]
  { :location [0 0] 
    :body  ( blocks n ) 
    :color ( colors n )})
 ([] (make-block (rand-int (count blocks)))))

(defn point-to-screen-rect [pt] 
  (map #(* cell-size %) [(pt 0) (pt 1)  1 1]))

(defn fill-point [g pt color]
  (let [[x y width height] (point-to-screen-rect pt)]
  (.setColor g color)
  (.fillRect g x y width height)))

(defn paint-block [g {:keys [body location color]}]
  (doseq [point body]
    (fill-point g  (vec (map + point location)) color)))

(defn paint-stash [g stash] 
  (doseq [m stash]
    (fill-point g (key m) (val m)))) 

(defn insert-to-stash [stash {:keys [body location color] }]
  (let [body-shifted (map #(vec (map + location %)) body) ]
    (merge stash (zipmap body-shifted (repeat color)) )))

(defn hits-bottom? [{:keys [location body] }]
  (let [[x y] (map + location (apply map max body))]
    (= y height) ))

(defn collision? [stash {:keys [location body]} direction]
  (let [body-shifted (map #(vec (map + location direction %)) body) ]
    (some #(contains? stash %) body-shifted) ))

(defn hits-stash? [stash block]
  (collision? stash block [0 1]))
 
(defn delete-row [stash row]
  (let [new-stash (filter #(not= row ((key %) 1)) stash)
        new-stash-keys ( map #( cond (< (% 1) row) 
                                (vec (map + % [0 1])) 
    :else % ) (keys new-stash) ) ]
    (zipmap new-stash-keys (vals new-stash))  ))

(defn count-row [stash row]
  (count (filter #(= row (% 1)) (keys stash))) )

(defn delete-rows [stash row]
  (if (> row height) stash 
   (if (> (count-row stash row)  width) 
      (recur  (delete-row stash row) (inc row) )
      (recur  stash (inc row) ) 
   ) ))
       
(defn transpose-pt [pt height]
  [(- height (pt 1)) (pt 0) ])

(defn rotate-right [{:keys [body] :as block}]
  (let [[width height] (apply map max body)]
    (assoc block :body (map #(transpose-pt % height) body))))

(defn rotate-left [block]
  (rotate-right (rotate-right (rotate-right block))))

(defn move [{:keys [location] :as block} direction]
  (assoc block :location (vec (map + location direction))) )

(defn block-hits-border? [{:keys [body location] } newdir]
  (let [min_x (first (map + (vec (apply map min body)) newdir location)) 
        max_x (first (map + (vec (apply map max body)) newdir location)) ]
  (or (< min_x 0) (> max_x width)) ))

(defn adjust-border [{:keys [body location] :as block}]
  (let [offset (- width (first (map + (apply map max body) location)))]
   (cond (< offset 0) (move block [offset 0]) 
    :else block ) ))

(defn update-position [stash block newdir]
  (when-not (or (collision? stash @block newdir) 

    (block-hits-border? @block newdir) ) 
    (dosync (alter block move newdir)) ))

(defn update-drop [stash block]
  (when-not (collision? stash @block [0 1])    
    (dosync (alter block move [0 1])) ))

(defn update-rotation [f stash block]
  (let [shifted-block (adjust-border (f @block))]
    (when-not (collision? stash shifted-block [0 0])   
      (dosync (ref-set block shifted-block)) )))  

(defn update-stash  [stash block]
  (dosync (alter stash insert-to-stash block))
  (dosync (alter stash delete-rows 0)) ) 

(defn game-panel [frame block]
(let [framecounter (ref  0)
      stash (ref {})]
(proxy [JPanel ActionListener KeyListener] []  
  (paintComponent [g]
   (proxy-super paintComponent g)
   (paint-block g @block)
   (paint-stash g @stash)
  )
  (actionPerformed [e] 
   (dosync (alter framecounter inc))
   (when (= 0 (mod @framecounter frames-to-drop)) 
    (update-drop @stash block)
    (when (or (hits-stash? @stash @block) (hits-bottom? @block)) 
     (update-stash stash @block)
     (dosync (ref-set block (make-block)))))
    (.repaint this) )
  (keyPressed [e]       
   (let [key (.getKeyCode e)]
   (cond 
     (= key java.awt.event.KeyEvent/VK_UP)   (update-rotation rotate-right @stash block)
     (= key java.awt.event.KeyEvent/VK_DOWN) (update-rotation rotate-left  @stash block)
     :else 
     (update-position @stash block (dirs key)) ))  )
  (keyReleased [e])
  (keyTyped [e])
  (getPreferredSize []
    (Dimension. (* (inc width) cell-size)
                (* (inc height) cell-size)))
)))

(defn frame-closing [timer] (proxy [WindowAdapter] []
                (windowClosing [e] (do (println "stopped") (.stop timer)))))

(defn game[]
  (let [frame (JFrame. "Tetris")
 block (ref (make-block))
        panel (game-panel frame block)
        timer (Timer. frame-millis panel)]
  (doto panel
   (.setFocusable true)
   (.addKeyListener panel))
  (doto frame
   (.addWindowListener  (frame-closing timer))
   (.add panel)
   (.pack)
   (.setVisible true))
   (.start timer) [timer]))