├── src └── games │ ├── puzzle │ ├── core.cljs │ ├── subs.cljs │ ├── controls.cljs │ ├── events.cljs │ ├── db.cljs │ └── views.cljs │ ├── views │ ├── util.cljs │ ├── about.cljs │ └── components.cljs │ ├── debug │ ├── subs.cljs │ ├── events.cljs │ ├── controls.cljs │ ├── db.cljs │ ├── core.cljs │ └── views.cljs │ ├── controls │ ├── core.cljs │ ├── views.cljs │ ├── db.cljs │ ├── events.cljs │ └── re_pressed.cljs │ ├── core.cljs │ ├── puyo │ ├── shapes.cljs │ ├── events.cljs │ ├── controls.cljs │ ├── subs.cljs │ ├── views.cljs │ ├── db.cljs │ ├── views │ │ └── classic.cljs │ └── core.cljs │ ├── tetris │ ├── events.cljs │ ├── controls.cljs │ ├── views.cljs │ ├── subs.cljs │ ├── shapes.cljs │ ├── db.cljs │ ├── views │ │ └── classic.cljs │ └── core.cljs │ ├── views.cljs │ ├── db.cljs │ ├── color.cljs │ ├── events │ ├── timeout.cljs │ └── interceptors.cljs │ ├── subs.cljs │ ├── select │ └── views.cljs │ ├── grid │ ├── views.cljs │ └── core.cljs │ └── events.cljs ├── bin └── kaocha ├── public ├── css │ ├── main.css │ └── reset.css └── index.html ├── test └── games │ ├── core_test.cljs │ └── grid │ └── core_test.cljs ├── .gitignore ├── package.json ├── shadow-cljs.edn ├── tests.edn ├── deps.edn ├── LICENSE └── readme.org /src/games/puzzle/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.core) 2 | -------------------------------------------------------------------------------- /bin/kaocha: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | clojure -A:test -m kaocha.runner "$@" 3 | -------------------------------------------------------------------------------- /public/css/main.css: -------------------------------------------------------------------------------- 1 | 2 | .selection:hover { 3 | background: rgba(255, 255, 255, 0.2) 4 | } 5 | -------------------------------------------------------------------------------- /src/games/views/util.cljs: -------------------------------------------------------------------------------- 1 | (ns games.views.util) 2 | 3 | (defn with-precision [p num] 4 | (let [num (or num 0)] 5 | (.toFixed num p))) 6 | -------------------------------------------------------------------------------- /test/games/core_test.cljs: -------------------------------------------------------------------------------- 1 | (ns games.core-test 2 | (:require 3 | [cljs.test :as t :refer-macros [deftest is testing]])) 4 | 5 | 6 | (deftest fake-test 7 | (testing "fake description" 8 | (is (= 1 1)))) 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .idea 3 | tmp/ 4 | *.log 5 | target 6 | *-init.clj 7 | public/js/compiled 8 | public/css/screen.css 9 | out 10 | .nrepl-port 11 | .shadow-cljs/ 12 | node_modules/ 13 | reframe-games.zip 14 | .cpcache/ 15 | 16 | .cljs_node_repl/ 17 | -------------------------------------------------------------------------------- /src/games/debug/subs.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.subs 2 | (:require [re-frame.core :as rf])) 3 | 4 | (rf/reg-sub 5 | ::debug-game-opts 6 | (fn [db] 7 | (let [games (vals (:games db)) 8 | game-opts (map :game-opts games)] 9 | (filter :debug-game? game-opts)))) 10 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "games", 3 | "main": "index.js", 4 | "devDependencies": { 5 | "shadow-cljs": "^2.8.83" 6 | }, 7 | "dependencies": { 8 | "create-react-class": "^15.6.3", 9 | "highlight.js": "9.15.10", 10 | "react": "^16.12.0", 11 | "react-dom": "^16.12.0", 12 | "react-highlight.js": "1.0.7" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /src/games/controls/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.controls.core) 2 | 3 | (defn ->id 4 | "Converts a passed id and game-opts to a viable control-id." 5 | [id game-opts] 6 | (let [ns (namespace ::x) 7 | id (str (name id) "-" (name (:name game-opts)))] 8 | (keyword ns id))) 9 | 10 | (comment 11 | (->id :move-left {:name :my-game})) 12 | 13 | ;; TODO explore control 'profiles' - premade and byo 14 | ;; supporting that might mean editable controls for free 15 | 16 | -------------------------------------------------------------------------------- /src/games/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.core 2 | (:require 3 | [reagent.core :as reagent] 4 | [games.views :as views] 5 | [games.events :as events] 6 | [games.events.timeout] ;; make sure this is required 7 | [re-frame.core :as rf])) 8 | 9 | (defn dev-setup [] 10 | (enable-console-print!)) 11 | 12 | (defn mount-root [] 13 | (reagent/render [views/root] 14 | (.getElementById js/document "app"))) 15 | 16 | (defn ^:export init 17 | "Called on page-load in public/index.html. 18 | Only called once - does not get called on 'live-reloads' during development. 19 | " 20 | [] 21 | (dev-setup) 22 | (mount-root) 23 | 24 | (rf/dispatch-sync [::events/init])) 25 | -------------------------------------------------------------------------------- /shadow-cljs.edn: -------------------------------------------------------------------------------- 1 | {:deps {:aliases [:nrepl :cljs]} 2 | 3 | :source-paths ["src" "test"] 4 | 5 | :nrepl {:port 2988 6 | :middleware 7 | [cider-nrepl.plugin/middleware 8 | refactor-nrepl.middleware/wrap-refactor]} 9 | 10 | :builds 11 | {:app {:target :browser 12 | :modules {:main {:entries [games.core]}} 13 | :output-dir "public/js/compiled" 14 | :asset-path "/js/compiled" 15 | :closure-defines {} 16 | :devtools 17 | {:http-root "public" 18 | :http-port 2989 19 | :loader-mode :eval 20 | :after-load games.core/mount-root 21 | :preloads [devtools.preload]}}}} 22 | -------------------------------------------------------------------------------- /src/games/puyo/shapes.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.shapes) 2 | 3 | 4 | (defn build-piece-fn [colors] 5 | (let [[colorA colorB] colors] 6 | (fn [{x :x y :y}] 7 | [{:x x :y y :anchor? true :color colorA} 8 | {:x x :y (- y 1) :color colorB}]))) 9 | 10 | (defn next-bag 11 | "'bag' terminology carried over from tetris." 12 | [{:keys [game-opts min-queue-size]}] 13 | (let [colors (:colors game-opts)] 14 | (repeatedly min-queue-size 15 | (fn [] 16 | [(rand-nth colors) (rand-nth colors)])))) 17 | 18 | (comment 19 | (let [colors [:red :blue :green]] 20 | (repeatedly 4 21 | (fn [] 22 | [(rand-nth colors) (rand-nth colors)])))) 23 | -------------------------------------------------------------------------------- /src/games/puzzle/subs.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.subs 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.grid.core :as grid])) 5 | 6 | (defn ->grid 7 | [cells] 8 | (-> {:height 5 :width 5} 9 | (grid/build-grid) 10 | (grid/add-cells 11 | {:update-cell #(assoc % :color 12 | (rand-nth [:red :blue :green])) 13 | :cells (map #(grid/relative {:x 1 :y 1} %) cells)}))) 14 | 15 | (rf/reg-sub 16 | ::piece-grids 17 | (fn [db [_ game-opts]] 18 | (let [piece-cells 19 | (-> db :games (get (:name game-opts)) :pieces)] 20 | (map 21 | (fn [{:keys [cells] :as piece}] 22 | [piece (->grid cells)]) 23 | piece-cells)))) 24 | -------------------------------------------------------------------------------- /src/games/puyo/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.events 2 | (:require 3 | [games.events :as events] 4 | [games.puyo.core :as puyo])) 5 | 6 | (events/reg-game-events 7 | {:n (namespace ::x) 8 | :step-fn puyo/step}) 9 | 10 | (events/reg-game-move-events 11 | {:n (namespace ::x) 12 | :move-piece puyo/move-piece 13 | :instant-fall puyo/instant-fall 14 | :after-piece-played puyo/after-piece-played 15 | :rotate-piece puyo/rotate-piece}) 16 | 17 | (events/reg-hold-event 18 | {:n (namespace ::x) 19 | :can-player-move? puyo/can-player-move? 20 | :clear-falling-cells puyo/clear-falling-cells 21 | :add-preview-piece puyo/add-preview-piece 22 | :on-hold (fn [db] (update db :current-piece-num dec))}) 23 | -------------------------------------------------------------------------------- /src/games/tetris/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.events 2 | (:require 3 | [games.tetris.core :as tetris] 4 | [games.events :as events])) 5 | 6 | ;; register game events 7 | (events/reg-game-events 8 | {:n (namespace ::x) 9 | :step-fn tetris/step}) 10 | 11 | (events/reg-game-move-events 12 | {:n (namespace ::x) 13 | :move-piece tetris/move-piece 14 | :instant-fall tetris/instant-fall 15 | :after-piece-played tetris/after-piece-played 16 | :rotate-piece tetris/rotate-piece}) 17 | 18 | ;; TODO gravity-grid namespace? 19 | (events/reg-hold-event 20 | {:n (namespace ::x) 21 | :can-player-move? tetris/can-player-move? 22 | :clear-falling-cells tetris/clear-falling-cells 23 | :add-preview-piece tetris/add-preview-piece}) 24 | -------------------------------------------------------------------------------- /src/games/debug/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.events 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.events.interceptors :refer [game-db-interceptor]] 5 | [games.debug.core :as debug] 6 | [games.events :as events])) 7 | 8 | ;; register game events 9 | (events/reg-game-events 10 | {:n (namespace ::x) 11 | ;; TODO handle no-step cases, optional timers 12 | :step-fn identity}) 13 | 14 | (events/reg-game-move-events 15 | {:n (namespace ::x) 16 | :move-piece debug/move-piece 17 | :instant-fall debug/instant-fall 18 | :rotate-piece debug/rotate-piece}) 19 | 20 | (rf/reg-event-db 21 | ::add-piece 22 | [(game-db-interceptor)] 23 | (fn [db _game-opts] 24 | (debug/add-pieces db))) 25 | 26 | (rf/reg-event-db 27 | ::toggle-debug 28 | [(game-db-interceptor)] 29 | (fn [db _game-opts] 30 | (update-in db [:game-opts :debug?] not))) 31 | -------------------------------------------------------------------------------- /tests.edn: -------------------------------------------------------------------------------- 1 | ;; tests.edn 2 | #kaocha/v1 3 | {:tests [{:id :unit-cljs 4 | :type :kaocha.type/cljs 5 | :test-paths ["test"] 6 | :cljs/timeout 10000 7 | :cljs/repl-env cljs.repl.node/repl-env 8 | }] 9 | 10 | :plugins [ 11 | ;; circular dep, apparently... 12 | ;; :kaocha.plugin/cloverage 13 | :kaocha.plugin/notifier 14 | ] 15 | 16 | :cloverage/opts 17 | {:ns-exclude-regex [], 18 | :text? false, 19 | :lcov? false, 20 | :high-watermark 80, 21 | :fail-threshold 0, 22 | :output "target/coverage", 23 | :low-watermark 50, 24 | :ns-regex [], 25 | :summary? true, 26 | :coveralls? false, 27 | :emma-xml? false, 28 | :html? true, 29 | :nop? false, 30 | :codecov? false} 31 | } 32 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src"] 2 | 3 | :deps {org.clojure/clojure {:mvn/version "1.10.1"} 4 | org.clojure/clojurescript {:mvn/version "1.10.597"} 5 | 6 | reagent {:mvn/version "0.9.1"} 7 | re-frame {:mvn/version "0.11.0"} 8 | re-pressed {:mvn/version "0.3.1"} 9 | 10 | 11 | binaryage/devtools {:mvn/version "1.0.0"} 12 | adzerk/cljs-console {:mvn/version "0.1.1"}} 13 | 14 | :aliases 15 | {:cljs 16 | {:extra-deps {thheller/shadow-cljs {:mvn/version "2.8.77"}}} 17 | 18 | :test 19 | {:extra-paths ["test"] 20 | :extra-deps 21 | {lambdaisland/kaocha {:mvn/version "0.0-590"} 22 | lambdaisland/kaocha-cljs {:mvn/version "0.0-68"} 23 | lambdaisland/kaocha-cloverage {:mvn/version "0.0-41"}}} 24 | 25 | :nrepl {:extra-deps 26 | {cider/cider-nrepl {:mvn/version "0.23.0"} 27 | refactor-nrepl {:mvn/version "2.4.0"}}}}} 28 | -------------------------------------------------------------------------------- /src/games/controls/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.controls.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.subs :as subs] 5 | [games.views.components :as components])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Controls-mini 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defn mini-text 12 | "Lists passed controls in text. 13 | The expected controls passed are the control's `:id`" 14 | [{:keys [controls]}] 15 | [components/widget 16 | {:style 17 | {:padding "0.9rem" 18 | :flex "1"}} 19 | (doall 20 | (for [ctr controls] 21 | (let [{:keys [label event keys]} 22 | @(rf/subscribe [::subs/controls-for ctr])] 23 | (when (and keys event) 24 | ^{:key label} 25 | [:p 26 | {:style {:margin-bottom "0.3rem"} 27 | :on-click #(rf/dispatch event)} 28 | (str label " (" (first keys) ")")]))))]) 29 | 30 | -------------------------------------------------------------------------------- /src/games/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.views 2 | (:require 3 | [games.puyo.views.classic :as puyo.classic] 4 | [games.puzzle.views :as puzzle.views] 5 | [games.tetris.views.classic :as tetris.classic] 6 | [games.debug.views :as debug.views] 7 | [games.views.about :as views.about] 8 | [games.subs :as subs] 9 | [games.select.views :as select.views] 10 | [re-frame.core :as rf])) 11 | 12 | (defn show-page 13 | [] 14 | (let [page @(rf/subscribe [::subs/current-page]) 15 | page (or page :select)] 16 | (case page 17 | ;; TODO restore proper controls view, perhaps as a modal intead of a page 18 | ;; :controls [controls.views/page] 19 | :controls [debug.views/page] 20 | :about [views.about/page] 21 | 22 | :tetris [tetris.classic/page] 23 | :puyo [puyo.classic/page] 24 | :puzzle [puzzle.views/page] 25 | 26 | :debug [debug.views/page] 27 | :select [select.views/page]))) 28 | 29 | (defn root [] 30 | (rf/clear-subscription-cache!) 31 | [:div#root 32 | {:style {:width "100vw"}} 33 | [show-page]]) 34 | 35 | -------------------------------------------------------------------------------- /src/games/debug/controls.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.controls 2 | (:require [games.controls.core :as controls])) 3 | 4 | (defn initial 5 | [game-opts] 6 | [{:id (controls/->id ::move-left game-opts) 7 | :label "Move Left" 8 | :keys (set ["left" "h" "a"]) 9 | :event [:games.debug.events/move-piece game-opts :left]} 10 | {:id (controls/->id ::move-down game-opts) 11 | :label "Move Down" 12 | :keys (set ["down" "j" "s"]) 13 | ;; :event [:games.debug.events/instant-fall game-opts :down] 14 | :event [:games.debug.events/move-piece game-opts :down]} 15 | {:id (controls/->id ::move-right game-opts) 16 | :label "Move Right" 17 | :keys (set ["right" "l" "d"]) 18 | :event [:games.debug.events/move-piece game-opts :right]} 19 | {:id (controls/->id ::move-up game-opts) 20 | :label "Move Up" 21 | :keys (set ["up" "k" "s"]) 22 | :event [:games.debug.events/move-piece game-opts :up]} 23 | {:id (controls/->id ::rotate game-opts) 24 | :label "Rotate" 25 | :keys (set ["space"]) 26 | :event [:games.debug.events/rotate-piece game-opts]}]) 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Russell Matney 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 17 | 18 | 19 | 20 | 27 | 28 | 29 | 30 |
31 | 32 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/games/controls/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.controls.db) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Global controls 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (def global-controls 8 | [{:id ::home-nav 9 | :label "Home" 10 | :keys (set ["m" "x"]) 11 | :event [:games.events/set-page :select]} 12 | {:id ::controls-nav 13 | :label "Controls" 14 | :keys (set ["c" "?"]) 15 | :event [:games.events/set-page :controls]} 16 | {:id ::about-nav 17 | :label "About" 18 | :keys (set ["b"]) 19 | :event [:games.events/set-page :about]} 20 | {:id ::tetris-nav 21 | :label "Play Tetris" 22 | :keys (set ["t"]) 23 | :event [:games.events/set-page :tetris]} 24 | {:id ::puyo-nav 25 | :label "Play Puyo-Puyo" 26 | :keys (set ["p"]) 27 | :event [:games.events/set-page :puyo]} 28 | {:id ::puzzle-nav 29 | :label "Play Puzzle" 30 | :keys (set ["z"]) 31 | :event [:games.events/set-page :puzzle]} 32 | {:id ::debug-nav 33 | :label "Debug view" 34 | :keys (set ["d"]) 35 | :event [:games.events/set-page :debug]}]) 36 | 37 | -------------------------------------------------------------------------------- /src/games/puzzle/controls.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.controls 2 | (:require [games.controls.core :as controls])) 3 | 4 | (defn initial 5 | [game-opts] 6 | [{:id (controls/->id ::move-left game-opts) 7 | :label "Move Left" 8 | :keys (set ["left" "h" "a"]) 9 | :event [:games.puzzle.events/move-piece game-opts :left]} 10 | {:id (controls/->id ::move-down game-opts) 11 | :label "Move Down" 12 | :keys (set ["down" "j" "s"]) 13 | :event [:games.puzzle.events/move-piece game-opts :down]} 14 | {:id (controls/->id ::move-up game-opts) 15 | :label "Move Up" 16 | :keys (set ["up" "k" "w"]) 17 | :event [:games.puzzle.events/move-piece game-opts :up]} 18 | {:id (controls/->id ::move-right game-opts) 19 | :label "Move Right" 20 | :keys (set ["right" "l" "d"]) 21 | :event [:games.puzzle.events/move-piece game-opts :right]} 22 | {:id (controls/->id ::rotate game-opts) 23 | :label "Rotate" 24 | :keys (set ["space"]) 25 | :event [:games.puzzle.events/rotate-piece game-opts]} 26 | {:id (controls/->id ::set-piece game-opts) 27 | :label "Set Piece" 28 | :keys (set ["enter"]) 29 | :event [:games.puzzle.events/set-piece game-opts]}]) 30 | -------------------------------------------------------------------------------- /src/games/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.db 2 | (:require 3 | [games.tetris.db :as tetris.db] 4 | [games.puzzle.db :as puzzle.db] 5 | [games.puyo.db :as puyo.db] 6 | [games.controls.db :as controls.db] 7 | [games.debug.db :as debug.db])) 8 | 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; DB 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (def initial-db 15 | (let [game-db-merge-keys [:games] 16 | game-dbs [puzzle.db/db 17 | puyo.db/db 18 | tetris.db/db 19 | debug.db/db] 20 | db 21 | { ;; NOTE also the initial page 22 | :current-page :puzzle 23 | ;; initial controls 24 | :controls controls.db/global-controls}] 25 | 26 | ;; merge game-dbs keys 27 | ;; NOTE this is NOT a deep merge - matching keys will overwrite 28 | (reduce 29 | (fn [db merge-key] 30 | (let [merged-map 31 | (merge (into {} (map merge-key game-dbs)))] 32 | (assoc db merge-key merged-map))) 33 | db game-db-merge-keys))) 34 | 35 | 36 | (comment 37 | (keys (:games initial-db))) 38 | -------------------------------------------------------------------------------- /src/games/tetris/controls.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.controls 2 | (:require [games.controls.core :as controls])) 3 | 4 | (defn initial 5 | [game-opts] 6 | [{:id (controls/->id ::move-left game-opts) 7 | :label "Move Left" 8 | :keys (set ["left" "h" "a"]) 9 | :event [:games.tetris.events/move-piece game-opts :left]} 10 | {:id (controls/->id ::move-down game-opts) 11 | :label "Move Down" 12 | :keys (set ["down" "j" "s"]) 13 | ;; :event [:games.tetris.events/move-piece game-opts :down] 14 | :event [:games.tetris.events/instant-fall game-opts :down]} 15 | {:id (controls/->id ::move-right game-opts) 16 | :label "Move Right" 17 | :keys (set ["right" "l" "d"]) 18 | :event [:games.tetris.events/move-piece game-opts :right]} 19 | {:id (controls/->id ::hold game-opts) 20 | :label "Hold" 21 | :keys (set ["space"]) 22 | :event [:games.tetris.events/hold-and-swap-piece game-opts]} 23 | {:id (controls/->id ::rotate game-opts) 24 | :label "Rotate" 25 | :keys (set ["up" "k" "w"]) 26 | :event [:games.tetris.events/rotate-piece game-opts]} 27 | {:id (controls/->id ::pause game-opts) 28 | :label "Pause" 29 | :keys (set ["enter"]) 30 | :event [:games.tetris.events/toggle-pause game-opts]}]) 31 | -------------------------------------------------------------------------------- /src/games/color.cljs: -------------------------------------------------------------------------------- 1 | (ns games.color) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Cells 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (def green "#92CC41") ;; light green (lime?) 8 | (def red "#FE493C") 9 | (def magenta "#B564D4") 10 | (def light-blue "#6ebff5") ;; sky? 11 | (def blue "#209CEE") 12 | (def yellow "#F7D51D") 13 | (def orange "#E76E55") 14 | 15 | (def color->piece-color 16 | {:green green 17 | :red red 18 | :blue blue 19 | :yellow yellow 20 | :light-blue light-blue 21 | :orange orange 22 | :magenta magenta}) 23 | 24 | (defn cell->piece-color 25 | [c] 26 | (-> c :color (color->piece-color))) 27 | 28 | (defn cell->style 29 | [c] 30 | (if (:color c) 31 | {:background (cell->piece-color c)} 32 | {})) 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;; Cell 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (def board-black "#212529") 39 | (def border-color "#484848") 40 | 41 | (defn cell->background 42 | ;; [{:keys [x y]}] 43 | [_] 44 | board-black 45 | ;; (str "rgba(" (* x 20) ", 100, " (* x 20) ", " (- 1 (/ y 10)) ")") 46 | ) 47 | -------------------------------------------------------------------------------- /src/games/events/timeout.cljs: -------------------------------------------------------------------------------- 1 | (ns games.events.timeout 2 | (:require 3 | [reagent.core :as reagent] 4 | [re-frame.core :as rf])) 5 | 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Timeout logic and impl ripped from: 9 | ;; https://purelyfunctional.tv/guide/timeout-effect-in-re-frame/ 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (defonce timeouts (reagent/atom {})) 13 | 14 | (defn handle-timeout 15 | [{:keys [id event time]}] 16 | (when-some [existing (get @timeouts id)] 17 | (js/clearTimeout existing) 18 | (swap! timeouts dissoc id)) 19 | (when (some? event) 20 | (swap! timeouts assoc id 21 | (js/setTimeout 22 | (fn [] 23 | (rf/dispatch event)) 24 | time)))) 25 | 26 | (defn clear-timeout 27 | [{:keys [id]}] 28 | (when-some [existing (get @timeouts id)] 29 | (js/clearTimeout existing) 30 | (swap! timeouts dissoc id))) 31 | 32 | (rf/reg-fx 33 | :timeout 34 | handle-timeout) 35 | 36 | (rf/reg-fx 37 | :timeouts 38 | (fn [ts] (doall (map handle-timeout ts)))) 39 | 40 | (rf/reg-fx 41 | :clear-timeout 42 | clear-timeout) 43 | 44 | (rf/reg-fx 45 | :clear-timeouts 46 | (fn [xs] 47 | (doall (map clear-timeout xs)))) 48 | -------------------------------------------------------------------------------- /src/games/views/about.cljs: -------------------------------------------------------------------------------- 1 | (ns games.views.about 2 | (:require 3 | [games.views.components :as components])) 4 | 5 | (defn about 6 | [] 7 | [:div 8 | {:style 9 | {:text-align "left" 10 | :font-size "14px" 11 | :padding "3.5rem"}} 12 | [:h3 13 | {:style 14 | {:margin-bottom "2rem"}} 15 | "About"] 16 | [:p 17 | "The tetris clone was initially created for itch.io's " 18 | [:a {:href "https://itch.io/jam/finally-finish-something-2020"} 19 | "Finally Finish Something 2020"] 20 | " Game Jam. Puyo-puyo was added for " 21 | "itch.io's " 22 | [:a {:href "https://itch.io/jam/my-first-game-jam-winter-2020"} 23 | "My First Game Jam - Winter 2020"] 24 | "."] 25 | [:p 26 | "The code is open source and available on github at " 27 | [:a {:href "https://github.com/russmatney/reframe-games"} 28 | " russmatney/reframe-games"] 29 | "."] 30 | [:p "The engine was built using ClojureScript, Reagent, and Re-Frame."] 31 | [:p 32 | "The NES-style graphics come from " 33 | [:a {:href "https://github.com/nostalgic-css/NES.css"} "NES.css"] 34 | "."] 35 | [:p "Thanks for playing!"] 36 | [:p "Press m to return to the main menu."]]) 37 | 38 | (defn page [] 39 | [components/page {} 40 | [components/widget 41 | {:style 42 | {:width "100%" 43 | :height "100%"}} 44 | [about]]]) 45 | -------------------------------------------------------------------------------- /src/games/puyo/controls.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.controls 2 | (:require [games.controls.core :as controls])) 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; Initial Controls 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | (defn initial 9 | [game-opts] 10 | [{:id (controls/->id ::move-left game-opts) 11 | :label "Move Left" 12 | :keys (set ["left" "h" "a"]) 13 | :event [:games.puyo.events/move-piece game-opts :left]} 14 | {:id (controls/->id ::move-down game-opts) 15 | :label "Move Down" 16 | :keys (set ["down" "j" "s"]) 17 | :event [:games.puyo.events/instant-fall game-opts :down] 18 | ;; :event [:games.puyo.events/move-piece game-opts :down] 19 | } 20 | {:id (controls/->id ::move-right game-opts) 21 | :label "Move Right" 22 | :keys (set ["right" "l" "d"]) 23 | :event [:games.puyo.events/move-piece game-opts :right]} 24 | {:id (controls/->id ::hold game-opts) 25 | :label "Hold" 26 | :keys (set ["space"]) 27 | :event [:games.puyo.events/hold-and-swap-piece game-opts]} 28 | {:id (controls/->id ::rotate game-opts) 29 | :label "Rotate" 30 | :keys (set ["up" "k" "w"]) 31 | :event [:games.puyo.events/rotate-piece game-opts]} 32 | {:id (controls/->id ::pause game-opts) 33 | :label "Pause" 34 | :keys (set ["enter"]) 35 | :event [:games.puyo.events/toggle-pause game-opts]}]) 36 | -------------------------------------------------------------------------------- /src/games/tetris/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.grid.views :as grid.views] 5 | [games.subs :as subs] 6 | [games.color :as color])) 7 | 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;; Cells 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | (defn cell->style [game-opts {:keys [color] :as c}] 14 | (merge 15 | (or (:cell-style game-opts) {}) 16 | (if color 17 | {:background (color/cell->piece-color c)} 18 | {:background (color/cell->background c)}))) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Grid 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (defn matrix 25 | "Returns the rows of cells." 26 | [grid game-opts] 27 | (grid.views/matrix 28 | grid 29 | {:cell->style (partial cell->style game-opts)})) 30 | 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | ;; Select game 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | 35 | (defn select-game 36 | "Intended as a mini-game to be used when choosing a game to play." 37 | [] 38 | (let [game-opts {:name :tetris-select-game} 39 | grid @(rf/subscribe [::subs/game-grid game-opts]) 40 | game-opts @(rf/subscribe [::subs/game-opts game-opts])] 41 | [:div 42 | [matrix grid game-opts]])) 43 | 44 | -------------------------------------------------------------------------------- /public/css/reset.css: -------------------------------------------------------------------------------- 1 | /* Box sizing rules */ 2 | *, 3 | *::before, 4 | *::after { 5 | box-sizing: border-box; 6 | } 7 | 8 | /* Remove default padding */ 9 | ul[class], 10 | ol[class] { 11 | padding: 0; 12 | } 13 | 14 | /* Remove default margin */ 15 | body, 16 | h1, 17 | h2, 18 | h3, 19 | h4, 20 | p, 21 | ul[class], 22 | ol[class], 23 | figure, 24 | blockquote, 25 | dl, 26 | dd { 27 | margin: 0; 28 | } 29 | 30 | /* Set core body defaults */ 31 | body { 32 | min-height: 100vh; 33 | scroll-behavior: smooth; 34 | text-rendering: optimizeSpeed; 35 | line-height: 1.5; 36 | } 37 | 38 | /* Remove list styles on ul, ol elements with a class attribute */ 39 | ul[class], 40 | ol[class] { 41 | list-style: none; 42 | } 43 | 44 | /* A elements that don't have a class get default styles */ 45 | a:not([class]) { 46 | text-decoration-skip-ink: auto; 47 | } 48 | 49 | /* Make images easier to work with */ 50 | img { 51 | max-width: 100%; 52 | display: block; 53 | } 54 | 55 | /* Natural flow and rhythm in articles by default */ 56 | article > * + * { 57 | margin-top: 1em; 58 | } 59 | 60 | /* Inherit fonts for inputs and buttons */ 61 | input, 62 | button, 63 | textarea, 64 | select { 65 | font: inherit; 66 | } 67 | 68 | /* Remove all animations and transitions for people that prefer not to see them */ 69 | @media (prefers-reduced-motion: reduce) { 70 | * { 71 | animation-duration: 0.01ms !important; 72 | animation-iteration-count: 1 !important; 73 | transition-duration: 0.01ms !important; 74 | scroll-behavior: auto !important; 75 | } 76 | } 77 | -------------------------------------------------------------------------------- /src/games/tetris/subs.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.subs 2 | (:require 3 | [re-frame.core :as rf])) 4 | 5 | (defn game-opts->db 6 | ([db {:keys [name] :as _game-opts}] 7 | (-> db :games name)) 8 | ([db {:keys [name] :as _game-opts} k] 9 | (-> db :games name k))) 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; Grids 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (rf/reg-sub 16 | ::preview-grids 17 | (fn [db [_ game-opts]] 18 | (-> db 19 | (game-opts->db game-opts :preview-grids)))) 20 | 21 | (rf/reg-sub 22 | ::held-grid 23 | (fn [db [_ game-opts]] 24 | (-> db 25 | (game-opts->db game-opts :held-grid)))) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; Logic 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | (rf/reg-sub 32 | ::paused? 33 | (fn [db [_ game-opts]] 34 | (-> db 35 | (game-opts->db game-opts :paused?)))) 36 | 37 | (rf/reg-sub 38 | ::gameover? 39 | (fn [db [_ game-opts]] 40 | (-> db 41 | (game-opts->db game-opts :gameover?)))) 42 | 43 | (rf/reg-sub 44 | ::any-held? 45 | (fn [db [_ game-opts]] 46 | (-> db 47 | (game-opts->db game-opts :held-shape-fn)))) 48 | 49 | (rf/reg-sub 50 | ::score 51 | (fn [db [_ game-opts]] 52 | (-> db 53 | (game-opts->db game-opts :score)))) 54 | 55 | (rf/reg-sub 56 | ::time 57 | (fn [db [_ game-opts]] 58 | (-> db 59 | (game-opts->db game-opts :time)))) 60 | 61 | (rf/reg-sub 62 | ::level 63 | (fn [db [_ game-opts]] 64 | (-> db 65 | (game-opts->db game-opts :level)))) 66 | -------------------------------------------------------------------------------- /src/games/puyo/subs.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.subs 2 | (:require 3 | [re-frame.core :as rf])) 4 | 5 | (defn game-opts->db 6 | ([db {:keys [name] :as _game-opts}] 7 | (-> db :games name)) 8 | ([db {:keys [name] :as _game-opts} k] 9 | (-> db :games name k))) 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; Grids 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (rf/reg-sub 16 | ::preview-grids 17 | (fn [db [_ game-opts]] 18 | (-> db 19 | (game-opts->db game-opts :preview-grids)))) 20 | 21 | (rf/reg-sub 22 | ::held-grid 23 | (fn [db [_ game-opts]] 24 | (-> db 25 | (game-opts->db game-opts :held-grid)))) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; Logic 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | (rf/reg-sub 32 | ::paused? 33 | (fn [db [_ game-opts]] 34 | (-> db 35 | (game-opts->db game-opts :paused?)))) 36 | 37 | (rf/reg-sub 38 | ::gameover? 39 | (fn [db [_ game-opts]] 40 | (-> db 41 | (game-opts->db game-opts :gameover?)))) 42 | 43 | (rf/reg-sub 44 | ::any-held? 45 | (fn [db [_ game-opts]] 46 | (-> db 47 | (game-opts->db game-opts :held-shape)))) 48 | 49 | (rf/reg-sub 50 | ::score 51 | (fn [db [_ game-opts]] 52 | (-> db 53 | (game-opts->db game-opts :score)))) 54 | 55 | (rf/reg-sub 56 | ::time 57 | (fn [db [_ game-opts]] 58 | (-> db 59 | (game-opts->db game-opts :time)))) 60 | 61 | (rf/reg-sub 62 | ::level 63 | (fn [db [_ game-opts]] 64 | (-> db 65 | (game-opts->db game-opts :level)))) 66 | -------------------------------------------------------------------------------- /src/games/tetris/shapes.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.shapes 2 | (:require [games.grid.core :as grid])) 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; Piece Shapes 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | (def tetrominos 9 | [{:type :square :cells [{:x 1 :y -1} {:x 1} {:y -1} {:anchor? true}]} 10 | {:type :line :cells [{:x 2} {:x 1} {:anchor? true} {:x -1}]} 11 | {:type :t :cells [{:x -1} {:x 1} {:anchor? true} {:y -1}]} 12 | {:type :z :cells [{:x -1 :y -1} {:y -1} {:anchor? true} {:x 1}]} 13 | {:type :s :cells [{:x 1 :y -1} {:y -1} {:anchor? true} {:x -1}]} 14 | {:type :r :cells [{:x -1 :y -1} {:x 1} {:anchor? true} {:x -1}]} 15 | {:type :l :cells [{:x 1 :y -1} {:x 1} {:anchor? true} {:x -1}]}]) 16 | 17 | (def type->cells 18 | "The above `tetrominos` as a map to cells by its `:type`" 19 | (into {} (map (fn [{type :type cells :cells}] [type cells]) tetrominos))) 20 | 21 | (defn type->props [type] 22 | (case type 23 | :square {:color :yellow} 24 | :line {:color :light-blue} 25 | :l {:color :orange} 26 | :r {:color :blue} 27 | :s {:color :green} 28 | :z {:color :red} 29 | :t {:color :magenta})) 30 | 31 | ;; TODO how can this be the name of this function. 32 | (defn type->ec->cell 33 | [type] 34 | (let [cells (get type->cells type) 35 | props (type->props type)] 36 | (fn [ec] 37 | (map (comp 38 | #(merge % props) 39 | #(grid/relative ec %)) 40 | cells)))) 41 | 42 | (def allowed-shapes 43 | (map :type tetrominos)) 44 | 45 | (defn next-bag 46 | "Returns a shuffled group of the allowed shapes. 47 | https://tetris.wiki/Random_Generator 48 | " 49 | [{:keys [allowed-shapes]}] 50 | (shuffle allowed-shapes)) 51 | -------------------------------------------------------------------------------- /src/games/subs.cljs: -------------------------------------------------------------------------------- 1 | (ns games.subs 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.grid.core :as grid])) 5 | 6 | 7 | (rf/reg-sub 8 | ::current-page 9 | (fn [db _] 10 | (:current-page db))) 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;; Game shared subs 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | (rf/reg-sub 17 | ::game-db 18 | (fn [db evt] 19 | (case (count evt) 20 | 2 (let [[_e game-opts] evt] 21 | (-> db :games (get (:name game-opts)))) 22 | 3 (let [[_e game-opts k] evt] 23 | (-> db :games (get (:name game-opts)) (get k)))))) 24 | 25 | (rf/reg-sub 26 | ::game-opts 27 | (fn [db [_ game-opts]] 28 | (-> db :games (get (:name game-opts)) :game-opts))) 29 | 30 | (rf/reg-sub 31 | ::game-grid 32 | (fn [db [_ game-opts]] 33 | (-> db :games (get (:name game-opts)) :game-grid 34 | (grid/only-positive-rows)))) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;; Controls 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | 40 | (rf/reg-sub 41 | ::controls 42 | (fn [db] 43 | (-> db :controls))) 44 | 45 | (rf/reg-sub 46 | ::controls-for 47 | :<- [::controls] 48 | (fn [controls [_ for]] 49 | (let [controls-by-id (group-by :id controls)] 50 | (-> controls-by-id for first)))) 51 | 52 | (rf/reg-sub 53 | ::keys-for 54 | :<- [::controls] 55 | (fn [controls [_ for]] 56 | (let [controls-by-id (group-by :id controls)] 57 | (-> controls-by-id for first :keys)))) 58 | 59 | ;; TODO fix these `first` uses 60 | ;; probably a controls revamp 61 | (rf/reg-sub 62 | ::event-for 63 | :<- [::controls] 64 | (fn [controls [_ for]] 65 | (let [controls-by-id (group-by :id controls)] 66 | (-> controls-by-id for first :event)))) 67 | -------------------------------------------------------------------------------- /src/games/puzzle/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.events 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.events :as events] 5 | [games.events.interceptors :refer [game-db-interceptor]] 6 | [games.grid.core :as grid])) 7 | 8 | (defn move-piece [db direction] 9 | (update 10 | db :game-grid 11 | #(grid/move-cells % {:cells :in-hand? :direction direction}))) 12 | 13 | (defn rotate-piece [db] 14 | (update 15 | db :game-grid 16 | (fn [g] 17 | (grid/move-cells 18 | g {:cells :in-hand? :rotation :clockwise})))) 19 | 20 | (defn add-piece 21 | [db {:keys [cells]}] 22 | (update 23 | db :game-grid 24 | (fn [g] 25 | (-> g 26 | (grid/clear-cells :in-hand?) 27 | (grid/add-cells 28 | {:update-cell #(assoc % :in-hand? true) 29 | :cells 30 | (map 31 | (comp 32 | #(assoc % :color (rand-nth [:red :blue :green])) 33 | #(grid/relative {:x 1 :y 1} %)) 34 | cells)}))))) 35 | 36 | (defn set-piece 37 | [db] 38 | (update 39 | db :game-grid 40 | (fn [g] 41 | (grid/update-cells 42 | g 43 | :in-hand? 44 | (fn [c] 45 | (-> c 46 | (dissoc :in-hand?) 47 | (assoc :set? true))))))) 48 | 49 | (events/reg-game-events 50 | ;; no step features needed, but this initializes controls for us 51 | {:n (namespace ::x) 52 | :step-fn identity}) 53 | 54 | (events/reg-game-move-events 55 | ;; connects a few controls to functions for us 56 | {:n (namespace ::x) 57 | :move-piece move-piece 58 | :rotate-piece rotate-piece}) 59 | 60 | (rf/reg-event-db 61 | ::select-piece 62 | [(game-db-interceptor)] 63 | (fn [db [_game-opts piece]] 64 | (add-piece db piece))) 65 | 66 | (rf/reg-event-db 67 | ::set-piece 68 | [(game-db-interceptor)] 69 | (fn [db _game-opts] 70 | (set-piece db))) 71 | -------------------------------------------------------------------------------- /src/games/puzzle/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.db 2 | (:require 3 | [games.puzzle.controls :as puzzle.controls] 4 | [games.grid.core :as grid] 5 | [games.tetris.shapes :as tetris.shapes])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Pieces 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defn initial-pieces 12 | "Tetrominos for now." 13 | [] 14 | tetris.shapes/tetrominos) 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;; game db 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | 20 | (def defaults {}) 21 | 22 | (defn game-db 23 | [game-opts] 24 | (let [{:keys [name game-grid] :as game-opts} 25 | (merge defaults game-opts)] 26 | {:name name 27 | :game-opts game-opts 28 | :init-event-name :games.puzzle.events/init-game 29 | :stop-event-name :games.puzzle.events/stop 30 | 31 | ;; game 32 | :game-grid 33 | (grid/build-grid 34 | (merge {:height 10 :width 6 35 | :entry-cell {:x 1 :y 1} 36 | } game-grid)) 37 | 38 | ;; puzzle-pieces 39 | :pieces (initial-pieces) 40 | 41 | ;; timer 42 | :time 0 43 | 44 | ;; controls 45 | :controls (puzzle.controls/initial game-opts)})) 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;; games dbs 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | 51 | (def classic-game-db 52 | (-> 53 | {:name :puzzle-classic-game 54 | :pages #{:puzzle} 55 | :game-grid {:height 10 :width 6}} 56 | (game-db))) 57 | 58 | (def select-game-db 59 | (-> {:name :puzzle-select-game 60 | :pages #{:select} 61 | :game-grid {:height 5 :width 5}} 62 | (game-db))) 63 | 64 | (def game-dbs 65 | [select-game-db 66 | classic-game-db]) 67 | 68 | (def game-dbs-map 69 | (->> game-dbs 70 | (map (fn [game] [(-> game :name) game])) 71 | (into {}))) 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;; db 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | 77 | (def db 78 | {:games game-dbs-map}) 79 | -------------------------------------------------------------------------------- /src/games/puzzle/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puzzle.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.subs :as subs] 5 | [games.puzzle.subs :as puzzle.subs] 6 | [games.grid.views :as grid.views] 7 | [games.views.components :as components] 8 | [games.puzzle.events :as puzzle.events])) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Select game 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (defn select-game-cells 15 | [{:keys [placed? x y]}] 16 | ^{:key (str x y)} 17 | [:div 18 | {:style 19 | {:height "48px" 20 | :width "48px" 21 | :border (if placed? "1px solid white" "1px solid black") 22 | :background (if placed? "green" "white")}} 23 | ""]) 24 | 25 | (defn select-game 26 | [] 27 | (let [game-opts {:name :puzzle-select-game} 28 | grid @(rf/subscribe [::subs/game-grid game-opts])] 29 | [grid.views/matrix grid 30 | {:->cell select-game-cells}])) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; Classic Game 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (defn pieces 37 | [game-opts] 38 | (let [piece-grids @(rf/subscribe [::puzzle.subs/piece-grids game-opts]) 39 | piece-grids (or piece-grids [])] 40 | [:div 41 | {:style {:flex "1"}} 42 | [:h3 "Pieces"] 43 | (for [[piece g] piece-grids] 44 | ^{:key (str piece)} 45 | [:div 46 | {:on-click #(rf/dispatch [::puzzle.events/select-piece game-opts piece]) 47 | :style {:margin-bottom "8px"}} 48 | [grid.views/matrix g]])])) 49 | 50 | (defn board 51 | [game-opts] 52 | (let [grid @(rf/subscribe [::subs/game-grid game-opts])] 53 | [grid.views/matrix grid game-opts])) 54 | 55 | (defn classic-game 56 | [] 57 | (let [game-opts {:name :puzzle-classic-game}] 58 | [components/widget 59 | {:style {:flex-direction "row"}} 60 | ^{:key "board"} 61 | [board game-opts] 62 | ^{:key "pieces"} 63 | [pieces game-opts]])) 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | ;; Page 67 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | 69 | (defn page 70 | [] 71 | [components/page 72 | {:header [components/widget {:label "Puzzle"}]} 73 | ^{:key "classic"} 74 | [classic-game] 75 | ]) 76 | -------------------------------------------------------------------------------- /src/games/controls/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.controls.events 2 | (:require 3 | [re-frame.core :as rf] 4 | [re-pressed.core :as rp] 5 | [games.controls.re-pressed :as controls.rp] 6 | [games.events.interceptors :refer [game-db-interceptor]])) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Init controls listener, global controls, and controls game 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (rf/reg-event-fx 13 | ::init 14 | (fn [_cofx] 15 | {:dispatch-n 16 | [[::rp/add-keyboard-event-listener "keydown"] 17 | [::controls.rp/register-key-listeners] 18 | [::controls.rp/register-key-dispatchers]]})) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Global control registry 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (defn distinct-by [f coll] 25 | (let [groups (group-by f coll)] 26 | (map #(first (groups %)) (distinct (map f coll))))) 27 | 28 | (defn set-controls 29 | "Takes a list of control objects, and sets them on the db. 30 | Broken out to support registering and deregistering controls. 31 | " 32 | [db controls] 33 | (let [by-key (controls.rp/controls->by-key controls)] 34 | (assoc db 35 | :controls controls 36 | :controls-by-key by-key))) 37 | 38 | (rf/reg-event-fx 39 | ::register 40 | [rf/trim-v] 41 | (fn [{:keys [db]} [controls]] 42 | (let [controls (concat (:controls db) (or controls [])) 43 | controls (distinct-by :id controls)] 44 | {:db (set-controls db controls)}))) 45 | 46 | (rf/reg-event-fx 47 | ::deregister 48 | [rf/trim-v] 49 | (fn [{:keys [db]} [controls-to-remove]] 50 | (let [ids-to-remove (set (map :id controls-to-remove)) 51 | controls (:controls db) 52 | controls (remove 53 | (fn [{:keys [id]}] 54 | (contains? ids-to-remove id)) 55 | controls)] 56 | {:db (set-controls db controls)}))) 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;; Game control events 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (rf/reg-event-fx 63 | ::register-controls 64 | [(game-db-interceptor)] 65 | (fn [{:keys [db]} {:keys [ignore-controls]}] 66 | (when-not ignore-controls 67 | {:dispatch [::register (:controls db)]}))) 68 | 69 | (rf/reg-event-fx 70 | ::deregister-controls 71 | [(game-db-interceptor)] 72 | (fn [{:keys [db]} _game-opts] 73 | {:dispatch [::deregister (:controls db)]})) 74 | 75 | -------------------------------------------------------------------------------- /src/games/puyo/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.views.components :as components] 5 | [games.grid.core :as grid] 6 | [games.grid.views :as grid.views] 7 | [games.color :as color] 8 | [games.subs :as subs])) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Cells 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (defn cell->style [game-opts {:keys [color] :as c}] 15 | (merge 16 | (or (:cell-style game-opts) {}) 17 | (if color 18 | {:background (color/cell->piece-color c)} 19 | {:background (color/cell->background c)}))) 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;; Grid 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | (defn matrix 26 | [grid game-opts] 27 | (let [spin? @(rf/subscribe [::subs/game-db game-opts :spin-the-bottle?]) 28 | pieces-played @(rf/subscribe [::subs/game-db game-opts :pieces-played]) 29 | 30 | grid 31 | (cond-> grid 32 | spin? 33 | (grid/spin {:reverse-y? (contains? #{1 2 3} (mod pieces-played 6)) 34 | :reverse-x? (contains? #{2 3 4} (mod pieces-played 6))}))] 35 | [grid.views/matrix 36 | grid 37 | {:cell->style (partial cell->style game-opts)}])) 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;; Selectable game 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (defn select-game 45 | "Intended as a selectable game (from a list)." 46 | [] 47 | (let [game-opts {:name :puyo-select-game} 48 | grid @(rf/subscribe [::subs/game-grid game-opts]) 49 | game-opts @(rf/subscribe [::subs/game-opts game-opts])] 50 | [:div 51 | [matrix grid game-opts]])) 52 | 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;; Debug game 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | 57 | (defn debug-game 58 | "Intended as a debug helper." 59 | [] 60 | (let [game-opts {:name :puyo-debug-game} 61 | game-opts @(rf/subscribe [::subs/game-opts game-opts]) 62 | grid @(rf/subscribe [::subs/game-grid game-opts])] 63 | 64 | (components/page 65 | {:direction :row 66 | :full-height? true} 67 | [grid.views/matrix 68 | grid 69 | {:->cell 70 | (fn [c] 71 | [:div 72 | {:style 73 | (merge 74 | (cell->style game-opts c) 75 | {:width "180px" 76 | :border "1px solid white"})} 77 | (str c)])}]))) 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/games/debug/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.db 2 | (:require 3 | [games.debug.core :as debug] 4 | [games.grid.core :as grid] 5 | [games.debug.controls :as debug.controls])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Game DB 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (def game-opts-defaults 12 | {:no-walls? true 13 | :debug? false}) 14 | 15 | (defn initial-game-db 16 | ([] (initial-game-db {})) 17 | ([game-opts] 18 | (let [{:keys [name game-grid] :as game-opts} 19 | (merge game-opts-defaults game-opts)] 20 | {:name name 21 | :game-opts game-opts 22 | :init-event-name :games.debug.events/init-game 23 | :stop-event-name :games.debug.events/stop 24 | 25 | :game-grid (grid/build-grid 26 | (merge 27 | {:entry-cell {:x 0 :y 0} 28 | :height 3 29 | :width 3 30 | :phantom-columns 2 31 | :phantom-rows 2} 32 | game-grid)) 33 | :controls (debug.controls/initial game-opts)}))) 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;; Game DBs 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | (def select-game-db 40 | (-> {:name :debug-select-game 41 | :pages #{:select}} 42 | (initial-game-db) 43 | (debug/add-pieces))) 44 | 45 | (defn make-debug-game-db 46 | [name opts] 47 | (-> (merge 48 | {:name name 49 | :pages #{:debug}} 50 | opts) 51 | (initial-game-db) 52 | (debug/add-pieces))) 53 | 54 | (def game-dbs 55 | [select-game-db 56 | ;; (make-debug-game-db 57 | ;; :debug-debug-game 58 | ;; {:debug? true}) 59 | (make-debug-game-db 60 | :debug-debug-game-1 61 | {:debug-game? true 62 | :game-grid {:height 3 :width 3 63 | :phantom-columns 1 :phantom-rows 1} 64 | :debug? false}) 65 | ;; (make-debug-game-db 66 | ;; :debug-debug-game-2 67 | ;; {:game-grid {:height 3 :width 3} 68 | ;; :debug-game? true 69 | ;; :debug? false}) 70 | ;; (make-debug-game-db 71 | ;; :debug-debug-game-3 72 | ;; {:game-grid {:height 3 :width 3} 73 | ;; :cell-height "24px" 74 | ;; :cell-width "24px" 75 | ;; :debug-game? true 76 | ;; :debug? false}) 77 | ]) 78 | 79 | (def game-dbs-map 80 | (->> game-dbs 81 | (map (fn [game] [(-> game :game-opts :name) game])) 82 | (into {}))) 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | ;; DB 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | (def db 89 | {:games game-dbs-map}) 90 | -------------------------------------------------------------------------------- /src/games/select/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.select.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.events :as events] 5 | [games.tetris.views :as tetris.views] 6 | [games.puyo.views :as puyo.views] 7 | [games.debug.views :as debug.views] 8 | [games.puzzle.views :as puzzle.views] 9 | [games.views.components :as components])) 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; Data 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (def selectable-games 16 | [{:label "Tetris" 17 | :on-click #(rf/dispatch [::events/set-page :tetris]) 18 | :component [tetris.views/select-game]} 19 | {:label "Puyo" 20 | :on-click #(rf/dispatch [::events/set-page :puyo]) 21 | :component [puyo.views/select-game]} 22 | {:label "Puzzle" 23 | :on-click #(rf/dispatch [::events/set-page :puzzlle]) 24 | :component [puzzle.views/select-game]} 25 | {:label "Debug" 26 | :on-click #(rf/dispatch [::events/set-page :debug]) 27 | :component [debug.views/select-game]}]) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;; Selections 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (defn selection 34 | [{:keys [label on-click component]}] 35 | ^{:key label} 36 | [components/widget 37 | {:class "selection" 38 | :on-click on-click 39 | :label label 40 | :style {:flex "1"}} 41 | ^{:key (str "selection-container-" label)} 42 | [:div 43 | {:style 44 | {:flex "1"}} 45 | ^{:key label} 46 | component]]) 47 | 48 | (defn selections 49 | [] 50 | [:div.selections 51 | {:style 52 | {:width "100%" 53 | :flex "1" 54 | :display "flex"}} 55 | (for [{:keys [label] :as game} selectable-games] 56 | ^{:key label} 57 | (selection game))]) 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | ;; Expectations 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | 64 | ;; TODO support this copy well enough to include 65 | (defn expectations 66 | "TODO fade-in effect, maybe on the widget api?" 67 | [] 68 | [components/widget 69 | { 70 | :style {:flex "1"} 71 | :label "Expectations" 72 | :subhead [:ul {:style {:list-style "none"}} 73 | [:li "Move with mouse*, arrow keys, wasd, or vim bindings"] 74 | [:li "Enter, Click, or Score to choose."] 75 | [:li "*Mouse not yet implemented*"]]}]) 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | ;; Header 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | (defn header [] 82 | [components/widget 83 | {:class "header" 84 | :style {} 85 | :label "Select a game"}]) 86 | 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | ;; Main page component 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (defn page [] 92 | [components/page 93 | {:direction :row 94 | :header [header]} 95 | ;; [expectations] 96 | ^{:key "selections-comp"} 97 | [selections]]) 98 | -------------------------------------------------------------------------------- /src/games/debug/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.core 2 | (:require [games.grid.core :as grid])) 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; Shapes 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | (def shapes 9 | "Shapes added to the debug game." 10 | [ 11 | ;; {:props {:moveable? true} 12 | ;; :cells [{:y -1} {:x -1} {:anchor? true} {:x 1} {:y 1}]} 13 | {:props {:moveable? true} 14 | :cells [{:y -1} {:x -1} {:anchor? true}]} 15 | ]) 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;; Adding Pieces 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (defn shape->cells [{:keys [cells props]}] 22 | (fn [ec] (map 23 | (fn [c] 24 | (as-> c cell 25 | (merge props cell) 26 | (grid/relative ec cell))) 27 | cells))) 28 | 29 | (defn add-pieces 30 | [db] 31 | (let [ec->cell-fns (map shape->cells shapes)] 32 | (update db :game-grid 33 | (fn [g] 34 | (reduce 35 | (fn [grid cell-fn] 36 | (grid/add-cells grid {:make-cells cell-fn})) 37 | g 38 | ec->cell-fns))))) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;; Move Logic 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (defn move-allowed? 45 | "True if user-interaction with the piece is allowed 46 | (i.e. the game is not paused or otherwise disabled.)" 47 | [_db] 48 | true) 49 | 50 | (defn move-piece 51 | "Gathers `:moveable?` cells and moves them with `grid/move-cells`" 52 | [{:keys [game-grid game-opts] :as db} dir] 53 | (let [move-f #(grid/move-cell-coords 54 | % dir 55 | (merge game-opts {:grid game-grid})) 56 | moveable-cells (grid/get-cells game-grid :moveable?) 57 | updated-grid (grid/move-cells 58 | game-grid 59 | {:move-f move-f 60 | :cells moveable-cells 61 | :can-move? (fn [_] true)}) 62 | db (assoc db :game-grid updated-grid)] 63 | db)) 64 | 65 | (defn is-space? [cell] 66 | (not (:moveable? cell))) 67 | 68 | (defn instant-fall 69 | "Gathers `:moveable?` cells and moves them with `grid/instant-fall`" 70 | [{:keys [game-grid game-opts] :as db} direction] 71 | (update 72 | db :game-grid 73 | (fn [g] 74 | (grid/instant-fall 75 | g 76 | {:direction direction 77 | :cells (grid/get-cells game-grid :moveable?) 78 | :keep-shape? (or false (:keep-shape? game-opts)) 79 | :can-move? is-space?})))) 80 | 81 | (defn rotate-piece [{:keys [game-grid] :as db}] 82 | (let [cells (grid/get-cells game-grid :props) 83 | anchor-cell (first (filter :anchor? cells))] 84 | (if-not anchor-cell 85 | ;; no anchor-cell, do nothing 86 | db 87 | (update 88 | db :game-grid 89 | (fn [grid] 90 | (grid/move-cells 91 | grid 92 | {:move-f #(grid/calc-rotate-target anchor-cell %) 93 | :can-move? (fn [_] true) 94 | :cells (remove :anchor? cells)})))))) 95 | -------------------------------------------------------------------------------- /src/games/tetris/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.db 2 | (:require 3 | [games.tetris.shapes :as tetris.shapes] 4 | [games.tetris.controls :as tetris.controls] 5 | [games.grid.core :as grid])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Game DB 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (def shape-grid 12 | (grid/build-grid 13 | {:height 2 14 | :width 4 15 | :entry-cell {:x 1 :y 1}})) 16 | 17 | (def defaults 18 | {:step-timeout 500 19 | :ignore-controls false}) 20 | 21 | (defn game-db 22 | "Creates an initial tetris game-state." 23 | [game-opts] 24 | (let [{:keys [name game-grid step-timeout ignore-controls] :as game-opts} 25 | (merge defaults game-opts)] 26 | {:name name 27 | :game-opts game-opts 28 | :init-event-name :games.tetris.events/init-game 29 | :stop-event-name :games.tetris.events/stop 30 | 31 | ;; game matrix 32 | :game-grid 33 | (grid/build-grid 34 | (merge 35 | {:height 10 36 | :width 10 37 | :phantom-rows 2 38 | :entry-cell {:x 5 :y -1}} 39 | game-grid)) 40 | 41 | ;; game logic 42 | :step-timeout step-timeout 43 | :paused? false 44 | :gameover? false 45 | 46 | ;; queue 47 | :piece-queue (shuffle tetris.shapes/allowed-shapes) 48 | :min-queue-size 5 49 | :allowed-shapes tetris.shapes/allowed-shapes 50 | :preview-grids (repeat 3 shape-grid) 51 | 52 | ;; controls 53 | :controls (tetris.controls/initial game-opts) 54 | :ignore-controls ignore-controls 55 | 56 | ;; hold/swap 57 | :falling-shape nil 58 | :held-shape nil 59 | :held-grid shape-grid 60 | :hold-lock false 61 | 62 | ;; timer 63 | :time 0 64 | 65 | ;; level/score 66 | :level 1 67 | :rows-per-level 5 68 | :rows-cleared 0 69 | :pieces-played 0 70 | :score 0 71 | :score-per-row-clear 10 72 | :rows-in-combo 0 73 | :last-combo-piece-num nil 74 | })) 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | ;; Game DBs 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | 80 | (def classic-game-db 81 | (-> 82 | {:name :tetris-classic-game 83 | :pages #{:tetris} 84 | :game-grid {:entry-cell {:x 4 :y -1} 85 | :height 16 86 | :width 10}} 87 | (game-db))) 88 | 89 | (def select-game-db 90 | (-> {:name :tetris-select-game 91 | :pages #{:select} 92 | :tick-timeout 500 93 | :on-gameover :restart 94 | :no-walls-x? true 95 | :game-grid {:height 10 :width 5 :entry-cell {:x 2 :y -1}}} 96 | (game-db))) 97 | 98 | (def game-dbs 99 | [select-game-db 100 | classic-game-db]) 101 | 102 | ;; TODO dry up 103 | (def game-dbs-map 104 | (->> game-dbs 105 | (map (fn [game] [(-> game :game-opts :name) game])) 106 | (into {}))) 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | ;; DB 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | (def db 113 | {:games game-dbs-map}) 114 | -------------------------------------------------------------------------------- /src/games/grid/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.grid.views 2 | (:require 3 | [games.views.components :refer [widget]] 4 | [games.color :as color])) 5 | 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;; Cell 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (defn cell 11 | [{c :cell 12 | style :style 13 | debug :debug :as opts}] 14 | (let [{:keys [cell-comp]} (:game-opts opts) 15 | {:keys [x y]} c 16 | style (or style {}) 17 | width (if debug "260px" "40px") 18 | height (if debug "120px" "40px")] 19 | [:div 20 | {:style 21 | (merge 22 | {:max-width width 23 | :max-height height 24 | :width width 25 | :height height 26 | :border (str color/border-color " solid 1px")} 27 | (color/cell->style c) 28 | style)} 29 | (if debug (str c) "") 30 | 31 | ^{:key (str x y)} 32 | (when cell-comp 33 | (cell-comp c))])) 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | ;; Matrix 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | (defn matrix 40 | "Displays the game matrix itself, using the passed grid-db and cell->style 41 | functions. 42 | 43 | `cell->style` merges the resulting map with the `cell` component's styles. 44 | 45 | `cell-comp` attaches a passed component as a child to the above cell component. 46 | 47 | Passing `->cell` allows you to write your own cell component, ignoring 48 | `cell->style` and `cell-comp`. 49 | " 50 | ([grid-db] [matrix grid-db {}]) 51 | 52 | ([grid-db {:keys [cell->style ->cell] :as game-opts}] 53 | (let [grid (:grid grid-db)] 54 | [:div.matrix 55 | {:style 56 | {:display "flex" 57 | :text-align "center" 58 | :align-items "center" 59 | :flex-direction "column" 60 | :justify-content "center" 61 | :flex "1"}} 62 | (for [[i row] (map-indexed vector grid)] 63 | ^{:key i} 64 | [:div 65 | {:style 66 | {:display "flex"}} 67 | (for [{:keys [x y] :as c} row] 68 | (let [] 69 | (if ->cell 70 | ^{:key (str "custom-" x y)} 71 | (->cell c) 72 | 73 | ^{:key (str "cell-" x y)} 74 | [cell 75 | {:game-opts game-opts 76 | :cell c 77 | :style (if cell->style (cell->style c) {})}])))])]))) 78 | 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | ;; Piece-list (Matricies) 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | 83 | (defn piece-list 84 | "Displays a centered list of pieces below a label." 85 | ([] [piece-list {}]) 86 | ([{:keys [label style piece-grids cell->style]}] 87 | [widget 88 | {:label label 89 | :style {:flex "1"}} 90 | ^{:key (str "piece-list-container" label)} 91 | [:div 92 | {:style 93 | (merge 94 | {:display "flex" 95 | :flex-direction "column" 96 | :justify-content "space-around" 97 | :width "100%"} 98 | style)} 99 | (for [[i g] (map-indexed vector piece-grids)] 100 | ^{:key (str "matrix-container" i)} 101 | [:div 102 | {:style 103 | {:display "flex" 104 | :margin-bottom "12px"}} 105 | [matrix g {:cell->style cell->style}]])]])) 106 | -------------------------------------------------------------------------------- /readme.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Reframe Games 2 | 3 | Games built in ClojureScript, with [[https://github.com/reagent-project/reagent][Reagent]], [[https://github.com/day8/re-frame][Re-frame]], [[https://github.com/thheller/shadow-cljs][Shadow-cljs]], and 4 | [[https://github.com/nostalgic-css/NES.css][NES.css]]. 5 | 6 | This repo will be expanded to include other games, but for now, it's just a 7 | Tetris clone. Check out the live game at [[https://russmatney.itch.io/tetruss][russmatney.itch.io/tetruss]]. 8 | 9 | * Release 10 | ** Building the release 11 | #+BEGIN_SRC sh 12 | # remove 'complied' dir from dev-mode 13 | rm -rf public/js/compiled 14 | 15 | # build release version 16 | shadow-cljs release app 17 | #+END_SRC 18 | ** Deploying to s3 19 | #+BEGIN_SRC sh 20 | # deploy to s3 21 | aws s3 sync public/ s3://games.russmatney.com 22 | #+END_SRC 23 | 24 | **** Requires aws cli tool: 25 | #+BEGIN_SRC zsh 26 | yay -S aws-cli 27 | 28 | # setup creds 29 | aws configure 30 | #+END_SRC 31 | 32 | ** Packaging for itch.io 33 | Itch.io requires a .zip of the web-app. 34 | 35 | Build as described above, then zip it up. 36 | 37 | #+BEGIN_SRC sh 38 | zip -r reframe-games.zip public 39 | #+END_SRC 40 | * misc todos 41 | **** [X] control registration/deregistration 42 | **** [X] dry up game-db events 43 | **** [X] pause doesn't always stop the clock? 44 | **** [ ] dry up @rf/subscribe usage with suggested subscribe macro 45 | `(<-sub! ::s/current-page])`? 46 | **** [X] move 'controls-game' to learn/help/debug namespace? 47 | **** [ ] update uses of :name to :id where relevant 48 | **** [ ] add :group-id to pieces/cell-groups 49 | **** [ ] show/learn controls overlay 50 | no keys detected yet overlay with suggestions for clicking? 51 | **** [ ] pause overlay (with controls) 52 | **** [ ] 'learn' namespace with minigame for learning controls for currently active games 53 | **** [ ] support optional url navigation? (back button?) 54 | **** [ ] show combo chains and rows-to-next-level 55 | **** [ ] mobile touch/gesture support 56 | **** [ ] customizable controls 57 | **** [ ] configurable pieces and board size 58 | **** [ ] high-score, custom controls preserved across re-fresh 59 | **** [ ] rows-to-next-level visual indication 60 | **** [ ] rotate in two directions 61 | **** [ ] show 'ghost' piece (for fast drop) 62 | **** [ ] mobile detection and 'alert'? 63 | **** [ ] add a robot to make moves when no one has for a while 64 | something for leaving it on 65 | **** [ ] add garden/stylesheets 66 | https://github.com/lambdaisland/garden-watcher 67 | **** [ ] make get-cell warning optional 68 | ** ideas 69 | **** [ ] spin-board after x-many pieces 70 | **** [ ] battle with AI 71 | **** [ ] rotation styles on rows 72 | **** [ ] bullet mode: size-3 pieces, 10x speed 73 | **** [ ] draw your own piece 74 | **** [ ] build up a puzzle/art piece 75 | **** [ ] record and show replay/highlights 76 | **** [ ] shared high-score + leaderboard 77 | **** [ ] bonus for clearing the screen completely 78 | **** [ ] comments for holding same-piece type 79 | **** [ ] 'doom' face - show emotion during left/right/rotate/score 80 | **** [ ] Add achievements 81 | **** [ ] poster-ized level clears (gunn style) 82 | ***** include current game state metadata 83 | **** [ ] display character commentary per piece played 84 | **** [ ] Write a metadata component 85 | include: current combo, highest combo, combos to next level, highest level 86 | pieces played, combos scored, items available 87 | * Resources 88 | ** Tetris 89 | The [[https://tetris.wiki][Tetris Wiki]] has some great Tetris related resources. 90 | * Contributing 91 | My intention for this repository is to build some things from scratch on my 92 | own - selfishly, I'm somewhat closed-minded to contributions. 93 | 94 | I'm open to talking about the things in here via PRs and Issues, and I encourage 95 | you to fork and do what you want with the code! 96 | 97 | My motivation for developing this in the public: 98 | - to share the code as an example 99 | - to get feedback 100 | - (hopefully) to inspire others to build things! 101 | -------------------------------------------------------------------------------- /src/games/events/interceptors.cljs: -------------------------------------------------------------------------------- 1 | (ns games.events.interceptors 2 | (:require 3 | [re-frame.core :as rf] 4 | [re-frame.interceptor :as rfi] 5 | [re-frame.utils :as rfu] 6 | [adzerk.cljs-console :as log])) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Intereceptors 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | ;; TODO break event modifier out of game-db path usage 13 | ;; one for list event -> map or subvec 1 list 14 | ;; one for pulling key out of game-opts 15 | ;; TODO accept fn for getting k out of game-opts (instead of implicit :name) 16 | (defn game-db-interceptor 17 | "Interceptor that operates over the game db. 18 | Events passed through this interceptor will 19 | have their first argument consumed and used to 20 | find the game-db passed into the handler. 21 | 22 | The event will also be trimmed. Whether this helps 23 | or causes more insanity remains an open question." 24 | [] 25 | (rfi/->interceptor 26 | :id :game-db-interceptor 27 | :before 28 | (fn game-db-interceptor-before 29 | [context] 30 | (let [event (get-in context [:coeffects :event]) 31 | {:keys [name]} 32 | (if (> (count event) 1) (nth event 1) 33 | (log/warn 34 | "Game-interceptor received event without argument: ~{event}"))] 35 | (-> context 36 | ;; set db to the game's db 37 | (assoc-in 38 | [:coeffects :db] 39 | (get-in context [:coeffects :db :games name])) 40 | 41 | ;; set original-db for :after clause 42 | (assoc-in 43 | [:coeffects ::original-db] 44 | (get-in context [:coeffects :db])) 45 | 46 | ;; trim event object 47 | (update-in [:coeffects :event] 48 | (fn [event] 49 | (let [trimmed (subvec event 1)] 50 | (if (= 1 (count trimmed)) 51 | (first trimmed) 52 | trimmed)))) 53 | 54 | ;; store untrimmed for retrieval 55 | (assoc-in [:coeffects ::untrimmed-event] 56 | (get-in context [:coeffects :event]))))) 57 | :after 58 | (fn game-db-interceptor-after 59 | [context] 60 | (let [{:keys [name]} 61 | (nth (get-in context [:coeffects ::untrimmed-event]) 1) 62 | game-db (-> context :effects :db) 63 | og-db (-> context :coeffects ::original-db) 64 | updated-db (if game-db 65 | (assoc-in og-db [:games name] game-db) 66 | og-db)] 67 | (-> context 68 | ;; clean up trimming, retore event 69 | (rfu/dissoc-in [:coeffects ::untrimmed-event]) 70 | (assoc-in [:coeffects :event] 71 | (get-in context [:coeffects ::untrimmed-event])) 72 | ;; remove our helper 73 | (rfu/dissoc-in [:coeffects ::original-db]) 74 | ;; set the new db on 'EFFECTS' (NOT COEFFECTS) 75 | (assoc-in [:effects :db] updated-db)))))) 76 | 77 | 78 | (rf/reg-event-fx 79 | ::interceptor-example 80 | [(game-db-interceptor)] 81 | (fn [{:keys [db]} _game-opts] 82 | (log/debug "~{_game-opts}") 83 | (log/debug "~{(keys db)}") 84 | {:db db})) 85 | 86 | 87 | (comment 88 | (rf/dispatch [::interceptor-example {:name :default}])) 89 | 90 | (defn ->fancy-interceptor 91 | "'This thing is just a map.'" 92 | [& {:keys [id before after]}] 93 | (rfi/->interceptor 94 | :id (or id :unnamed) 95 | :before before 96 | :after after ) 97 | ) 98 | 99 | (comment 100 | (def my-fancy-interceptor 101 | (->fancy-interceptor 102 | :id :something-fancy 103 | :before 104 | (fn remove-complexity [ctx] ctx) 105 | :after 106 | (fn add-back-to-context 107 | ;; Remember to add to :effects, not :coeffects 108 | [ctx] ctx)))) 109 | -------------------------------------------------------------------------------- /src/games/debug/views.cljs: -------------------------------------------------------------------------------- 1 | (ns games.debug.views 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.views.components :as components] 5 | [games.grid.views :as grid.views] 6 | [games.debug.events :as debug.events] 7 | [games.debug.subs :as debug.subs] 8 | [games.subs :as subs])) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Select game 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (defn select-game-cells 15 | [{:keys [moveable? x y]}] 16 | ^{:key (str x y)} 17 | [:div 18 | {:style 19 | {:height "48px" 20 | :width "48px" 21 | :border (if moveable? "1px solid white" "1px solid black") 22 | :background (if moveable? "green" "white")}} 23 | ""]) 24 | 25 | (defn select-game 26 | "Intended as a div. Starts itself." 27 | [] 28 | (let [game-opts {:name :debug-select-game} 29 | grid @(rf/subscribe [::subs/game-grid game-opts])] 30 | [grid.views/matrix grid 31 | {:->cell select-game-cells}])) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;; Debug game 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | (defn debug-cell 38 | "Debug cells have clickable `:anchor?`s." 39 | [{:keys [moveable? x y anchor?] :as cell} 40 | {:keys [debug? cell-height cell-width] :as game-opts}] 41 | (let [ 42 | ;; cell-width (or cell-width (if debug? "148px" "48px")) 43 | ;; cell-height (or cell-height (if debug? "148px" "48px")) 44 | cell-width (or cell-width (if debug? "unset" "48px")) 45 | cell-height (or cell-height (if debug? "unset" "48px")) 46 | props (dissoc cell :x :y)] 47 | ^{:key (str x y)} 48 | [:div 49 | {:on-click 50 | (when anchor? 51 | #(rf/dispatch [::debug.events/toggle-debug game-opts])) 52 | :style 53 | {:height cell-height 54 | :width cell-width 55 | :border (if moveable? "1px solid white" "1px solid red") 56 | :background (cond 57 | anchor? "blue" 58 | moveable? "green" 59 | :else "gray")}} 60 | (if debug? (str "x:" x " y:" y " " (when (seq props) props)) "")])) 61 | 62 | (defn debug-game 63 | "Intended as a full page. 64 | Useful as a debugger and sandbox, for implementing fancy features. 65 | Click the anchor cell to toggle `debug`. 66 | " 67 | ([] (debug-game {:name :debug-debug-game})) 68 | ([game-opts] 69 | (let [grid @(rf/subscribe [::subs/game-grid game-opts]) 70 | debug? @(rf/subscribe [::subs/game-db game-opts :debug?]) 71 | game-opts @(rf/subscribe [::subs/game-opts game-opts])] 72 | 73 | [:div 74 | (when debug? [:h1 {:style {:color "white"}} (str "debug? :" debug?)]) 75 | 76 | (when debug? [:h3 {:style {:color "white"}} (:name game-opts)]) 77 | [grid.views/matrix grid {:->cell #(debug-cell % game-opts)}] 78 | 79 | (when debug? [:div {:style {:background "white"}} [:p (str game-opts)]])]))) 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;; Pages 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | (defn n-games-page [n] 86 | (let [debug-game-opts @(rf/subscribe [::debug.subs/debug-game-opts]) 87 | debug-game-opts (take n debug-game-opts)] 88 | [:div 89 | {:style {:width "100%" 90 | :display "flex" 91 | :justify-content "space-around"}} 92 | (for [opts debug-game-opts] 93 | ^{:key (:name opts)} 94 | [components/widget 95 | {:label (:name opts)} 96 | ^{:key "dbg-game"} 97 | [debug-game opts]])])) 98 | 99 | (defn page [] 100 | [components/page 101 | {:direction :row 102 | :full-height? true 103 | :header [components/widget {:label "Debug"}]} 104 | ;; ^{:key "debug-game"} 105 | ;; [debug-game] 106 | ^{:key "two-games"} 107 | [n-games-page 1] 108 | ]) 109 | -------------------------------------------------------------------------------- /src/games/views/components.cljs: -------------------------------------------------------------------------------- 1 | (ns games.views.components) 2 | 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; Label 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | (defn display-label 9 | [label] 10 | [:h3 11 | {:style 12 | {:opacity "0.9"}} 13 | label]) 14 | 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | ;; Subhead 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | ;;(defn display-subhead [subhead] subhead) 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;; Widget 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | (defn widget 26 | "A div with a 'vget-itude" 27 | ([{:keys [label subhead value class style] :as opts} & children] 28 | (let [opts (-> opts ;; quick and dirty - could clean up 29 | (dissoc :label) 30 | (dissoc :subhead) 31 | (dissoc :value) 32 | (dissoc :class) 33 | (dissoc :style))] 34 | [:div 35 | (merge 36 | {:class (str "widget nes-container is-dark " class) 37 | :style 38 | (merge 39 | {:display "flex" 40 | :text-align "center" 41 | :align-items "center" 42 | :flex-direction "column" 43 | :justify-content "center"} 44 | style)} 45 | opts) 46 | 47 | (when label 48 | ^{:key (str "display-label-" label)} 49 | [display-label label]) 50 | 51 | (when subhead 52 | ^{:key (str "subhead-" label)} 53 | subhead) 54 | 55 | (when value 56 | ^{:key (str "value-" value)} 57 | [:h2 58 | {:style {:margin-top "12px" 59 | :opacity "0.95"}} 60 | value]) 61 | (when children 62 | (for [[i c] (map-indexed vector children)] ^{:key i} c))]))) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;; Page 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | (def background-color "#441086") 69 | ;;:background "#5d08c7" 70 | (def background 71 | (str "linear-gradient(135deg, " background-color " 21px, 72 | black 22px, black 24px, transparent 24px, transparent 67px, 73 | black 67px, black 69px, transparent 69px), 74 | linear-gradient(225deg, " background-color " 21px, 75 | black 22px, black 24px, transparent 24px, transparent 67px, 76 | black 67px, black 69px, transparent 69px), 64px")) 77 | (def global-bg {:background background 78 | :background-color background-color 79 | :background-size "64px 128px"}) 80 | 81 | (defn page-column [children] 82 | (when children 83 | (for [[i c] (map-indexed vector children)] 84 | ^{:key i} c))) 85 | 86 | (defn page-row [{:keys [full-height?]} children] 87 | [:div 88 | {:style 89 | {:display "flex" 90 | :flex-wrap "wrap" 91 | :flex-direction "row" 92 | :height (when full-height? "100%")}} 93 | (when children 94 | (for [[i c] (map-indexed vector children)] 95 | ^{:key i} c))]) 96 | 97 | (defn page 98 | ([{:keys [class style empty-bg? direction header] :as opts} & children] 99 | (let [div-opts (dissoc opts 100 | :style 101 | :class 102 | :header 103 | :full-height?)] 104 | [:div 105 | (merge 106 | {:class (str "page " class) 107 | :style 108 | (merge 109 | {:height "100vh" 110 | :width "100vw" 111 | :display "flex" 112 | :padding "24px" 113 | :flex-direction "column"} 114 | (if empty-bg? {} global-bg) 115 | style)} 116 | div-opts) 117 | 118 | (when header header) 119 | 120 | (when (= :row direction) (page-row opts children)) 121 | (when (or (not direction) (= :column direction)) (page-column children))]))) 122 | -------------------------------------------------------------------------------- /src/games/puyo/db.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.db 2 | (:require 3 | [games.grid.core :as grid] 4 | [games.puyo.shapes :as puyo.shapes] 5 | [games.puyo.controls :as puyo.controls])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Game DB 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (def shape-grid 12 | (grid/build-grid 13 | {:height 2 14 | :width 1 15 | :entry-cell {:x 0 :y 1}})) 16 | 17 | (def defaults 18 | {:step-timeout 500 19 | :ignore-controls false 20 | :colors 21 | [:red 22 | :green 23 | :yellow 24 | :blue]}) 25 | 26 | (defn game-db 27 | "Creates an initial puyo game state." 28 | [game-opts] 29 | (let [{:keys 30 | [name game-grid step-timeout ignore-controls 31 | group-size 32 | ] :as game-opts} 33 | (merge defaults game-opts)] 34 | {:name name 35 | :game-opts game-opts 36 | :init-event-name :games.puyo.events/init-game 37 | :stop-event-name :games.puyo.events/stop 38 | 39 | ;; game (matrix) 40 | :game-grid 41 | (grid/build-grid 42 | (merge 43 | {:height 10 44 | :width 10 45 | :phantom-rows 2 46 | :entry-cell {:x 4 :y -1}} 47 | game-grid)) 48 | 49 | ;; game logic 50 | :group-size (or group-size 4) ;; number of puyos in a group to be removed 51 | :step-timeout step-timeout 52 | :paused? false 53 | :gameover? false 54 | :current-piece-num 0 55 | 56 | ;; timer 57 | :time 0 58 | 59 | ;; queue 60 | :piece-queue (puyo.shapes/next-bag {:game-opts game-opts 61 | :min-queue-size 5}) 62 | :min-queue-size 5 63 | :preview-grids (repeat 3 shape-grid) 64 | 65 | ;; controls 66 | :controls (puyo.controls/initial game-opts) 67 | :ignore-controls ignore-controls 68 | 69 | ;; hold/swap 70 | :falling-shape nil 71 | :held-shape nil 72 | :held-grid shape-grid 73 | :hold-lock false 74 | 75 | ;; modes 76 | :spin-the-bottle? false ;; rotate the board on every piece 77 | :pacman-sides true ;; travel across the walls 78 | :fancy-pants false ;; travel between games 79 | :mirror-mode false ;; reverse left/right 80 | 81 | ;; level/score 82 | :level 1 83 | :groups-per-level 5 84 | :groups-cleared 0 85 | :score 0 86 | :score-per-group-clear 10 87 | :groups-in-combo 0 88 | :last-combo-piece-num nil})) 89 | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | ;; Game DBs 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | 94 | (def classic-game-db 95 | (-> 96 | {:name :puyo-classic-game 97 | :pages #{:puyo} 98 | :no-walls-x? true 99 | :game-grid {:entry-cell {:x 3 :y -1} 100 | :height 16 101 | :width 8}} 102 | (game-db))) 103 | 104 | (def select-game-db 105 | (-> {:name :puyo-select-game 106 | :pages #{:select} 107 | :tick-timeout 500 108 | :on-gameover :restart 109 | :no-walls-x? true 110 | :game-grid {:entry-cell {:x 1 :y 0} 111 | :height 10 112 | :width 5}} 113 | (game-db))) 114 | 115 | (def debug-game-db 116 | (-> 117 | {:name :puyo-debug-game 118 | :pages #{:debug} 119 | :on-gameover :restart 120 | :colors [:red :blue] 121 | :group-size 3 122 | :game-grid {:entry-cell {:x 1 :y 0} 123 | :height 5 124 | :width 3}} 125 | (game-db))) 126 | 127 | (def game-dbs 128 | [select-game-db 129 | classic-game-db 130 | debug-game-db]) 131 | 132 | ;; TODO dry up 133 | (def game-dbs-map 134 | (->> game-dbs 135 | (map (fn [game] [(-> game :name) game])) 136 | (into {}))) 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | ;; DB 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | 142 | (def db 143 | {:games game-dbs-map}) 144 | -------------------------------------------------------------------------------- /src/games/tetris/views/classic.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.views.classic 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.views.components :as components] 5 | [games.views.util :as util] 6 | [games.grid.views :as grid.views] 7 | [games.controls.views :as controls.views] 8 | [games.subs :as subs] 9 | [games.tetris.subs :as tetris.subs] 10 | [games.tetris.events :as tetris.events] 11 | [games.tetris.views :as tetris.views] 12 | [games.color :as color])) 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | ;; Center Panel 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (defn gameover 19 | [] 20 | [:h3 {:style {:margin-bottom "1rem"}} "Game Over."]) 21 | 22 | (defn restart 23 | [game-opts] 24 | [:p 25 | {:style {:margin-top "1rem"} 26 | ;; TODO impl event 27 | :on-click #(rf/dispatch [::tetris.events/restart-game game-opts])} 28 | "Click here to restart."]) 29 | 30 | (defn center-panel [game-opts] 31 | (let [grid @(rf/subscribe [::subs/game-grid game-opts]) 32 | gameover? @(rf/subscribe [::tetris.subs/gameover? game-opts])] 33 | [:div.center-panel 34 | {:style 35 | {:display "flex" 36 | :flex "1"}} 37 | [components/widget 38 | {:style {:flex "1"}} 39 | 40 | (when gameover? ^{:key "go"} [gameover]) 41 | ^{:key "matrix"} [tetris.views/matrix grid game-opts] 42 | (when gameover? ^{:key "rest."} [restart game-opts])]])) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;; Left panel 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | (defn left-panel [game-opts] 49 | (let [score @(rf/subscribe [::tetris.subs/score game-opts]) 50 | t @(rf/subscribe [::tetris.subs/time game-opts]) 51 | level @(rf/subscribe [::tetris.subs/level game-opts]) 52 | paused? @(rf/subscribe [::tetris.subs/paused? game-opts]) 53 | time (str (util/with-precision 1 (/ t 1000)) "s")] 54 | [:div.left-panel 55 | {:style 56 | {:display "flex" 57 | :flex "1" 58 | :flex-direction "column"}} 59 | [components/widget 60 | {:style 61 | {:flex "1"} 62 | :label (if paused? "Paused" "Time") 63 | :value time}] 64 | [components/widget 65 | {:style 66 | {:flex "1"} 67 | :label "Level" :value level}] 68 | [components/widget 69 | {:style 70 | {:flex "1"} 71 | :label "Score" :value score}]])) 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;; Queue 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | 77 | (defn piece-queue [game-opts] 78 | (let [preview-grids @(rf/subscribe [::tetris.subs/preview-grids game-opts])] 79 | (grid.views/piece-list 80 | {:label "Queue" 81 | :cell->style (fn [c] {:background (color/cell->piece-color c)}) 82 | :piece-grids preview-grids}))) 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | ;; Hold/Swap 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | (defn hold-string [game-opts] 89 | (let [any-held? @(rf/subscribe [::tetris.subs/any-held? game-opts]) 90 | hold-keys @(rf/subscribe [::subs/keys-for :hold]) 91 | hold-key (first hold-keys)] 92 | (str (if any-held? "Swap (" "Hold (") hold-key ")"))) 93 | 94 | (defn held-piece [game-opts] 95 | (let [held-grid @(rf/subscribe [::tetris.subs/held-grid game-opts])] 96 | (grid.views/piece-list 97 | {:label (hold-string game-opts) 98 | :piece-grids [held-grid] 99 | :cell->style (fn [c] {:background (color/cell->piece-color c)})}))) 100 | 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | ;; Right panel 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | 105 | (defn debug-game [game-opts] 106 | (let [fields [:falling-shape :piece-queue] 107 | db @(rf/subscribe [::subs/game-db game-opts])] 108 | [components/widget 109 | {} 110 | [:div 111 | [:h3 "Game DB"] 112 | (for [f fields] 113 | [:p 114 | (str f ":=> " (get db f))])]])) 115 | 116 | (defn right-panel [game-opts] 117 | [:div 118 | {:style 119 | {:display "flex" 120 | :flex "1" 121 | :flex-direction "column"}} 122 | (when false [debug-game game-opts]) 123 | [piece-queue game-opts] 124 | [held-piece game-opts] 125 | [controls.views/mini-text 126 | {:controls [:pause :hold :rotate]}]]) 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | ;; Classic game 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | (defn classic-game 133 | [] 134 | (let [game-opts {:name :tetris-classic-game} 135 | game-opts @(rf/subscribe [::subs/game-opts game-opts])] 136 | [components/page 137 | {:direction :row 138 | :full-height? true} 139 | ^{:key "left"} 140 | [left-panel game-opts] 141 | 142 | ^{:key "center"} 143 | [center-panel game-opts] 144 | 145 | ^{:key "right"} 146 | [right-panel game-opts]])) 147 | 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | ;; Main page component 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | 152 | (defn page 153 | [] 154 | [classic-game]) 155 | -------------------------------------------------------------------------------- /src/games/puyo/views/classic.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.views.classic 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.views.components :as components] 5 | [games.views.util :as util] 6 | [games.controls.views :as controls.views] 7 | [games.grid.views :as grid.views] 8 | [games.puyo.events :as puyo.events] 9 | [games.subs :as subs] 10 | [games.color :as color] 11 | [games.puyo.subs :as puyo.subs] 12 | [games.puyo.views :as puyo.views])) 13 | 14 | 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | ;; Center Panel 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (defn gameover 20 | [] 21 | ^{:key "go"} 22 | [:h3 {:style {:margin-bottom "1rem"}} "Game Over."]) 23 | 24 | (defn restart 25 | [game-opts] 26 | ^{:key "rest."} 27 | [:p 28 | {:style {:margin-top "1rem"} 29 | :on-click #(rf/dispatch [::puyo.events/restart-game game-opts])} 30 | "Click here to restart."]) 31 | 32 | (defn center-panel [game-opts] 33 | (let [grid @(rf/subscribe [::subs/game-grid game-opts]) 34 | gameover? @(rf/subscribe [::puyo.subs/gameover? game-opts])] 35 | [:div.center-panel 36 | {:style 37 | {:display "flex" 38 | :flex "1"}} 39 | [components/widget 40 | {:style {:flex "1"}} 41 | 42 | (when gameover? ^{:key "go"} [gameover]) 43 | ^{:key "matrix"} [puyo.views/matrix grid game-opts] 44 | (when gameover? ^{:key "rest."} [restart game-opts])]])) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;; Left panel 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | (defn left-panel [game-opts] 51 | (let [score @(rf/subscribe [::puyo.subs/score game-opts]) 52 | t @(rf/subscribe [::puyo.subs/time game-opts]) 53 | level @(rf/subscribe [::puyo.subs/level game-opts]) 54 | paused? @(rf/subscribe [::puyo.subs/paused? game-opts]) 55 | time (str (util/with-precision 1 (/ t 1000)) "s")] 56 | [:div.left-panel 57 | {:style 58 | {:display "flex" 59 | :flex "1" 60 | :flex-direction "column"}} 61 | [components/widget 62 | {:on-click #(rf/dispatch [::puyo.events/toggle-pause game-opts]) 63 | :style {:flex "1"} 64 | :label (if paused? "Paused" "Time") 65 | :value time}] 66 | [components/widget 67 | {:style {:flex "1"} 68 | :label "Level" 69 | :value level}] 70 | [components/widget 71 | {:style {:flex "1"} 72 | :label "Score" 73 | :value score}]])) 74 | 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | ;; Piece Queue 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | 79 | (defn piece-queue [{:keys [cell-style] :as game-opts}] 80 | (let [preview-grids @(rf/subscribe [::puyo.subs/preview-grids game-opts])] 81 | ^{:key "piece-queue"} 82 | [grid.views/piece-list 83 | {:label "Queue" 84 | :piece-grids preview-grids 85 | :style {:justify-content "space-between" 86 | :flex-direction "row"} 87 | :cell->style 88 | (fn [c] 89 | (merge 90 | (or cell-style {}) 91 | {:background (color/cell->piece-color c)}))}])) 92 | 93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 | ;; Held Piece 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | 97 | (defn hold-string [game-opts] 98 | (let [any-held? @(rf/subscribe [::puyo.subs/any-held? game-opts]) 99 | hold-keys @(rf/subscribe [::subs/keys-for :hold]) 100 | hold-key (first hold-keys)] 101 | (str (if any-held? "Swap (" "Hold (") hold-key ")"))) 102 | 103 | (defn held-piece [{:keys [cell-style] :as game-opts}] 104 | (let [held-grid @(rf/subscribe [::puyo.subs/held-grid game-opts])] 105 | (grid.views/piece-list 106 | {:label (hold-string game-opts) 107 | :piece-grids [held-grid] 108 | :cell->style 109 | (fn [{:keys [color] :as c}] 110 | (merge 111 | (or cell-style {}) 112 | (if color 113 | {:background (color/cell->piece-color c)} 114 | {:background "transparent"})))}))) 115 | 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | ;; Right panel 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | 120 | (defn right-panel [game-opts] 121 | [:div 122 | {:style 123 | {:display "flex" 124 | :flex "1" 125 | :flex-direction "column"}} 126 | [piece-queue game-opts] 127 | [held-piece game-opts] 128 | [controls.views/mini-text 129 | {:controls [:pause :hold :rotate]}]]) 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | ;; Classic Game 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | 135 | (defn classic-game 136 | [] 137 | (let [game-opts {:name :puyo-classic-game} 138 | game-opts @(rf/subscribe [::subs/game-opts game-opts])] 139 | (components/page 140 | {:direction :row 141 | :full-height? true} 142 | ^{:key "left"} 143 | [left-panel game-opts] 144 | ^{:key "center"} 145 | [center-panel game-opts] 146 | ^{:key "right"} 147 | [right-panel game-opts]))) 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | ;; Page 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | 153 | (defn page 154 | [] 155 | [classic-game]) 156 | -------------------------------------------------------------------------------- /src/games/controls/re_pressed.cljs: -------------------------------------------------------------------------------- 1 | (ns games.controls.re-pressed 2 | (:require 3 | [re-frame.core :as rf] 4 | [re-pressed.core :as rp])) 5 | 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;; Key Data and maps 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (def key-label->re-pressed-key 11 | "Maps a 'nice' string to a re-pressed key with keyCode." 12 | { 13 | "backspace" {:keyCode 8} 14 | "tab" {:keyCode 9} 15 | "enter" {:keyCode 13} 16 | 17 | "space" {:keyCode 32} 18 | "pageup" {:keyCode 33} 19 | "pagedown" {:keyCode 34} 20 | "end" {:keyCode 35} 21 | "home" {:keyCode 36} 22 | "left" {:keyCode 37} 23 | "up" {:keyCode 38} 24 | "right" {:keyCode 39} 25 | "down" {:keyCode 40} 26 | "delete" {:keyCode 46} 27 | 28 | "a" {:keyCode 65} 29 | "b" {:keyCode 66} 30 | "c" {:keyCode 67} 31 | "d" {:keyCode 68} 32 | "e" {:keyCode 69} 33 | "f" {:keyCode 70} 34 | "g" {:keyCode 71} 35 | "h" {:keyCode 72} 36 | "i" {:keyCode 73} 37 | "j" {:keyCode 74} 38 | "k" {:keyCode 75} 39 | "l" {:keyCode 76} 40 | "m" {:keyCode 77} 41 | "n" {:keyCode 78} 42 | "o" {:keyCode 79} 43 | "p" {:keyCode 80} 44 | "q" {:keyCode 81} 45 | ;; "r" {:keyCode 82} ;; TODO reenable - right now this clobbers ctrl+r 46 | "s" {:keyCode 83} 47 | "t" {:keyCode 84} 48 | "u" {:keyCode 85} 49 | "v" {:keyCode 86} 50 | "w" {:keyCode 87} 51 | "x" {:keyCode 88} 52 | "y" {:keyCode 89} 53 | "z" {:keyCode 90} 54 | 55 | ";" {:keyCode 186} 56 | ":" {:keyCode 186} 57 | "+" {:keyCode 187} 58 | "=" {:keyCode 187} 59 | "," {:keyCode 188} 60 | "<" {:keyCode 188} 61 | "-" {:keyCode 189} 62 | "_" {:keyCode 189} 63 | "." {:keyCode 190} 64 | ">" {:keyCode 190} 65 | "?" {:keyCode 191} 66 | "/" {:keyCode 191} 67 | "`" {:keyCode 192} 68 | "~" {:keyCode 192} 69 | "[" {:keyCode 219} 70 | "{" {:keyCode 219} 71 | "\\" {:keyCode 220} 72 | "|" {:keyCode 220} 73 | "]" {:keyCode 221} 74 | "}" {:keyCode 221} 75 | "'" {:keyCode 222} 76 | "\"" {:keyCode 222} 77 | }) 78 | 79 | (def supported-keys (set (keys key-label->re-pressed-key))) 80 | 81 | 82 | (defn str-key->event-name [id] 83 | (keyword :games.controls.key-press id)) 84 | 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | ;; Transforms over key data 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | 89 | (defn ->rp-event 90 | "Only supports one key press per event. 91 | Returns [event[kbd]], assumes passed `:event` is already a vector." 92 | [{:keys [event kbd]}] 93 | [event [kbd]]) 94 | 95 | (def rp-event-keys 96 | "Converts the supported keys into a re-pressed `[[::event][kbd1][kbd2]]` list." 97 | (into [] (map 98 | (fn [[str-key rp-key]] 99 | (->rp-event {:kbd rp-key 100 | :event [(str-key->event-name str-key)]})) 101 | key-label->re-pressed-key))) 102 | 103 | (def rp-all-keys 104 | "Converts the passed controls-db into a re-pressed `[kbd1 kbd2]` list." 105 | (into [] 106 | (vals key-label->re-pressed-key))) 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | ;; Key-press listener events 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | ;; Registers each listener with re-pressed's listener 113 | (rf/reg-event-fx 114 | ::register-key-listeners 115 | (fn [_cofx _evt] 116 | {:dispatch 117 | [::rp/set-keydown-rules 118 | {:event-keys rp-event-keys 119 | :prevent-default-keys rp-all-keys}]})) 120 | 121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 122 | ;; Key-press handler and registration 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | 125 | (defn key-press-handler 126 | "Dispatches registered events when the passed key is pressed. 127 | Selects events to dispatch using the db's :controls-by-key map. 128 | " 129 | [str-key cofx _event] 130 | (let [controls (get-in cofx [:db :controls-by-key str-key])] 131 | {:dispatch-n (map :event controls)})) 132 | 133 | (defn register-dispatcher 134 | [[str-key _]] 135 | (rf/reg-event-fx 136 | (str-key->event-name str-key) 137 | (partial key-press-handler str-key))) 138 | 139 | (defn register-dispatchers 140 | "Registers an internal (games) event for every key in `supported-keys`" 141 | [] 142 | (doall (map register-dispatcher key-label->re-pressed-key))) 143 | 144 | ;; Registers handler for with re-pressed's events 145 | (rf/reg-event-fx 146 | ::register-key-dispatchers 147 | (fn [_cofx _evt] 148 | (register-dispatchers) 149 | {})) 150 | 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | ;; Controls->controls by key 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | 155 | (defn controls->by-key 156 | "Converts controls from a list of control maps like 157 | `{:keys #{k1 k2} :event [evt] :id :control-id}` 158 | into a map of controls by key, like: 159 | `{k1 [{:keys #{k1 k2} :event [evt] :id ctrl-id}] 160 | k2 [{:keys #{k1 k2} :event [evt] :id ctrl-id}]}` 161 | 162 | Multiple controls will be registered for keys that share a control, 163 | so that events can be dispatched to them simultaneously. 164 | 165 | Supports looking up events to dispatch by keys pressed in above handler. 166 | Called at control registration time. 167 | " 168 | [controls] 169 | (reduce 170 | (fn [by-key {:keys [keys] :as control}] 171 | (reduce 172 | (fn [by-key str-key] 173 | (let [controls (get by-key str-key)] 174 | (assoc by-key str-key (conj controls control)))) 175 | by-key 176 | keys)) 177 | {} 178 | controls)) 179 | -------------------------------------------------------------------------------- /src/games/events.cljs: -------------------------------------------------------------------------------- 1 | (ns games.events 2 | (:require 3 | [re-frame.core :as rf] 4 | [games.events.interceptors :refer [game-db-interceptor]] 5 | [games.controls.events :as controls.events] 6 | [games.db :as db])) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Init 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (rf/reg-event-fx 13 | ::init 14 | (fn [_] 15 | {:db db/initial-db 16 | :dispatch-n 17 | [[::start-games] 18 | [::controls.events/init]]})) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Start Games 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | ;; implies games have page knowledge (`pages`) 25 | ;; maybe the pages should call out their named-games? 26 | (defn for-page? 27 | [page {:keys [game-opts] :as _game-db}] 28 | (contains? (:pages game-opts) page)) 29 | 30 | (defn games-for-page 31 | [db page] 32 | (let [games (-> db :games vals)] 33 | (filter #(for-page? page %) 34 | games))) 35 | 36 | (defn games-not-for-page 37 | [db page] 38 | (let [games (-> db :games vals)] 39 | (remove #(for-page? page %) 40 | games))) 41 | 42 | (rf/reg-event-fx 43 | ::start-games 44 | (fn [{:keys [db]}] 45 | (let [page (:current-page db) 46 | start-games (games-for-page db page) 47 | stop-games (games-not-for-page db page)] 48 | {:db (assoc db :active-games (map :name start-games)) 49 | :dispatch-n 50 | (concat 51 | (map (fn [game] 52 | [(:init-event-name game) (:game-opts game)]) 53 | start-games) 54 | (map (fn [game] 55 | [(:stop-event-name game) (:game-opts game)]) 56 | stop-games))}))) 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;; Navigation 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (rf/reg-event-fx 63 | ::set-page 64 | (fn [{:keys [db]} [_ page]] 65 | {:db (assoc db :current-page page) 66 | :dispatch [::start-games]})) 67 | 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | ;; Per game start, stop, restart, step, pause events 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | 72 | (defn opts->timer-id 73 | [opts] 74 | (keyword (namespace ::x) 75 | (str (name :timer) "-" (name (:name opts))))) 76 | 77 | (defn n->step-id 78 | [n] 79 | (keyword n (str (name :step)))) 80 | 81 | (defn opts-n->timeouts 82 | [opts n] 83 | [{:id (n->step-id n)} 84 | {:id (opts->timer-id opts)}]) 85 | 86 | (defn reg-game-events 87 | "Registers general game events: 88 | 89 | - ::init-game 90 | - ::stop 91 | - ::restart 92 | - ::step 93 | - ::pause 94 | - ::resume 95 | - ::toggle-pause 96 | - ::timer 97 | 98 | NOTE Some of these event names are baked into default db events (init, stop), 99 | or are otherwise called from controls/ui dispatches (restart, pause, resume). 100 | 101 | Handles a few keys on game-dbs: 102 | 103 | - :time - time passed since start 104 | - :time-increment - how often the timer should be incremented 105 | - :step-timeout - the time between game-steps, often decreased as levels 106 | increase (in falling-block games like tetris/puyo). 107 | - :paused? - whether or not the game is paused 108 | - :gameover? - read-only. if the game is over, the ::step event will kill the 109 | running timers 110 | " 111 | ([] (reg-game-events {})) 112 | ([{:keys [n step-fn]}] 113 | (let [init-evt (keyword n :init-game) 114 | stop-evt (keyword n :stop) 115 | restart-evt (keyword n :restart) 116 | pause-evt (keyword n :pause) 117 | resume-evt (keyword n :resume) 118 | toggle-pause-evt (keyword n :toggle-pause) 119 | timer-evt (keyword n :timer)] 120 | 121 | (rf/reg-event-fx 122 | init-evt 123 | [(game-db-interceptor)] 124 | (fn [_cofx game-opts] 125 | {:dispatch-n 126 | [[::controls.events/register-controls game-opts] 127 | [(n->step-id n) game-opts] 128 | [timer-evt game-opts]]})) 129 | 130 | 131 | (rf/reg-event-fx 132 | stop-evt 133 | [(game-db-interceptor)] 134 | (fn [_cofx game-opts] 135 | {:dispatch-n 136 | [[::controls.events/deregister-controls game-opts]] 137 | :clear-timeouts (opts-n->timeouts game-opts n)})) 138 | 139 | (rf/reg-event-fx 140 | restart-evt 141 | [(game-db-interceptor)] 142 | (fn [_cofx game-opts] 143 | {:db (-> db/initial-db :games (get (:name game-opts))) 144 | :dispatch-n 145 | [[(n->step-id n) game-opts] 146 | [timer-evt game-opts]]})) 147 | 148 | (when step-fn 149 | (rf/reg-event-fx 150 | (n->step-id n) 151 | [(game-db-interceptor)] 152 | (fn [{:keys [db]} game-opts] 153 | (let [{:keys [step-timeout] :as db} 154 | (step-fn db game-opts)] 155 | (if (:gameover? db) 156 | {:db db 157 | :clear-timeouts 158 | (opts-n->timeouts game-opts n)} 159 | {:db db 160 | :timeout 161 | {:id (n->step-id n) 162 | :event [(n->step-id n) game-opts] 163 | :time step-timeout}}))))) 164 | 165 | (rf/reg-event-fx 166 | pause-evt 167 | [(game-db-interceptor)] 168 | (fn [{:keys [db]} game-opts] 169 | {:db (assoc db :paused? true) 170 | :clear-timeouts (opts-n->timeouts game-opts n)})) 171 | 172 | (rf/reg-event-fx 173 | resume-evt 174 | [(game-db-interceptor)] 175 | (fn [{:keys [db]} game-opts] 176 | (let [updated-db (assoc db :paused? false)] 177 | {:db updated-db 178 | :dispatch-n 179 | [[(n->step-id n) game-opts] 180 | [timer-evt game-opts]]}))) 181 | 182 | (rf/reg-event-fx 183 | toggle-pause-evt 184 | [(game-db-interceptor)] 185 | (fn [{:keys [db]} game-opts] 186 | (if-not (:gameover? db) 187 | (if (:paused? db) 188 | ;; unpause 189 | {:dispatch [resume-evt game-opts]} 190 | ;; pause 191 | {:dispatch [pause-evt game-opts]})))) 192 | 193 | (rf/reg-event-fx 194 | timer-evt 195 | [(game-db-interceptor)] 196 | (fn [{:keys [db]} game-opts] 197 | (let [{:keys [timer-increment]} db 198 | timer-increment (or timer-increment 400)] 199 | {:db (update db :time #(+ % timer-increment)) 200 | :timeout 201 | {:id (opts->timer-id game-opts) 202 | :event [timer-evt game-opts] 203 | :time timer-increment}})))))) 204 | 205 | (defn reg-game-move-events 206 | [{:keys [n 207 | move-piece 208 | instant-fall 209 | after-piece-played 210 | rotate-piece 211 | ]}] 212 | (let [can-player-move? (fn [db] (:paused? db)) 213 | move-evt (keyword n :move-piece) 214 | instant-fall-evt (keyword n :instant-fall) 215 | rotate-evt (keyword n :rotate-piece) 216 | after-piece-played (or after-piece-played identity)] 217 | 218 | (rf/reg-event-db 219 | move-evt 220 | [(game-db-interceptor)] 221 | (fn [db [_game-opts direction]] 222 | (if (can-player-move? db) 223 | (move-piece db direction) 224 | db))) 225 | 226 | (rf/reg-event-db 227 | instant-fall-evt 228 | [(game-db-interceptor)] 229 | (fn [db [_game-opts direction]] 230 | (if (can-player-move? db) 231 | (-> db 232 | (instant-fall direction) 233 | (after-piece-played)) 234 | db))) 235 | 236 | (rf/reg-event-db 237 | rotate-evt 238 | [(game-db-interceptor)] 239 | (fn [db _game-opts] 240 | (if (can-player-move? db) 241 | (rotate-piece db) 242 | db))))) 243 | 244 | (defn reg-hold-event 245 | [{:keys [n clear-falling-cells add-preview-piece on-hold can-player-move?]}] 246 | (let [hold-evt (keyword n :hold-and-swap-piece) 247 | can-player-move? (or can-player-move? (fn [_] true)) 248 | on-hold (or on-hold identity)] 249 | (rf/reg-event-db 250 | hold-evt 251 | [(game-db-interceptor)] 252 | (fn [{:keys [held-shape falling-shape hold-lock] 253 | :as db 254 | } _game-opts] 255 | (if (or (not falling-shape) 256 | hold-lock 257 | (not (can-player-move? db))) 258 | db 259 | (cond-> db 260 | ;; prepend queue with held piece 261 | held-shape 262 | (update :piece-queue (fn [q] 263 | (cons held-shape q))) 264 | 265 | falling-shape 266 | (-> 267 | ;; move falling piece to held piece 268 | (assoc :held-shape falling-shape) 269 | ;; clear falling piece if there was one 270 | (assoc :falling-shape nil) 271 | ;; clear the falling pieces from the board 272 | (clear-falling-cells) 273 | ;; update grid for showing held piece 274 | (update :held-grid 275 | #(add-preview-piece % falling-shape)) 276 | 277 | ;; indicate that a piece was held to prevent double-holds 278 | (assoc :hold-lock true) 279 | 280 | (on-hold)))))))) 281 | -------------------------------------------------------------------------------- /src/games/tetris/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.tetris.core 2 | (:require 3 | [games.grid.core :as grid] 4 | [games.tetris.db :as tetris.db] 5 | [games.tetris.shapes :as tetris.shapes])) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;; Predicates and game logic 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | (defn cell-occupied? [{:keys [game-grid]} cell] 12 | (:occupied (grid/get-cell game-grid cell))) 13 | 14 | (defn cell-open? 15 | "Returns true if the indicated cell is within the grid's bounds AND not 16 | occupied." 17 | [{:keys [game-grid] :as db} cell] 18 | (and 19 | (grid/within-bounds? game-grid cell {:allow-above? true}) 20 | (not (cell-occupied? db cell)))) 21 | 22 | (defn row-fully-occupied? [row] 23 | (grid/true-for-row? row :occupied)) 24 | 25 | (defn rows-to-clear 26 | "Returns true if there are rows to be removed from the board." 27 | [{:keys [game-grid]}] 28 | (grid/select-rows game-grid row-fully-occupied?)) 29 | 30 | (defn clear-full-rows 31 | "Removes rows satisfying the predicate, replacing them with rows of empty 32 | cells." 33 | [db] 34 | (update db :game-grid 35 | #(grid/remove-rows % row-fully-occupied?))) 36 | 37 | (defn any-falling? 38 | "Returns true if there is a falling cell anywhere in the grid." 39 | [{:keys [game-grid]}] 40 | (seq (grid/get-cells game-grid :falling))) 41 | 42 | (defn gameover? 43 | "Returns true if any cell of the grid has a y < 0 and is :occupied." 44 | [{:keys [game-grid]}] 45 | (grid/any-cell? game-grid 46 | (fn [{:keys [y occupied] :as c}] 47 | (and occupied 48 | (< y 0))))) 49 | 50 | (defn mark-cell-occupied 51 | "Marks the passed cell (x, y) as occupied, dissoc-ing the :falling key. 52 | Returns an updated db." 53 | [db cell] 54 | (update db :game-grid 55 | #(grid/update-cell % cell 56 | (fn [c] (-> c 57 | (assoc :occupied true) 58 | (dissoc :falling)))))) 59 | 60 | (defn mark-cells-occupied 61 | [db cells] 62 | (reduce (fn [db cell] (mark-cell-occupied db cell)) db cells)) 63 | 64 | 65 | (defn get-falling-cells 66 | "Returns all cells with a `:falling true` prop" 67 | [{:keys [game-grid]}] 68 | (grid/get-cells game-grid :falling)) 69 | 70 | 71 | (defn after-piece-played 72 | "Updates flags/counters after a piece has been played." 73 | [db] 74 | (-> db 75 | ;; this also indicates that the pieces has been played, so we increment 76 | (update :pieces-played inc) 77 | ;; remove the hold-lock to allow another hold to happen 78 | (assoc :hold-lock false))) 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;; Instant fall 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | 84 | (defn can-overwrite-cell? 85 | "Returns true if the PASSED cell is within the grid's bounds, not 86 | occupied, and not falling. this does NOT read from the board, but expects 87 | the cell to be freshly looked up and passed to it." 88 | [{:keys [game-grid]} 89 | {:keys [occupied falling] :as cell}] 90 | (and 91 | (grid/within-bounds? game-grid cell {:allow-above? true}) 92 | (not occupied) 93 | (not falling))) 94 | 95 | (defn instant-fall 96 | "Gathers `:falling` cells and moves them with `grid/instant-fall`" 97 | [db direction] 98 | (let [falling-cells (get-falling-cells db) 99 | updated-db (update db 100 | :game-grid 101 | (fn [g] 102 | (grid/instant-fall 103 | g 104 | {:direction direction 105 | :cells falling-cells 106 | :keep-shape? true 107 | :can-move? #(can-overwrite-cell? db %)})))] 108 | (-> updated-db 109 | ;; mark new cell coords as occupied 110 | (mark-cells-occupied 111 | (get-falling-cells updated-db))))) 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | ;; Move piece 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | 117 | (defn move-piece 118 | "Moves a floating cell in the direction passed. 119 | If pieces try to move down but are blocked, they are locked in place (with an 120 | :occupied flag). 121 | " 122 | [{:keys [game-grid game-opts] :as db} direction] 123 | (let [falling-cells (get-falling-cells db) 124 | move-f #(grid/move-cell-coords 125 | % direction 126 | (merge game-opts {:grid game-grid})) 127 | 128 | updated-grid 129 | (grid/move-cells game-grid 130 | {:move-f move-f 131 | :can-move? #(cell-open? db %) 132 | :cells falling-cells}) 133 | 134 | db (assoc db :game-grid updated-grid) 135 | 136 | should-lock-cells? 137 | (and 138 | ;; down-only 139 | (= direction :down) 140 | ;; any falling cells? 141 | falling-cells 142 | ;; any falling cells that can't move down? 143 | ;; i.e. with occupied cells below them 144 | (seq (remove #(cell-open? db (move-f %)) falling-cells)))] 145 | 146 | (if should-lock-cells? 147 | ;; mark all cells :occupied, remove :falling 148 | ;; Effectively a 'piece-played' event 149 | (as-> db db 150 | (reduce (fn [d cell] (mark-cell-occupied d cell)) 151 | db falling-cells) 152 | (after-piece-played db)) 153 | 154 | ;; otherwise just return the db 155 | db))) 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | ;; Rotating pieces 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | 161 | (defn rotate-piece 162 | "Rotates a falling piece in-place. 163 | This requires one falling cell to be an 'anchor'. 164 | The anchor attempts to stay in place - the other cells calc an x/y delta 165 | between themselves and the anchor, which is used to update the cells locations 166 | as they rotate around the anchor. 167 | 168 | If the rotation cannot be done due to conflict with boundaries or occupied 169 | pieces, fallback moves are attempted, moving the pieces one two spaces to the 170 | left or right before attempting the rotate. This results in the 'bumping' away 171 | from walls when attempting to rotate on the edge of the grid." 172 | [db] 173 | (let [falling-cells (get-falling-cells db) 174 | anchor-cell (first (filter :anchor? falling-cells))] 175 | 176 | (if-not anchor-cell 177 | ;; no anchor-cell, do nothing 178 | db 179 | (update db :game-grid 180 | (fn [grid] 181 | (grid/move-cells 182 | grid 183 | {:move-f #(grid/calc-rotate-target anchor-cell %) 184 | :fallback-moves 185 | [{:additional-cells [anchor-cell] 186 | :fallback-move-f (fn [c] 187 | (as-> c c 188 | (grid/move-cell-coords c :right) 189 | (grid/calc-rotate-target 190 | (update anchor-cell :x inc) c)))} 191 | {:additional-cells [anchor-cell] 192 | :fallback-move-f (fn [c] 193 | (as-> c c 194 | (grid/move-cell-coords c :left) 195 | (grid/calc-rotate-target 196 | (update anchor-cell :x dec) c)))} 197 | {:additional-cells [anchor-cell] 198 | :fallback-move-f (fn [c] 199 | (as-> c c 200 | (grid/move-cell-coords c :right) 201 | (grid/move-cell-coords c :right) 202 | (grid/calc-rotate-target 203 | (update anchor-cell :x #(+ % 2)) c)))} 204 | {:additional-cells [anchor-cell] 205 | :fallback-move-f (fn [c] 206 | (as-> c c 207 | (grid/move-cell-coords c :left) 208 | (grid/move-cell-coords c :left) 209 | (grid/calc-rotate-target 210 | (update anchor-cell :x #(- % 2)) c)))}] 211 | :can-move? #(cell-open? db %) 212 | :cells (remove :anchor? falling-cells)})))))) 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | ;; Adding new pieces 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | 218 | ;; TODO this is a grid-db function 219 | (defn add-preview-piece [grid piece] 220 | (-> grid 221 | (grid/build-grid) 222 | (grid/add-cells 223 | {:update-cell #(assoc % :preview true) 224 | :make-cells (tetris.shapes/type->ec->cell piece)}))) 225 | 226 | (defn add-new-piece 227 | "Adds a new cell to the grid. 228 | Does not care if there is room to add it! 229 | Depends on the `new-piece-coord`." 230 | [{:keys [piece-queue min-queue-size] :as db}] 231 | (let [next-three (take 3 (drop 1 piece-queue)) 232 | piece-type (first piece-queue)] 233 | (-> db 234 | (update :piece-queue 235 | (fn [q] 236 | (let [q (drop 1 q)] 237 | (if (< (count q) min-queue-size) 238 | (concat q (tetris.shapes/next-bag db)) 239 | q)))) 240 | 241 | (assoc :falling-shape piece-type) 242 | 243 | (update :game-grid 244 | (fn [g] 245 | (grid/add-cells 246 | g 247 | {:update-cell #(assoc % :falling true) 248 | :make-cells (tetris.shapes/type->ec->cell piece-type)}))) 249 | 250 | (update :preview-grids 251 | (fn [gs] 252 | (let [[g1 g2 g3] gs 253 | [p1 p2 p3] next-three] 254 | [(add-preview-piece g1 p1) 255 | (add-preview-piece g2 p2) 256 | (add-preview-piece g3 p3)])))))) 257 | 258 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | ;; Removing Pieces (for hold/swap feature) 260 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 261 | 262 | (defn clear-falling-cells 263 | "Removes all cells that have a :falling prop." 264 | [db] 265 | (update db :game-grid #(grid/clear-cells % :falling))) 266 | 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | ;; Score 269 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 270 | 271 | (defn update-score 272 | "Score is a function of the number of rows cleared and the level. 273 | Combos function by double-counting previously cleared rows. 274 | Ex: if rows are cleared by piece n, and another row is cleared by piece n + 1, 275 | the original rows are included in the row-count-score multipled by the current 276 | level. 277 | " 278 | [{:keys [score-per-row-clear 279 | level 280 | rows-in-combo 281 | last-combo-piece-num 282 | pieces-played] 283 | :as db}] 284 | (let [rows-cleared (count (rows-to-clear db)) 285 | carry-combo? (= pieces-played (+ last-combo-piece-num 1)) 286 | row-count-score (if carry-combo? 287 | (+ rows-cleared rows-in-combo) 288 | rows-cleared) 289 | updated-rows-in-combo (if carry-combo? 290 | row-count-score 291 | rows-cleared)] 292 | (-> db 293 | (update :score #(+ % (* score-per-row-clear row-count-score level))) 294 | (assoc :rows-in-combo updated-rows-in-combo) 295 | (assoc :last-combo-piece-num pieces-played) 296 | (update :rows-cleared #(+ % rows-cleared))))) 297 | 298 | (defn should-advance-level? 299 | [{:keys [level rows-per-level rows-cleared]}] 300 | (>= rows-cleared (* level rows-per-level))) 301 | 302 | (defn advance-level 303 | "Each level updates the step timeout to 90% of the current speed." 304 | [db] 305 | (-> db 306 | (update :level inc) 307 | (update :tick-timeout #(.floor js/Math (* % 0.9))))) 308 | 309 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 310 | ;; Game tick/steps functions 311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 312 | 313 | (defn step [db game-opts] 314 | (cond 315 | ;; clear pieces, update db and return 316 | (> (count (rows-to-clear db)) 0) 317 | (-> db 318 | (update-score) 319 | (clear-full-rows)) 320 | 321 | ;; game is over, update db and return 322 | (gameover? db) 323 | (case (-> game-opts :on-gameover) 324 | :restart (tetris.db/game-db game-opts) 325 | nil (assoc db :gameover? true)) 326 | 327 | (should-advance-level? db) 328 | (advance-level db) 329 | 330 | ;; a piece is falling, move it down 331 | (any-falling? db) 332 | (move-piece db :down) 333 | 334 | ;; nothing is falling, add a new piece 335 | (not (any-falling? db)) 336 | (add-new-piece db) 337 | 338 | ;; do nothing 339 | :else db)) 340 | 341 | -------------------------------------------------------------------------------- /src/games/puyo/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.puyo.core 2 | (:require 3 | [clojure.set :as set] 4 | [games.grid.core :as grid] 5 | [games.puyo.db :as puyo.db] 6 | [games.puyo.shapes :as puyo.shapes])) 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Game logic, predicates, helpers 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (defn cell-occupied? 13 | [{:keys [game-grid]} cell] 14 | (:occupied (grid/get-cell game-grid cell))) 15 | 16 | (defn cell-falling? 17 | [{:keys [game-grid]} cell] 18 | (:falling (grid/get-cell game-grid cell))) 19 | 20 | (defn cell-within-bounds? 21 | [{:keys [game-grid]} cell] 22 | (grid/within-bounds? game-grid cell {:allow-above? true})) 23 | 24 | (defn cell-open? 25 | "Returns true if the indicated cell is within the grid's bounds AND not 26 | occupied." 27 | [{:keys [game-grid] :as db} cell] 28 | (and 29 | (grid/within-bounds? game-grid cell {:allow-above? true}) 30 | (not (cell-occupied? db cell)))) 31 | 32 | (defn can-overwrite-cell? 33 | "Returns true if the PASSED cell is within the grid's bounds, not 34 | occupied, and not falling. this does NOT read from the board, but expects 35 | the cell to be freshly looked up and passed to it." 36 | [{:keys [game-grid]} 37 | {:keys [occupied falling] :as cell}] 38 | (and 39 | (grid/within-bounds? game-grid cell {:allow-above? true}) 40 | (not occupied) 41 | (not falling))) 42 | 43 | (defn any-falling? 44 | "Returns true if there is a falling cell anywhere in the grid." 45 | [{:keys [game-grid]}] 46 | (seq (grid/get-cells game-grid :falling))) 47 | 48 | (defn get-falling-cells 49 | "Returns all cells with a `:falling true` prop" 50 | [{:keys [game-grid]}] 51 | (grid/get-cells game-grid :falling)) 52 | 53 | (defn do-mark-cell-occupied 54 | [c] 55 | (-> c 56 | (assoc :occupied true) 57 | (dissoc :falling))) 58 | 59 | (defn mark-cell-occupied 60 | "Marks the passed cell (x, y) as occupied, dissoc-ing the :falling key. 61 | Returns an updated db." 62 | [db cell] 63 | (update db :game-grid #(grid/update-cell % cell do-mark-cell-occupied))) 64 | 65 | (defn mark-cells-occupied 66 | [db cells] 67 | (reduce (fn [db cell] (mark-cell-occupied db cell)) db cells)) 68 | 69 | (defn gameover? 70 | "Returns true if any cell of the grid has a y < 0. 71 | TODO fix this! only true if entry cell blocked" 72 | [{:keys [game-grid]}] 73 | (grid/any-cell? game-grid (fn [{:keys [y occupied]}] 74 | (and occupied 75 | (< y 0))))) 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | ;; Piece movement 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | (defn instant-fall 82 | "Gathers `:falling` cells and moves them with `grid/instant-fall`" 83 | [db direction] 84 | (let [falling-cells (get-falling-cells db) 85 | updated-db 86 | (update 87 | db 88 | :game-grid 89 | (fn [g] 90 | (grid/instant-fall 91 | g 92 | {:direction direction 93 | :cells falling-cells 94 | :keep-shape? false 95 | ;; TODO fix this to not need the db (should be handled underneath, this 96 | ;; can be a cheap cell prop check) 97 | ;; works for now b/c it only checks bounds and :occupied 98 | ;; TODO investigate/simplify cell-open? usage and :falling flag 99 | :can-move? #(can-overwrite-cell? db %)})))] 100 | ;; mark new cell coords as occupied 101 | (mark-cells-occupied updated-db 102 | (get-falling-cells updated-db)))) 103 | 104 | (defn ->blocked-cells 105 | "Returns only the cells that cannot make the passed `move-f`, because 106 | `cell-open?` returns false for the target (new) cell." 107 | [db {:keys [cells move-f]}] 108 | (remove #(cell-open? db (move-f %)) cells)) 109 | 110 | (defn after-piece-played [db] 111 | (-> db 112 | ;; re-enable holds after a blocked movement event 113 | (assoc :hold-lock false))) 114 | 115 | (defn handle-blocked-cells 116 | "Updates cells after a move. Should only be called if the moved direction was 117 | `:down`. It is also assumed that there are blocked-cells passed. 118 | 119 | `Blocked` cells are marked occupied, other falling cells are instant-dropped." 120 | [db blocked-cells] 121 | (-> (reduce (fn [d cell] 122 | (mark-cell-occupied d cell)) 123 | db blocked-cells) 124 | (instant-fall :down) 125 | (after-piece-played))) 126 | 127 | (defn- do-move-piece 128 | [db move-opts] 129 | (update db :game-grid #(grid/move-cells % move-opts))) 130 | 131 | (defn move-piece 132 | "Moves 'falling' cells in the passed direction. 133 | Updates blocked cells and instant-falls after first block via 134 | `handle-blocked-cells`." 135 | [{:keys [game-grid game-opts] :as db} direction] 136 | (let [falling-cells (get-falling-cells db) 137 | move-f #(grid/move-cell-coords 138 | % direction 139 | (merge game-opts {:grid game-grid})) 140 | move-opts {:move-f move-f 141 | :can-move? #(cell-open? db %) 142 | :cells falling-cells} 143 | blocked-cells (seq (->blocked-cells db move-opts)) 144 | db (do-move-piece db move-opts)] 145 | (if (and 146 | (= :down direction) 147 | blocked-cells 148 | (seq falling-cells)) 149 | (handle-blocked-cells db blocked-cells) 150 | db))) 151 | 152 | ;; TODO think about swapping colors vs 'rotating', especially in narrow 153 | ;; situations 154 | (defn rotate-piece 155 | [db] 156 | (let [falling-cells (get-falling-cells db) 157 | anchor-cell (first (filter :anchor? falling-cells))] 158 | 159 | (if-not anchor-cell 160 | ;; no anchor-cell, do nothing 161 | db 162 | (update 163 | db :game-grid 164 | (fn [grid] 165 | (grid/move-cells 166 | grid 167 | {:move-f #(grid/calc-rotate-target anchor-cell %) 168 | :fallback-moves 169 | [{:additional-cells [anchor-cell] 170 | :fallback-move-f 171 | (fn [c] 172 | (as-> c c 173 | (grid/move-cell-coords c :right) 174 | (grid/calc-rotate-target 175 | (update anchor-cell :x inc) c)))} 176 | {:additional-cells [anchor-cell] 177 | :fallback-move-f 178 | (fn [c] 179 | (as-> c c 180 | (grid/move-cell-coords c :left) 181 | (grid/calc-rotate-target 182 | (update anchor-cell :x dec) c)))}] 183 | :can-move? #(cell-open? db %) 184 | :cells (remove :anchor? falling-cells)})))))) 185 | 186 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 187 | ;; Adding Pieces 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | 190 | (defn add-preview-piece 191 | "Rebuilds a passed preview grid and adds the passed piece (func) to it." 192 | [grid piece] 193 | (-> grid 194 | (grid/build-grid) 195 | (grid/add-cells 196 | {:update-cell #(assoc % :preview true) 197 | :make-cells (puyo.shapes/build-piece-fn piece)}))) 198 | 199 | (defn add-new-piece 200 | "Adds a new cell to the grid. 201 | Does not care if there is room to add it! 202 | Depends on the `new-piece-coord`. 203 | 204 | Note that this does not always indicate a 'new' piece, as the swap mechanic 205 | prepends the piece-queue to add held pieces back. 206 | " 207 | [{:keys [piece-queue min-queue-size] :as db}] 208 | (let [next-three (take 3 (drop 1 piece-queue)) 209 | next-colors (first piece-queue)] 210 | (-> ;; this also indicates that the pieces has been played, so we increment 211 | db 212 | (update :current-piece-num inc) 213 | 214 | (update :piece-queue 215 | (fn [q] 216 | (let [q (drop 1 q)] 217 | (if (< (count q) min-queue-size) 218 | (concat q (puyo.shapes/next-bag db)) 219 | q)))) 220 | 221 | ;; update the current falling fn 222 | (assoc :falling-shape next-colors) 223 | 224 | ;; add the cells to the matrix! 225 | (update :game-grid 226 | (fn [g] 227 | (grid/add-cells g 228 | {:update-cell #(assoc % :falling true) 229 | :make-cells 230 | (puyo.shapes/build-piece-fn next-colors)}))) 231 | 232 | (update :preview-grids 233 | (fn [gs] 234 | (let [[g1 g2 g3] gs 235 | [p1 p2 p3] next-three] 236 | [(add-preview-piece g1 p1) 237 | (add-preview-piece g2 p2) 238 | (add-preview-piece g3 p3)])))))) 239 | 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | ;; Clearing pieces and cells 242 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 243 | 244 | (defn clear-falling-cells 245 | "Supports the 'hold/swap' mechanic." 246 | [db] 247 | (update db :game-grid #(grid/clear-cells % :falling))) 248 | 249 | (defn groups-to-clear 250 | "Returns true if there are any groups of 4 or more adjacent same-color cells." 251 | [{:keys [game-grid group-size]}] 252 | (let [puyos (grid/get-cells game-grid :occupied) 253 | color-groups (vals (group-by :color puyos)) 254 | groups (mapcat grid/group-adjacent-cells color-groups)] 255 | (filter (fn [group] (<= group-size (count group))) groups))) 256 | 257 | (defn clear-groups 258 | "Clears groups that are have reached the group-size." 259 | [db groups] 260 | (-> db 261 | (update :game-grid 262 | (fn [grid] 263 | (grid/update-cells 264 | grid 265 | (fn [cell] 266 | (seq (filter #(contains? % cell) groups))) 267 | #(dissoc % :occupied :color :anchor?)))))) 268 | 269 | (defn update-fallers 270 | "Updates cells that have had a cell below removed." 271 | [db groups] 272 | (let [deepest-by-x (grid/->deepest-by-x (reduce set/union groups)) 273 | should-update? 274 | (fn [{:keys [color x y] :as cell}] 275 | (let [deep-y (:y (get deepest-by-x x)) 276 | should? (and 277 | color 278 | (not (nil? deep-y)) 279 | (< y deep-y))] 280 | should?))] 281 | (update db :game-grid 282 | (fn [grid] 283 | (grid/update-cells 284 | grid 285 | should-update? 286 | #(-> % 287 | (dissoc :occupied) 288 | (assoc :falling true))))))) 289 | 290 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291 | ;; Score and Level 292 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 | 294 | ;; TODO should depend on a piece-played event 295 | (defn update-score 296 | "Score is a function of the number of groups cleared and the level. 297 | Combos function by double-counting previously cleared groups. 298 | Ex: if groups are cleared by piece n, and another group is cleared by piece n + 1, 299 | the original groups are included in the group-count-score multipled by the current 300 | level. 301 | 302 | ;; TODO update to take size of groups into account 303 | " 304 | [{:keys [score-per-group-clear 305 | level 306 | groups-in-combo 307 | last-combo-piece-num ;; TODO rename last-score-piece-num? 308 | current-piece-num] 309 | :as db}] 310 | (let [groups-cleared (count (groups-to-clear db)) 311 | carry-combo? (= current-piece-num last-combo-piece-num) 312 | groups-in-combo (if carry-combo? 313 | (+ groups-cleared groups-in-combo) 314 | groups-cleared) 315 | addl-score (* score-per-group-clear groups-in-combo level)] 316 | (-> db 317 | (update :score #(+ % addl-score)) 318 | (assoc :groups-in-combo groups-in-combo) 319 | (assoc :last-combo-piece-num current-piece-num)))) 320 | 321 | (defn should-advance-level? 322 | [{:keys [level groups-per-level groups-cleared]}] 323 | (>= groups-cleared (* level groups-per-level))) 324 | 325 | (defn advance-level 326 | "Each level updates the step timeout to 90% of the current speed." 327 | [db] 328 | (-> db 329 | (update :level inc) 330 | (update :step-timeout #(.floor js/Math (* % 0.9))))) 331 | 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 | ;; Step 334 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 335 | 336 | (defn step 337 | [db game-opts] 338 | (let [groups (groups-to-clear db)] 339 | (cond 340 | 341 | ;; game is over, update db and return 342 | ;; TODO gameover event, score event? 343 | (gameover? db) 344 | (case (-> game-opts :on-gameover) 345 | :restart (puyo.db/game-db game-opts) 346 | nil (assoc db :gameover? true)) 347 | 348 | (should-advance-level? db) 349 | (advance-level db) 350 | 351 | ;; a piece is falling, move it down 352 | (any-falling? db) 353 | (move-piece db :down) 354 | 355 | ;; clear puyo groups, update db and return 356 | (seq groups) 357 | (-> db 358 | (update-score) 359 | (clear-groups groups) 360 | (update-fallers groups) 361 | (instant-fall :down)) 362 | 363 | ;; nothing is falling, add a new piece 364 | (not (any-falling? db)) 365 | (add-new-piece db) 366 | 367 | ;; do nothing 368 | :else db))) 369 | 370 | -------------------------------------------------------------------------------- /test/games/grid/core_test.cljs: -------------------------------------------------------------------------------- 1 | (ns games.grid.core-test 2 | (:require 3 | [games.grid.core :as sut] 4 | [cljs.test :as t :refer-macros [deftest is testing]] 5 | [adzerk.cljs-console :as log])) 6 | 7 | ;; TODO move somewhere relevant 8 | (enable-console-print!) 9 | 10 | (deftest build-grid-test 11 | (testing "builds a grid" 12 | (let [width 3 height 5 13 | gdb (sut/build-grid 14 | {:width width :height height})] 15 | (testing "with the expected width" 16 | (doall 17 | (map 18 | (fn [row] 19 | (is (= (count row) width))) 20 | (:grid gdb)))) 21 | 22 | (testing "with the expected height" 23 | (is (= (count (:grid gdb)) height))) 24 | 25 | (testing "sets x and y on cells" 26 | (testing "first cell" 27 | (is (= (-> gdb :grid first first) 28 | {:x 0 29 | :y 0}))) 30 | (testing "one corner" 31 | (is (= (-> gdb :grid reverse first first) 32 | {:x 0 33 | :y (- height 1)}))) 34 | (testing "another corner" 35 | (is (= (-> gdb :grid first reverse first) 36 | {:x (- width 1) 37 | :y 0}))) 38 | (testing "last cell" 39 | (is (= (-> gdb :grid reverse first reverse first) 40 | {:x (- width 1) 41 | :y (- height 1)}))))))) 42 | 43 | (deftest build-grid-phantom-test 44 | (testing "builds a grid with phantom rows" 45 | (let [width 3 height 5 46 | phantom-rows 3 47 | phantom-columns 1 48 | gdb (sut/build-grid 49 | {:phantom-rows phantom-rows 50 | :phantom-columns phantom-columns 51 | :width width 52 | :height height})] 53 | (testing "with the expected width" 54 | (doall 55 | (map 56 | (fn [row] 57 | (is (= (count row) (+ phantom-columns width)))) 58 | (:grid gdb)))) 59 | (testing "with the expected height" 60 | (is (= (count (:grid gdb)) (+ phantom-rows height)))) 61 | (testing "sets x and y on cells" 62 | (testing "first cell" 63 | (is (= (-> gdb :grid first first) 64 | {:x (* -1 phantom-columns) 65 | :y (* -1 phantom-rows)}))) 66 | (testing "one corner" 67 | (is (= (-> gdb :grid reverse first first) 68 | {:x (* -1 phantom-columns) 69 | :y (- height 1)}))) 70 | (testing "another corner" 71 | (is (= (-> gdb :grid first reverse first) 72 | {:x (- width 1) 73 | :y (* -1 phantom-rows)}))) 74 | (testing "last cell" 75 | (is (= (-> gdb :grid reverse first reverse first) 76 | {:x (- width 1) 77 | :y (- height 1)}))))))) 78 | 79 | 80 | (deftest update-cells-test 81 | (testing "updates cells if pred is true" 82 | (testing "always true sets for all" 83 | (let [gdb (sut/build-grid {:height 5 :width 3}) 84 | gdb (sut/update-cells 85 | gdb (fn [_] true) #(assoc % :test true))] 86 | (doall 87 | (map 88 | (fn [r] 89 | (doall (map (fn [c] (is (:test c))) r))) 90 | (:grid gdb))))) 91 | (testing "sets for only those specified" 92 | (let [gdb (sut/build-grid {:height 5 :width 3}) 93 | target {:x 2 :y 1} 94 | gdb (sut/update-cells 95 | gdb (fn [c] (and 96 | (= (:x c) (:x target)) 97 | (= (:y c) (:y target)))) 98 | #(assoc % :test true)) 99 | target-cell (sut/get-cell gdb target) 100 | another-cell (sut/get-cell gdb (update target :y dec)) 101 | ] 102 | (is (not (:test another-cell))) 103 | (is (:test target-cell)))))) 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | ;; Misc cell utils test 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | (deftest get-cell-in-group-test 110 | (testing "returns the matching cell from a group with coords" 111 | (let [group [{:x 1 :y 1 :blah 1} {:x 2 :y 3 :gibber true}]] 112 | (is (= {:x 1 :y 1 :blah 1} (sut/get-cell-in-group group {:x 1 :y 1}))) 113 | (is (= nil (sut/get-cell-in-group group {:x 0 :y 1})))))) 114 | 115 | (deftest cell-in-group-test 116 | (testing "returns true if a cell's coords are in the group" 117 | (let [group [{:x 1 :y 1 :blah 1} {:x 2 :y 3 :gibber true}]] 118 | (is (sut/cell-in-group? group {:x 1 :y 1})) 119 | (is (not (sut/cell-in-group? group {:x 0 :y 1})))))) 120 | 121 | (deftest add-cells-test 122 | (let [todo true] 123 | (is todo))) 124 | 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | ;; Move cells tests 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | 129 | (defn move-cells-test 130 | "Creates and updates a grid db with the passed lists of cells. 131 | Calls `move-cells` in the passed `direction`. 132 | 133 | Asserts that `empty-cells` are not :flagged. 134 | Asserts that the `expected-cells` are :flagged. 135 | " 136 | [{:keys 137 | [mark-cells expected-cells empty-cells move-cells 138 | direction debug? force-fail?]}] 139 | (let [direction (or direction :down) 140 | 141 | move-opts {:cells move-cells 142 | :direction direction 143 | :can-move? #(not (:flagged %))} 144 | gdb 145 | (-> (sut/build-grid {:height 5 :width 3 :phantom-rows 2}) 146 | (sut/update-cells 147 | #(sut/cell-in-group? mark-cells %) 148 | (fn [c] 149 | (let [props (sut/get-cell-in-group mark-cells c) 150 | props (dissoc props :x :y)] 151 | (-> c 152 | (assoc :flagged true) 153 | (merge props)))))) 154 | gdb' (sut/move-cells gdb move-opts)] 155 | (when debug? (sut/log gdb)) 156 | (when debug? (sut/log gdb')) 157 | (doall 158 | (map 159 | (fn [expected-cell] 160 | (let [c (sut/get-cell gdb' expected-cell)] 161 | (when (and debug? (not (:flagged c))) 162 | (log/debug "Should be flagged ~{c}")) 163 | (is (= expected-cell c)))) 164 | (map #(assoc % :flagged true) expected-cells))) 165 | (doall 166 | (map 167 | (fn [cell] 168 | (let [c (sut/get-cell gdb' cell)] 169 | (when (and debug? (:flagged c)) 170 | (log/debug "Should not be flagged ~{c}")) 171 | (is (not (:flagged c))))) 172 | empty-cells)) 173 | (when force-fail? (is false)))) 174 | 175 | (deftest move-cells-basic 176 | (testing "move one cell down" 177 | (let [cells [{:x 1 :y 0}]] 178 | (move-cells-test 179 | {:mark-cells cells 180 | :move-cells cells 181 | :empty-cells cells 182 | :expected-cells [{:x 1 :y 1}] 183 | :direction :down})))) 184 | 185 | (deftest move-cells-shape 186 | (testing "move shape down" 187 | (let [cells [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1} {:x 1 :y 0}] 188 | expected-cells [{:x 2 :y 0} {:x 2 :y -1} {:x 1 :y 0} {:x 1 :y 1}]] 189 | (move-cells-test 190 | {:mark-cells cells 191 | :move-cells cells 192 | :empty-cells [{:x 1 :y -1} {:x 2 :y -2}] 193 | :expected-cells expected-cells 194 | :direction :down})))) 195 | 196 | (deftest move-cells-shape-copy-order-down 197 | (testing "move shape copy order check - down" 198 | (let [cells [{:x 2 :y -1 :a true} 199 | {:x 2 :y -2 :b true} 200 | {:x 1 :y -1 :c true} 201 | {:x 1 :y 0 :d true}] 202 | expected-cells [{:x 2 :y 0 :a true} 203 | {:x 2 :y -1 :b true} 204 | {:x 1 :y 0 :c true} 205 | {:x 1 :y 1 :d true}]] 206 | (move-cells-test 207 | {:mark-cells cells 208 | :move-cells cells 209 | :empty-cells [{:x 1 :y -1} {:x 2 :y -2}] 210 | :expected-cells expected-cells 211 | :direction :down})))) 212 | 213 | (deftest move-cells-shape-copy-order-up 214 | (testing "move shape copy order check - up" 215 | (let [cells [{:x 2 :y 0 :a true} 216 | {:x 2 :y -1 :b true} 217 | {:x 1 :y 0 :c true} 218 | {:x 1 :y 1 :d true}] 219 | expected-cells [{:x 2 :y -1 :a true} 220 | {:x 2 :y -2 :b true} 221 | {:x 1 :y -1 :c true} 222 | {:x 1 :y 0 :d true}]] 223 | (move-cells-test 224 | {:mark-cells cells 225 | :move-cells cells 226 | :empty-cells [{:x 1 :y 1} {:x 2 :y 0}] 227 | :expected-cells expected-cells 228 | :direction :up})))) 229 | 230 | (deftest move-cells-shape-copy-order-left 231 | (testing "move shape copy order check - left" 232 | (let [cells 233 | [{:x 2 :y 0 :a true} 234 | {:x 2 :y -1 :b true} 235 | {:x 1 :y 0 :c true} 236 | {:x 1 :y 1 :d true}] 237 | expected-cells 238 | [{:x 1 :y 0 :a true} 239 | {:x 1 :y -1 :b true} 240 | {:x 0 :y 0 :c true} 241 | {:x 0 :y 1 :d true}]] 242 | (move-cells-test 243 | {:mark-cells cells 244 | :move-cells cells 245 | :empty-cells [{:x 2 :y 0} 246 | {:x 2 :y -1}] 247 | :expected-cells expected-cells 248 | :direction :left})))) 249 | 250 | (deftest move-cells-shape-copy-order-right 251 | (testing "move shape copy order check - right" 252 | (let [cells 253 | [{:x 1 :y 0 :a true} 254 | {:x 1 :y -1 :b true} 255 | {:x 0 :y 0 :c true} 256 | {:x 0 :y 1 :d true}] 257 | expected-cells 258 | [{:x 2 :y 0 :a true} 259 | {:x 2 :y -1 :b true} 260 | {:x 1 :y 0 :c true} 261 | {:x 1 :y 1 :d true}]] 262 | (move-cells-test 263 | {:mark-cells cells 264 | :move-cells cells 265 | :empty-cells [{:x 0 :y 0} 266 | {:x 0 :y 1}] 267 | :expected-cells expected-cells 268 | :direction :right})))) 269 | 270 | (deftest move-cells-rotate-test 271 | (let [todo true] 272 | (is todo))) 273 | 274 | (deftest move-cells-rotate-near-wall-test 275 | (let [todo true] 276 | (is todo))) 277 | 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | ;; Instant Drop tests 280 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 281 | 282 | (defn instant-fall-test 283 | "Creates and updates a grid db with the passed lists of cells. 284 | Calls `instant-fall` in the passed `direction`. 285 | 286 | Asserts that `empty-cells` are not :flagged. 287 | Asserts that the `expected-cells` are :flagged. 288 | " 289 | [{:keys 290 | [mark-cells expected-cells empty-cells move-cells 291 | keep-shape? direction debug? force-fail?]}] 292 | (let [direction (or direction :down) 293 | move-opts {:cells move-cells 294 | :keep-shape? keep-shape? 295 | :direction direction 296 | :can-move? #(not (:flagged %))} 297 | gdb 298 | (-> (sut/build-grid {:height 5 :width 3 :phantom-rows 2}) 299 | (sut/update-cells 300 | #(sut/cell-in-group? mark-cells %) 301 | #(assoc % :flagged true))) 302 | gdb' (sut/instant-fall gdb move-opts)] 303 | (when debug? (sut/log gdb)) 304 | (when debug? (sut/log gdb')) 305 | (doall 306 | (map 307 | (fn [cell] 308 | (let [c (sut/get-cell gdb' cell)] 309 | (when (and debug? (not (:flagged c))) 310 | (log/debug "Should be flagged ~{c}")) 311 | (is (:flagged c)))) 312 | expected-cells)) 313 | (doall 314 | (map 315 | (fn [cell] 316 | (let [c (sut/get-cell gdb' cell)] 317 | (when (and debug? (:flagged c)) 318 | (log/debug "Should not be flagged ~{c}")) 319 | (is (not (:flagged c))))) 320 | empty-cells)) 321 | (when force-fail? (is false)))) 322 | 323 | (deftest instant-fall-test-basic 324 | (testing "single cell drop" 325 | (testing "keep-shape" 326 | (instant-fall-test 327 | {:mark-cells [{:x 1 :y 0}] 328 | :move-cells [{:x 1 :y 0}] 329 | :empty-cells [{:x 1 :y 0}] 330 | :expected-cells [{:x 1 :y 4}] 331 | :keep-shape? true})) 332 | (testing "don't keep-shape" 333 | (instant-fall-test 334 | {:mark-cells [{:x 1 :y 0}] 335 | :move-cells [{:x 1 :y 0}] 336 | :empty-cells [{:x 1 :y 0}] 337 | :expected-cells [{:x 1 :y 4}] 338 | :keep-shape? false})))) 339 | 340 | (deftest instant-fall-test-blocked 341 | (testing "single cell drop with blockers" 342 | (testing "keep-shape" 343 | (instant-fall-test 344 | {:mark-cells [{:x 1 :y 0} {:x 1 :y 4}] 345 | :move-cells [{:x 1 :y 0}] 346 | :empty-cells [{:x 1 :y 0}] 347 | :expected-cells [{:x 1 :y 3} {:x 1 :y 4}] 348 | :keep-shape? true})) 349 | (instant-fall-test 350 | {:mark-cells [{:x 1 :y 0} {:x 1 :y 4} {:x 1 :y 3} {:x 1 :y 2} {:x 1 :y 1}] 351 | :move-cells [{:x 1 :y 0}] 352 | :empty-cells [] 353 | :expected-cells [{:x 1 :y 0} {:x 1 :y 4} {:x 1 :y 3} {:x 1 :y 2} {:x 1 :y 1}] 354 | :keep-shape? true}) 355 | (testing "don't keep shape" 356 | (instant-fall-test 357 | {:mark-cells [{:x 1 :y 0} {:x 1 :y 4}] 358 | :move-cells [{:x 1 :y 0}] 359 | :empty-cells [{:x 1 :y 0}] 360 | :expected-cells [{:x 1 :y 3} {:x 1 :y 4}] 361 | :keep-shape? false})))) 362 | 363 | (deftest instant-fall-test-stacked-piece 364 | (testing "vertical two-cell drop" 365 | (testing "keep-shape?" 366 | (instant-fall-test 367 | {:mark-cells [{:x 1 :y 0} {:x 1 :y 1}] 368 | :move-cells [{:x 1 :y 0} {:x 1 :y 1}] 369 | :empty-cells [{:x 1 :y 0} {:x 1 :y 1}] 370 | :expected-cells [{:x 1 :y 3} {:x 1 :y 4}] 371 | :keep-shape? true})) 372 | (testing "don't keep shape" 373 | (instant-fall-test 374 | {:mark-cells [{:x 1 :y 0} {:x 1 :y 1}] 375 | :move-cells [{:x 1 :y 0} {:x 1 :y 1}] 376 | :empty-cells [{:x 1 :y 0} {:x 1 :y 1}] 377 | :expected-cells [{:x 1 :y 3} {:x 1 :y 4}] 378 | :keep-shape? false})))) 379 | 380 | (deftest instant-fall-test-staggered-piece-keep-shape 381 | (testing "horizontal shape drop, keep shape" 382 | (let [shape (map #(sut/relative {:x 1 :y 0} %) 383 | [{:x 1 :y -1} {:y -1} {} {:x -1}]) 384 | shape-after-drop (map #(sut/relative {:x 1 :y 4} %) 385 | [{:x 1 :y -1} {:y -1} {} {:x -1}])] 386 | (instant-fall-test 387 | {:mark-cells shape 388 | :move-cells shape 389 | :empty-cells shape 390 | :expected-cells shape-after-drop 391 | :keep-shape? true})))) 392 | 393 | (deftest instant-fall-test-staggered-piece-drop-shape 394 | (testing "horizontal shape drop, don't keep shape" 395 | (let [shape (map #(sut/relative {:x 1 :y 0} %) 396 | [{:x 1 :y -1} {:y -1} {} {:x -1}]) 397 | shape-after-drop (map #(sut/relative {:x 1 :y 4} %) 398 | [{:x 1 :y 0} {:y -1} {} {:x -1}])] 399 | (instant-fall-test 400 | {:mark-cells shape 401 | :move-cells shape 402 | :empty-cells shape 403 | :expected-cells shape-after-drop 404 | :keep-shape? false})))) 405 | 406 | (deftest instant-fall-test-staggered-piece-keep-shape-vertical 407 | (testing "vertical shape drop, keep shape" 408 | (let [shape [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1} {:x 1 :y 0}] 409 | shape-after-drop [{:x 2 :y 2} {:x 2 :y 3} {:x 1 :y 3} {:x 1 :y 4}] 410 | other-cells [{:x 2 :y 4}]] 411 | (instant-fall-test 412 | {:mark-cells (concat shape other-cells) 413 | :move-cells shape 414 | :empty-cells shape 415 | :expected-cells (concat shape-after-drop other-cells) 416 | :keep-shape? true})))) 417 | 418 | (deftest instant-fall-test-staggered-piece-keep-shape-vertical-blocked 419 | (testing "vertical shape drop, keep shape, more blockers" 420 | (let [shape [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1} {:x 1 :y 0}] 421 | shape-after-drop [{:x 2 :y 2} {:x 2 :y 1} {:x 1 :y 3} {:x 1 :y 2}] 422 | blockers [{:x 2 :y 4} {:x 1 :y 4}] 423 | empty [{:x 2 :y 3}]] 424 | (instant-fall-test 425 | {:mark-cells (concat shape blockers) 426 | :move-cells shape 427 | :empty-cells (concat shape empty) 428 | :expected-cells (concat shape-after-drop blockers) 429 | :keep-shape? true})))) 430 | 431 | (deftest instant-fall-test-move-one-cell-keep-shape 432 | (testing "vertical shape drop, keep shape, blocker one below" 433 | (let [shape [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1} {:x 1 :y 0}] 434 | empty [{:x 1 :y -1} {:x 2 :y -2}] 435 | shape-after-drop [{:x 2 :y 0} {:x 2 :y -1} {:x 1 :y 0} {:x 1 :y 1}] 436 | blockers [{:x 1 :y 2}]] 437 | (instant-fall-test 438 | {:mark-cells (concat shape blockers) 439 | :move-cells shape 440 | :empty-cells empty 441 | :expected-cells (concat shape-after-drop blockers) 442 | :debug? true 443 | :keep-shape? true})))) 444 | 445 | (deftest instant-fall-test-move-one-cell-no-keep-shape 446 | (testing "vertical shape drop, don't keep shape, blocker one below" 447 | (let [shape [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1} {:x 1 :y 0}] 448 | shape-after-drop [{:x 2 :y 3} {:x 2 :y 4} {:x 1 :y 0} {:x 1 :y 1}] 449 | empty [{:x 2 :y -1} {:x 2 :y -2} {:x 1 :y -1}] 450 | blockers [{:x 1 :y 2}]] 451 | (instant-fall-test 452 | {:mark-cells (concat shape blockers) 453 | :move-cells shape 454 | :empty-cells empty 455 | :expected-cells (concat shape-after-drop blockers) 456 | :keep-shape? false})))) 457 | 458 | -------------------------------------------------------------------------------- /src/games/grid/core.cljs: -------------------------------------------------------------------------------- 1 | (ns games.grid.core 2 | (:require 3 | [clojure.set :as set] 4 | [clojure.walk :as walk] 5 | [adzerk.cljs-console :as log] 6 | [clojure.string :as string])) 7 | 8 | ;; TODO break grid/cell functions into grid.cells namespace 9 | 10 | (defn cell->str 11 | "Converts a cell into a coords and keys str." 12 | [{:keys [x y falling occupied flagged] :as c}] 13 | (let [props (dissoc c :x :y :falling :occupied :flagged)] 14 | (str " | " x "," y " " 15 | (if flagged "f" "") 16 | (if falling "f" "") 17 | (if occupied "o" "") 18 | (if (seq props) (keys props) "")))) 19 | 20 | (defn row->str [row] 21 | (let [cells row 22 | cell-strs (map cell->str cells)] 23 | (string/join cell-strs))) 24 | 25 | (defn grid->str [grid] 26 | (let [rows grid 27 | row-strs (map row->str rows)] 28 | (string/join "\n" row-strs))) 29 | 30 | (defn log [db] 31 | (let [st (grid->str (:grid db))] 32 | (js/console.log st))) 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;; Grid, row, and cell creation 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (defn reset-cell-labels 39 | "Adds :x, :y keys and vals to every cell in the grid. 40 | Used to initialize the board, and to reset x/y after removing rows/cells. 41 | " 42 | [{:keys [phantom-rows phantom-columns]} grid] 43 | (vec 44 | (map-indexed 45 | (fn [y row] 46 | (vec 47 | (map-indexed 48 | (fn [x cell] 49 | (assoc cell :y (- y phantom-rows) :x (- x phantom-columns))) 50 | row))) 51 | grid))) 52 | 53 | (defn build-row 54 | "Used to create initial rows as well as new ones after rows are removed." 55 | [{:keys [width phantom-columns]}] 56 | (vec (take (+ width phantom-columns) (repeat {})))) 57 | 58 | ;; TODO be nice to write a build-grid-for-shape to auto-size itself 59 | ;; could include a x/y buffer, and be used to dry up queue/hold/test grid usage 60 | (defn build-grid 61 | "Builds a grid with the passed `opts`. 62 | Expects :height, :width, :phantom-rows, :phantom-columns as `int`s. 63 | 64 | Can also be used to rebuild/reset the grid. 65 | " 66 | [{:keys [height phantom-rows] :as opts}] 67 | (assoc 68 | opts :grid 69 | (reset-cell-labels 70 | opts 71 | (take (+ height phantom-rows) 72 | (repeat (build-row opts)))))) 73 | 74 | (defn relative 75 | "Helper for creating cells relative to another, usually an entry-cell. 76 | Maintains the properties of the passed `cell` (2nd argument)." 77 | [{x0 :x y0 :y} {:keys [x y] :as cell}] 78 | (-> cell 79 | (assoc :x (+ x0 x)) 80 | (assoc :y (+ y0 y)))) 81 | 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | ;; Row manipulation 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | 87 | (defn only-positive-rows 88 | [db] 89 | (update db :grid 90 | (fn [grid] 91 | (filter (fn [row] (<= 0 (-> row (first) :y))) grid)))) 92 | 93 | (defn select-rows 94 | "Returns true if any row satisfies the passed row predicate." 95 | [{:keys [grid]} pred] 96 | (seq (filter pred grid))) 97 | 98 | (defn true-for-row? 99 | "Helper for writing row-predicates. Funs the passed `f?` against every cell in 100 | a row, returning if the number of trues matches the number of cells." 101 | [row f?] 102 | (= (count row) 103 | (count (filter f? row)))) 104 | 105 | (defn remove-rows 106 | "Removes rows that return true for the passed `row-predicate`" 107 | [{:keys [grid height phantom-rows] :as db} row-predicate] 108 | (let [cleared-grid (remove row-predicate grid) 109 | rows-to-add (- (+ height phantom-rows) (count cleared-grid)) 110 | new-rows (take rows-to-add (repeat (build-row db))) 111 | grid-with-new-rows (concat new-rows cleared-grid) 112 | updated-grid (reset-cell-labels db grid-with-new-rows)] 113 | (assoc db :grid updated-grid))) 114 | 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | ;; Cell Prop Updates 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | 119 | (defn get-cell 120 | ([db cell] (get-cell db cell {})) 121 | ([{:keys [grid width height phantom-rows phantom-columns] :as db} 122 | {:keys [x y]} 123 | {:keys [ignore-warning?]}] 124 | (let [ynth (+ y phantom-rows) 125 | xnth (+ x phantom-columns) 126 | _db-meta (dissoc db :grid) 127 | outside-bounds? 128 | (or 129 | (>= y height) 130 | (>= x width) 131 | (< xnth 0) 132 | (< ynth 0))] 133 | (if outside-bounds? 134 | (if-not ignore-warning? 135 | (log/warn 136 | "WARN: Attempting access outside grid bounds! 137 | | x,y: #{x},#{y} | gdb: ~{_db-meta}")) 138 | (-> grid (nth ynth) (nth xnth)))))) 139 | 140 | (defn get-cells 141 | [{:keys [grid]} pred] 142 | (filter pred (flatten grid))) 143 | 144 | (defn any-cell? 145 | "Returns a seq of all the cells for which the passed predicate is true" 146 | [db pred] 147 | (seq (get-cells db pred))) 148 | 149 | (defn update-cell 150 | "Applies the passed function to the cell at the specified coords." 151 | [{:keys [grid phantom-rows phantom-columns] :as db} {:keys [x y]} f] 152 | (let [updated (update-in grid [(+ phantom-rows y) (+ phantom-columns x)] f)] 153 | (assoc db :grid updated))) 154 | 155 | (defn update-cells 156 | "Applies the passed function to the cells that return true for pred." 157 | [db pred f] 158 | (update 159 | db :grid 160 | (fn [g] 161 | (into 162 | [] 163 | (map 164 | (fn [row] 165 | (into 166 | [] 167 | (map 168 | (fn [cell] 169 | (if (pred cell) 170 | (f cell) 171 | cell)) 172 | row))) 173 | g))))) 174 | 175 | (defn cell->props [cell] 176 | (dissoc cell :x :y ::prop-stack)) 177 | 178 | (defn overwrite-cell 179 | "Copies all props from `cell` to `target`. 180 | Looks up the cell passed to get the latest props before copying. 181 | Sets any properies included on the passed `cell`. 182 | Any props in the target are added to the cell's `::prop-stack`, 183 | a special key that allows for restoring previous cell states. 184 | " 185 | [db {:keys [cell target]}] 186 | (let [props (cell->props cell)] 187 | (update-cell 188 | db target 189 | (fn [target] 190 | (let [target-props (cell->props target)] 191 | (cond-> props 192 | true 193 | (-> 194 | (assoc :x (:x target)) 195 | (assoc :y (:y target))) 196 | 197 | ;; clear prop-stack if target was empty 198 | ;; TODO shouldn't ever happen? 199 | (empty? target-props) 200 | (dissoc ::prop-stack) 201 | 202 | (seq target-props) 203 | (assoc ::prop-stack 204 | (cons target-props (or (::prop-stack target) []))))))))) 205 | 206 | (defn clear-cell 207 | "Removes non-coordinate flags from cells. 208 | " 209 | [db cell] 210 | (update-cell 211 | db cell 212 | (fn [c] 213 | {:x (:x c) 214 | :y (:y c)}))) 215 | 216 | (defn reset-or-clear-cell 217 | "" 218 | [db cell] 219 | (let [prop-stack (or (::prop-stack (get-cell db cell)) []) 220 | props (first prop-stack) 221 | rest-props (rest prop-stack)] 222 | (if-not props 223 | (clear-cell db cell) 224 | (update-cell 225 | db cell 226 | (fn [c] 227 | (-> props 228 | {:x (:x c) 229 | :y (:y c) 230 | ::prop-stack rest-props})))))) 231 | 232 | ;; TODO remove make-cells completely 233 | (defn add-cells 234 | "Adds the passed cells to the passed grid" 235 | [{:keys [entry-cell] :as db} {:keys [cells make-cells update-cell]}] 236 | (let [entry-cell (or entry-cell {:x 0 :y 0}) 237 | update-cell (or update-cell identity) 238 | cells (or cells (make-cells entry-cell)) 239 | cells (map update-cell cells)] 240 | (if-not cells 241 | db 242 | (reduce 243 | (fn [db {:keys [x y] :as cell}] 244 | (overwrite-cell db {:cell cell :target {:x x :y y}})) 245 | db 246 | cells)))) 247 | 248 | (defn clear-cells 249 | [db pred] 250 | (reduce 251 | (fn [db c] (reset-or-clear-cell db c)) 252 | db 253 | (get-cells db pred))) 254 | 255 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 256 | 257 | (defn cell->coords 258 | "Returns only the coords of a cell as :x and :y 259 | Essentially drops the props. 260 | Used to compare sets of cells." 261 | [{:keys [x y]}] {:x x :y y}) 262 | 263 | (defn same-cell? 264 | "True if the cells have the same coords" 265 | [c1 c2] 266 | (= (cell->coords c1) (cell->coords c2))) 267 | 268 | (defn cell-in-group? 269 | [group c] 270 | (let [coords (set (map cell->coords group))] 271 | (contains? coords (cell->coords c)))) 272 | 273 | (defn get-cell-in-group 274 | [group c] 275 | (first (filter (fn [group-c] 276 | (= (cell->coords group-c) 277 | (cell->coords c)) 278 | ) group))) 279 | 280 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 281 | ;; Cell Transforms 282 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 283 | 284 | (defn deeper-y? 285 | [{y0 :y} {y1 :y}] 286 | (> y0 y1)) 287 | 288 | (defn ->deepest-by-x 289 | "Transforms a list of cells into a map of each x and the 'deepest' cell for 290 | that x in the given list. 291 | 292 | [{:x 1 :y 2} 293 | {:x 1 :y 1} 294 | {:x 2 :y 1}] 295 | => 296 | {1 {:x 1 :y 2} 297 | 2 {:x 2 :y 1}} 298 | " 299 | [cells] 300 | (let [cols (vals (group-by :x cells)) 301 | deepest-per-col (map #(first (sort deeper-y? %)) 302 | cols)] 303 | (->> 304 | deepest-per-col 305 | (group-by :x) 306 | (map (fn [[k v]] [k (first v)])) 307 | (into {})))) 308 | 309 | (defn- adjacent? 310 | "True if the cells are neighboring cells. 311 | Determined by having the same x and y +/- 1, or same y and x +/- 1. 312 | TODO add no-walls x/y support! 313 | " 314 | [c0 c1] 315 | (let [{x0 :x y0 :y} c0 316 | {x1 :x y1 :y} c1] 317 | (or (and (= x0 x1) 318 | (or 319 | (= y0 (+ y1 1)) 320 | (= y0 (- y1 1)))) 321 | (and (= y0 y1) 322 | (or 323 | (= x0 (+ x1 1)) 324 | (= x0 (- x1 1))))))) 325 | 326 | (defn group-adjacent-cells 327 | "Takes a collection of cells, returns a list of cells grouped by adjacency. 328 | See `adjacent?`." 329 | [cells] 330 | ;; iterate over cells 331 | ;; first cell - create set, add all adjacent cells from group 332 | ;; next cell - if in first cell, add all adjacent to that group 333 | ;; else, add all adjacent to new set 334 | ;; iterate 335 | (reduce 336 | (fn [groups cell] 337 | (let [in-a-set? (seq (filter #(contains? % cell) groups)) 338 | adjacent-cells (set (filter #(adjacent? % cell) cells))] 339 | (if in-a-set? 340 | ;; in a set, so walk and update group in-place 341 | ;; probably a better way to do this kind of in-place update 342 | (walk/walk 343 | (fn [group] 344 | (if (contains? group cell) 345 | (set/union group adjacent-cells) 346 | group)) 347 | identity 348 | groups) 349 | ;; otherwise, add a new set to groups 350 | (conj groups (conj adjacent-cells cell))))) 351 | [] 352 | cells)) 353 | 354 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 | ;; Cell/Grid Predicates 356 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 357 | 358 | (defn within-bounds? 359 | "Returns true if the passed cell coords is within the edges of the grid." 360 | ([db cell] (within-bounds? db cell {:allow-above? false})) 361 | ([{:keys [height width]} {:keys [x y]} {:keys [allow-above?]}] 362 | (and 363 | (> height y) 364 | (> width x) 365 | (or allow-above? (>= y 0)) 366 | (>= x 0)))) 367 | 368 | (defn entry-cell-is? 369 | "Returns true if the passed predicate is true of the entry-cell." 370 | [{:keys [entry-cell] :as db} pred] 371 | (pred (get-cell db entry-cell))) 372 | 373 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 374 | ;; Cell relative movement/distance and rotation helpers 375 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 376 | 377 | (defn rotate-diff 378 | "x1 = y0 379 | y1 = -x0" 380 | [{:keys [x y]}] 381 | {:x y 382 | :y (* -1 x)}) 383 | 384 | (defn calc-diff [cell-a cell-b] 385 | {:x (- (:x cell-a) (:x cell-b)) 386 | :y (- (:y cell-a) (:y cell-b))}) 387 | 388 | (defn apply-diff [cell-a cell-b] 389 | {:x (+ (:x cell-a) (:x cell-b)) 390 | :y (+ (:y cell-a) (:y cell-b))}) 391 | 392 | (defn calc-rotate-target 393 | "Rotates the passed `cell` about the `anchor-cell` clockwise. 394 | Returns a target cell as a map with :x and :y keys for `cell`'s new 395 | coordinates." 396 | [anchor-cell cell] 397 | (apply-diff anchor-cell (rotate-diff (calc-diff anchor-cell cell)))) 398 | 399 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 400 | ;; Cell Movement 401 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 402 | 403 | (defn grid-min-max 404 | "Returns legal x/y mins and maxes for the passed grid. 405 | Some grids use phantom-columns, others don't allow it." 406 | [{:keys [phantom-columns phantom-rows width height]}] 407 | {:x-min (* -1 phantom-columns) 408 | :x-max (- width 1) 409 | :y-min (* -1 phantom-rows) 410 | :y-max (- height 1)}) 411 | 412 | (defn move-cell-coords 413 | "Returns a map with :x, :y coords relative to the passed direction 414 | (:left, :right, :up, :down). 415 | 416 | Also accepts a third `game-opts` option, which it uses to support 417 | moving across walls in `no-walls?` `no-walls-x?` and `no-walls-y?` modes" 418 | ([{:keys [x y]} direction] 419 | (let [x-diff (case direction :left -1 :right 1 0) 420 | y-diff (case direction :down 1 :up -1 0)] 421 | {:x (+ x x-diff) 422 | :y (+ y y-diff)})) 423 | 424 | ([cell direction 425 | {:keys [no-walls? no-walls-x? no-walls-y? grid]}] 426 | (let [{:keys [x y]} (move-cell-coords cell direction) 427 | {:keys [x-min x-max y-min y-max]} (grid-min-max grid) 428 | 429 | x (if (or no-walls? no-walls-x?) 430 | (cond (< x x-min) x-max 431 | (> x x-max) x-min 432 | :else x) 433 | x) 434 | y (if (or no-walls? no-walls-y?) 435 | (cond (< y y-min) y-max 436 | (> y y-max) y-min 437 | :else y) 438 | y)] 439 | {:x x :y y}))) 440 | 441 | (defn- calc-move-cells 442 | "Calculates targets for cells, cells to be cleared, 443 | and whether or not this group of moves can be made. 444 | 445 | Targets are calced with the passed `move-f`. 446 | 447 | `all-can-move?` returns true if both: 448 | 1. none of the calced targets are nil 449 | 2. the 'new' targets are positive for `can-move?` 450 | 'new' targets are calced targets excluding current cells, 451 | which will presumably be empty. 452 | 453 | TODO probably an issue with copy-order here, may need 454 | to sort to make sure the correct cell-overwrites are made 455 | " 456 | [db {:keys [cells move-f can-move?]}] 457 | (let [cells-and-targets 458 | (map (fn [c] {:cell (get-cell db c) 459 | :target (get-cell db (move-f c) {:ignore-warning? true})}) 460 | cells) 461 | targets (map :target cells-and-targets) 462 | cells-to-move (set (map cell->coords cells)) 463 | target-coords (set (map cell->coords targets)) 464 | cells-to-clear (set/difference cells-to-move target-coords) 465 | ;; targets that are not current cells 466 | new-targets 467 | (filter (fn [trgt] 468 | (let [trgt-coords (cell->coords trgt)] 469 | (not (contains? cells-to-move trgt-coords))) 470 | ) targets) 471 | all-can-move? (and (not-any? nil? targets) 472 | (not (seq 473 | (remove 474 | can-move? 475 | new-targets))))] 476 | 477 | {:cells-and-targets cells-and-targets 478 | :targets targets 479 | :cells-to-clear cells-to-clear 480 | :all-can-move? all-can-move?})) 481 | 482 | ;; TODO pull move-f into move-cells? or build on top of it 483 | ;; TODO support :direction AND no-walls/game-opts 484 | (defn move-cells 485 | "Moves a group of passed `cells` according to `move-f`. 486 | Only moves if all passed cells return true for `can-move?`. 487 | Otherwise, returns the db as-is. 488 | 489 | This function does the work of copying cell props from one cell to another, 490 | clearing props on cells that have been abandoned, and being smart about not 491 | clearing cells that are being moved into. 492 | " 493 | [db {:keys [fallback-moves move-f direction cells can-move? rotation] :as move-opts}] 494 | (let [ 495 | move-opts 496 | (if (and (not move-f) direction) 497 | (assoc move-opts :move-f #(move-cell-coords % direction)) 498 | move-opts) 499 | 500 | move-opts 501 | (if (not (coll? cells)) 502 | (assoc move-opts :cells (get-cells db cells)) 503 | move-opts) 504 | 505 | move-opts 506 | (if (and (not (:move-f move-opts)) rotation) 507 | ;; TODO support rotation direction (clock/counter) 508 | (assoc 509 | move-opts :move-f 510 | (fn [c] 511 | (let [anchor-cell 512 | ;; single-anchor assumption slips through 513 | (first (filter :anchor? (:cells move-opts)))] 514 | (calc-rotate-target anchor-cell c)))) 515 | move-opts) 516 | 517 | move-opts 518 | (update move-opts :can-move? #(or can-move? (fn [_] true))) 519 | 520 | {:keys [cells-and-targets cells-to-clear all-can-move?]} 521 | (calc-move-cells db move-opts) 522 | {:keys [fallback-move-f additional-cells]} (first fallback-moves)] 523 | (cond 524 | all-can-move? 525 | (as-> db db 526 | ;; copy cells that are 'moving' 527 | (reduce overwrite-cell db cells-and-targets) 528 | ;; clear cells that were left 529 | (reduce reset-or-clear-cell db cells-to-clear)) 530 | 531 | fallback-move-f 532 | (let [fallback-moves (drop 1 fallback-moves)] 533 | (as-> db db 534 | (move-cells 535 | db 536 | (-> move-opts 537 | (update :cells #(concat % additional-cells)) 538 | (assoc :move-f fallback-move-f) 539 | (assoc :fallback-moves fallback-moves))))) 540 | 541 | :else db))) 542 | 543 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 544 | ;; Cell Instant Down 545 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 546 | 547 | (defn greater-x? [{x1 :x} {x2 :x}] (> x1 x2)) 548 | (defn less-x? [{x1 :x} {x2 :x}] (< x1 x2)) 549 | (defn same-x? [{x1 :x} {x2 :x}] (= x1 x2)) 550 | 551 | (defn greater-y? [{y1 :y} {y2 :y}] (> y1 y2)) 552 | (defn less-y? [{y1 :y} {y2 :y}] (< y1 y2)) 553 | (defn same-y? [{y1 :y} {y2 :y}] (= y1 y2)) 554 | 555 | (defn get-column-or-row [db cell direction] 556 | (get-cells 557 | db 558 | (fn [c] 559 | (case direction 560 | (:up :down) (same-x? cell c) 561 | (:left :right) (same-y? cell c))))) 562 | 563 | (defn cells-in-direction 564 | "Returns the cells in the passed direction from the given cell." 565 | [db cell direction] 566 | (let [col-or-row-cells (get-column-or-row db cell direction)] 567 | (filter #(case direction 568 | :up (less-y? % cell) 569 | :down (greater-y? % cell) 570 | :right (greater-x? % cell) 571 | :left (less-x? % cell)) 572 | col-or-row-cells))) 573 | 574 | 575 | (defn cell->furthest-open-space 576 | "Returns the open cell that is furthest in `direction`. 577 | 578 | furthest _consecutive_ open space 579 | 580 | Currently walks in that direction until a cell is not open. Could be expanded 581 | to allow 'skipping' but that behavior doesn't fit a tetris/puyo game that i've 582 | played, so, leaving this for now. 583 | " 584 | [db cell {:keys [can-move? direction]}] 585 | (let [cells-in-dir (cells-in-direction db cell direction) 586 | 587 | sorted 588 | (sort-by 589 | (case direction 590 | (:up :down) :y 591 | (:left :right) :x) 592 | (case direction 593 | (:up :left) > 594 | (:down :right) <) 595 | cells-in-dir) 596 | 597 | target 598 | (:best 599 | (reduce 600 | (fn [{:keys [best skip?]} next-cell] 601 | (cond 602 | skip? 603 | {:skip? true 604 | :best best} 605 | 606 | (and 607 | ;; nothing set and can't move already? 608 | ;; we're blocked, skip and return nil 609 | (not (can-move? next-cell)) 610 | (not best)) 611 | {:skip? true 612 | :best nil} 613 | 614 | (can-move? next-cell) 615 | {:best next-cell 616 | :skip? false} 617 | 618 | :else 619 | {:best best 620 | :skip? true})) 621 | {:best nil 622 | :skip? false} 623 | sorted))] 624 | (when (seq cells-in-dir) 625 | target))) 626 | 627 | (defn ->cell-and-target 628 | "Derp, baked in this furthest open space logic." 629 | [db c move-opts] 630 | {:cell c 631 | :target (cell->furthest-open-space 632 | db c move-opts)}) 633 | 634 | (defn ->diff-and-magnitude 635 | [{:keys [cell target] :as c-n-t}] 636 | (let [{dx :x dy :y :as diff} ;; document the negative diff here 637 | (calc-diff target cell)] 638 | (assoc c-n-t 639 | :magnitude 640 | (apply max (map #(.abs js/Math %) [dx dy])) 641 | :diff diff))) 642 | 643 | (defn instant-fall 644 | "Returns a `db` with the passed cells moving as far in the passed `direction` 645 | as possible. 646 | 647 | If `keep-shape?` is true, the shortest available move will be made for all 648 | passed cells. If it is false, cells will fall independently until they reach 649 | the furthest open space. 650 | 651 | See furthest open space for definition/note on consecutive spaces. 652 | " 653 | [db {:keys [cells keep-shape? can-move? direction] 654 | :as move-opts}] 655 | (if-not keep-shape? 656 | 657 | (let [sorted-cells 658 | (sort-by 659 | (case direction 660 | (:up :down) :y 661 | (:left :right) :x) 662 | (case direction 663 | (:up :left) < 664 | (:down :right) >) 665 | cells)] 666 | ;; order is important - go from the direction passed 667 | ;; (:down -> start from bottom of grid (decreasing y)) 668 | (reduce 669 | (fn [db cell] 670 | (let [{:keys [diff target]} 671 | (->diff-and-magnitude 672 | (->cell-and-target db cell move-opts))] 673 | (if-not target 674 | db 675 | (move-cells 676 | db 677 | {:cells [cell] 678 | :move-f #(apply-diff % diff) 679 | :can-move? can-move?}))) 680 | ) db sorted-cells)) 681 | 682 | (let [c-n-ts (map #(->cell-and-target db % move-opts) cells) 683 | c-n-ts (filter :target c-n-ts) 684 | c-n-ts (map ->diff-and-magnitude c-n-ts) 685 | shortest (first (sort-by :magnitude < c-n-ts))] 686 | (if (can-move? (:target shortest)) 687 | (move-cells db 688 | {:cells cells 689 | :move-f #(apply-diff % (:diff shortest)) 690 | :can-move? can-move?}) 691 | db) 692 | ))) 693 | 694 | (comment 695 | (.abs js/Math -1) 696 | 697 | (sort-by :x < [{:x 2} {:x 1}])) 698 | 699 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 700 | ;; Grid rotation helpers 701 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 702 | 703 | (defn spin 704 | "Reverses the grid in the x or y direction, returning a rotated grid." 705 | [db {:keys [reverse-x? reverse-y?]}] 706 | (update db :grid 707 | (fn [grid] 708 | (map (fn [row] (if reverse-x? (reverse row) row)) 709 | (if reverse-y? (reverse grid) grid))))) 710 | --------------------------------------------------------------------------------