THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.
36 | 37 |1. DEFINITIONS
38 | 39 |"Contribution" means:
40 | 41 |a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and
43 |b) in the case of each subsequent Contributor:
44 |i) changes to the Program, and
45 |ii) additions to the Program;
46 |where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.
54 | 55 |"Contributor" means any person or entity that distributes 56 | the Program.
57 | 58 |"Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.
61 | 62 |"Program" means the Contributions distributed in accordance 63 | with this Agreement.
64 | 65 |"Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.
67 | 68 |2. GRANT OF RIGHTS
69 | 70 |a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.
76 | 77 |b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.
88 | 89 |c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.
101 | 102 |d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.
105 | 106 |3. REQUIREMENTS
107 | 108 |A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:
110 | 111 |a) it complies with the terms and conditions of this 112 | Agreement; and
113 | 114 |b) its license agreement:
115 | 116 |i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;
120 | 121 |ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;
124 | 125 |iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and
128 | 129 |iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.
133 | 134 |When the Program is made available in source code form:
135 | 136 |a) it must be made available under this Agreement; and
137 | 138 |b) a copy of this Agreement must be included with each 139 | copy of the Program.
140 | 141 |Contributors may not remove or alter any copyright notices contained 142 | within the Program.
143 | 144 |Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.
147 | 148 |4. COMMERCIAL DISTRIBUTION
149 | 150 |Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.
172 | 173 |For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.
183 | 184 |5. NO WARRANTY
185 | 186 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.
197 | 198 |6. DISCLAIMER OF LIABILITY
199 | 200 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
208 | 209 |7. GENERAL
210 | 211 |If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.
216 | 217 |If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.
223 | 224 |All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.
232 | 233 |Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.
252 | 253 |This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.
258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /src/examples/clojure/examples/monads.clj: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;; 4 | ;; Monad application examples 5 | ;; 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | 9 | (ns 10 | #^{:author "Konrad Hinsen" 11 | :skip-wiki true 12 | :doc "Examples for using monads"} 13 | examples.monads 14 | (:use [clojure.algo.monads 15 | :only (domonad with-monad m-lift m-seq m-reduce m-when 16 | sequence-m 17 | maybe-m 18 | state-m fetch-state set-state 19 | writer-m write 20 | cont-m run-cont call-cc 21 | maybe-t)])) 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;; 25 | ;; Sequence manipulations with the sequence monad 26 | ;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | ; Note: in the Haskell world, this monad is called the list monad. 30 | ; The Clojure equivalent to Haskell's lists are (possibly lazy) 31 | ; sequences. This is why I call this monad "sequence". All sequences 32 | ; created by sequence monad operations are lazy. 33 | 34 | ; Monad comprehensions in the sequence monad work exactly the same 35 | ; as Clojure's 'for' construct, except that :while clauses are not 36 | ; available. 37 | (domonad sequence-m 38 | [x (range 5) 39 | y (range 3)] 40 | (+ x y)) 41 | 42 | ; Inside a with-monad block, domonad is used without the monad name. 43 | (with-monad sequence-m 44 | (domonad 45 | [x (range 5) 46 | y (range 3)] 47 | (+ x y))) 48 | 49 | ; Conditions are written with :when, as in Clojure's for form: 50 | (domonad sequence-m 51 | [x (range 5) 52 | y (range (+ 1 x)) 53 | :when (= (+ x y) 2)] 54 | (list x y)) 55 | 56 | ; :let is also supported like in for: 57 | (domonad sequence-m 58 | [x (range 5) 59 | y (range (+ 1 x)) 60 | :let [sum (+ x y) 61 | diff (- x y)] 62 | :when (= sum 2)] 63 | (list diff)) 64 | 65 | ; An example of a sequence function defined in terms of a lift operation. 66 | (with-monad sequence-m 67 | (defn pairs [xs] 68 | ((m-lift 2 #(list %1 %2)) xs xs))) 69 | 70 | (pairs (range 5)) 71 | 72 | ; Another way to define pairs is through the m-seq operation. It takes 73 | ; a sequence of monadic values and returns a monadic value containing 74 | ; the sequence of the underlying values, obtained from chaining together 75 | ; from left to right the monadic values in the sequence. 76 | (with-monad sequence-m 77 | (defn pairs [xs] 78 | (m-seq (list xs xs)))) 79 | 80 | (pairs (range 5)) 81 | 82 | ; This definition suggests a generalization: 83 | (with-monad sequence-m 84 | (defn ntuples [n xs] 85 | (m-seq (repeat n xs)))) 86 | 87 | (ntuples 2 (range 5)) 88 | (ntuples 3 (range 5)) 89 | 90 | ; Lift operations can also be used inside a monad comprehension: 91 | (domonad sequence-m 92 | [x ((m-lift 1 (partial * 2)) (range 5)) 93 | y (range 2)] 94 | [x y]) 95 | 96 | ; The m-plus operation does concatenation in the sequence monad. 97 | (domonad sequence-m 98 | [x ((m-lift 2 +) (range 5) (range 3)) 99 | y (m-plus (range 2) '(10 11))] 100 | [x y]) 101 | 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;; 105 | ;; Handling failures with the maybe monad 106 | ;; 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | ; Maybe monad versions of basic arithmetic 110 | (with-monad maybe-m 111 | (def m+ (m-lift 2 +)) 112 | (def m- (m-lift 2 -)) 113 | (def m* (m-lift 2 *))) 114 | 115 | ; Division is special for two reasons: we can't call it m/ because that's 116 | ; not a legal Clojure symbol, and we want it to fail if a division by zero 117 | ; is attempted. It is best defined by a monad comprehension with a 118 | ; :when clause: 119 | (defn safe-div [x y] 120 | (domonad maybe-m 121 | [a x 122 | b y 123 | :when (not (zero? b))] 124 | (/ a b))) 125 | 126 | ; Now do some non-trivial computation with division 127 | ; It fails for (1) x = 0, (2) y = 0 or (3) y = -x. 128 | (with-monad maybe-m 129 | (defn some-function [x y] 130 | (let [one (m-result 1)] 131 | (safe-div one (m+ (safe-div one (m-result x)) 132 | (safe-div one (m-result y))))))) 133 | 134 | ; An example that doesn't fail: 135 | (some-function 2 3) 136 | ; And two that do fail, at different places: 137 | (some-function 2 0) 138 | (some-function 2 -2) 139 | 140 | ; In the maybe monad, m-plus selects the first monadic value that 141 | ; holds a valid value. 142 | (with-monad maybe-m 143 | (m-plus (some-function 2 0) (some-function 2 -2) (some-function 2 3))) 144 | 145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 146 | ;; 147 | ;; Random numbers with the state monad 148 | ;; 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | ; A state monad item represents a computation that changes a state and 152 | ; returns a value. Its structure is a function that takes a state argument 153 | ; and returns a two-item list containing the value and the updated state. 154 | ; It is important to realize that everything you put into a state monad 155 | ; expression is a state monad item (thus a function), and everything you 156 | ; get out as well. A state monad does not perform a calculation, it 157 | ; constructs a function that does the computation when called. 158 | 159 | ; First, we define a simple random number generator with explicit state. 160 | ; rng is a function of its state (an integer) that returns the 161 | ; pseudo-random value derived from this state and the updated state 162 | ; for the next iteration. This is exactly the structure of a state 163 | ; monad item. 164 | (defn rng [seed] 165 | (let [m 259200 166 | value (/ (float seed) (float m)) 167 | next (rem (+ 54773 (* 7141 seed)) m)] 168 | [value next])) 169 | 170 | ; We define a convenience function that creates an infinite lazy seq 171 | ; of values obtained from iteratively applying a state monad value. 172 | (defn value-seq [f seed] 173 | (lazy-seq 174 | (let [[value next] (f seed)] 175 | (cons value (value-seq f next))))) 176 | 177 | ; Next, we define basic statistics functions to check our random numbers 178 | (defn sum [xs] (apply + xs)) 179 | (defn mean [xs] (/ (sum xs) (count xs))) 180 | (defn variance [xs] 181 | (let [m (mean xs) 182 | sq #(* % %)] 183 | (mean (for [x xs] (sq (- x m)))))) 184 | 185 | ; rng implements a uniform distribution in the interval [0., 1.), so 186 | ; ideally, the mean would be 1/2 (0.5) and the variance 1/12 (0.08333). 187 | (mean (take 1000 (value-seq rng 1))) 188 | (variance (take 1000 (value-seq rng 1))) 189 | 190 | ; We make use of the state monad to implement a simple (but often sufficient) 191 | ; approximation to a Gaussian distribution: the sum of 12 random numbers 192 | ; from rng's distribution, shifted by -6, has a distribution that is 193 | ; approximately Gaussian with 0 mean and variance 1, by virtue of the central 194 | ; limit theorem. 195 | ; In the first version, we call rng 12 times explicitly and calculate the 196 | ; shifted sum in a monad comprehension: 197 | (def gaussian1 198 | (domonad state-m 199 | [x1 rng 200 | x2 rng 201 | x3 rng 202 | x4 rng 203 | x5 rng 204 | x6 rng 205 | x7 rng 206 | x8 rng 207 | x9 rng 208 | x10 rng 209 | x11 rng 210 | x12 rng] 211 | (- (+ x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) 6.))) 212 | 213 | ; Let's test it: 214 | (mean (take 1000 (value-seq gaussian1 1))) 215 | (variance (take 1000 (value-seq gaussian1 1))) 216 | 217 | ; Of course, we'd rather have a loop construct for creating the 12 218 | ; random numbers. This would be easy if we could define a summation 219 | ; operation on random-number generators, which would then be used in 220 | ; combination with reduce. The lift operation gives us exactly that. 221 | ; More precisely, we need (m-lift 2 +), because we want both arguments 222 | ; of + to be lifted to the state monad: 223 | (def gaussian2 224 | (domonad state-m 225 | [sum12 (reduce (m-lift 2 +) (repeat 12 rng))] 226 | (- sum12 6.))) 227 | 228 | ; Such a reduction is often quite useful, so there's m-reduce predefined 229 | ; to simplify it: 230 | (def gaussian2 231 | (domonad state-m 232 | [sum12 (m-reduce + (repeat 12 rng))] 233 | (- sum12 6.))) 234 | 235 | ; The statistics should be strictly the same as above, as long as 236 | ; we use the same seed: 237 | (mean (take 1000 (value-seq gaussian2 1))) 238 | (variance (take 1000 (value-seq gaussian2 1))) 239 | 240 | ; We can also do the subtraction of 6 in a lifted function, and get rid 241 | ; of the monad comprehension altogether: 242 | (with-monad state-m 243 | (def gaussian3 244 | ((m-lift 1 #(- % 6.)) 245 | (m-reduce + (repeat 12 rng))))) 246 | 247 | ; Again, the statistics are the same: 248 | (mean (take 1000 (value-seq gaussian3 1))) 249 | (variance (take 1000 (value-seq gaussian3 1))) 250 | 251 | ; For a random point in two dimensions, we'd like a random number generator 252 | ; that yields a list of two random numbers. The m-seq operation can easily 253 | ; provide it: 254 | (with-monad state-m 255 | (def rng2 (m-seq (list rng rng)))) 256 | 257 | ; Let's test it: 258 | (rng2 1) 259 | 260 | ; fetch-state and get-state can be used to save the seed of the random 261 | ; number generator and go back to that saved seed later on: 262 | (def identical-random-seqs 263 | (domonad state-m 264 | [seed (fetch-state) 265 | x1 rng 266 | x2 rng 267 | _ (set-state seed) 268 | y1 rng 269 | y2 rng] 270 | (list [x1 x2] [y1 y2]))) 271 | 272 | (identical-random-seqs 1) 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | ;; 276 | ;; Logging with the writer monad 277 | ;; 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | 280 | ; A basic logging example 281 | (domonad (writer-m "") 282 | [x (m-result 1) 283 | _ (write "first step\n") 284 | y (m-result 2) 285 | _ (write "second step\n")] 286 | (+ x y)) 287 | 288 | ; For a more elaborate application, let's trace the recursive calls of 289 | ; a naive implementation of a Fibonacci function. The starting point 290 | ; is: 291 | 292 | (defn fib [n] 293 | (if (< n 2) 294 | n 295 | (let [n1 (dec n) 296 | n2 (dec n1)] 297 | (+ (fib n1) (fib n2))))) 298 | 299 | ; First we rewrite it to make every computational step explicit 300 | ; in a let expression: 301 | 302 | (defn fib [n] 303 | (if (< n 2) 304 | n 305 | (let [n1 (dec n) 306 | n2 (dec n1) 307 | f1 (fib n1) 308 | f2 (fib n2)] 309 | (+ f1 f2)))) 310 | 311 | ; Next, we replace the let by a domonad in a writer monad that uses a 312 | ; vector accumulator. We can then place calls to write in between the 313 | ; steps, and obtain as a result both the return value of the function 314 | ; and the accumulated trace values. 315 | 316 | (with-monad (writer-m []) 317 | 318 | (defn fib-trace [n] 319 | (if (< n 2) 320 | (m-result n) 321 | (domonad 322 | [n1 (m-result (dec n)) 323 | n2 (m-result (dec n1)) 324 | f1 (fib-trace n1) 325 | _ (write [n1 f1]) 326 | f2 (fib-trace n2) 327 | _ (write [n2 f2]) 328 | ] 329 | (+ f1 f2)))) 330 | 331 | ) 332 | 333 | (fib-trace 5) 334 | 335 | 336 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 337 | ;; 338 | ;; Sequences with undefined value: the maybe-t monad transformer 339 | ;; 340 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 341 | 342 | ; A monad transformer is a function that takes a monad argument and 343 | ; returns a monad as its result. The resulting monad adds some 344 | ; specific behaviour aspect to the input monad. 345 | 346 | ; The simplest monad transformer is maybe-t. It adds the functionality 347 | ; of the maybe monad (handling failures or undefined values) to any other 348 | ; monad. We illustrate this by applying maybe-t to the sequence monad. 349 | ; The result is an enhanced sequence monad in which undefined values 350 | ; (represented by nil) are not subjected to any transformation, but 351 | ; lead immediately to a nil result in the output. 352 | 353 | ; First we define the combined monad: 354 | (def seq-maybe-m (maybe-t sequence-m)) 355 | 356 | ; As a first illustration, we create a range of integers and replace 357 | ; all even values by nil, using a simple when expression. We use this 358 | ; sequence in a monad comprehension that yields (inc x). The result 359 | ; is a sequence in which inc has been applied to all non-nil values, 360 | ; whereas the nil values appear unmodified in the output: 361 | (domonad seq-maybe-m 362 | [x (for [n (range 10)] (when (odd? n) n))] 363 | (inc x)) 364 | 365 | ; Next we repeat the definition of the function pairs (see above), but 366 | ; using the seq-maybe monad: 367 | (with-monad seq-maybe-m 368 | (defn pairs-maybe [xs] 369 | (m-seq (list xs xs)))) 370 | 371 | ; Applying this to a sequence containing nils yields the pairs of all 372 | ; non-nil values interspersed with nils that result from any combination 373 | ; in which one or both of the values is nil: 374 | (pairs-maybe (for [n (range 5)] (when (odd? n) n))) 375 | 376 | ; It is important to realize that undefined values (nil) are not eliminated 377 | ; from the iterations. They are simply not passed on to any operations. 378 | ; The outcome of any function applied to arguments of which at least one 379 | ; is nil is supposed to be nil as well, and the function is never called. 380 | 381 | 382 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 383 | ;; 384 | ;; Continuation-passing style in the cont monad 385 | ;; 386 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 387 | 388 | ; A simple computation performed in continuation-passing style. 389 | ; (m-result 1) returns a function that, when called with a single 390 | ; argument f, calls (f 1). The result of the domonad-computation is 391 | ; a function that behaves in the same way, passing 3 to its function 392 | ; argument. run-cont executes a continuation by calling it on identity. 393 | (run-cont 394 | (domonad cont-m 395 | [x (m-result 1) 396 | y (m-result 2)] 397 | (+ x y))) 398 | 399 | ; Let's capture a continuation using call-cc. We store it in a global 400 | ; variable so that we can do with it whatever we want. The computation 401 | ; is the same one as in the first example, but it has the side effect 402 | ; of storing the continuation at (m-result 2). 403 | (def continuation nil) 404 | 405 | (run-cont 406 | (domonad cont-m 407 | [x (m-result 1) 408 | y (call-cc (fn [c] (def continuation c) (c 2)))] 409 | (+ x y))) 410 | 411 | ; Now we can call the continuation with whatever argument we want. The 412 | ; supplied argument takes the place of 2 in the above computation: 413 | (run-cont (continuation 5)) 414 | (run-cont (continuation 42)) 415 | (run-cont (continuation -1)) 416 | 417 | ; Next, a function that illustrates how a captured continuation can be 418 | ; used as an "emergency exit" out of a computation: 419 | (defn sqrt-as-str [x] 420 | (call-cc 421 | (fn [k] 422 | (domonad cont-m 423 | [_ (m-when (< x 0) (k (str "negative argument " x)))] 424 | (str (. Math sqrt x)))))) 425 | 426 | (run-cont (sqrt-as-str 2)) 427 | (run-cont (sqrt-as-str -2)) 428 | 429 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 430 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/algo/monads.clj: -------------------------------------------------------------------------------- 1 | ;; Monads in Clojure 2 | 3 | ;; Copyright (c) Konrad Hinsen, 2011. All rights reserved. The use 4 | ;; and distribution terms for this software are covered by the Eclipse 5 | ;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 6 | ;; which can be found in the file epl-v10.html at the root of this 7 | ;; distribution. By using this software in any fashion, you are 8 | ;; agreeing to be bound by the terms of this license. You must not 9 | ;; remove this notice, or any other, from this software. 10 | 11 | (ns 12 | ^{:author "Konrad Hinsen" 13 | :see-also [["https://github.com/khinsen/monads-in-clojure/blob/master/PART1.md" "Monad tutorial part 1"] 14 | ["https://github.com/khinsen/monads-in-clojure/blob/master/PART2.md" "Monad tutorial part 2"] 15 | ["https://github.com/khinsen/monads-in-clojure/blob/master/PART3.md" "Monad tutorial part 3"] 16 | ["https://github.com/khinsen/monads-in-clojure/blob/master/PART4.md" "Monad tutorial part 4"] 17 | ["http://www.clojure.net/tags.html#monads-ref" "Blog posts on monads in Clojure"]] 18 | :doc "This library contains the most commonly used monads as well 19 | as macros for defining and using monads and useful monadic 20 | functions."} 21 | clojure.algo.monads 22 | (:require [clojure.set]) 23 | (:use [clojure.tools.macro 24 | :only (with-symbol-macros defsymbolmacro name-with-attributes)])) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;; 28 | ;; Defining monads 29 | ;; 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | (defmacro monad 33 | "Define a monad by defining the monad operations. The definitions 34 | are written like bindings to the monad operations m-bind and 35 | m-result (required) and m-zero and m-plus (optional)." 36 | [operations] 37 | `(let [~'m-bind ::this-monad-does-not-define-m-bind 38 | ~'m-result ::this-monad-does-not-define-m-result 39 | ~'m-zero ::this-monad-does-not-define-m-zero 40 | ~'m-plus ::this-monad-does-not-define-m-plus 41 | ~@operations] 42 | {:m-result ~'m-result 43 | :m-bind ~'m-bind 44 | :m-zero ~'m-zero 45 | :m-plus ~'m-plus})) 46 | 47 | (defmacro defmonad 48 | "Define a named monad by defining the monad operations. The definitions 49 | are written like bindings to the monad operations m-bind and 50 | m-result (required) and m-zero and m-plus (optional)." 51 | 52 | ([name doc-string operations] 53 | (let [doc-name (with-meta name {:doc doc-string})] 54 | `(defmonad ~doc-name ~operations))) 55 | 56 | ([name operations] 57 | `(def ~name (monad ~operations)))) 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | ;; 62 | ;; Using monads 63 | ;; 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | 66 | (defn- ensure-items [n steps] 67 | "Ensures there are at least n elements on a list, will fill up with nil 68 | values when list is not big enough." 69 | (take n (concat steps (repeat nil)))) 70 | 71 | (defn- each3-steps [steps] 72 | "Transforms a list in a list of triples following the form: 73 | [a b c] => [[a b c] [b c nil] [c nil nil]]." 74 | (let [n (count steps)] 75 | (map vector (ensure-items n steps) 76 | (ensure-items n (rest steps)) 77 | (ensure-items n (rest (rest steps)))))) 78 | 79 | (def ^:private prepare-monadic-steps 80 | #(->> % (partition 2) reverse each3-steps)) 81 | 82 | (defn- if-then-else-statement 83 | "Process an :if :then :else steps when adding a new 84 | monadic step to the mexpr." 85 | [[[_ else-mexpr] 86 | [then-bform then-mexpr] 87 | [if-bform if-conditional]] mexpr continuation] 88 | (cond 89 | (and (identical? then-bform :then) 90 | (identical? if-bform :if)) 91 | `(if ~if-conditional 92 | ~(reduce continuation 93 | mexpr 94 | (prepare-monadic-steps then-mexpr)) 95 | ~(reduce continuation 96 | mexpr 97 | (prepare-monadic-steps else-mexpr))) 98 | :else 99 | (throw (Exception. "invalid :if without :then and :else")))) 100 | 101 | (defn- merge-cond-branches [cond-branches] 102 | (let [merger (fn [result cond-branch] 103 | (-> result 104 | (conj (first cond-branch)) 105 | (conj (second cond-branch))))] 106 | (reduce merger [] cond-branches))) 107 | 108 | (defn cond-statement 109 | "Process a :cond steps when adding a new monadic step to the mexpr." 110 | [expr mexpr continuation] 111 | (let [cond-sexps (partition 2 expr) 112 | result (for [[cond-sexp monadic-sexp] cond-sexps] 113 | (list cond-sexp 114 | (reduce continuation 115 | mexpr 116 | (prepare-monadic-steps monadic-sexp))))] 117 | `(cond ~@(merge-cond-branches result)))) 118 | 119 | (defn- add-monad-step 120 | "Add a monad comprehension step before the already transformed 121 | monad comprehension expression mexpr." 122 | [mexpr steps] 123 | (let [[[bform expr :as step] & _] steps] 124 | (cond 125 | (identical? bform :when) `(if ~expr ~mexpr ~'m-zero) 126 | (identical? bform :let) `(let ~expr ~mexpr) 127 | (identical? bform :cond) (cond-statement expr mexpr add-monad-step) 128 | (identical? bform :then) mexpr 129 | ; ^ ignore :then step (processed on the :else step) 130 | (identical? bform :if) mexpr 131 | ; ^ ignore :if step (processed on the :else step) 132 | (identical? bform :else) 133 | (if-then-else-statement steps mexpr add-monad-step) 134 | :else 135 | (list 'm-bind expr (list 'fn [bform] mexpr))))) 136 | 137 | (defn- monad-expr 138 | "Transforms a monad comprehension, consisting of a list of steps 139 | and an expression defining the final value, into an expression 140 | chaining together the steps using :bind and returning the final value 141 | using :result. The steps are given as a vector of 142 | binding-variable/monadic-expression pairs." 143 | [steps expr] 144 | (when (odd? (count steps)) 145 | (throw (Exception. "Odd number of elements in monad comprehension steps"))) 146 | 147 | (let [rsteps (prepare-monadic-steps steps) 148 | [[lr ls] & _] (first rsteps)] 149 | (if (= lr expr) 150 | ; Optimization: if the result expression is equal to the result 151 | ; of the last computation step, we can eliminate an m-bind to 152 | ; m-result. 153 | (reduce add-monad-step 154 | ls 155 | (rest rsteps)) 156 | ; The general case. 157 | (reduce add-monad-step 158 | (list 'm-result expr) 159 | rsteps)))) 160 | 161 | (defmacro with-monad 162 | "Evaluates an expression after replacing the keywords defining the 163 | monad operations by the functions associated with these keywords 164 | in the monad definition given by name." 165 | [monad & exprs] 166 | `(let [name# ~monad 167 | ~'m-bind (:m-bind name#) 168 | ~'m-result (:m-result name#) 169 | ~'m-zero (:m-zero name#) 170 | ~'m-plus (:m-plus name#)] 171 | (with-symbol-macros ~@exprs))) 172 | 173 | (defmacro domonad 174 | "Monad comprehension. Takes the name of a monad, a vector of steps 175 | given as binding-form/monadic-expression pairs, and a result value 176 | specified by expr. The monadic-expression terms can use the binding 177 | variables of the previous steps. 178 | If the monad contains a definition of m-zero, the step list can also 179 | contain conditions of the form :when p, where the predicate p can 180 | contain the binding variables from all previous steps. 181 | A clause of the form :let [binding-form expr ...], where the bindings 182 | are given as a vector as for the use in let, establishes additional 183 | bindings that can be used in the following steps." 184 | ([steps expr] 185 | (monad-expr steps expr)) 186 | ([name steps expr] 187 | (let [mexpr (monad-expr steps expr)] 188 | `(with-monad ~name ~mexpr)))) 189 | 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | ;; 192 | ;; Defining functions used with monads 193 | ;; 194 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 195 | 196 | (defmacro defmonadfn 197 | "Like defn, but for functions that use monad operations and are used inside 198 | a with-monad block." 199 | {:arglists '([name docstring? attr-map? args expr] 200 | [name docstring? attr-map? (args expr) ...])} 201 | [name & options] 202 | (let [[name options] (name-with-attributes name options) 203 | fn-name (format "m+%s+m" (str name)) 204 | fn-sym (symbol fn-name) 205 | full-sym (symbol (str *ns*) fn-name) 206 | make-fn-body (fn [args expr] 207 | (list (vec (concat ['m-bind 'm-result 208 | 'm-zero 'm-plus] args)) 209 | (list `with-symbol-macros expr)))] 210 | (if (list? (first options)) 211 | ; multiple arities 212 | (let [arglists (map first options) 213 | exprs (map second options) 214 | ] 215 | `(do 216 | (defsymbolmacro ~name (partial ~full-sym ~'m-bind ~'m-result 217 | ~'m-zero ~'m-plus)) 218 | (defn ~fn-sym ~@(map make-fn-body arglists exprs)))) 219 | ; single arity 220 | (let [[args expr] options] 221 | `(do 222 | (defsymbolmacro ~name (partial ~full-sym ~'m-bind ~'m-result 223 | ~'m-zero ~'m-plus)) 224 | (defn ~fn-sym ~@(make-fn-body args expr))))))) 225 | 226 | 227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | ;; 229 | ;; Commonly used monad functions 230 | ;; 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | 233 | ; Define the four basic monad operations as symbol macros that 234 | ; expand to their unqualified symbol equivalents. This makes it possible 235 | ; to use them inside macro templates without having to quote them. 236 | (defsymbolmacro m-result m-result) 237 | (defsymbolmacro m-bind m-bind) 238 | (defsymbolmacro m-zero m-zero) 239 | (defsymbolmacro m-plus m-plus) 240 | 241 | (defmacro m-lift 242 | "Converts a function f of n arguments into a function of n 243 | monadic arguments returning a monadic value." 244 | [n f] 245 | (let [expr (take n (repeatedly #(gensym "x_"))) 246 | vars (vec (take n (repeatedly #(gensym "mv_")))) 247 | steps (vec (interleave expr vars))] 248 | (list `fn vars (monad-expr steps (cons f expr))))) 249 | 250 | (defmonadfn m-join 251 | "Converts a monadic value containing a monadic value into a 'simple' 252 | monadic value." 253 | [m] 254 | (m-bind m identity)) 255 | 256 | (defmonadfn m-fmap 257 | "Bind the monadic value m to the function returning (f x) for argument x" 258 | [f m] 259 | (m-bind m (fn [x] (m-result (f x))))) 260 | 261 | (defmonadfn m-seq 262 | "'Executes' the monadic values in ms and returns a sequence of the 263 | basic values contained in them." 264 | [ms] 265 | (reduce (fn [q p] 266 | (m-bind p (fn [x] 267 | (m-bind q (fn [y] 268 | (m-result (cons x y)))) ))) 269 | (m-result '()) 270 | (reverse ms))) 271 | 272 | (defmonadfn m-map 273 | "'Executes' the sequence of monadic values resulting from mapping 274 | f onto the values xs. f must return a monadic value." 275 | [f xs] 276 | (m-seq (map f xs))) 277 | 278 | (defmonadfn m-chain 279 | "Chains together monadic computation steps that are each functions 280 | of one parameter. Each step is called with the result of the previous 281 | step as its argument. (m-chain (step1 step2)) is equivalent to 282 | (fn [x] (domonad [r1 (step1 x) r2 (step2 r1)] r2))." 283 | [steps] 284 | (reduce (fn m-chain-link [chain-expr step] 285 | (fn [v] (m-bind (chain-expr v) step))) 286 | m-result 287 | steps)) 288 | 289 | (defmonadfn m-reduce 290 | "Return the reduction of (m-lift 2 f) over the list of monadic values mvs 291 | with initial value (m-result val)." 292 | ([f mvs] 293 | (if (empty? mvs) 294 | (m-result (f)) 295 | (let [m-f (m-lift 2 f)] 296 | (reduce m-f mvs)))) 297 | ([f val mvs] 298 | (let [m-f (m-lift 2 f) 299 | m-val (m-result val)] 300 | (reduce m-f m-val mvs)))) 301 | 302 | (defmonadfn m-until 303 | "While (p x) is false, replace x by the value returned by the 304 | monadic computation (f x). Return (m-result x) for the first 305 | x for which (p x) is true." 306 | [p f x] 307 | (if (p x) 308 | (m-result x) 309 | (domonad 310 | [y (f x) 311 | z (m-until p f y)] 312 | z))) 313 | 314 | (defmacro m-when 315 | "If test is logical true, return monadic value m-expr, else return 316 | (m-result nil)." 317 | [test m-expr] 318 | `(if ~test ~m-expr (~'m-result nil))) 319 | 320 | (defmacro m-when-not 321 | "If test if logical false, return monadic value m-expr, else return 322 | (m-result nil)." 323 | [test m-expr] 324 | `(if ~test (~'m-result nil) ~m-expr)) 325 | 326 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 327 | ;; 328 | ;; Utility functions used in monad definitions 329 | ;; 330 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331 | 332 | (defn- flatten* 333 | "Like #(apply concat %), but fully lazy: it evaluates each sublist 334 | only when it is needed." 335 | [ss] 336 | (lazy-seq 337 | (when-let [s (seq ss)] 338 | (concat (first s) (flatten* (rest s)))))) 339 | 340 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 341 | ;; 342 | ;; Commonly used monads 343 | ;; 344 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 345 | 346 | ; Identity monad 347 | (defmonad identity-m 348 | "Monad describing plain computations. This monad does in fact nothing 349 | at all. It is useful for testing, for combination with monad 350 | transformers, and for code that is parameterized with a monad." 351 | [m-result identity 352 | m-bind (fn m-result-id [mv f] 353 | (f mv)) 354 | ]) 355 | 356 | ; Maybe monad 357 | (defmonad maybe-m 358 | "Monad describing computations with possible failures. Failure is 359 | represented by nil, any other value is considered valid. As soon as 360 | a step returns nil, the whole computation will yield nil as well." 361 | [m-zero nil 362 | m-result (fn m-result-maybe [v] v) 363 | m-bind (fn m-bind-maybe [mv f] 364 | (when-not (nil? mv) (f mv))) 365 | m-plus (fn m-plus-maybe [& mvs] 366 | (first (drop-while nil? mvs))) 367 | ]) 368 | 369 | ; Sequence monad (called "list monad" in Haskell) 370 | (defmonad sequence-m 371 | "Monad describing multi-valued computations, i.e. computations 372 | that can yield multiple values. Any object implementing the seq 373 | protocol can be used as a monadic value." 374 | [m-result (fn m-result-sequence [v] 375 | (list v)) 376 | m-bind (fn m-bind-sequence [mv f] 377 | (flatten* (map f mv))) 378 | m-zero (list) 379 | m-plus (fn m-plus-sequence [& mvs] 380 | (flatten* mvs)) 381 | ]) 382 | 383 | ; Set monad 384 | (defmonad set-m 385 | "Monad describing multi-valued computations, like sequence-m, 386 | but returning sets of results instead of sequences of results." 387 | [m-result (fn m-result-set [v] 388 | #{v}) 389 | m-bind (fn m-bind-set [mv f] 390 | (apply clojure.set/union (map f mv))) 391 | m-zero #{} 392 | m-plus (fn m-plus-set [& mvs] 393 | (apply clojure.set/union mvs)) 394 | ]) 395 | 396 | ; State monad 397 | (defmonad state-m 398 | "Monad describing stateful computations. The monadic values have the 399 | structure (fn [old-state] [result new-state])." 400 | [m-result (fn m-result-state [v] 401 | (fn [s] [v s])) 402 | m-bind (fn m-bind-state [mv f] 403 | (fn [s] 404 | (let [[v ss] (mv s)] 405 | ((f v) ss)))) 406 | ]) 407 | 408 | (defn update-state 409 | "Return a state-monad function that replaces the current state by the 410 | result of f applied to the current state and that returns the old state." 411 | [f] 412 | (fn [s] [s (f s)])) 413 | 414 | (defn set-state 415 | "Return a state-monad function that replaces the current state by s and 416 | returns the previous state." 417 | [s] 418 | (update-state (fn [_] s))) 419 | 420 | (defn fetch-state 421 | "Return a state-monad function that returns the current state and does not 422 | modify it." 423 | [] 424 | (update-state identity)) 425 | 426 | (defn fetch-val 427 | "Return a state-monad function that assumes the state to be a map and 428 | returns the value corresponding to the given key. The state is not modified." 429 | [key] 430 | (fn [s] [(get s key ) s])) 431 | 432 | (defn update-val 433 | "Return a state-monad function that assumes the state to be a map and 434 | replaces the value associated with the given key by the return value 435 | of f applied to the old value. The old value is returned." 436 | [key f] 437 | (fn [s] 438 | (let [old-val (get s key) 439 | new-s (assoc s key (f old-val))] 440 | [old-val new-s]))) 441 | 442 | (defn set-val 443 | "Return a state-monad function that assumes the state to be a map and 444 | replaces the value associated with key by val. The old value is returned." 445 | [key val] 446 | (update-val key (fn [_] val))) 447 | 448 | (defn with-state-field 449 | "Returns a state-monad function that expects a map as its state and 450 | runs statement (another state-monad function) on the state defined by 451 | the map entry corresponding to key. The map entry is updated with the 452 | new state returned by statement." 453 | [key statement] 454 | (fn [s] 455 | (let [substate (get s key nil) 456 | [result new-substate] (statement substate) 457 | new-state (assoc s key new-substate)] 458 | [result new-state]))) 459 | 460 | (defn state-m-until 461 | "An optimized implementation of m-until for the state monad that 462 | replaces recursion by a loop." 463 | [p f x] 464 | (letfn [(until [p f x s] 465 | (if (p x) 466 | [x s] 467 | (let [[x s] ((f x) s)] 468 | (recur p f x s))))] 469 | (fn [s] (until p f x s)))) 470 | 471 | ; Writer monad 472 | (defprotocol writer-monad-protocol 473 | "Accumulation of values into containers" 474 | (writer-m-add [container value] 475 | "add value to container, return new container") 476 | (writer-m-combine [container1 container2] 477 | "combine two containers, return new container")) 478 | 479 | (extend-protocol writer-monad-protocol 480 | 481 | clojure.lang.IPersistentVector 482 | (writer-m-add [c v] (conj c v)) 483 | (writer-m-combine [c1 c2] (vec (concat c1 c2))) 484 | 485 | clojure.lang.IPersistentList 486 | (writer-m-add [c v] (conj c v)) 487 | (writer-m-combine [c1 c2] (apply list (concat c1 c2))) 488 | 489 | clojure.lang.APersistentSet 490 | (writer-m-add [c v] (conj c v)) 491 | (writer-m-combine [c1 c2] (clojure.set/union c1 c2)) 492 | 493 | java.lang.String 494 | (writer-m-add [c v] (str c v)) 495 | (writer-m-combine [c1 c2] (str c1 c2))) 496 | 497 | (defn writer-m 498 | "Monad describing computations that accumulate data on the side, e.g. for 499 | logging. The monadic values have the structure [value log]. Any of the 500 | accumulators from clojure.contrib.accumulators can be used for storing the 501 | log data. Its empty value is passed as a parameter." 502 | [empty-accumulator] 503 | (monad 504 | [m-result (fn m-result-writer [v] 505 | [v empty-accumulator]) 506 | m-bind (fn m-bind-writer [mv f] 507 | (let [[v1 a1] mv 508 | [v2 a2] (f v1)] 509 | [v2 (writer-m-combine a1 a2)])) 510 | ])) 511 | 512 | (defmonadfn write [v] 513 | (let [[_ a] (m-result nil)] 514 | [nil (writer-m-add a v)])) 515 | 516 | (defn listen [mv] 517 | (let [[v a] mv] [[v a] a])) 518 | 519 | (defn censor [f mv] 520 | (let [[v a] mv] [v (f a)])) 521 | 522 | ; Reader monad 523 | (defmonad reader-m 524 | "Monad describing computations which read values from a shared environment. 525 | Also known as the environment monad." 526 | [m-result (fn m-result-reader [v] 527 | (fn [r] v)) 528 | m-bind (fn m-bind-reader [mv f] 529 | (fn [r] 530 | ((f (mv r)) r))) 531 | ]) 532 | 533 | (defn ask 534 | "Returns the environment." 535 | [] 536 | identity) 537 | 538 | (defn asks 539 | "Returns a function of the current environment." 540 | [f] 541 | (fn [env] 542 | (f env))) 543 | 544 | (defn local 545 | "Runs reader g in the context of an environment modified by f" 546 | [f g] 547 | (fn [env] 548 | (g (f env)))) 549 | 550 | ; Continuation monad 551 | (defmonad cont-m 552 | "Monad describing computations in continuation-passing style. The monadic 553 | values are functions that are called with a single argument representing 554 | the continuation of the computation, to which they pass their result." 555 | [m-result (fn m-result-cont [v] 556 | (fn [c] (c v))) 557 | m-bind (fn m-bind-cont [mv f] 558 | (fn [c] 559 | (mv (fn [v] ((f v) c))))) 560 | ]) 561 | 562 | (defn run-cont 563 | "Execute the computation c in the cont monad and return its result." 564 | [c] 565 | (c identity)) 566 | 567 | (defn call-cc 568 | "A computation in the cont monad that calls function f with a single 569 | argument representing the current continuation. The function f should 570 | return a continuation (which becomes the return value of call-cc), 571 | or call the passed-in current continuation to terminate." 572 | [f] 573 | (fn [c] 574 | (let [cc (fn cc [a] (fn [_] (c a))) 575 | rc (f cc)] 576 | (rc c)))) 577 | 578 | 579 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 580 | ;; 581 | ;; Monad transformers 582 | ;; 583 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 584 | 585 | (defmacro monad-transformer 586 | "Define a monad transformer in terms of the monad operations and the base 587 | monad. The argument which-m-plus chooses if m-zero and m-plus are taken 588 | from the base monad or from the transformer." 589 | [base which-m-plus operations] 590 | `(let [which-m-plus# (cond (= ~which-m-plus :m-plus-default) 591 | (if (= ::this-monad-does-not-define-m-plus 592 | (with-monad ~base ~'m-plus)) 593 | :m-plus-from-transformer 594 | :m-plus-from-base) 595 | (or (= ~which-m-plus :m-plus-from-base) 596 | (= ~which-m-plus :m-plus-from-transformer)) 597 | ~which-m-plus 598 | :else 599 | (throw (java.lang.IllegalArgumentException. 600 | "undefined m-plus choice"))) 601 | combined-monad# (monad ~operations)] 602 | (if (= which-m-plus# :m-plus-from-base) 603 | (assoc combined-monad# 604 | :m-zero (with-monad ~base ~'m-zero) 605 | :m-plus (with-monad ~base ~'m-plus)) 606 | combined-monad#))) 607 | 608 | (defn maybe-t 609 | "Monad transformer that transforms a monad m into a monad in which 610 | the base values can be invalid (represented by nothing, which defaults 611 | to nil). The third argument chooses if m-zero and m-plus are inherited 612 | from the base monad (use :m-plus-from-base) or adopt maybe-like 613 | behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base 614 | if the base monad m has a definition for m-plus, and 615 | :m-plus-from-transformer otherwise." 616 | ([m] (maybe-t m nil :m-plus-default)) 617 | ([m nothing] (maybe-t m nothing :m-plus-default)) 618 | ([m nothing which-m-plus] 619 | (monad-transformer m which-m-plus 620 | [m-result (with-monad m m-result) 621 | m-bind (with-monad m 622 | (fn m-bind-maybe-t [mv f] 623 | (m-bind mv 624 | (fn [x] 625 | (if (identical? x nothing) 626 | (m-result nothing) 627 | (f x)))))) 628 | m-zero (with-monad m (m-result nothing)) 629 | m-plus (with-monad m 630 | (fn m-plus-maybe-t [& mvs] 631 | (if (empty? mvs) 632 | (m-result nothing) 633 | (m-bind (first mvs) 634 | (fn [v] 635 | (if (= v nothing) 636 | (apply m-plus-maybe-t (rest mvs)) 637 | (m-result v))))))) 638 | ]))) 639 | 640 | (defn sequence-t 641 | "Monad transformer that transforms a monad m into a monad in which 642 | the base values are sequences. The argument which-m-plus chooses 643 | if m-zero and m-plus are inherited from the base monad 644 | (use :m-plus-from-base) or adopt sequence-like 645 | behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base 646 | if the base monad m has a definition for m-plus, and 647 | :m-plus-from-transformer otherwise." 648 | ([m] (sequence-t m :m-plus-default)) 649 | ([m which-m-plus] 650 | (monad-transformer m which-m-plus 651 | [m-result (with-monad m 652 | (fn m-result-sequence-t [v] 653 | (m-result (list v)))) 654 | m-bind (with-monad m 655 | (fn m-bind-sequence-t [mv f] 656 | (m-bind mv 657 | (fn [xs] 658 | (m-fmap flatten* 659 | (m-map f xs)))))) 660 | m-zero (with-monad m (m-result (list))) 661 | m-plus (with-monad m 662 | (fn m-plus-sequence-t [& mvs] 663 | (m-reduce concat (list) mvs))) 664 | ]))) 665 | 666 | ;; Contributed by Jim Duey 667 | (defn state-t 668 | "Monad transformer that transforms a monad m into a monad of stateful 669 | computations that have the base monad type as their result." 670 | [m] 671 | (monad [m-result (with-monad m 672 | (fn m-result-state-t [v] 673 | (fn [s] 674 | (m-result [v s])))) 675 | m-bind (with-monad m 676 | (fn m-bind-state-t [stm f] 677 | (fn [s] 678 | (m-bind (stm s) 679 | (fn [[v ss]] 680 | ((f v) ss)))))) 681 | m-zero (with-monad m 682 | (if (= ::this-monad-does-not-define-m-zero m-zero) 683 | ::this-monad-does-not-define-m-zero 684 | (fn [s] 685 | m-zero))) 686 | m-plus (with-monad m 687 | (if (= ::this-monad-does-not-define-m-plus m-plus) 688 | ::this-monad-does-not-define-m-plus 689 | (fn [& stms] 690 | (fn [s] 691 | (apply m-plus (map #(% s) stms)))))) 692 | ])) 693 | --------------------------------------------------------------------------------