001 (ns ^{:doc "Experimental, probably of no interest to anyone else; attempt to
002 compute drainage on a world, assumed to have altitudes already set
003 from a heightmap."
004 :author "Simon Brooke"}
005 mw-engine.drainage
006 (:require [mw-engine.core :refer [run-world]]
007 [mw-engine.heightmap :as heightmap]
008 [mw-engine.utils :refer [get-int-or-zero get-least-cell get-neighbours
009 get-neighbours-with-property-value
010 map-world]]))
011
012 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
013 ;;;;
014 ;;;; mw-engine: the state/transition engine of MicroWorld.
015 ;;;;
016 ;;;; This program is free software; you can redistribute it and/or
017 ;;;; modify it under the terms of the GNU General Public License
018 ;;;; as published by the Free Software Foundation; either version 2
019 ;;;; of the License, or (at your option) any later version.
020 ;;;;
021 ;;;; This program is distributed in the hope that it will be useful,
022 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
023 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
024 ;;;; GNU General Public License for more details.
025 ;;;;
026 ;;;; You should have received a copy of the GNU General Public License
027 ;;;; along with this program; if not, write to the Free Software
028 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
029 ;;;; USA.
030 ;;;;
031 ;;;; Copyright (C) 2014 Simon Brooke
032 ;;;;
033 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
034
035
036 (def ^:dynamic *sealevel* 10)
037
038 ;; forward declaration of flow, to allow for a wee bit of mutual recursion.
039 (declare flow)
040
041 (defn rainfall
042 "Compute rainfall for a cell with this `gradient` west-east, given
043 `remaining` drops to distribute, and this overall map width."
044 [gradient remaining map-width]
045 (cond
046 ;; if there's no rain left in the cloud, it can't fall;
047 (zero? remaining)
048 0
049 (pos? gradient)
050 ;; rain, on prevailing westerly wind, falls preferentially on rising ground;
051 (int (rand gradient))
052 ;; rain falls randomly across the width of the map...
053 (zero? (int (rand map-width))) 1
054 :else
055 0))
056
057 (defn rain-row
058 "Return a row like this `row`, across which rainfall has been distributed;
059 if `rain-probability` is specified, it is the probable rainfall on a cell
060 with no gradient."
061 ([row]
062 (rain-row row 1))
063 ([row rain-probability]
064 (rain-row row (count row) 0 (int (* (count row) rain-probability))))
065 ([row map-width previous-altitude drops-in-cloud]
066 (cond
067 (empty? row) nil
068 (pos? drops-in-cloud)
069 (let [cell (first row)
070 alt (or (:altitude cell) 0)
071 rising (- alt previous-altitude)
072 fall (rainfall rising drops-in-cloud map-width)]
073 (cons
074 (assoc cell :rainfall fall)
075 (rain-row (rest row) map-width alt (- drops-in-cloud fall))))
076 :else
077 (map
078 #(assoc % :rainfall 0)
079 row))))
080
081
082 (defn rain-world
083 "Simulate rainfall on this `world`. TODO: Doesn't really work just now - should
084 rain more on west-facing slopes, and less to the east of high ground"
085 [world]
086 (map
087 rain-row
088 world))
089
090
091 (defn flow-contributors
092 "Return a list of the cells in this `world` which are higher than this
093 `cell` and for which this cell is the lowest neighbour, or which are at the
094 same altitude and have greater flow"
095 [cell world]
096 (filter #(map? %)
097 (map
098 (fn [n]
099 (cond
100 (= cell (get-least-cell (get-neighbours world n) :altitude)) n
101 (and (= (:altitude cell) (:altitude n))
102 (> (or (:flow n) 0) (or (:flow cell) 0))) n))
103 (get-neighbours-with-property-value
104 world (:x cell) (:y cell) 1 :altitude
105 (or (:altitude cell) 0) >=))))
106
107
108 (defn is-hollow
109 "Detects point hollows - that is, individual cells all of whose neighbours
110 are higher. Return true if this `cell` has an altitude lower than any of
111 its neighbours in this `world`"
112 [world cell]
113 ;; quicker to count the elements of the list and compare equality of numbers
114 ;; than recursive equality check on members, I think. But worth benchmarking.
115 (let [neighbours (get-neighbours world cell)
116 altitude (get-int-or-zero cell :altitude)]
117 (= (count neighbours)
118 (count (get-neighbours-with-property-value
119 world (:x cell) (:y cell) 1 :altitude altitude >)))))
120
121
122 (defn flood-hollow
123 "Raise the altitude of a copy of this `cell` of this `world` to the altitude
124 of the lowest of its `neighbours`."
125 ([_world cell neighbours]
126 (let [lowest (get-least-cell neighbours :altitude)]
127 (merge cell {:state :water :altitude (:altitude lowest)})))
128 ([world cell]
129 (flood-hollow world cell (get-neighbours world cell))))
130
131
132 (defn flood-hollows
133 "Flood all local hollows in this `world`. At this stage only floods single
134 cell hollows."
135 [world]
136 (map-world world
137 #(if (is-hollow %1 %2) (flood-hollow %1 %2) %2)))
138
139
140 (def max-altitude 255)
141
142 (defn flow-nr
143 "Experimental non recursive flow algorithm, needs to be run on a world as
144 many times as there are distinct altitude values. This algorithm works only
145 if applied sequentially from the highest altitude to the lowest, see
146 `flow-world-nr`."
147 [cell world]
148 (when (= (- max-altitude (get-int-or-zero cell :generation))
149 (get-int-or-zero cell :altitude))
150 (merge cell
151 {:flow (reduce +
152 (map
153 #(+ (get-int-or-zero % :rainfall)
154 (get-int-or-zero % :flow))
155 (flow-contributors cell world)))})))
156
157
158 (def flow
159 "Compute the total flow upstream of this `cell` in this `world`, and return a cell identical
160 to this one but having a value of its flow property set from that computation. The function is
161 memoised because the consequence of mapping a recursive function across an array is that many
162 cells will be revisited - potentially many times.
163
164 Flow comes from a higher cell to a lower only if the lower is the lowest neighbour of the higher."
165 (memoize
166 (fn [cell world]
167 (cond
168 (not (nil? (:flow cell))) cell
169 (<= (or (:altitude cell) 0) *sealevel*) cell
170 :else
171 (merge cell
172 {:flow (+ (:rainfall cell)
173 (apply +
174 (map (fn [neighbour] (:flow (flow neighbour world)))
175 (flow-contributors cell world))))})))))
176
177
178 (defn flow-world-nr
179 "Experimental non-recursive flow-world algorithm"
180 [world]
181 (run-world world nil (list flow-nr) max-altitude))
182
183 (defn flow-world
184 "Return a world like this `world`, but with cells tagged with the amount of
185 water flowing through them."
186 [world]
187 (map-world (rain-world world) flow))
188
189 (defn explore-lake
190 "Return a sequence of cells starting with this `cell` in this `world` which
191 form a contiguous lake"
192 [_world _cell]
193 )
194
195 (defn is-lake?
196 "If this `cell` in this `world` is not part of a lake, return nil. If it is,
197 return a cell like this `cell` tagged as part of a lake."
198 [world cell]
199 (if
200 ;; if it's already tagged as a lake, it's a lake
201 (:lake cell) cell
202 (let
203 [outflow (apply min (map :altitude (get-neighbours world cell)))]
204 (when-not
205 (> (:altitude cell) outflow)
206 (assoc cell :lake true)))))
207
208
209 (defn find-lakes
210 [_world]
211 )
212
213 (defn run-drainage
214 "Create a world from the heightmap `hmap`, rain on it, and then compute river
215 flows."
216 [hmap]
217 (flow-world (rain-world (flood-hollows (heightmap/apply-heightmap hmap)))))