rlm@2: (ns mtg.frame) rlm@2: rlm@2: ;; GENERALLY USEFUL FUNCTIONS rlm@2: rlm@2: (defn assay "Takes x and a series of pred-value pairs. Returns a list of vals for which the corresponding preds are true of x." [x & pred-vals] rlm@2: (reduce #(if ((first %2) x) (conj %1 (second %2))) '() pred-vals) rlm@2: ) rlm@2: (defn alter-val "Applies f to the current value associated with each key, associating each key with the value returned." [m f & keys] rlm@2: (map #(assoc m % (f (get m %))) keys)) rlm@2: rlm@2: (defn every-nth "Returns every nth member of coll. If n is not positive, returns an empty list." [n coll] rlm@2: (if (<= n 0) '() rlm@2: (take-while (comp not nil?) (map first (iterate #(nthnext % n) coll))))) rlm@2: rlm@2: rlm@2: rlm@2: rlm@2: rlm@2: ;; FRAME MANIPULATION rlm@2: rlm@2: (defn conj-key "Adds the xs to the seq associated with the given key." [map key & xs] rlm@2: (assoc map key (apply conj (get map key []) xs))) rlm@2: rlm@2: (defn update "Takes a frame and a sequence of key-fn pairs. Applies f to the current value associated with key, updating the current value with the result. Frames generate and store a unique id for each call to update." rlm@2: [frame & kfs] rlm@2: (let [id (gensym "") rlm@2: keys (every-nth 2 kfs) rlm@2: fns (every-nth 2 (rest kfs))] rlm@2: rlm@2: ((reduce comp (map (fn[k f](fn[m](conj-key m k (list id f)))) keys fns)) rlm@2: (conj-key frame :*bindings* (map (fn [k f](list id k)) keys fns)) rlm@2: ) rlm@2: )) rlm@2: rlm@2: (defn rollback "Undo the update with the given id." [frame id] rlm@2: (let [affected-keys rlm@2: (conj (map second (filter #(=(first %) id) (:*bindings* frame))) :*bindings*)] rlm@2: (reduce (fn[frame key] rlm@2: (alter-val (partial filter #(=(first %) id)) key) rlm@2: ) frame affected-keys) rlm@2: )) rlm@2: rlm@2: rlm@2: (defn get-fn "Keys in a frame store lists of modifiers. Produces the end result of applying all the modifiers in order." [frame key] rlm@2: (reduce #(%2) (constantly nil) (list (constantly 1))) rlm@2: ) rlm@2: rlm@2: rlm@2: (def *frame* (atom {:*bindings* '()})) rlm@2: