├── .gitignore ├── README.md ├── project.clj ├── src └── doomcalc │ ├── components.clj │ ├── core.clj │ ├── digits.clj │ ├── logic.clj │ ├── machine_builder.clj │ ├── tree.clj │ ├── wad_builder.clj │ ├── wad_constants.clj │ ├── write_primitives.clj │ └── write_pwad.clj └── texpatch.wad /.gitignore: -------------------------------------------------------------------------------- 1 | target/ 2 | .calva/ 3 | .clj-kondo/ 4 | .lein-* 5 | .lsp/ 6 | *.wad 7 | *.bak 8 | 9 | !texpatch.wad -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Doom Calculator 2 | 3 | ## What is this? 4 | 5 | This project builds a Doom WAD that implements an adding machine! It is written in Clojure. 6 | 7 | I go into depth in my blog post: https://blog.otterstack.com/posts/202212-doom-calculator/ 8 | 9 | 10 | ## How to build the WAD map 11 | 12 | You need to install Leiningen, a project build tool for Clojure. Instructions are on the site: https://leiningen.org/ 13 | 14 | You will also need to install Java to use Clojure. If it's not already installed, one way to obtain Java is to install OpenJDK 11 or 17 from Adoptium: https://adoptium.net/ 15 | 16 | Once everything is installed, run the following in your shell: 17 | 18 | ```sh 19 | lein run 20 | ``` 21 | 22 | The above will execute the `-main` function in [src/doomcalc/core.clj](src/doomcalc/core.clj), which will create out.wad. 23 | 24 | Note that the map is missing BSP node and segment information, so it won't run in Vanilla Doom out of the box. If you would like to build this extra information, I recommend using a map editor such as SLADE and re-saving the level. 25 | 26 | ## Interactive REPL environment 27 | 28 | There are many ways to use the Clojure REPL. The lowest learning-curve IMO is to use Leiningen. In your shell: 29 | 30 | ```sh 31 | lein repl 32 | ``` 33 | 34 | This will give you immediate access to an interactive REPL environment where you can run Clojure code. 35 | 36 | ### Optional: VS Code, Calva 37 | 38 | If you'd like to use an IDE, I use the VS Code plugin "Calva". Outside of VS Code, CIDER is good if you're an Emacs user. In this section, I will focus on Calva. 39 | 40 | You can install Calva by searching for it in the VS Code extensions section. 41 | 42 | Follow the steps here to connect to a Clojure project: https://calva.io/connect/ 43 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject doomcalc "1.0.0" 2 | :dependencies [[org.clojure/clojure "1.11.1"]] 3 | :repl-options {:init-ns doomcalc.core} 4 | :source-paths ["src"] 5 | 6 | :main doomcalc.core/-main) -------------------------------------------------------------------------------- /src/doomcalc/components.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.components 2 | (:require [doomcalc.logic :as l] 3 | [doomcalc.tree :as t :refer [mkvar]] 4 | [doomcalc.wad-builder :as w] 5 | [doomcalc.digits :as digits] 6 | [doomcalc.wad-constants :as wc])) 7 | 8 | ;; A Component couples drawing and logic. 9 | ;; I found that passing lists of variables around like hot potato 10 | ;; from tree-building procedures to drawing procedures was discouraging and confusing. 11 | 12 | (def MONSTER_THING wc/THING_PINKY) 13 | (def MONSTER_RADIUS wc/PINKY_RADIUS) 14 | 15 | ;; a size of 60 is the bare minimum for a Pinky to fit teleport somewhere without any problems 16 | ;; i.e. 2 times the radius 17 | (def MONSTER_TELE_DEST_MIN_WIDTH (* MONSTER_RADIUS 2)) 18 | 19 | (def DIGIT_PIXEL_HEIGHT 48) 20 | 21 | ;; Vanilla Doom hardcodes the switch texture names and which textures they become. 22 | ;; I'm choosing to override a switch texture in a PWAD. 23 | ;; It falls back gracefully to the built-in SW1EXIT if our texture PWAD isn't used. 24 | (def DIGIT-SWITCH-TEXTURES-HACK 25 | {0 ["SW1EXIT" (* 32 0) (* 72 0)] 26 | 1 ["SW1EXIT" (* 32 1) (* 72 0)] 27 | 2 ["SW1EXIT" (* 32 2) (* 72 0)] 28 | 3 ["SW1EXIT" (* 32 3) (* 72 0)] 29 | 4 ["SW1EXIT" (* 32 4) (* 72 0)] 30 | 5 ["SW1EXIT" (* 32 5) (* 72 0)] 31 | 6 ["SW1EXIT" (* 32 0) (* 72 1)] 32 | 7 ["SW1EXIT" (* 32 1) (* 72 1)] 33 | 8 ["SW1EXIT" (* 32 2) (* 72 1)] 34 | 9 ["SW1EXIT" (* 32 3) (* 72 1)]}) 35 | 36 | (def DIGIT-SWITCH-TEXTURES DIGIT-SWITCH-TEXTURES-HACK) 37 | 38 | ;; Vertex positions: 39 | ;; C B 40 | ;; D E .......... A 41 | (defn draw-switches [tags switch-info {:keys [x y outer-sector base-floor-height ceil-height]}] 42 | (w/with-pushpop-state 43 | (let [outer-tex "STONE2" 44 | 45 | switches (count tags) 46 | 47 | switch-width 32 48 | switch-height 64 49 | switch-thick 8 50 | 51 | switch-sector (w/create-sector {:floor-height (+ base-floor-height switch-height) 52 | :ceil-height ceil-height 53 | :floor-tex "MFLR8_1" 54 | :ceil-tex "MFLR8_1"}) 55 | 56 | pos (fn [ox oy] [(+ x ox) (+ y oy)]) 57 | 58 | A (pos (* switch-width switches) 0) 59 | B (pos (* switch-width switches) switch-thick) 60 | C (pos 0 switch-thick) 61 | D (pos 0 0)] 62 | (w/set-front {:sector outer-sector 63 | :lower-tex outer-tex}) 64 | (w/set-back {:sector switch-sector}) 65 | (w/draw-poly A B C D) 66 | 67 | (w/set-line-special wc/SPECIAL_S1_DOOR_STAY_OPEN_FAST) 68 | (doseq [i (range switches)] 69 | (let [[tex xoff yoff] (switch-info i)] 70 | (w/set-line-tag (nth tags i)) 71 | (w/set-front {:sector outer-sector 72 | :lower-tex tex 73 | :xoff xoff 74 | :yoff yoff}) 75 | (w/draw-poly (pos (* switch-width i) 0) 76 | (pos (* switch-width (inc i)) 0))))))) 77 | 78 | (defn digit-input [{:keys [x y]}] 79 | (let [mkvar-i (fn [] (mkvar nil :optimize-same-left-right? false)) 80 | da01 (mkvar-i) da23 (mkvar-i) da45 (mkvar-i) da67 (mkvar-i) da89 (mkvar-i) 81 | b3 (mkvar) b2 (mkvar) b1 (mkvar) b0 (mkvar) 82 | 83 | tree (l/make-digit-input [da01 da23 da45 da67 da89] 84 | [b3 b2 b1 b0])] 85 | 86 | {:trees [tree] 87 | :vars [b3 b2 b1 b0] 88 | :draw (fn [var->door-tag var->tele-tag {:keys [outer-sector floor-height ceil-height]}] 89 | (let [tags [(var->door-tag da01 0) (var->door-tag da01 1) (var->door-tag da23 0) (var->door-tag da23 1) 90 | (var->door-tag da45 0) (var->door-tag da45 1) (var->door-tag da67 0) (var->door-tag da67 1) 91 | (var->door-tag da89 0) (var->door-tag da89 1)] 92 | x2 (+ x (* 5 32) 4)] 93 | ;; draw 2 sets of switch arrays: 0 to 4, and 5 to 9 94 | (draw-switches (take 5 tags) (fn [i] (get DIGIT-SWITCH-TEXTURES i)) 95 | {:x x, :y y, :outer-sector outer-sector, :base-floor-height floor-height, :ceil-height ceil-height}) 96 | (draw-switches (drop 5 tags) (fn [i] (get DIGIT-SWITCH-TEXTURES (+ i 5))) 97 | {:x x2, :y y, :outer-sector outer-sector, :base-floor-height floor-height, :ceil-height ceil-height})))})) 98 | 99 | (defn binary-4-input [{:keys [x y]}] 100 | (let [b3 (mkvar) b2 (mkvar) b1 (mkvar) b0 (mkvar)] 101 | {:trees [] 102 | :vars [b3 b2 b1 b0] 103 | :draw (fn [var->door-tag var->tele-tag {:keys [outer-sector floor-height ceil-height]}] 104 | (let [ds (fn [v offx] (draw-switches [(var->door-tag v 0) (var->door-tag v 1)] 105 | (fn [i] (get DIGIT-SWITCH-TEXTURES i)) 106 | {:x (+ x offx), :y y, :outer-sector outer-sector, :base-floor-height floor-height, :ceil-height ceil-height}))] 107 | (ds b3 0) 108 | (ds b2 80) 109 | (ds b1 160) 110 | (ds b0 240)))})) 111 | 112 | (defn binary-sequence-4 113 | "Returns a sequence of the number paired with 4 binary digits in big-endian order: 114 | [0 [0 0 0 0]], [1 [0 0 0 1]], [2 [0 0 1 0]] ... [15 [1 1 1 1]]" 115 | [] 116 | (map-indexed vector 117 | (for [b3 (range 2) b2 (range 2) b1 (range 2) b0 (range 2)] 118 | [b3 b2 b1 b0]))) 119 | 120 | (defn make-base2-digit-at-position [position b0 r] 121 | ;; it's just 0 or 1, to show the carry digit 122 | (let [f (fn [digit] (let [v (get (get digits/digits digit) position)] 123 | (if (= v '_) 0 1)))] 124 | (b0 (r (f 0)) 125 | (r (f 1))))) 126 | 127 | (defn make-base10-digit-at-position [position b3 b2 b1 b0 r] 128 | (let [f (fn [digit] (let [v (get (get digits/digits digit) position)] 129 | (if (= v '_) 0 1)))] 130 | (l/solve-truth-table [b3 b2 b1 b0] r 131 | (into {} 132 | (comp (take 10) (map (fn [[i x]] [x (f i)]))) 133 | (binary-sequence-4))))) 134 | 135 | (defn make-base16-digit-at-position [position b3 b2 b1 b0 r] 136 | (let [f (fn [digit] (let [v (get (get digits/digits digit) position)] 137 | (if (= v '_) 0 1)))] 138 | (l/solve-truth-table [b3 b2 b1 b0] r 139 | (into {} 140 | (comp (take 16) (map (fn [[i x]] [x (f i)]))) 141 | (binary-sequence-4))))) 142 | 143 | (defn draw-digit-display [tags {:keys [pixels-w pixels-h outer-sector base-floor-height ceil-height increment-floor-by]}] 144 | (w/draw-square-lattice 145 | (for [i (reverse (range pixels-h))] 146 | (for [j (range pixels-w)] 147 | {:sector (w/create-sector {:floor-height (+ base-floor-height (* increment-floor-by (- (- pixels-h 1) i))) 148 | :ceil-height ceil-height 149 | :floor-tex "CEIL4_1" 150 | :ceil-tex "MFLR8_1" 151 | :light 255 152 | :tag (nth tags (+ (* i pixels-w) j))}) 153 | :t {:lower-tex "BLAKWAL2"} 154 | :r {:flags wc/ML_BLOCKING} 155 | :b {:flags wc/ML_BLOCKING} 156 | :draw (fn [] (w/add-thing {:angle 90 :type wc/THING_TELEPORTER}))})) 157 | {:sector outer-sector 158 | :lower-tex "STONE2" 159 | :flags wc/ML_DONTPEGBOTTOM} 160 | MONSTER_TELE_DEST_MIN_WIDTH MONSTER_TELE_DEST_MIN_WIDTH)) 161 | 162 | (defn digit-carry-display [{:keys [x y bit base-floor-height]}] 163 | (let [output-vars (mapv (fn [_] (mkvar)) (range digits/digit-positions)) 164 | trees (vec 165 | (for [position (range digits/digit-positions)] 166 | (make-base2-digit-at-position position bit (nth output-vars position))))] 167 | 168 | {:trees trees 169 | :vars {} 170 | :draw (fn [var->door-tag var->tele-tag {:keys [outer-sector floor-height ceil-height]}] 171 | (let [tags (mapv #(var->tele-tag % 1) output-vars)] 172 | (w/with-pushpop-state 173 | (w/translate x y) 174 | (draw-digit-display tags 175 | {:pixels-w digits/digit-width :pixels-h digits/digit-height 176 | :outer-sector outer-sector 177 | :base-floor-height (+ floor-height base-floor-height) 178 | :ceil-height ceil-height 179 | :increment-floor-by DIGIT_PIXEL_HEIGHT}))))})) 180 | 181 | (defn digit-display [{:keys [x y bits base-floor-height]}] 182 | (let [[b3 b2 b1 b0] bits 183 | output-vars (mapv (fn [_] (mkvar)) (range digits/digit-positions)) 184 | trees (vec 185 | (for [position (range digits/digit-positions)] 186 | (make-base10-digit-at-position position b3 b2 b1 b0 (nth output-vars position))))] 187 | 188 | {:trees trees 189 | :vars {} 190 | :draw (fn [var->door-tag var->tele-tag {:keys [outer-sector floor-height ceil-height]}] 191 | (let [tags (mapv #(var->tele-tag % 1) output-vars)] 192 | (w/with-pushpop-state 193 | (w/translate x y) 194 | (draw-digit-display tags 195 | {:pixels-w digits/digit-width :pixels-h digits/digit-height 196 | :outer-sector outer-sector 197 | :base-floor-height (+ floor-height base-floor-height) 198 | :ceil-height ceil-height 199 | :increment-floor-by DIGIT_PIXEL_HEIGHT}))))})) 200 | 201 | (defn glyph 202 | "A component that draws a vertical (looking) 2x2 grid with the pattern." 203 | [cells {:keys [x y size] 204 | :or {size 64}}] 205 | {:draw (fn [_ _ {:keys [outer-sector floor-height ceil-height]}] 206 | (let [empty-row (repeat (count (first cells)) '_) 207 | ;; prepend an empty row to render the top 208 | cells (cons empty-row cells)] 209 | (w/with-pushpop-state 210 | (w/translate x y) 211 | (w/draw-square-lattice 212 | (for [[i row] (map-indexed vector (reverse cells))] 213 | (for [cell row] 214 | {:sector (w/create-sector {:floor-height (+ floor-height (* size i)) 215 | :ceil-height ceil-height 216 | :floor-tex "CEIL4_1" 217 | :ceil-tex "MFLR8_1" 218 | :light (if (= cell '_) 0 255)}) 219 | :t {:lower-tex (if (= cell '_) "ASHWALL2" "ASHWALL2")}})) 220 | {:sector outer-sector 221 | :lower-tex "STONE2" 222 | :flags wc/ML_DONTPEGBOTTOM} 223 | 4 size))))}) 224 | 225 | (defn player [x y angle] 226 | {:draw (fn [_ _ _] 227 | (w/add-thing {:x x :y y :angle angle 228 | :type wc/THING_PLAYER1}))}) 229 | 230 | 231 | (defn variable-display 232 | "Debugging tool to show a variable result" 233 | [{:keys [x y v base-floor-height] 234 | :or {base-floor-height 0}}] 235 | (let [floor-tex "CEIL4_1" 236 | ceil-tex "MFLR8_1" 237 | side-tex "STONE2"] 238 | {:draw (fn [var->door-tag var->tele-tag {:keys [outer-sector floor-height ceil-height]}] 239 | (w/with-pushpop-state 240 | (w/translate x y) 241 | (w/draw-square-lattice 242 | [[{:sector (w/create-sector {:floor-height (+ floor-height base-floor-height) 243 | :ceil-height ceil-height 244 | :floor-tex floor-tex 245 | :ceil-tex ceil-tex 246 | :light 255 247 | :tag (var->tele-tag v 0)}) 248 | :draw (fn [] (w/add-thing {:angle 90 :type wc/THING_TELEPORTER})) 249 | :t {:flags wc/ML_BLOCKING} :b {:flags wc/ML_BLOCKING} :l {:flags wc/ML_BLOCKING} :r {:flags wc/ML_BLOCKING}} 250 | {:sector (w/create-sector {:floor-height (+ floor-height base-floor-height) 251 | :ceil-height ceil-height 252 | :floor-tex floor-tex 253 | :ceil-tex ceil-tex 254 | :light 255 255 | :tag (var->tele-tag v 1)}) 256 | :draw (fn [] (w/add-thing {:angle 90 :type wc/THING_TELEPORTER})) 257 | :t {:flags wc/ML_BLOCKING} :b {:flags wc/ML_BLOCKING} :l {:flags wc/ML_BLOCKING} :r {:flags wc/ML_BLOCKING}}]] 258 | {:sector outer-sector 259 | :lower-tex side-tex} 260 | 261 | MONSTER_TELE_DEST_MIN_WIDTH MONSTER_TELE_DEST_MIN_WIDTH)))})) 262 | 263 | 264 | (defn bcd-adding-machine 265 | "An adding machine component. 266 | Inputs are lists of 4-item vectors." 267 | [bits-a bits-b] 268 | (let [bits-a (reverse bits-a) 269 | bits-b (reverse bits-b)] 270 | (loop [trees [] 271 | vars [] 272 | cin nil 273 | [in-a & bits-a] bits-a 274 | [in-b & bits-b] bits-b] 275 | (if (and in-a in-b) 276 | (let [cout (mkvar) 277 | out [(mkvar) (mkvar) (mkvar) (mkvar)] 278 | trees (conj trees 279 | (l/make-bcd-adder cin 280 | in-a 281 | in-b 282 | out 283 | cout)) 284 | vars (conj vars out)] 285 | (recur trees vars cout bits-a bits-b)) 286 | 287 | ;; we're done! 288 | {:trees trees 289 | :vars {:carry cin 290 | :sum (vec (reverse vars))}})))) 291 | 292 | (defn digit-input-and-display [{:keys [x y distance] 293 | :or {distance 768}}] 294 | (let [di (digit-input {:x x :y y}) 295 | dd (digit-display {:x x :y (+ y distance) 296 | :bits (:vars di) 297 | :base-floor-height 64})] 298 | {:trees [(:trees di) (:trees dd)] 299 | :vars (:vars di) 300 | :draw (fn [var->door-tag var->tele-tag outer] 301 | ((:draw di) var->door-tag var->tele-tag outer) 302 | ((:draw dd) var->door-tag var->tele-tag outer))})) 303 | -------------------------------------------------------------------------------- /src/doomcalc/core.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.core 2 | (:require [doomcalc.write-pwad :refer [spit-pwad]] 3 | [doomcalc.wad-builder :as w] 4 | [doomcalc.machine-builder :refer [compile-machines]] 5 | [doomcalc.components :as c])) 6 | 7 | (defn level [] 8 | (let [di01 (c/digit-input-and-display {:x 388 :y 400}) 9 | di00 (c/digit-input-and-display {:x 738 :y 400}) 10 | di11 (c/digit-input-and-display {:x 1588 :y 400}) 11 | di10 (c/digit-input-and-display {:x 1938 :y 400}) 12 | 13 | addm (c/bcd-adding-machine [(:vars di01) (:vars di00)] 14 | [(:vars di11) (:vars di10)])] 15 | [(c/player 688 64 90) 16 | di01 di00 17 | di11 di10 18 | addm 19 | (c/glyph '[[_ _ x _ _] 20 | [_ _ x _ _] 21 | [x x x x x] 22 | [_ _ x _ _] 23 | [_ _ x _ _]] 24 | {:x 1138 :y 1536}) 25 | (c/glyph '[[_ _ _ _ _] 26 | [x x x x x] 27 | [_ _ _ _ _] 28 | [x x x x x] 29 | [_ _ _ _ _]] 30 | {:x 2336 :y 1536}) 31 | (c/digit-carry-display {:x 2788 :y (+ 400 768) 32 | :bit (-> addm :vars :carry) 33 | :base-floor-height 64}) 34 | (c/digit-display {:x 3088 :y (+ 400 768) 35 | :bits (-> addm :vars :sum (nth 0)) 36 | :base-floor-height 64}) 37 | (c/digit-display {:x 3388 :y (+ 400 768) 38 | :bits (-> addm :vars :sum (nth 1)) 39 | :base-floor-height 64})])) 40 | 41 | 42 | (defn summarize-wad-data [data] 43 | (println (str " Vertex count: " (count (:vertexes data)))) 44 | (println (str "Linedef count: " (count (:linedefs data)))) 45 | (println (str "Sidedef count: " (count (:sidedefs data)))) 46 | (println (str " Sector count: " (count (:sectors data)))) 47 | (println (str " Thing count: " (count (:things data))))) 48 | 49 | (defn -main [] 50 | (w/with-debug-svg 51 | (compile-machines level) 52 | (summarize-wad-data (w/wad-data)) 53 | (spit-pwad "out.wad" (w/wad-data)))) 54 | 55 | -------------------------------------------------------------------------------- /src/doomcalc/digits.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.digits) 2 | 3 | (def digit-width 4) 4 | (def digit-height 7) 5 | (def digit-positions (* digit-width digit-height)) 6 | 7 | (def digits 8 | '{0 [_ x x _ 9 | x _ _ x 10 | x _ _ x 11 | x _ _ x 12 | x _ _ x 13 | x _ _ x 14 | _ x x _] 15 | 16 | 1 [_ _ x _ 17 | _ x x _ 18 | _ _ x _ 19 | _ _ x _ 20 | _ _ x _ 21 | _ _ x _ 22 | _ x x x] 23 | 24 | 2 [_ x x _ 25 | x _ _ x 26 | _ _ _ x 27 | _ _ x _ 28 | _ x _ _ 29 | x _ _ _ 30 | x x x x] 31 | 32 | 3 [_ x x _ 33 | x _ _ x 34 | _ _ _ x 35 | _ x x _ 36 | _ _ _ x 37 | x _ _ x 38 | _ x x _] 39 | 40 | 4 [_ _ _ x 41 | x _ _ x 42 | x _ _ x 43 | x x x x 44 | _ _ _ x 45 | _ _ _ x 46 | _ _ _ x] 47 | 48 | 5 [x x x x 49 | x _ _ _ 50 | x _ _ _ 51 | x x x _ 52 | _ _ _ x 53 | _ _ _ x 54 | x x x _] 55 | 56 | 6 [_ x x _ 57 | x _ _ x 58 | x _ _ _ 59 | x x x _ 60 | x _ _ x 61 | x _ _ x 62 | _ x x _] 63 | 64 | 7 [x x x x 65 | _ _ _ x 66 | _ _ _ x 67 | _ _ x _ 68 | _ _ x _ 69 | _ x _ _ 70 | _ x _ _] 71 | 72 | 8 [_ x x _ 73 | x _ _ x 74 | x _ _ x 75 | _ x x _ 76 | x _ _ x 77 | x _ _ x 78 | _ x x _] 79 | 80 | 9 [_ x x _ 81 | x _ _ x 82 | x _ _ x 83 | _ x x x 84 | _ _ _ x 85 | x _ _ x 86 | _ x x _] 87 | 88 | 10 [_ _ _ _ 89 | _ x x _ 90 | x _ _ x 91 | _ x x x 92 | x _ _ x 93 | x _ _ x 94 | _ x x x] 95 | 96 | 11 [x _ _ _ 97 | x _ _ _ 98 | x _ _ _ 99 | x x x _ 100 | x _ _ x 101 | x _ _ x 102 | x x x _] 103 | 104 | 12 [_ _ _ _ 105 | _ _ _ _ 106 | _ _ _ _ 107 | _ x x _ 108 | x _ _ _ 109 | x _ _ _ 110 | _ x x _] 111 | 112 | 13 [_ _ _ x 113 | _ _ _ x 114 | _ _ _ x 115 | _ x x x 116 | x _ _ x 117 | x _ _ x 118 | _ x x x] 119 | 120 | 14 [_ _ _ _ 121 | _ _ _ _ 122 | _ x x _ 123 | x _ _ x 124 | x x x x 125 | x _ _ _ 126 | _ x x x] 127 | 128 | 15 [_ x x _ 129 | x _ _ x 130 | x _ _ _ 131 | x x x _ 132 | x _ _ _ 133 | x _ _ _ 134 | x _ _ _]}) -------------------------------------------------------------------------------- /src/doomcalc/logic.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.logic 2 | (:require [doomcalc.tree :as t :refer [mkvar]])) 3 | 4 | 5 | (defn make-and [a b r] 6 | (a (r 0) 7 | (b (r 0) (r 1)))) 8 | 9 | 10 | (defn make-nand [a b r] 11 | (a (r 1) 12 | (b (r 1) (r 0)))) 13 | 14 | 15 | (defn make-xor [a b r] 16 | (a (b (r 0) (r 1)) 17 | (b (r 1) (r 0)))) 18 | 19 | 20 | (defn make-half-adder [a b s cout] 21 | [(make-and a b cout) 22 | (make-xor a b s)]) 23 | 24 | 25 | (defn make-full-adder [cin a b s cout] 26 | [;; Sum bit 27 | (cin (a (b (s 0) (s 1)) 28 | (b (s 1) (s 0))) 29 | (a (b (s 1) (s 0)) 30 | (b (s 0) (s 1)))) 31 | 32 | ;; Carry bit 33 | (cin (a (cout 0) 34 | (b (cout 0) (cout 1))) 35 | (a (b (cout 0) (cout 1)) 36 | (cout 1)))]) 37 | 38 | 39 | (defn make-n-bit-adder [cin a-vars b-vars s-vars cout] 40 | (let [a-vars (reverse a-vars) 41 | b-vars (reverse b-vars) 42 | s-vars (reverse s-vars) 43 | bits (count a-vars) 44 | carry-vars (map (fn [_] (mkvar)) (range 1 bits))] 45 | 46 | [(if (nil? cin) 47 | (make-half-adder (nth a-vars 0) (nth b-vars 0) (nth s-vars 0) (nth carry-vars 0 cout)) 48 | (make-full-adder cin (nth a-vars 0) (nth b-vars 0) (nth s-vars 0) (nth carry-vars 0 cout))) 49 | (vec (for [i (range 1 bits)] 50 | (make-full-adder (nth carry-vars (dec i)) (nth a-vars i) (nth b-vars i) (nth s-vars i) (nth carry-vars i cout))))])) 51 | 52 | 53 | (defn make-bcd-adder [cin 54 | [a3 a2 a1 a0] 55 | [b3 b2 b1 b0] 56 | [s3 s2 s1 s0] 57 | cout] 58 | (let [z3 (mkvar) 59 | z2 (mkvar) 60 | z1 (mkvar) 61 | 62 | zc (mkvar) 63 | cc1 (mkvar) 64 | cc2 (mkvar)] 65 | [(make-n-bit-adder cin 66 | [a3 a2 a1 a0] 67 | [b3 b2 b1 b0] 68 | [z3 z2 z1 s0] 69 | zc) 70 | 71 | ;; zc + z3*z2 + z3*z1 72 | ;; i.e. zc + z3*(z2+z1) 73 | (zc (z3 (cout 0) 74 | (z2 (z1 (cout 0) 75 | (cout 1)) 76 | (cout 1))) 77 | (cout 1)) 78 | 79 | ;; implement a 3-bit adder manually 80 | ;; i.e. if cout=1, then (z3..z1)+3 -> s3..s1 81 | (make-half-adder cout z1 s1 cc1) 82 | (make-full-adder cc1 cout z2 s2 cc2) 83 | (make-xor cc2 z3 s3)])) 84 | 85 | 86 | (defn- remove-nth [v n] 87 | (into (subvec v 0 n) (subvec v (inc n)))) 88 | 89 | (defn- split-truth-table-at-n [table n] 90 | [(into {} 91 | (comp 92 | (filter (fn [[k _]] (= (nth k n) 0))) 93 | (map (fn [[k v]] [(remove-nth k n) v]))) 94 | table) 95 | (into {} 96 | (comp 97 | (filter (fn [[k _]] (= (nth k n) 1))) 98 | (map (fn [[k v]] [(remove-nth k n) v]))) 99 | table)]) 100 | 101 | (defn- solve-truth-table-recur [vars out-var table] 102 | (if (empty? vars) 103 | :UNDEFINED 104 | 105 | (if (= (count vars) 1) 106 | (let [current-var (nth vars 0) 107 | l (get table [0] :UNDEFINED) 108 | r (get table [1] :UNDEFINED) 109 | l (cond (= l :UNDEFINED) l 110 | (= l 0) (out-var 0) 111 | :else (out-var 1)) 112 | r (cond (= r :UNDEFINED) r 113 | (= r 0) (out-var 0) 114 | :else (out-var 1))] 115 | (current-var l r)) 116 | 117 | (let [trees (for [i (range (count vars))] 118 | (let [current-var (nth vars i) 119 | remaining-vars (remove-nth vars i) 120 | [tt-0 tt-1] (split-truth-table-at-n table i)] 121 | (current-var (solve-truth-table-recur remaining-vars out-var tt-0) 122 | (solve-truth-table-recur remaining-vars out-var tt-1))))] 123 | (t/minimize-trees trees))))) 124 | 125 | (defn solve-truth-table 126 | "Returns a single tree. 127 | Note that this algorithm is expected to emit lots of unused subtrees." 128 | [vars out-var table] 129 | (solve-truth-table-recur vars out-var table)) 130 | 131 | 132 | (defn make-digit-input [[da01 da23 da45 da67 da89] [a3 a2 a1 a0]] 133 | [(da01 (a3 0) (a3 0)) 134 | (da01 (a2 0) (a2 0)) 135 | (da01 (a1 0) (a1 0)) 136 | (da01 (a0 0) (a0 1)) 137 | 138 | (da23 (a3 0) (a3 0)) 139 | (da23 (a2 0) (a2 0)) 140 | (da23 (a1 1) (a1 1)) 141 | (da23 (a0 0) (a0 1)) 142 | 143 | (da45 (a3 0) (a3 0)) 144 | (da45 (a2 1) (a2 1)) 145 | (da45 (a1 0) (a1 0)) 146 | (da45 (a0 0) (a0 1)) 147 | 148 | (da67 (a3 0) (a3 0)) 149 | (da67 (a2 1) (a2 1)) 150 | (da67 (a1 1) (a1 1)) 151 | (da67 (a0 0) (a0 1)) 152 | 153 | (da89 (a3 1) (a3 1)) 154 | (da89 (a2 0) (a2 0)) 155 | (da89 (a1 0) (a1 0)) 156 | (da89 (a0 0) (a0 1))]) 157 | 158 | 159 | (comment 160 | 161 | (contains? ["a" "b"] "a") 162 | 163 | (-> (make-bcd-adder (mkvar :cin) 164 | [(mkvar :a3) (mkvar :a2) (mkvar :a1) (mkvar :a0)] 165 | [(mkvar :b3) (mkvar :b2) (mkvar :b1) (mkvar :b0)] 166 | [(mkvar :s3) (mkvar :s2) (mkvar :s1) (mkvar :s0)] 167 | (mkvar :cout)) 168 | (t/simplify-trees) 169 | (t/debug-dot)) 170 | ;; 171 | ) -------------------------------------------------------------------------------- /src/doomcalc/machine_builder.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.machine-builder 2 | (:require [doomcalc.tree :as t :refer [mkvar]] 3 | [doomcalc.wad-builder :as w] 4 | [doomcalc.wad-constants :as wc])) 5 | 6 | (def MONSTER_THING wc/THING_PINKY) 7 | (def MONSTER_RADIUS wc/PINKY_RADIUS) 8 | 9 | (defn make-level-parts [root-trees output-vars var->door-tag tree->tele-tag tree-has-tele-tag?] 10 | (let [root-trees (t/flatten-vectors root-trees) 11 | 12 | is-root? (set root-trees) 13 | is-output-var? (set output-vars) 14 | 15 | out (atom []) 16 | add (fn [type v] (swap! out conj [type v]))] 17 | (doseq [tree root-trees] 18 | (when (t/out? tree) 19 | (when (tree-has-tele-tag? tree) 20 | (add :const {:o (tree->tele-tag tree)})))) 21 | (t/traverse-trees-uniquely 22 | root-trees 23 | (fn 24 | ([t varfn varval outval] 25 | (when-not (is-output-var? varfn) 26 | (let [Y (tree->tele-tag t)] 27 | (add :droom {:Y Y})))) 28 | ([t varfn varval l r] 29 | (let [X (if (is-root? t) 0 (tree->tele-tag t)) 30 | I0 (var->door-tag varfn 0) 31 | I1 (var->door-tag varfn 1) 32 | O0 (tree->tele-tag l) 33 | O1 (tree->tele-tag r) 34 | item (if (is-root? t) :monster :teleporter)] 35 | (add :tele2 {:X X, :I0 I0, :I1 I1, :o0 O0, :o1 O1, :item item}))))) 36 | @out)) 37 | 38 | (defn- interpose-many-every-n [lv coll n] 39 | (apply concat (interpose lv (partition n coll)))) 40 | 41 | (defn- interpose-every-n [v coll n] 42 | (interpose-many-every-n [v] coll n)) 43 | 44 | (defn- round-up-to-nearest-even [x] 45 | (if (= 0 (mod x 2)) 46 | x 47 | (inc x))) 48 | 49 | (defn get-tessellated-machines-dimensions 50 | [consts tele2s drooms] 51 | (let [tc-count (+ (quot (round-up-to-nearest-even (count consts)) 2) (count tele2s)) 52 | total-count (max tc-count (count drooms)) 53 | cols (int (Math/ceil (Math/sqrt tc-count))) 54 | rows (int (Math/ceil (/ total-count cols)))] 55 | {:rows rows 56 | :cols cols 57 | :width (* cols 128) 58 | :height (* rows 128)})) 59 | 60 | (defn draw-tessellated-machines 61 | "To minimize the amount of lines drawn, we will tessellate the machines. 62 | We will tessellate the 'tele2' parts as L-shaped triominoes. 63 | 'droom' parts will fit in any gaps, or where those gaps would go. 64 | 65 | Example: 66 | 0 _ 0 _ 0 _ 67 | X 1 X 1 X 1 68 | 0 _ 0 _ 0 _ 69 | X 1 X 1 X 1 70 | 0 _ 0 _ 0 _ 71 | X 1 X 1 X 1 72 | 73 | (where X is the monster or teleport destination, 0 and 1 are doors, and _ is a potential droom) 74 | " 75 | [consts tele2s drooms outer-sector make-door-sector] 76 | (let [floor-height 32 77 | ceil-height 92 78 | floor-tex "MFLR8_1" 79 | ceil-tex "MFLR8_1" 80 | side-tex "BLAKWAL2" 81 | door-tex "SPCDOOR3" 82 | 83 | {:keys [rows cols]} (get-tessellated-machines-dimensions consts tele2s drooms) 84 | consts-count-half (quot (round-up-to-nearest-even (count consts)) 2) 85 | 86 | squares 87 | (for [i (range (* rows 2))] 88 | (for [j (range (* cols 2))] 89 | (let [even-i? (= 0 (mod i 2)) 90 | even-j? (= 0 (mod j 2)) 91 | n (+ (quot j 2) (* cols (quot i 2))) 92 | const-1 (get consts (* n 2)) 93 | const-2 (get consts (inc (* n 2))) 94 | const (or const-1 const-2) 95 | tele2 (get tele2s (- n consts-count-half)) 96 | droom (get drooms n)] 97 | (cond 98 | ;; X 99 | (and even-i? even-j?) 100 | (cond 101 | tele2 102 | {:sector (w/create-sector {:floor-height floor-height 103 | :ceil-height ceil-height 104 | :floor-tex floor-tex 105 | :ceil-tex ceil-tex 106 | :tag (:X tele2)}) 107 | :draw (fn [] (w/add-thing {:angle 90 108 | :type (case (:item tele2) 109 | :monster MONSTER_THING 110 | :teleporter wc/THING_TELEPORTER)})) 111 | :t {:tag (:o0 tele2) :special wc/SPECIAL_WR_TELEPORT :upper-tex door-tex} 112 | :r {:tag (:o1 tele2) :special wc/SPECIAL_WR_TELEPORT :upper-tex door-tex} 113 | :b {} 114 | :l {}} 115 | 116 | const 117 | {:sector (w/create-sector {:floor-height floor-height 118 | :ceil-height ceil-height 119 | :floor-tex floor-tex 120 | :ceil-tex ceil-tex})}) 121 | 122 | ;; 0 123 | (and (not even-i?) even-j?) 124 | (cond 125 | tele2 126 | {:sector (make-door-sector (:I0 tele2))} 127 | 128 | const-1 129 | {:sector (w/create-sector {:floor-height floor-height 130 | :ceil-height ceil-height 131 | :floor-tex floor-tex 132 | :ceil-tex ceil-tex}) 133 | :draw (fn [] (w/add-thing {:angle 270 :type MONSTER_THING})) 134 | :b {:tag (:o const-1) :special wc/SPECIAL_WR_TELEPORT}}) 135 | 136 | ;; 1 137 | (and even-i? (not even-j?)) 138 | (cond 139 | tele2 140 | {:sector (make-door-sector (:I1 tele2))} 141 | 142 | const-2 143 | {:sector (w/create-sector {:floor-height floor-height 144 | :ceil-height ceil-height 145 | :floor-tex floor-tex 146 | :ceil-tex ceil-tex}) 147 | :draw (fn [] (w/add-thing {:angle 180 :type MONSTER_THING})) 148 | :l {:tag (:o const-2) :special wc/SPECIAL_WR_TELEPORT}}) 149 | 150 | ;; droom 151 | :else 152 | (when droom 153 | (let [droom-sector (w/create-sector {:floor-height 80 154 | :ceil-height ceil-height 155 | :floor-tex floor-tex 156 | :ceil-tex ceil-tex}) 157 | door-sector (make-door-sector (:Y droom)) 158 | szh 8 159 | szw 8 160 | nszw (- szw) 161 | nszh (- szh) 162 | 163 | A [nszw nszh] 164 | B [nszw szh] 165 | C [szw szh] 166 | D [szw nszh]] 167 | {:sector droom-sector 168 | :draw (fn [] 169 | ;; draw a door that monsters can open. 170 | ;; only one linedef needs to have the special (and it's better that it's only one, to avoid spechit overruns in vanilla doom) 171 | (w/draw-poly-ex {:front {:sector door-sector} 172 | :back {:sector droom-sector :upper-tex door-tex :lower-tex door-tex :special wc/SPECIAL_DR_DOOR}} 173 | A B) 174 | (w/draw-poly-ex {:front {:sector door-sector} 175 | :back {:sector droom-sector :upper-tex door-tex :lower-tex door-tex}} 176 | B C D A) 177 | (w/add-thing {:angle 90 :type wc/THING_TELEPORTER})) 178 | :t {} 179 | :r {} 180 | :b {} 181 | :l {}})))))) 182 | 183 | ;; add spaces for debugging and demonstration purposes 184 | add-spaces? true 185 | 186 | squares (if add-spaces? 187 | (mapv (fn [v] (vec (interpose-many-every-n [nil] v 2))) squares) 188 | squares) 189 | squares (if add-spaces? 190 | (vec (interpose-many-every-n [[]] squares 2)) 191 | squares) 192 | 193 | sizef (if add-spaces? 194 | (fn [i] (let [m (mod i 3)] 195 | (case m 196 | 0 64 197 | 1 60 198 | 2 4))) 199 | 64)] 200 | (w/draw-square-lattice squares 201 | {:sector outer-sector 202 | :upper-tex side-tex 203 | :lower-tex side-tex} 204 | sizef sizef))) 205 | 206 | (defn pop-v [queue path] 207 | (let [[x & xs] (get-in queue path) 208 | queue (assoc-in queue path (vec xs))] 209 | [queue x])) 210 | 211 | (defn conjv [coll v] (conj (or coll []) v)) 212 | 213 | (defn push-v [queue path newvar] 214 | (update-in queue path conjv newvar)) 215 | 216 | (defn take-queue-pseudovar [queue var v] 217 | (let [[queue pseudovar] (pop-v queue [var v])] 218 | (if pseudovar 219 | [queue pseudovar] 220 | 221 | (let [newvar (mkvar) 222 | queue (-> queue 223 | (push-v [var 0] newvar) 224 | (push-v [var 1] newvar))] 225 | (pop-v queue [var v]))))) 226 | 227 | (defn coll-has-value? [coll x] 228 | (cond 229 | (set? coll) (contains? coll x) 230 | :else (or (some #(= x %) coll) false))) 231 | 232 | (defn conj-unique [coll x] 233 | (if (coll-has-value? coll x) 234 | coll 235 | (conj coll x))) 236 | 237 | (defn compile-machines [level-fn] 238 | (let [wadtag-start 1 239 | wadtag-counter (atom (dec wadtag-start)) 240 | new-wadtag (fn [] (swap! wadtag-counter inc)) 241 | 242 | pseudo-out-trees (atom []) 243 | pseudo-out-vars (atom []) 244 | 245 | pseudo-out-queue (atom {}) 246 | tree-has-tele-tag? (atom #{}) 247 | tree->tele-tag (memoize (fn [tree] 248 | (swap! tree-has-tele-tag? conj tree) 249 | (new-wadtag))) 250 | 251 | pseudo-out-tag (fn [varr v] 252 | (let [[queue pseudovar] (take-queue-pseudovar @pseudo-out-queue varr v)] 253 | (reset! pseudo-out-queue queue) 254 | (swap! pseudo-out-trees conj-unique (varr (pseudovar 0) (pseudovar 1))) 255 | (swap! pseudo-out-vars conj-unique pseudovar) 256 | (tree->tele-tag (pseudovar v)))) 257 | 258 | var->door-tag (fn [varr v] (tree->tele-tag (varr v))) 259 | 260 | var->tele-tag (fn [varr v] (pseudo-out-tag varr v))] 261 | (let [interior-ceil-height 400 262 | 263 | main-room-sector 264 | (w/create-sector {:floor-height 0 265 | :ceil-height interior-ceil-height 266 | :floor-tex "MFLR8_1" 267 | :ceil-tex "MFLR8_1" 268 | :tag 0}) 269 | 270 | machines-room-sector 271 | (w/create-sector {:floor-height 0 272 | :ceil-height interior-ceil-height 273 | :floor-tex "MFLR8_1" 274 | :ceil-tex "MFLR8_1" 275 | :tag 0}) 276 | 277 | components (level-fn)] 278 | 279 | (doseq [draw (map :draw components)] 280 | (when draw 281 | (w/with-pushpop-state 282 | (draw var->door-tag var->tele-tag {:outer-sector main-room-sector :floor-height 0 :ceil-height interior-ceil-height})))) 283 | 284 | (let [trees (mapv :trees components) 285 | trees [trees @pseudo-out-trees] 286 | trees (t/simplify-trees trees) 287 | trees (t/prune-unreachable-trees trees @pseudo-out-vars) 288 | parts (make-level-parts trees @pseudo-out-vars var->door-tag tree->tele-tag @tree-has-tele-tag?) 289 | 290 | consts (into [] (comp (filter #(= (first %) :const)) (map second)) parts) 291 | tele2s (into [] (comp (filter #(= (first %) :tele2)) (map second)) parts) 292 | drooms (into [] (comp (filter #(= (first %) :droom)) (map second)) parts) 293 | 294 | make-door-sector (memoize (fn [tag] 295 | (w/create-sector {:floor-height 32 296 | :ceil-height 32 297 | :floor-tex "MFLR8_1" 298 | :ceil-tex "MFLR8_1" 299 | :tag tag}))) 300 | 301 | mres (get-tessellated-machines-dimensions consts tele2s drooms)] 302 | (w/with-pushpop-state 303 | (w/translate -256 256) 304 | (w/translate (- (:width mres)) 0) 305 | (draw-tessellated-machines consts 306 | tele2s 307 | drooms 308 | machines-room-sector 309 | make-door-sector)) 310 | 311 | ;; draw the room perimeter after we know the dimensions of what's inside of it 312 | (let [main-w 4500 main-h 2048 machines-w (+ (:width mres) 256 256) machines-h (+ (:height mres) 256 256) gap-w 8 gap-h 8 313 | door-w 128 door-overhang 64 314 | door-overhang-sector (w/create-sector {:floor-height 0 315 | :ceil-height 128 316 | :floor-tex "MFLR8_1" 317 | :ceil-tex "MFLR8_1" 318 | :tag 0}) 319 | door-sector (w/create-sector {:floor-height 0 :ceil-height 0})] 320 | (w/draw-poly-ex 321 | {:front {:sector main-room-sector :middle-tex "STONE2"}} 322 | [0 (+ gap-h door-w)] [0 main-h] [main-w main-h] [main-w 0] 323 | [door-overhang 0]) 324 | (w/draw-poly-ex 325 | {:front {:sector machines-room-sector :middle-tex "STONE2"}} 326 | [(- door-overhang) 0] [(- gap-w machines-w) 0] [(- gap-w machines-w) machines-h] [(- gap-w) machines-h] [(- gap-w) (+ gap-h door-w)]) 327 | 328 | ;; right overhang 329 | (w/draw-poly-ex 330 | {:front {:sector main-room-sector :upper-tex "STONE2"} 331 | :back {:sector door-overhang-sector}} 332 | [door-overhang 0] [door-overhang (+ gap-h door-w)] [0 (+ gap-h door-w)]) 333 | ;; left overhang 334 | (w/draw-poly-ex 335 | {:front {:sector machines-room-sector :upper-tex "STONE2"} 336 | :back {:sector door-overhang-sector}} 337 | [(- gap-w) (+ gap-h door-w)] [(- door-overhang) (+ gap-h door-w)] [(- door-overhang) 0]) 338 | (w/draw-poly-ex 339 | {:front {:sector door-overhang-sector :middle-tex "STONE2"}} 340 | [door-overhang 0] [(- door-overhang) 0]) 341 | ;; door 342 | (w/draw-poly-ex 343 | {:front {:sector door-overhang-sector :upper-tex "BIGDOOR2" :special wc/SPECIAL_DR_DOOR} 344 | :back {:sector door-sector}} 345 | [(- gap-w) (+ gap-h door-w)] [(- gap-w) gap-h] [0 gap-h] [0 (+ gap-h door-w)]) 346 | (w/draw-poly-ex 347 | {:front {:sector door-sector :middle-tex "DOORTRAK" :flags wc/ML_DONTPEGBOTTOM}} 348 | [(- gap-w) (+ gap-h door-w)] [0 (+ gap-h door-w)])))))) 349 | -------------------------------------------------------------------------------- /src/doomcalc/tree.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.tree 2 | (:require [clojure.set :as set])) 3 | 4 | ;; we define trees generically. 5 | ;; 6 | ;; tree implementations can not be vectors 7 | ;; (we use vectors to represent collections of separate trees) 8 | 9 | ;; each tree is associated with 2 wadtags. 10 | ;; each tree _leaf_ is associated 1 wadtag (these are outputs). 11 | 12 | (defonce *counter* (atom 0)) 13 | (defonce *adjacency* (atom {})) 14 | (defn mkint [] (swap! *counter* inc)) 15 | 16 | (defn out? [tree] (= :out (first (get @*adjacency* tree)))) 17 | (defn decision? [tree] (= :decision (first (get @*adjacency* tree)))) 18 | (defn tree-varfn [tree] (nth (get @*adjacency* tree) 1)) 19 | (defn tree-varval [tree] (nth (get @*adjacency* tree) 2)) 20 | (defn tree-outval [tree] (when (out? tree) (nth (get @*adjacency* tree) 3))) 21 | (defn tree-left [tree] (when (decision? tree) (nth (get @*adjacency* tree) 3))) 22 | (defn tree-right [tree] (when (decision? tree) (nth (get @*adjacency* tree) 4))) 23 | 24 | (defn traverse [tree f] 25 | (cond 26 | (out? tree) 27 | (f tree (tree-varfn tree) (tree-varval tree) (tree-outval tree)) 28 | 29 | (decision? tree) 30 | (do 31 | (f tree (tree-varfn tree) (tree-varval tree) (tree-left tree) (tree-right tree)) 32 | (traverse (tree-left tree) f) 33 | (traverse (tree-right tree) f)))) 34 | 35 | (defn flatten-vectors [l] 36 | (cond 37 | (vector? l) (vec (apply concat (map flatten-vectors l))) 38 | (nil? l) [] 39 | :else [l])) 40 | 41 | (defn traverse-trees-uniquely [trees f] 42 | (let [ff (memoize f)] 43 | (doseq [tree (flatten-vectors trees)] 44 | (traverse tree ff)))) 45 | 46 | 47 | (defn inc-nil [v] (inc (or v 0))) 48 | 49 | (defn rewrite-tree 50 | "Returns a tree. 51 | Trees are rewritten top-down (from roots to leaves)" 52 | [tree f] 53 | 54 | (let [newtree (f tree) 55 | varfn (tree-varfn newtree)] 56 | (cond 57 | (out? newtree) 58 | (varfn (tree-outval newtree)) 59 | 60 | (decision? newtree) 61 | (varfn (rewrite-tree (tree-left newtree) f) 62 | (rewrite-tree (tree-right newtree) f))))) 63 | 64 | (defn actual-root-nodes [trees] 65 | (let [trees (flatten-vectors trees) 66 | roots (atom (into #{} trees))] 67 | (traverse-trees-uniquely trees 68 | (fn 69 | ([_ _ _ _]) 70 | ([_ _ _ l r] 71 | ;; remove any nodes that have parents 72 | (swap! roots disj l) 73 | (swap! roots disj r)))) 74 | (vec @roots))) 75 | 76 | (defn rewrite-trees 77 | "Returns a vector of trees. 78 | Trees are rewritten top-down (from roots to leaves)" 79 | [trees f] 80 | ;; rewrite every root node. 81 | ;; note: it's possible to rewrite trees in such a way that former root nodes have parents. 82 | ;; we correct for this edge case with (actual-root-nodes). 83 | (actual-root-nodes (mapv #(rewrite-tree % f) (flatten-vectors trees)))) 84 | 85 | 86 | (defn simplify-trees 87 | "Does simplification of some nodes. Some optimizations can only be done once the whole tree is known. 88 | Optimization 1) if any variables only appear once and are root nodes, then outputs setting the variable are rerouted. 89 | 1. count variable occurrences 90 | 2. for all with a count of 1, find the ones that are also root nodes and have been used as outputs 91 | (tracking outputs is important because if nothing writes to the variable, it's probably set from outside the tree) 92 | 3. keep them in a list and go to them during traversal 93 | Optimization 2) if any variable output is a root tree, it's a constant. rewrite trees that use the variable. 94 | " 95 | [trees] 96 | (let [trees (flatten-vectors trees) 97 | 98 | ;; all root trees that are outputs are constants. 99 | var-constants (into {} 100 | (comp (filter out?) 101 | (map (fn [t] [(tree-varfn t) (tree-outval t)]))) 102 | trees) 103 | 104 | varfn-counts (atom {}) 105 | varfn-as-outputs (atom #{}) 106 | _ (traverse-trees-uniquely trees 107 | (fn 108 | ([t varfn varval v]) 109 | ([t varfn varval l r] 110 | (swap! varfn-counts update varfn inc-nil) 111 | ;; only consider outputs with parents 112 | (when (out? l) (swap! varfn-as-outputs conj (tree-varfn l))) 113 | (when (out? r) (swap! varfn-as-outputs conj (tree-varfn r)))))) 114 | 115 | varfns-of-roots (into #{} (comp (filter decision?) (map tree-varfn)) trees) 116 | root-varfn->leftright (into {} 117 | (comp (filter decision?) 118 | (map (fn [t] [(tree-varfn t) [(tree-left t) (tree-right t)]]))) 119 | trees) 120 | varfns-once (into #{} (comp (filter (fn [[_ v]] (= v 1))) (map first)) @varfn-counts) 121 | varfns-to-simplify (set/intersection varfns-of-roots varfns-once @varfn-as-outputs) 122 | 123 | actual (fn [tree] 124 | (cond 125 | (out? tree) 126 | (if (contains? varfns-to-simplify (tree-varfn tree)) 127 | ;; This output goes directly somewhere else. 128 | (let [leftright (root-varfn->leftright (tree-varfn tree)) 129 | v (tree-outval tree) 130 | choose (if (= v 0) (first leftright) (second leftright))] 131 | choose) 132 | 133 | tree) 134 | 135 | (decision? tree) 136 | ;; if the tree uses a variable that's a constant, choose its left or right child 137 | (let [constant (get var-constants (tree-varfn tree))] 138 | (cond 139 | (= constant 0) (tree-left tree) 140 | (= constant 1) (tree-right tree) 141 | :else tree)))) 142 | 143 | ;; remove root nodes that are simplified away 144 | newtrees (into [] (remove (fn [t] (contains? varfns-to-simplify (tree-varfn t)))) trees)] 145 | (rewrite-trees newtrees actual))) 146 | 147 | (defn transpose-adjlist 148 | "Transposes the adjaency list. 149 | An adjacency list is a map of sets. e.g. {1: #{:a :b :c}, 2...}. 150 | a is an m*n list. Returns an n*m list." 151 | [a] 152 | (let [m-items (set (keys a)) 153 | n-items (reduce set/union (vals a))] 154 | (into {} 155 | (remove (comp empty? second)) 156 | (for [j n-items] 157 | [j (into #{} 158 | (mapcat (fn [i] (when (contains? (get a i) j) 159 | [i]))) 160 | m-items)])))) 161 | 162 | (defn *-adjlists 163 | "Like (0,1)-matrix multiplication, but for adjacency lists. 164 | An adjacency list is a map of sets. e.g. {1: #{:a :b :c}, 2...}. 165 | Domain is keys, codomain is elements of the set. Domain x Codomain. 166 | 167 | a is an m*n list, b is an n*o list. Returns an m*o list." 168 | [a b] 169 | (let [m-items (keys a) 170 | o-items (reduce set/union (vals b)) 171 | 172 | dot (fn [x y] (some? (seq (set/intersection x y)))) 173 | row (fn [adj i] (get adj i #{})) 174 | col (fn [adj j] (into #{} 175 | (comp (filter (fn [[_ v]] (contains? v j))) 176 | (map first)) 177 | adj))] 178 | (into {} 179 | (remove (comp empty? second)) 180 | (for [i m-items] 181 | [i (into #{} 182 | (mapcat (fn [j] (when (dot (row a i) (col b j)) 183 | [j]))) 184 | o-items)])))) 185 | 186 | (defn *-adjlists-transposed-second 187 | "An optimization of (*-adjlists a b), where b is transposed." 188 | [a b] 189 | (let [m-items (keys a) 190 | o-items (keys b) 191 | 192 | dot (fn [x y] (some? (seq (set/intersection x y)))) 193 | row (fn [adj i] (get adj i #{}))] 194 | (into {} 195 | (remove (comp empty? second)) 196 | (for [i m-items] 197 | [i (into #{} 198 | (mapcat (fn [j] (when (dot (row a i) (row b j)) 199 | [j]))) 200 | o-items)])))) 201 | 202 | (defn +-adjlists 203 | [a b] 204 | (into {} 205 | (for [i (set/union (set (keys a)) (set (keys b)))] 206 | [i (set/union (get a i #{}) (get b i #{}))]))) 207 | 208 | (defn tree->input-output-vars [tree] 209 | (let [invars (atom #{}) 210 | outvars (atom #{})] 211 | (traverse tree 212 | (fn 213 | ([t varfn varval v] (swap! outvars conj varfn)) 214 | ([t varfn varval l r] (swap! invars conj varfn)))) 215 | [@invars @outvars])) 216 | 217 | (defn prune-unreachable-trees 218 | "Keep the trees that eventually output to the provided variables, and remove the rest. 219 | Note that this operates on entire trees, and doesn't remove/rewrite subtrees. 220 | 221 | We solve this as follows: 222 | 223 | Let I be an adjacency matrix of trees to input variables. 224 | Let J be an adjacency matrix of output variables to trees. 225 | 226 | K = I * J 227 | Let K be an adjacency matrix of trees to trees (from output trees to input trees). 228 | 229 | L = 1 + K + K*K + K*K*K + ... 230 | Let L be an adjacency matrix of trees to trees (from output trees to all eventually reachable input trees). 231 | 232 | R = reachablevars*J * L 233 | Let R be a row vector of trees that are reachable from the variables. 234 | reachablevars is a row vector. 235 | 236 | Simplified: 237 | R = (reachablevars*J) * (1 + K + K*K + K*K*K + ...) 238 | n = reachablevars*J 239 | R = n + nK + nKK + nKKK + ... 240 | " 241 | [trees reachablevars] 242 | (let [tio (map (fn [t] [t (tree->input-output-vars t)]) 243 | (flatten-vectors trees)) 244 | I (into {} 245 | (map (fn [[k v]] [k (first v)])) 246 | tio) 247 | Jt (into {} 248 | (map (fn [[k v]] [k (second v)])) 249 | tio) 250 | J (transpose-adjlist Jt) 251 | 252 | K (*-adjlists-transposed-second I Jt) 253 | n (*-adjlists {:result (set reachablevars)} J) 254 | R (loop [term n 255 | sum term] 256 | (let [term (*-adjlists term K) 257 | newsum (+-adjlists sum term)] 258 | ;; the sum will eventually converge. end the loop when it does. 259 | (if (= sum newsum) 260 | sum 261 | (recur term newsum))))] 262 | (vec (:result R)))) 263 | 264 | (comment 265 | (let [a (mkvar :a), b (mkvar :b), c (mkvar :c), d (mkvar :d), e (mkvar :e) 266 | r (mkvar :r), s (mkvar :s), t (mkvar :t), y (mkvar :y), z (mkvar :z) 267 | 268 | trees 269 | [(a (b (r 1) 270 | (c (s 0) 271 | (s 1))) 272 | (r 1)) 273 | (r (t 1) 274 | (a (t 0) 275 | (t 1))) 276 | (y (z (c 1) 277 | (c 0)) 278 | (d 1)) 279 | (d (e 0) 280 | (e 1))]] 281 | (identity 282 | (prune-unreachable-trees trees [s t])))) 283 | 284 | (defn visit-dot-creator [] 285 | (let [counter (atom 100) 286 | h (memoize (fn [_] (swap! counter inc)))] 287 | (fn 288 | ([out-tree varfn varval v] 289 | (println (str (h out-tree) "[label=\"" (if varval varval (h varfn)) "." v "\",shape=rectangle]"))) 290 | ([decision-tree varfn varval l r] 291 | (let [num (h decision-tree)] 292 | (println (str num "[label=\"" (if varval varval (h varfn)) "\"]")) 293 | (println (str num " -> " (h l) " [label=0,style=dashed]")) 294 | (println (str num " -> " (h r) " [label=1]"))))))) 295 | 296 | (defn debug-dot 297 | "Prints a DOT representation of the trees. Useful for debugging!" 298 | [trees] 299 | (traverse-trees-uniquely trees (visit-dot-creator))) 300 | 301 | (defn emit-variable-output [varfn varval outval] 302 | (let [num (mkint)] 303 | (swap! *adjacency* assoc num [:out varfn varval outval]) 304 | num)) 305 | 306 | (defn emit-decision [varfn varval left right] 307 | (let [num (mkint)] 308 | (swap! *adjacency* assoc num [:decision varfn varval left right]) 309 | num)) 310 | 311 | (defn mkvar 312 | ([] (mkvar nil)) 313 | 314 | ([varval & {:keys [optimize-same-left-right?] 315 | :or {optimize-same-left-right? true}}] 316 | (let [intern-decisions (atom {}) 317 | intern-out-0 (atom nil) 318 | intern-out-1 (atom nil)] 319 | ;; We're treating a function as an opaque "Variable" type that we can call. 320 | ;; It would be valid to extract this into a deftype, but this is easy. 321 | (letfn [(varfn 322 | ;; 1-arity: Variable output 323 | ([outval] 324 | (let [a (if (= outval 0) intern-out-0 intern-out-1) 325 | num @a 326 | new? (nil? num) 327 | num (if new? (emit-variable-output varfn varval outval) num) 328 | _ (reset! a num)] 329 | num)) 330 | 331 | ;; 2-arity: Decision 332 | ([left right] 333 | (cond 334 | (= left :UNDEFINED) right 335 | (= right :UNDEFINED) left 336 | (and optimize-same-left-right? (= left right)) left 337 | :else 338 | (let [num (get @intern-decisions [left right]) 339 | new? (nil? num) 340 | num (if new? (emit-decision varfn varval left right) num) 341 | _ (swap! intern-decisions assoc [left right] num)] 342 | num))))] 343 | varfn)))) 344 | 345 | (defn count-unique-tree-values [tree] 346 | (let [uniq-values (atom #{})] 347 | (traverse tree (fn ([_ _ _ _]) ([v _ _ _ _] (swap! uniq-values conj v)))) 348 | (count @uniq-values))) 349 | 350 | (defn minimize-trees [trees] 351 | ;; count all the unique values in the tree 352 | ;; return the tree with the smallest number of unique values 353 | (second 354 | (reduce 355 | (fn [[c1 t1] [c2 t2]] 356 | (if (<= c1 c2) [c1 t1] [c2 t2])) 357 | 358 | (for [tree trees] 359 | [(count-unique-tree-values tree) tree])))) 360 | 361 | -------------------------------------------------------------------------------- /src/doomcalc/wad_builder.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.wad-builder) 2 | 3 | (def ^:dynamic *CTX* nil) 4 | 5 | (def NIL-SIDEDEF 65535) 6 | 7 | (deftype AutoId [on-new-value cache]) 8 | 9 | (defn get-id [autoid value] 10 | (if (contains? @(.-cache autoid) value) 11 | (get @(.-cache autoid) value) 12 | 13 | (let [id ((.-on-new-value autoid) value)] 14 | (swap! (.-cache autoid) assoc value id) 15 | id))) 16 | 17 | (defrecord WadBuilder [wad-data state state-history vertex-auto-id sidedef-auto-id]) 18 | 19 | (defn wad-data [] 20 | @(:wad-data *CTX*)) 21 | 22 | (defn add-record [type value] 23 | (let [new-wad-data (swap! (:wad-data *CTX*) update type conj value)] 24 | ;; return id 25 | (dec (count (get new-wad-data type))))) 26 | 27 | (defn make-wad-data-auto-id* [wad-data-atom type] 28 | (AutoId. (fn [value] 29 | (let [new-wad-data (swap! wad-data-atom update type conj value) 30 | new-id (dec (count (get new-wad-data type)))] 31 | new-id)) 32 | (atom {}))) 33 | 34 | (defn new-wad-builder [] 35 | (let [wad-data-atom (atom {:sectors [] 36 | :vertexes [] 37 | :sidedefs [] 38 | :linedefs [] 39 | :things []})] 40 | (WadBuilder. wad-data-atom 41 | (atom {}) 42 | (atom (list)) 43 | (make-wad-data-auto-id* wad-data-atom :vertexes) 44 | (make-wad-data-auto-id* wad-data-atom :sidedefs)))) 45 | 46 | (defmacro with-new-wad-builder [& body] 47 | `(binding [*CTX* (new-wad-builder)] 48 | ~@body)) 49 | 50 | (defn get-state* 51 | ([key] 52 | (get @(:state *CTX*) key)) 53 | ([key default] 54 | (get @(:state *CTX*) key default))) 55 | (defn set-state* [key value] 56 | (swap! (:state *CTX*) assoc key value)) 57 | 58 | (defn push-state [] 59 | (swap! (:state-history *CTX*) conj @(:state *CTX*))) 60 | (defn pop-state [] 61 | (let [[old _new] (swap-vals! (:state-history *CTX*) pop) 62 | popped (peek old)] 63 | (reset! (:state *CTX*) popped))) 64 | 65 | (defmacro with-pushpop-state [& body] 66 | `(let [_# (push-state) 67 | r# (do ~@body) 68 | _# (pop-state)] 69 | r#)) 70 | 71 | (defn line-tag [] 72 | (get-state* :line-tag 0)) 73 | (defn set-line-tag [wadtag] 74 | (set-state* :line-tag wadtag)) 75 | (defn clear-line-tag [] 76 | (set-state* :line-tag 0)) 77 | 78 | (defn line-special [] 79 | (get-state* :line-special 0)) 80 | (defn set-line-special [special] 81 | (set-state* :line-special special)) 82 | (defn clear-line-special [] 83 | (set-state* :line-special 0)) 84 | 85 | (defn line-flags [] 86 | (get-state* :line-flags 0)) 87 | (defn set-line-flags [flags] 88 | (set-state* :line-flags flags)) 89 | (defn clear-line-flags [] 90 | (set-state* :line-flags 0)) 91 | 92 | (defn back-sidedef-id [] 93 | (get-state* :back-sidedef-id NIL-SIDEDEF)) 94 | (defn front-sidedef-id [] 95 | (get-state* :front-sidedef-id NIL-SIDEDEF)) 96 | 97 | (defn create-sector [sector-info] 98 | (let [sector-defaults {:floor-height 0 99 | :ceil-height 0 100 | :floor-tex "MFLR8_1" 101 | :ceil-tex "MFLR8_1" 102 | :light 160 103 | :tag 0}] 104 | (add-record :sectors (merge sector-defaults 105 | (select-keys sector-info 106 | (keys sector-defaults)))))) 107 | 108 | (defn vertex->id [x y] 109 | (get-id (:vertex-auto-id *CTX*) [x y])) 110 | 111 | (defn sidedef->id [sidedef-info] 112 | (if (nil? sidedef-info) 113 | NIL-SIDEDEF 114 | (let [sidedef-defaults {:xoff 0 115 | :yoff 0 116 | :upper-tex "-" 117 | :middle-tex "-" 118 | :lower-tex "-" 119 | :sector 0}] 120 | (get-id (:sidedef-auto-id *CTX*) (merge sidedef-defaults 121 | (select-keys sidedef-info 122 | (keys sidedef-defaults))))))) 123 | 124 | 125 | (defn set-back [sidedef-info] 126 | (set-state* :back-sidedef-id (sidedef->id sidedef-info))) 127 | (defn set-front [sidedef-info] 128 | (set-state* :front-sidedef-id (sidedef->id sidedef-info))) 129 | (defn flip-sidedefs [] 130 | (let [f (front-sidedef-id) 131 | b (back-sidedef-id)] 132 | (set-state* :back-sidedef-id f) 133 | (set-state* :front-sidedef-id b))) 134 | 135 | 136 | (defn get-transform-matrix [] 137 | (get-state* :transform [[1 0 0] 138 | [0 1 0]])) 139 | 140 | (defn set-transform-matrix [matrix] 141 | (set-state* :transform matrix)) 142 | 143 | (defn- multiply-2x3-matrices [a b] 144 | ;; we assume the 3rd row of each matrix is [0 0 1] 145 | (let [dot (fn [x y] (reduce + (map * x y))) 146 | row (fn [m i] (if (= i 2) [0 0 1] (nth m i))) 147 | col (fn [m j] (mapv #(nth (row m %) j) (range 3)))] 148 | (vec (for [i (range 2)] 149 | (vec (for [j (range 3)] 150 | (dot (row a i) (col b j)))))))) 151 | 152 | 153 | (defn- det-of-2x3-matrix [[[a b _c] 154 | [d e _f]]] 155 | (- (* a e) (* b d))) 156 | 157 | (defn- transform-point 158 | "Get the transformed point given the transform matrix. Round to integers. 159 | 160 | Right-multiply the matrix with the column vector [x;y;1]: 161 | 162 | [x'] [m11 m12 m13] [x] 163 | [y'] = [m21 m22 m23] [y] 164 | [ 1] [ 0 0 1] [1] 165 | " 166 | [matrix [x y]] 167 | ;; we assume the 3rd row of the matrix is [0 0 1] 168 | (let [[[m11 m12 m13] [m21 m22 m23]] matrix] 169 | [(Math/round (double (+ (* m11 x) (* m12 y) m13))) 170 | (Math/round (double (+ (* m21 x) (* m22 y) m23)))])) 171 | 172 | (defn transform 173 | "Right-multiply the current transform matrix" 174 | [matrix] 175 | (set-transform-matrix (multiply-2x3-matrices (get-transform-matrix) matrix))) 176 | 177 | (defn translate 178 | "Translates the transform." 179 | [x y] 180 | (transform [[1 0 x] 181 | [0 1 y]])) 182 | 183 | (defn scale 184 | "Scales the transform." 185 | ([s] (scale s s)) 186 | ([x y] (transform [[x 0 0] 187 | [0 y 0]]))) 188 | 189 | (defn rotate 190 | "Rotates the transform counter-clockwise." 191 | [degrees] 192 | (let [radians (* (/ degrees 360) Math/PI 2) 193 | c (Math/cos radians) 194 | s (Math/sin radians)] 195 | (transform [[c (- s) 0] 196 | [s c 0]]))) 197 | 198 | (defn- transform-angle 199 | "Calculate the new angle in degrees after it's been transformed. Round to an integer." 200 | [matrix degrees] 201 | (let [[[m11 m12 _m13] 202 | [m21 m22 _m23]] matrix] 203 | (if (and (= m12 m21 0) (= m11 m22)) 204 | ;; don't do anything if matrix is identity or a uniform scale 205 | degrees 206 | 207 | (let [radians (* (/ degrees 360) Math/PI 2) 208 | c (Math/cos radians) 209 | s (Math/sin radians) 210 | 211 | unit-x (+ (* c m11) (* s m12)) 212 | unit-y (+ (* c m21) (* s m22)) 213 | new-radians (Math/atan2 unit-y unit-x)] 214 | (Math/round (* (/ new-radians (* Math/PI 2)) 360)))))) 215 | 216 | (defn add-thing [{:keys [x y angle type] 217 | ;; default type is health potion 218 | :or {x 0 y 0 angle 0 type 0x7DE}}] 219 | (let [matrix (get-transform-matrix) 220 | [x y] (transform-point matrix [x y]) 221 | angle (transform-angle matrix angle)] 222 | (add-record :things {:x x :y y :angle angle :type type}))) 223 | 224 | (defn draw-poly 225 | "Draw connected lines." 226 | [& points] 227 | ;; if the determinant of the matrix is negative, the orientation is flipped. 228 | ;; so we'll reverse the points to preserve orientation 229 | (let [matrix (get-transform-matrix) 230 | det (det-of-2x3-matrix matrix) 231 | points (if (>= det 0) points (reverse points))] 232 | 233 | (doseq [i (range (dec (count points)))] 234 | (let [[x0 y0] (transform-point matrix (nth points i)) 235 | [x1 y1] (transform-point matrix (nth points (inc i))) 236 | 237 | front (front-sidedef-id) 238 | back (back-sidedef-id) 239 | has-front? (not= front NIL-SIDEDEF) 240 | has-back? (not= back NIL-SIDEDEF)] 241 | (add-record :linedefs 242 | {:v1 (vertex->id x0 y0) 243 | :v2 (vertex->id x1 y1) 244 | :flags (bit-or (if (and has-front? has-back?) 4 0) 245 | (line-flags)) 246 | :special (line-special) 247 | :sector-tag (line-tag) 248 | :front-sidedef front 249 | :back-sidedef back}))))) 250 | 251 | (defn draw-poly-ex 252 | "An extended version of draw-poly that also sets sidedefs and the line tag/special/flags. 253 | If the linedef special is defined on the back, the lines are flipped so it can be activated by walking from that side. 254 | " 255 | [{:keys [front back]} & points] 256 | 257 | (let [special-on-back? (and (not (contains? front :special)) (contains? back :special))] 258 | ;; the front tag/special/flags are prioritized. fallback to the back if the front doesn't specify them. 259 | (set-line-tag (or (:tag front) (:tag back) 0)) 260 | (set-line-special (or (:special front) (:special back) 0)) 261 | (set-line-flags (bit-or (:flags front 0) (:flags back 0))) 262 | (if front 263 | (set-front (select-keys front [:sector :upper-tex :lower-tex :middle-tex :xoff :yoff])) 264 | (set-front nil)) 265 | (if back 266 | (set-back (select-keys back [:sector :upper-tex :lower-tex :middle-tex :xoff :yoff])) 267 | (set-back nil)) 268 | (if special-on-back? 269 | (do 270 | (flip-sidedefs) 271 | (apply draw-poly (reverse points))) 272 | 273 | (apply draw-poly points)))) 274 | 275 | (defn- lookup-or-constantly [x] 276 | (cond 277 | (fn? x) x 278 | (map? x) x 279 | :else (constantly x))) 280 | 281 | (defn draw-square-lattice 282 | "Draw a 2D array of squares. Adjancent squares share lines. 283 | Each square has a :sector, and 4 lines (:t :b :l :r for top, bottom, left, right) with the properties: 284 | :upper-tex :lower-tex :middle-tex :xoff :yoff 285 | Those lines can have additional line properties: 286 | :tag :special :flags 287 | " 288 | [squares outer row-size col-size] 289 | ;; This function draws a lattice of squares that look like this: 290 | ;; i,0 i,1 i,2 291 | ;; . . . 292 | ;; . . . 293 | ;; |___|___|__. . 2,j 294 | ;; | | | 295 | ;; |___|___|__. . 1,j 296 | ;; | | | 297 | ;; |___|___|__. . 0,j 298 | 299 | (let [row-size (lookup-or-constantly row-size) 300 | col-size (lookup-or-constantly col-size) 301 | rows (count squares) 302 | cols (reduce max (map count squares)) 303 | row-y (vec (cons 0 (reductions + (map row-size (range rows))))) 304 | col-x (vec (cons 0 (reductions + (map col-size (range cols))))) 305 | pos (fn [i j] [(get col-x j) (get row-y i)]) 306 | square-at (fn [i j] (nth (nth squares i nil) j nil))] 307 | (doseq [i (range rows) 308 | j (range cols)] 309 | (when-let [sq (square-at i j)] 310 | (let [north-sq (square-at (inc i) j) 311 | east-sq (square-at i (inc j)) 312 | south-sq (square-at (dec i) j) 313 | west-sq (square-at i (dec j)) 314 | 315 | current-sector (get sq :sector) 316 | north-sector (get north-sq :sector (:sector outer)) 317 | east-sector (get east-sq :sector (:sector outer)) 318 | south-sector (get south-sq :sector (:sector outer)) 319 | west-sector (get west-sq :sector (:sector outer)) 320 | draw-inside-square (:draw sq)] 321 | ;; if there's no north square, draw the top line 322 | ;; if there's no east square, draw the right line 323 | ;; always draw the bottom and left lines 324 | 325 | ;; top 326 | ;; front is north, back is current 327 | (when-not north-sq 328 | (draw-poly-ex {:front (if north-sq 329 | (merge (-> north-sq :b) {:sector north-sector}) 330 | outer) 331 | :back (merge (-> sq :t) {:sector current-sector})} 332 | (pos (inc i) (inc j)) (pos (inc i) j))) 333 | ;; right 334 | ;; front is east, back is current 335 | (when-not east-sq 336 | (draw-poly-ex {:front (if east-sq 337 | (merge (-> east-sq :l) {:sector east-sector}) 338 | outer) 339 | :back (merge (-> sq :r) {:sector current-sector})} 340 | (pos i (inc j)) (pos (inc i) (inc j)))) 341 | 342 | ;; bottom 343 | ;; front is current, back is south 344 | (draw-poly-ex {:front (merge (-> sq :b) {:sector current-sector}) 345 | :back (if south-sq 346 | (merge (-> south-sq :t) {:sector south-sector}) 347 | outer)} 348 | (pos i (inc j)) (pos i j)) 349 | ;; left 350 | ;; front is current, back is west 351 | 352 | (draw-poly-ex {:front (merge (-> sq :l) {:sector current-sector}) 353 | :back (if west-sq 354 | (merge (-> west-sq :r) {:sector west-sector}) 355 | outer)} 356 | (pos i j) (pos (inc i) j)) 357 | 358 | (when draw-inside-square 359 | (let [[x1 y1] (pos i j) 360 | [x2 y2] (pos (inc i) (inc j)) 361 | x (quot (+ x1 x2) 2) 362 | y (quot (+ y1 y2) 2)] 363 | (push-state) 364 | (translate x y) 365 | (draw-inside-square) 366 | (pop-state)))))))) 367 | 368 | (defn- round-down-to-even [v] 369 | (if (= 0 (mod v 2)) v (dec v))) 370 | 371 | (defn draw-triangle-lattice 372 | "Style includes :stride+, :stride0. 373 | :stride+ means as i increases, the triangle moves up and to the right (preserving the column's triangle shape). 374 | :stride0 means as i increases, the triangle moves up and flips orientation (preserving the column's x position). 375 | Default is :stride+" 376 | [tris outer base-w height & {:keys [style start-shape] 377 | :or {style :stride+ start-shape :A}}] 378 | ;; This function draws a lattice of triangles that look like this: 379 | ;; i,0 i,2 i,4 380 | ;; . . . 381 | ;; . . . 382 | ;; /\ /\ /\ 383 | ;; /__\/__\/__\ . . 1,j 384 | ;; /\ /\ /\ /\ 385 | ;; /__\/__\/__\/__\ . . 0,j 386 | ;; 387 | ;; The lower-left is index at row 0 col 0 (i=0,j=0, or 0,0) 388 | ;; as i increases, the row shifts half-way to the right (as per the default :stride+ style). 389 | 390 | (let [rows (count tris) 391 | cols (reduce max (map count tris)) 392 | 393 | ;; x,y position of lower-left vertex for "A" triangle at i,j 394 | ;; if j is odd, it's rounded down to an even number 395 | pos-A (fn [i j] [(+ (* base-w (quot (round-down-to-even j) 2)) 396 | (* i (/ base-w 2))) 397 | (* height i)]) 398 | 399 | draw-line 400 | (fn [v1 v2, f-tri f-side, b-tri b-side] 401 | (draw-poly-ex {:front (if f-tri 402 | (merge (f-side f-tri) {:sector (:sector f-tri)}) 403 | outer) 404 | :back (if b-tri 405 | (merge (b-side b-tri) {:sector (:sector b-tri)}) 406 | outer)} 407 | v1 v2)) 408 | 409 | avg-points 410 | (fn [points] 411 | [(quot (reduce + (map first points)) (count points)) 412 | (quot (reduce + (map second points)) (count points))]) 413 | 414 | tri-at-original (fn [i j] (nth (nth tris i nil) j nil)) 415 | 416 | ;; the style remaps the triangle coordinate system to the default :stride+. 417 | tri-at 418 | (case style 419 | :stride+ tri-at-original 420 | :stride0 (fn [i j] (tri-at-original i (+ i j)))) 421 | 422 | col-iter 423 | (case style 424 | :stride+ (fn [_i] (range cols)) 425 | :stride0 (fn [i] (range (- i) (- cols i)))) 426 | 427 | ;; r---t 428 | ;; / \ / 429 | ;; q---s 430 | ;; We draw "A" and "V" triangles 431 | draw-A 432 | (fn [i j] 433 | (when-let [cur (tri-at i j)] 434 | (let [q (pos-A i j) 435 | r (pos-A (inc i) j) 436 | s (pos-A i (+ j 2))] 437 | (draw-line q r, cur :l, (tri-at i (dec j)) :r) 438 | (draw-line s q, cur :s, (tri-at (dec i) (inc j)) :s) 439 | (when-not (tri-at i (inc j)) 440 | ;; right tri is missing 441 | (draw-line s r, nil :l, cur :s)) 442 | (when-let [draw (:draw cur)] 443 | (push-state) 444 | (apply translate (avg-points [q r s])) 445 | (draw) 446 | (pop-state))))) 447 | draw-V 448 | (fn [i j] 449 | (when-let [cur (tri-at i j)] 450 | (let [r (pos-A (inc i) (dec j)) 451 | s (pos-A i (inc j)) 452 | t (pos-A (inc i) (inc j))] 453 | (draw-line s r, cur :l, (tri-at i (dec j)) :r) 454 | (when-not (tri-at (inc i) (dec j)) 455 | ;; top tri is missing 456 | (draw-line t r, nil :s, cur :s)) 457 | (when-not (tri-at i (inc j)) 458 | ;; right tri is missing 459 | (draw-line s t, nil :l, cur :r)) 460 | (when-let [draw (:draw cur)] 461 | (push-state) 462 | (apply translate (avg-points [r s t])) 463 | (draw) 464 | (pop-state)))))] 465 | 466 | (case start-shape 467 | :A (doseq [i (range rows) 468 | j (col-iter i)] 469 | (if (= 0 (mod j 2)) 470 | (draw-A i j) 471 | (draw-V i j))) 472 | :V (do 473 | (push-state) 474 | (translate (quot base-w 2) 0) 475 | (doseq [i (range rows) 476 | j (col-iter i)] 477 | (if (= 0 (mod j 2)) 478 | (draw-V i j) 479 | (draw-A i j))) 480 | (pop-state))))) 481 | 482 | 483 | (defn debug-svg [] 484 | ;; just draw linedefs 485 | (let [data (wad-data) 486 | vertices (atom []) 487 | 488 | body 489 | (with-out-str 490 | (doseq [thing (:things data)] 491 | (println "") 492 | #_(println thing)) 493 | 494 | (doseq [linedef (:linedefs data)] 495 | (let [[v1x v1y] (nth (:vertexes data) (:v1 linedef)) 496 | [v2x v2y] (nth (:vertexes data) (:v2 linedef))] 497 | (swap! vertices conj [v1x v1y] [v2x v2y]) 498 | (println (str "")) 499 | ;; draw perpendicular line. rotate (v2-v1) 90 degrees counterclockwise. 500 | (let [dx (- v2x v1x) 501 | dy (- v2y v1y) 502 | len (Math/sqrt (+ (* dx dx) (* dy dy))) 503 | dx (* dx (/ 4 len)) 504 | dy (* dy (/ 4 len)) 505 | x1 (/ (+ v1x v2x) 2) 506 | y1 (/ (+ v1y v2y) 2) 507 | x2 (+ x1 dy) 508 | y2 (- y1 dx) 509 | 510 | x1 (double x1) 511 | y1 (double y1) 512 | x2 (double x2) 513 | y2 (double y2)] 514 | (println (str " ")))))) 515 | 516 | vertices @vertices 517 | 518 | min-x (reduce min (map first vertices)) 519 | max-x (reduce max (map first vertices)) 520 | min-y (reduce min (map second vertices)) 521 | max-y (reduce max (map second vertices)) 522 | margin 16 523 | min-x (- min-x margin) min-y (- min-y margin) 524 | max-x (+ max-x margin) max-y (+ max-y margin) 525 | 526 | ;; flip y to make Y point up 527 | [min-y max-y] [(- max-y) (- min-y)] 528 | 529 | svg (str "" 530 | "" 531 | ;; draw axis lines 532 | (str "") 533 | (str "") 534 | ;; draw everything else 535 | body 536 | "" 537 | "")] 538 | (spit "out.svg" svg))) 539 | 540 | (defmacro with-debug-svg [& body] 541 | `(with-new-wad-builder 542 | (let [out# (do ~@body)] 543 | (debug-svg) 544 | out#))) 545 | -------------------------------------------------------------------------------- /src/doomcalc/wad_constants.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.wad-constants) 2 | 3 | (def THING_PLAYER1 0x001) 4 | (def THING_PINKY 3002) 5 | (def PINKY_RADIUS 30) 6 | (def PINKY_HEIGHT 56) 7 | 8 | (def THING_ZOMBIEMAN 3004) 9 | (def ZOMBIEMAN_RADIUS 20) 10 | (def ZOMBIEMAN_HEIGHT 56) 11 | 12 | (def THING_TELEPORTER 0x00E) 13 | (def SPECIAL_DR_DOOR 1) 14 | (def SPECIAL_WR_LIFT_ALSO_MONSTERS 88) 15 | (def SPECIAL_WR_TELEPORT 97) 16 | (def SPECIAL_S1_DOOR_STAY_OPEN_FAST 112) 17 | (def ML_BLOCKING 1) ;; block players and monsters 18 | (def ML_BLOCKMONSTERS 2) ;; block monsters only 19 | (def ML_DONTPEGBOTTOM 16) ;; 20 | -------------------------------------------------------------------------------- /src/doomcalc/write_primitives.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.write-primitives) 2 | 3 | ;; Takes an ASCII string, and returns a zero-padded sequence of bytes that's always n items long. 4 | (defn str->null-terminated-seq [n s] 5 | (let [s-seq (seq (.getBytes s "ascii"))] 6 | (take n (concat s-seq (repeat 0))))) 7 | 8 | 9 | (defn output-u8 [byte-out value] 10 | (assert (and (integer? value) 11 | (<= 0 value 255))) 12 | (byte-out value)) 13 | 14 | 15 | (defn output-u16 [byte-out value] 16 | (assert (and (integer? value) 17 | (<= 0 value 65535))) 18 | ;; little-endian 19 | (byte-out (bit-and value 255)) 20 | (byte-out (bit-shift-right value 8))) 21 | 22 | 23 | (defn output-s16 [byte-out value] 24 | (assert (and (integer? value) 25 | (<= -32768 value 32767))) 26 | ;; little-endian 27 | (byte-out (bit-and value 255)) 28 | (byte-out (bit-shift-right value 8))) 29 | 30 | 31 | (defn output-u32 [byte-out value] 32 | (assert (and (integer? value) 33 | (<= 0 value 0xFFFFFFFF))) 34 | ;; little-endian 35 | (byte-out (bit-and value 255)) 36 | (byte-out (bit-and (bit-shift-right value 8) 255)) 37 | (byte-out (bit-and (bit-shift-right value 16) 255)) 38 | (byte-out (bit-and (bit-shift-right value 24) 255))) 39 | 40 | 41 | (defn output-str8 [byte-out value] 42 | (assert (and (string? value) 43 | (<= (count value) 8))) 44 | (dorun (map byte-out (str->null-terminated-seq 8 value)))) 45 | 46 | 47 | (defn write-schema [schema records byte-out] 48 | (doseq [record records 49 | [type f] schema] 50 | (let [value (f record)] 51 | (when (nil? value) 52 | (throw (ex-info (str "Missing value in record") {:f f :schema schema}))) 53 | (case type 54 | :u8 (output-u8 byte-out value) 55 | :u16 (output-u16 byte-out value) 56 | :s16 (output-s16 byte-out value) 57 | :str8 (output-str8 byte-out value))))) 58 | -------------------------------------------------------------------------------- /src/doomcalc/write_pwad.clj: -------------------------------------------------------------------------------- 1 | (ns doomcalc.write-pwad 2 | (:require [doomcalc.write-primitives :as w])) 3 | 4 | (def things-schema 5 | [[:s16 :x] 6 | [:s16 :y] 7 | [:s16 :angle] 8 | [:u16 :type] 9 | ;; flags: all skill levels 10 | [:u16 (fn [_] 0x0007)]]) 11 | 12 | 13 | (def sectors-schema 14 | [[:s16 :floor-height] 15 | [:s16 :ceil-height] 16 | [:str8 :floor-tex] 17 | [:str8 :ceil-tex] 18 | [:u16 :light] 19 | ;; sector type (or "special") 20 | [:u16 (fn [_] 0)] 21 | [:u16 :tag]]) 22 | 23 | 24 | (def linedefs-schema 25 | [[:u16 :v1] 26 | [:u16 :v2] 27 | [:u16 :flags] 28 | [:u16 :special] 29 | [:u16 :sector-tag] 30 | [:u16 :front-sidedef] 31 | [:u16 :back-sidedef]]) 32 | 33 | 34 | (def sidedefs-schema 35 | [[:s16 :xoff] 36 | [:s16 :yoff] 37 | [:str8 :upper-tex] 38 | [:str8 :lower-tex] 39 | [:str8 :middle-tex] 40 | [:u16 :sector]]) 41 | 42 | 43 | (def vertexes-schema 44 | [[:s16 (fn [[x _]] x)] 45 | [:s16 (fn [[_ y]] y)]]) 46 | 47 | 48 | (defn write-schema-to-vec [schema records] 49 | (let [v (transient []) 50 | byte-out (fn [b] (conj! v (int b)))] 51 | (w/write-schema schema records byte-out) 52 | (persistent! v))) 53 | 54 | 55 | (defn write-pwad [byte-out {:keys [sectors vertexes sidedefs linedefs things]}] 56 | (let [lumps [["MAP01" []] ; map marker 57 | ["THINGS" (write-schema-to-vec things-schema things)] 58 | ["LINEDEFS" (write-schema-to-vec linedefs-schema linedefs)] 59 | ["SIDEDEFS" (write-schema-to-vec sidedefs-schema sidedefs)] 60 | ["VERTEXES" (write-schema-to-vec vertexes-schema vertexes)] 61 | ["SECTORS" (write-schema-to-vec sectors-schema sectors)]] 62 | 63 | total-lump-size (->> lumps 64 | (map second) 65 | (map count) 66 | (reduce +))] 67 | 68 | ;; Magic header 69 | (byte-out (int \P)) (byte-out (int \W)) (byte-out (int \A)) (byte-out (int \D)) 70 | 71 | ;; Number of lumps 72 | (w/output-u32 byte-out (count lumps)) 73 | 74 | ;; Directory offset 75 | (w/output-u32 byte-out (+ 12 total-lump-size)) 76 | 77 | ;; Lump data 78 | (doseq [[lump-name lump-data] lumps 79 | value lump-data] 80 | (byte-out value)) 81 | 82 | ;; Directory starts here 83 | (let [offset (atom 12)] 84 | (doseq [[lump-name lump-data] lumps] 85 | ;; location of lump data in file 86 | (w/output-u32 byte-out @offset) 87 | ;; size of lump data 88 | (w/output-u32 byte-out (count lump-data)) 89 | ;; name of lump 90 | (w/output-str8 byte-out lump-name) 91 | 92 | ;; increase offset 93 | (swap! offset #(+ % (count lump-data))))))) 94 | 95 | (defn spit-pwad [file-path data] 96 | (with-open [out-file (clojure.java.io/output-stream file-path)] 97 | (let [byte-out (fn [b] (.write out-file (int b)))] 98 | (write-pwad byte-out data)))) 99 | -------------------------------------------------------------------------------- /texpatch.wad: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nukep/doom-calculator/624e2f0abd791528828728d1203b333d5e03ac39/texpatch.wad --------------------------------------------------------------------------------