1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100

(ns glimmer-gfx.maze
  "A WASD game on the same two files the widgets use, and nothing else.

   There is no glimmer here: a reconciler is for a UI that changes when state
   changes, and this changes sixty times a second whatever you do. So it takes
   the layer below -- x11 gives a framebuffer and the keys held this frame,
   raster draws into it -- which is the whole of what a game loop needs.

   Walk over the dots, don't walk through walls."
  (:require [glimmer-gfx.raster :as r]
            [glimmer-gfx.x11 :as w]))

(def ^:private CELL 24)
(def ^:private SPEED 3)                                  ; pixels per frame

;; keysyms, as XLookupKeysym reports them
(def ^:private keymap
  {0x77 [0 -1] 0x73 [0 1] 0x61 [-1 0] 0x64 [1 0]          ; w s a d
   0xff52 [0 -1] 0xff54 [0 1] 0xff51 [-1 0] 0xff53 [1 0]}) ; arrows

(def ^:private level
  ["###################"
   "#....#........#...#"
   "#.##.#.######.#.#.#"
   "#.#..........#..#.#"
   "#.#.####.###.####.#"
   "#...#......#......#"
   "#.###.####.#.####.#"
   "#.....#......#....#"
   "###################"])

(defn wall? [level c r]
  (let [row (get level r)]
    (or (nil? row) (not= \. (get row c \#)))))

(defn- cells-under
  "The grid cells a CELL-sized box at (x,y) overlaps."
  [x y]
  (for [c [(quot x CELL) (quot (+ x CELL -1) CELL)]
        r [(quot y CELL) (quot (+ y CELL -1) CELL)]]
    [c r]))

(defn free?
  "May the player box sit at (x,y)?"
  [level x y]
  (and (>= x 0) (>= y 0)
       (every? (fn [[c r]] (not (wall? level c r))) (cells-under x y))))

(defn move
  "Slide along a wall rather than stopping dead: each axis is tried alone."
  [level [x y] [dx dy]]
  (let [x' (if (free? level (+ x (* dx SPEED)) y) (+ x (* dx SPEED)) x)
        y' (if (free? level x' (+ y (* dy SPEED))) (+ y (* dy SPEED)) y)]
    [x' y']))

(defn- dir [keys]
  (let [[dx dy] (reduce (fn [a b] (mapv + a b)) [0 0]
                        (keep keymap keys))]
    [(min 1 (max -1 dx)) (min 1 (max -1 dy))]))

(defn- dots [level]
  (set (for [r (range (count level)) c (range (count (level r)))
             :when (= \. (get (level r) c))
             :when (odd? (+ c r))]                       ; every other cell
         [c r])))

(defn eat
  "The dot the player's centre is standing on, removed."
  [dots [x y]]
  (disj dots [(quot (+ x (quot CELL 2)) CELL) (quot (+ y (quot CELL 2)) CELL)]))

(def ^:private colours
  {:bg 0x1c1e26 :wall 0x373b49 :dot 0x9aa0b0 :player 0x5a6ea0 :fg 0xffffff})

(defn- draw! [buf {:keys [pos dots]}]
  (r/clear buf (:bg colours))
  (dotimes [r (count level)]
    (dotimes [c (count (level r))]
      (when (wall? level c r)
        (r/rect! buf (* c CELL) (* r CELL) (dec CELL) (dec CELL) (:wall colours)))))
  (doseq [[c r] dots]
    (r/rect! buf (+ 9 (* c CELL)) (+ 9 (* r CELL)) 6 6 (:dot colours)))
  (let [[x y] pos]
    (r/rect! buf (inc x) (inc y) (- CELL 2) (- CELL 2) (:player colours)))
  (let [y (* CELL (count level))]
    (r/text! buf 8 (+ y 8)
             (if (empty? dots) "CLEARED" (str "DOTS LEFT: " (count dots)))
             (:fg colours) 2)))

(defn -main [& _]
  (let [state (atom {:pos [CELL CELL] :dots (dots level)})]
    (w/run-window
      {:width (* CELL (count (first level)))
       :height (+ 32 (* CELL (count level)))
       :title "maze"}
      (fn [buf input]
        (draw! buf (swap! state
                          (fn [{:keys [pos dots]}]
                            (let [pos (move level pos (dir (:keys input)))]
                              {:pos pos :dots (eat dots pos)}))))))))