Commits

Meikel Brandmeyer  committed 39fc258

Added state monad

* monad/state.clj: new file

  • Participants
  • Parent commits 2d7bc43

Comments (0)

Files changed (2)

 				value="${build}"/>
 			<arg value="de.kotka.monad"/>
 			<arg value="de.kotka.monad.maybe"/>
+			<arg value="de.kotka.monad.state"/>
 		</java>
 	</target>
 

File src/de/kotka/monad/state.clj

+;-
+; Copyright 2008 (c) Meikel Brandmeyer.
+; All rights reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+; THE SOFTWARE.
+
+(clojure.core/ns de.kotka.monad.state
+  (:use
+     de.kotka.monad))
+
+(defn put-value
+  "Sets the value but leaves the state intact."
+  [x]
+  (return ::type #(vector x %)))
+
+(defn get-state
+  "Returns the state as the value."
+  [x]
+  (return ::type #(vector % %)))
+
+(defn put-state
+  "Sets the state and a nil value."
+  [s]
+  (return ::type (fn [_] [nil s])))
+
+(defn run-state
+  "Apply a state monad to the given initial state. Returns a vector
+  consisting of the value and the final state."
+  [m s]
+  ((monad m) s))
+
+(defmethod bind ::type
+  [m f]
+  (return ::type
+          (fn [s0]
+            (let [[a s1] (run-state m s0)]
+              (run-state (f a) s0)))))