New tetris example

tatut · Aug 8, 2023 · 674bb21 · 674bb21
1 parent acf870e
commit 674bb21
Show file tree

Hide file tree

Showing 4 changed files with 292 additions and 0 deletions.
diff --git a/examples/tetris/deps.edn b/examples/tetris/deps.edn
@@ -0,0 +1,4 @@
+{:paths ["src" "../../resources" "resources"]
+ :deps {ripley {:local/root "../.."}
+        compojure {:mvn/version "1.6.1"}}
+ :aliases {:run {:main-opts ["-m" "tetris.main"]}}}
diff --git a/examples/tetris/resources/public/tetris.css b/examples/tetris/resources/public/tetris.css
@@ -0,0 +1,10 @@
+rect.e { fill: gray; }
+rect.f { fill: red; stroke-width: 1; stroke: black; }
+
+.tetris-container { position: absolute; left: 50%; top: 50%; width: 0; height: 0; }
+.tetris { width: 200px; position: relative; left: -100px; top: -200px; }
+.game-over { position: fixed; top: 50%; }
+
+.score {
+    font-weight: 900;
+}
diff --git a/examples/tetris/src/tetris/main.clj b/examples/tetris/src/tetris/main.clj
@@ -0,0 +1,92 @@
+(ns tetris.main
+  (:require [ripley.html :as h]
+            [ripley.js :as js]
+            [ripley.live.source :as source]
+            [compojure.core :refer [routes GET]]
+            [compojure.route :refer [resources]]
+            [org.httpkit.server :as server]
+            [ripley.live.context :as context]
+            [tetris.state :as state]))
+
+(defonce server (atom nil))
+
+(defn key->action
+  "Map keycode to game action the player can take."
+  [c]
+  (case c
+    (87 38) state/up    ; W or up arrow
+    (65 37) state/left  ; A or left arrow
+    (83 40) state/down  ; S or down arrow
+    (68 39) state/right ; D or right arrow
+    32      state/fall  ; space
+    nil))
+
+(defn tick-thread [update-gs! tick?]
+  (.start (Thread. #(loop []
+                      (Thread/sleep 500)
+                      (when @tick?
+                        (update-gs! state/tick)
+                        (recur))))))
+
+(defn game
+  "Main component of our tetris game."
+  []
+  (let [initial-state (state/initial-state!)
+        w (state/width initial-state)
+        h (state/height initial-state)
+        [gs _set-gs! update-gs!] (source/use-state initial-state)
+        tick? (atom true)
+        gs (assoc gs :cleanup-fn #(reset! tick? false))]
+    ;; Start a thread to tick our game, this could be a go block instead or something fancier
+    (tick-thread update-gs! tick?)
+    (h/out! "<!DOCTYPE html>")
+    (h/html
+     [:html
+      [:head
+       [:title "Tetris with Ripley"]
+       [:link {:rel :stylesheet :href "tetris.css"}]
+       (h/live-client-script "/_ws")]
+      [:body {:onkeydown (js/js #(some-> % key->action update-gs!) js/keycode)}
+       [:div.tetris-container
+        [:div.tetris
+         [:div.score
+          "SCORE: "
+          [::h/live (source/computed :score gs)
+           (fn [score]
+             (h/html
+              [:span score]))]]
+         [:svg {:width (* 20 w)
+                :height (* 20 h)}
+          [::h/for [y (range h)]
+           [::h/live
+            (source/computed #(nth (state/board-with-piece %) y) gs)
+            (fn [row]
+              (h/html
+               [:g.row
+                [::h/for [x (range w)
+                          :let [filled? (= 1 (nth row x))]]
+                 [:rect {:x (* 20 x) :y (* 20 y) :width 20 :height 20
+                         :class (if filled? "f" "e")}]]]))]]]
+         [::h/live (source/computed :game-over? gs)
+          #(h/html
+            [:dialog.game-over {:open %} "Game over"])]]]]])))
+
+(def tetris-routes
+  (routes
+   (GET "/" _req
+        (h/render-response game))
+   (resources "/")
+   (context/connection-handler "/_ws")))
+
+(defn restart
+  ([] (restart 3000))
+  ([port]
+   (swap! server
+          (fn [old-server]
+            (when old-server
+              (old-server))
+            (println "Starting Tetris server on port " port)
+            (server/run-server tetris-routes {:port port})))))
+
+(defn -main []
+  (swap! server ()))
diff --git a/examples/tetris/src/tetris/state.clj b/examples/tetris/src/tetris/state.clj
@@ -0,0 +1,186 @@
+(ns tetris.state
+  "Tetris game logic state")
+
+(def pieces [[[1 1]
+              [1 1]]
+
+             [[1]
+              [1]
+              [1]
+              [1]]
+
+             [[0 1 1]
+              [1 1 0]]
+
+             [[1 1 0]
+              [0 1 1]]
+
+             [[1 0]
+              [1 0]
+              [1 1]]
+
+             [[0 1]
+              [0 1]
+              [1 1]]
+
+             [[1 1 1]
+              [0 1 0]]])
+
+(def board-size {:width 10 :height 20})
+
+(defn rotate [rows]
+  (let [row-count (count (first rows))
+        col-count (count rows)]
+    (vec (for [r (range row-count)]
+           (vec
+            (for [c (range col-count)]
+              (get-in rows [(- col-count c 1) r])))))))
+
+(defn random-piece! []
+  (rand-nth pieces))
+
+(comment
+  ;; Test every piece rotates correctly
+  (every? #(= % (nth (iterate rotate %) 4)) pieces)
+  ,,,)
+
+(defn initial-state!
+  "Generate initial game state, with random pieces."
+  []
+  (let [{:keys [width height]} board-size]
+    {:current-piece (random-piece!)
+     :piece-position [(- (/ width 2) 2) 0] ;; [x y] coordinate of piece
+     :next-piece (random-piece!)
+     :board (vec
+             (repeat height
+                     (vec (repeat width 0))))
+     :game-over? false
+     :score 0}))
+
+(defn can-occupy? [{b :board} piece [x y]]
+  (let [w (count (first b))
+        h (count b)]
+    (every? (fn [row-idx]
+              (let [board-y (+ y row-idx)
+                    row (and (< board-y h) (nth piece row-idx))]
+                (when row
+                  (every? (fn [col-idx]
+                            (let [board-x (+ x col-idx)
+                                  col (nth row col-idx)]
+                              (or (zero? col)
+                                  (and (< board-x w)
+                                       (zero? (get-in b [board-y board-x]))))))
+                          (range (count row))))))
+            (range (count piece)))))
+
+(defn occupy
+  "Occupy the given piece at given position on the board. Returns new game state."
+  [state piece [x y]]
+  (update state :board
+          (fn [b]
+            (reduce (fn [b [xp yp]]
+                      (if (zero? (get-in piece [yp xp]))
+                        b
+                        (assoc-in b [(+ y yp) (+ x xp)] 1)))
+                    b
+                    (for [x (range (count (first piece)))
+                          y (range (count piece))]
+                      [x y])))))
+
+(defn board-with-piece
+  "Get board with the current piece filled in."
+  [{:keys [board current-piece piece-position] :as gs}]
+  (:board (occupy gs current-piece piece-position)))
+
+(defn width [{b :board}]
+  (count (first b)))
+
+(defn height [{b :board}]
+  (count b))
+
+(defn- if-can-occupy [state update-fn]
+  (let [{:keys [current-piece piece-position] :as new-state} (update-fn state)]
+    (if (can-occupy? state current-piece piece-position)
+      new-state
+      state)))
+
+;; Players actions for game state
+(defn up
+  "Rotate current piece clockwise."
+  [state]
+  (if-can-occupy state #(update % :current-piece rotate)))
+
+(defn down
+  "Rotate current piece counterclockwise."
+  [state]
+  (if-can-occupy state #(update % :current-piece (fn [p]
+                                                 (nth (iterate rotate p) 3)))))
+
+
+(defn left
+  "Move current piece one place left."
+  [state]
+  (if-can-occupy state #(update % :piece-position (fn [[x y]] [(dec x) y]))))
+
+(defn right
+  "Move current piece one place right."
+  [state]
+  (if-can-occupy state #(update % :piece-position (fn [[x y]] [(inc x) y]))))
+
+(defn spawn
+  "Spawn the next piece, if the piece can't spawn, mark the game as over."
+  [{np :next-piece :as state}]
+  (let [w (width state)
+        pos [(dec (/ w 2)) 0]]
+    (if (can-occupy? state np pos)
+      ;; New piece can be spawned
+      (assoc state
+             :current-piece np
+             :piece-position pos
+             :next-piece (random-piece!))
+      ;; Can't spawn, game over :(
+      (assoc state :game-over? true))))
+
+(defn clear-filled
+  "Clear full lines"
+  [{b :board :as state}]
+  (let [h (height state)
+        w (width state)
+        lines (remove (fn [row]
+                        (every? #(= 1 %) row))
+                      b)
+        cleared-lines (- h (count lines))
+        score (if (pos? cleared-lines)
+                (nth (iterate #(* % 2) 10) cleared-lines)
+                0)]
+    (-> state
+        (update :score + score)
+        (assoc :board
+               (into (vec (repeat cleared-lines (vec (repeat w 0))))
+                     lines)))))
+
+(defn tick
+  "Drop current piece 1 row down. If current piece can't move down, it will occupy
+  the current position and the next piece will be spawned."
+  [{p :current-piece [x y] :piece-position :as state}]
+  (let [new-pos [x (inc y)]]
+    (if (can-occupy? state p new-pos)
+      ;; Can move down
+      (assoc state :piece-position new-pos)
+
+      ;; Can't move down, occupy the positions and spawn new piece.
+      (-> state
+          (occupy p [x y])
+          clear-filled
+          spawn))))
+
+(defn fall
+  "Let the current piece fall as low as it can."
+  [{p :current-piece :as state}]
+  (loop [[x y] (:piece-position state)]
+    (if (can-occupy? state p [x (inc y)])
+      (recur [x (inc y)])
+      (-> state
+          (occupy p [x y])
+          clear-filled
+          spawn))))