(ns ^{:doc "Experimental, probably of no interest to anyone else; attempt to compute drainage on a world, assumed to have altitudes already set from a heightmap." :author "Simon Brooke"} mw-engine.drainage (:require [clojure.string :refer [replace]] [hiccup2.core :refer [html]] [mw-engine.core :refer [run-world]] [mw-engine.heightmap :refer [apply-heightmap]] [mw-engine.utils :refer [get-int-or-zero get-least-cell get-neighbours get-neighbours-with-property-value map-world]] [taoensso.timbre :refer [info]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; mw-engine: the state/transition engine of MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License ;;;; as published by the Free Software Foundation; either version 2 ;;;; of the License, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Copyright (C) 2014 Simon Brooke ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^:dynamic *sealevel* 10) ;; forward declaration of flow, to allow for a wee bit of mutual recursion. (declare flow) (defn rainfall "Compute rainfall for a cell with this `gradient` west-east, given `remaining` drops to distribute, and this overall map width." [gradient remaining map-width] (cond ;; if there's no rain left in the cloud, it can't fall; (zero? remaining) 0 (pos? gradient) ;; rain, on prevailing westerly wind, falls preferentially on rising ground; (int (rand gradient)) ;; rain falls randomly across the width of the map... (zero? (int (rand map-width))) 1 :else 0)) (defn rain-row "Return a row like this `row`, across which rainfall has been distributed; if `rain-probability` is specified, it is the probable rainfall on a cell with no gradient." ([row] (rain-row row 1)) ([row rain-probability] (rain-row row (count row) 0 (int (* (count row) rain-probability)))) ([row map-width previous-altitude drops-in-cloud] (cond (empty? row) nil (pos? drops-in-cloud) (let [cell (first row) alt (or (:altitude cell) 0) rising (- alt previous-altitude) fall (rainfall rising drops-in-cloud map-width)] (cons (assoc cell :rainfall fall) (rain-row (rest row) map-width alt (- drops-in-cloud fall)))) :else (map #(assoc % :rainfall 0) row)))) (defn rain-world "Simulate rainfall on this `world`. TODO: Doesn't really work just now - should rain more on west-facing slopes, and less to the east of high ground" [world] (info "rain-world started.") (let [w' (into [] (map #(apply vector (rain-row %)) world))] (info "rain-world completed") w')) (defn flow-contributors "Return a list of the cells in this `world` which are higher than this `cell` and for which this cell is the lowest neighbour, or which are at the same altitude and have greater flow" [cell world] (filter #(map? %) (map (fn [n] (cond (= cell (get-least-cell (get-neighbours world n) :altitude)) n (and (= (:altitude cell) (:altitude n)) (> (or (:flow n) 0) (or (:flow cell) 0))) n)) (get-neighbours-with-property-value world (:x cell) (:y cell) 1 :altitude (or (:altitude cell) 0) >=)))) (defn is-hollow "Detects point hollows - that is, individual cells all of whose neighbours are higher. Return true if this `cell` has an altitude lower than any of its neighbours in this `world`" [world cell] ;; quicker to count the elements of the list and compare equality of numbers ;; than recursive equality check on members, I think. But worth benchmarking. (let [neighbours (get-neighbours world cell) altitude (get-int-or-zero cell :altitude)] (= (count neighbours) (count (get-neighbours-with-property-value world (:x cell) (:y cell) 1 :altitude altitude >))))) (defn flood-hollow "Raise the altitude of a copy of this `cell` of this `world` to the altitude of the lowest of its `neighbours`." ([_world cell neighbours] (let [lowest (get-least-cell neighbours :altitude)] (merge cell {:state :water :altitude (:altitude lowest)}))) ([world cell] (flood-hollow world cell (get-neighbours world cell)))) (defn flood-hollows "Flood all local hollows in this `world`. At this stage only floods single cell hollows." [world] (info "flood-hollows started.") (let [w' (map-world world #(if (is-hollow %1 %2) (flood-hollow %1 %2) %2))] (info "flood-hollows completed") w')) (def max-altitude 255) (defn flow-nr "Experimental non recursive flow algorithm, needs to be run on a world as many times as there are distinct altitude values. This algorithm works only if applied sequentially from the highest altitude to the lowest, see `flow-world-nr`." [cell world] (when (= (- max-altitude (get-int-or-zero cell :generation)) (get-int-or-zero cell :altitude)) (let [contributors (flow-contributors cell world)] (when contributors (merge cell {:flow (reduce + (map #(+ (get-int-or-zero % :rainfall) (get-int-or-zero % :flow)) contributors))}))))) (def flow "Compute the total flow upstream of this `cell` in this `world`, and return a cell identical to this one but having a value of its flow property set from that computation. The function is memoised because the consequence of mapping a recursive function across an array is that many cells will be revisited - potentially many times. Flow comes from a higher cell to a lower only if the lower is the lowest neighbour of the higher." (memoize (fn [cell world] (cond (not (nil? (:flow cell))) cell (<= (or (:altitude cell) 0) *sealevel*) cell :else (merge cell {:flow (+ (:rainfall cell) (apply + (map (fn [neighbour] (:flow (flow neighbour world))) (flow-contributors cell world))))}))))) (defn flow-world-nr "Experimental non-recursive flow-world algorithm" [world] (info "Non recursive flow-world started.") (let [w' (run-world world (list (vary-meta flow-nr assoc :rule-type :ad-hoc)) max-altitude)] (info "Non recursive flow-world completed") w')) (defn flow-world "Return a world like this `world`, but with cells tagged with the amount of water flowing through them." [world] (info "Recursive flow-world started.") (let [w' (map-world (rain-world world) flow)] (info "Recursive flow-world completed") w')) (defn explore-lake "Return a sequence of cells starting with this `cell` in this `world` which form a contiguous lake" [_world _cell]) (defn is-lake? "If this `cell` in this `world` is not part of a lake, return nil. If it is, return a cell like this `cell` tagged as part of a lake." [world cell] (cond ;; if it's already tagged as a lake, it's a lake (:lake cell) cell (#{:lake :sea :water} (:state cell)) cell ;; if it's already tagged as ;; wet, no need for change (and (integer? (:x cell)) (integer? (:y cell))) (let [outflow (apply min (map :altitude (get-neighbours world cell)))] (when-not (> (:altitude cell) outflow) (do (info (format "tagging cell at %d, %d as lake" (:x cell) (:y cell))) (assoc cell :lake true :state :lake)))) :else (throw (ex-info "Invalid cell?" {:cell cell})))) (defn identify-lake [world cell] (or (is-lake? world cell) cell)) (defn find-lakes "Identify cells in this `world` which are lakes." [world] (info "find-lakes started.") (let [w' (map-world world identify-lake)] (info "find-lakes completed.") w')) (defn run-drainage "Create a world from the heightmap `hmap`, rain on it, and then compute river flows." [hmap] (find-lakes (flow-world-nr (rain-world (flood-hollows (apply-heightmap hmap)))))) (defn visualise-drainage [world html-file] (let [mxf (apply max (map :flow (flatten world))) scf (/ 128 mxf) mxa (apply max (map :altitude (flatten world))) sca (/ 128 mxa)] (spit html-file (replace (str (html [:html [:head [:title "Drainage visualisation"] [:style "table, table tr td { padding: 0.5em; margin: 0.2em; width: 2em; height: 2em; border-collapse: collapse; border: none;}"]] [:body (into [:table] (map #(into [:tr] (map (fn [c] (let [g (- 255 (int (* sca (:altitude c))))] [:td {:style (if (> (:altitude c) 1) (let [blue (int (* scf (or (:flow c) 0))) o (- g blue)] (format "background-color: rgb(%d, %d, %d)" o o (+ g blue))) "background-color: cornflower-blue") :title (format "state %s, x %d, y %d, rainfall %d, flow %d" (:state c) (:x c) (:y c) (:rainfall c) (:flow c))} (or (:rainfall c) " ")])) %)) world))]])) "&" "&")))) (visualise-drainage (run-drainage "resources/heightmaps/20x20/crucible.png") "test.html")