Let's say I have a list:
((1 2 3) (8 4 7) (41 79 30) (0 8 5))
I want to do this:
(1+8+41+0 2+4+79+8 3+7+30+5) = (50 93 45)
I've found an ugly solution:
(defun nested+ (lst)
(let ((acc nil))
(dotimes (i (length (first lst)))
(push (apply #'+ (mapcar #'(lambda (a) (nth i a)) lst)) acc))
(reverse acc)))
It seems to work for my purposes, but I guess it is slow and un-lispy. What's the proper way?
One option is (apply #'mapcar #'+ list). Mapcar will consume as many lists as you give it and stop when it reaches the end of the shortest list.
The naive solution would be
(apply #'mapcar #'+ list)
However, as already pointed out e.g. here by stackoverflow and here by LispWorks, the call-arguments-limit of (in the worst case) 50 arguments applies to functions called by apply. And reduce is suggested instead.
Thus, I suggest:
(defun sum-all (lists)
(reduce #'(lambda (l1 l2) (mapcar #'+ l1 l2)) lists))
And indeed
(sum-all '((1 2 3) (8 4 7) (41 79 30) (0 8 5)))
;; (50 93 45)
Another option is to loop over your list of lists:
(defun sum-all (lists)
(loop
for list in lists
for result = (copy-list list) then (map-into result #'+ result list)
finally (return result)))
During the first iteration, the first list is copied. The resulting list is then used in successive iterations to hold the respective sums. At the end of the iteration, that result list is returned.
Related
As background I'm trying to make a NLP application in Racket and I arrived at the part where I have to stem the words (I also obtained their frequency).
I am using the (planet dyoo/porter-stemmer) package in order to stem, and as an example we can write:
(map (λ(x) (list (stem (first x)) (second x)))
'(("cryed" 1)
("racketeer" 2)
("crying" 3)
("playing" 4)
("racketing" 5)
("plays" 6)
("Racket" 7)))
Which produces: '(("cry" 1) ("racket" 2) ("cry" 3) ("plai" 4) ("racket" 5) ("plai" 6) ("racket" 7))
Now my goal is to sum up the frequency for each term, aka to arrive at: '(("cry" 4) ("racket" 14) ("plai" 10))
I came up with a way to do it, but I don't like my solution:
(define (frequency string)
(map (λ(x) (list (first x) (length x)))
(group-by (λ(x) x) (string-split string))))
(define (recalculate lst)
(frequency
(string-join
(flatten
(map (λ(x) (make-list (second x) (first x))) lst)))))
Basically I retype each word as many times as it's frequency, then make a single string containing all words and finally compute the frequency again. Is there a simpler(faster) way to achieve this?
I should perhaps add that the order doesn't matter ("plai" can come up before "cry" and so on). Also I'm looking for a simpler solution because I'm gonna have to use larger datasets and I want to make this faster (I'd also be glad even if the frequency function can be made more faster).
You could create an add-count procedure that takes a list of counts and a new count as arguments, and adds the count to the list if there are no similarly tagged counts already in the list, or combines the new count with an existing count.
#lang racket
(define (get-tag c) (first c))
(define (get-val c) (second c))
(define (add-count cs c)
(let* ((k (get-tag c))
(v (get-val c))
(old-count (assoc k cs)))
(if old-count
(cons (list k (+ v (get-val old-count)))
(remove old-count cs))
(cons c cs))))
Here get-tag and get-val are just convenience procedures to access the tag and value stored in a count. The assoc procedure is used to extract a copy of the first count in cs matching the new count c to be added. This count is stored in old-count, the value of which is used to create a new count which is added to the list after removing old-count from the original list cs.
With the add-count procedure defined, a procedure reduce-counts could be defined that goes through all of the counts and accumulates them to an empty list by using add-count. The resulting list will have the counts combined.
(define (reduce-counts cs (acc '()))
(if (null? cs)
acc
(reduce-counts (rest cs) (add-count acc (first cs)))))
Here is a test run:
reduce-counts.rkt> (define test-counts '(("cry" 1) ("racket" 2) ("cry" 3) ("play" 4) ("racket" 5) ("play" 6) ("racket" 7)))
reduce-counts.rkt> (reduce-counts test-counts)
'(("racket" 14) ("play" 10) ("cry" 4))
As an alternative approach you could use filter to collect counts with similar tags in a list, and combine those into a new count after summing the values. The combined counts can be collected in an accumulator before filtering the input to remove the tags which were just combined. This process can be repeated recursively until all counts have been combined, removed, and collected.
;;; An alternate solution
(define (combine-like-counts cs)
(list (get-tag (first cs))
(foldl (lambda (c x) (+ x (get-val c))) 0 cs)))
(define (reduce-counts cs (acc '()))
(if (null? cs)
acc
(let* ((k (get-tag (first cs)))
(k-tag? (lambda (c) (equal? k (get-tag c))))
(like (filter k-tag? cs))
(remaining (filter (negate k-tag?) cs)))
(reduce-counts remaining
(cons (combine-like-counts like) acc)))))
Here the combine-like-counts procedure assumes that all counts in the input list share the same tag, so a new count is formed by taking the tag and the sum of all values into a list.
The new reduce-counts procedure returns whatever has been placed in the accumulator when the input is the empty list, otherwise the tag of the first count is saved and used to create the k-tag? predicate, which is then used with filter to create a list of matching counts and a list of the remaining counts with all matching counts removed. The list of matching counts is combined into a single count with combine-like-counts and added to the accumulator, which is passed along with remaining recursively to reduce-counts.
This works as before, although the ordering has changed:
reduce-counts.rkt> (define test-counts '(("cry" 1) ("racket" 2) ("cry" 3) ("play" 4) ("racket" 5) ("play" 6) ("racket" 7)))
reduce-counts.rkt> (reduce-counts test-counts)
'(("play" 10) ("racket" 14) ("cry" 4))
I would suspect that these two implementations would have different performance characteristics depending on the particulars of their input data. My hunch is that the second would fare better for large input that contained large quantities of each tag, but the real answer would come from testing on some representative data samples.
If you are really concerned about performance for large amounts of data, you might consider converting the data to a hash table and using some of the built-in dictionary procedures to arrive at a similar solution.
Game rules
Consider a simple 2-player game played as follows: An even number of coins is laid out in a row. Taking turns, each player removes the coin on one of the ends of the row. The object is to have the highest value in coins when all coins have been taken.
Player one finds the sum of all of the even-numbered coins, and all the odd-numbered coins. If the sum of the odd numbered coins is higher, player one takes the leftmost coin; otherwise he takes the rightmost.
Player two has a choice, with an odd number of coins. So he tries taking a coin from both ends, to see which option would leave player 1 worse off.
The problem
I basically want to implement multitheading to this program. I am still very new to Clojure, and I couldn't really find any good material online, regarding multithreading, that could be applied to my program.
The code
(ns game.core
(:gen-class))
(defn vector-from-string [s]
(drop 1 (map read-string (clojure.string/split (clojure.string/trim-newline s) #" "))))
(defn string-from-file [f]
(slurp f))
(defn sum-of-evens [v]
(def evens (vector))
(loop [v v, index 1]
(when (seq v)
(if (even? index)
(def evens (conj evens (first v))))
(recur (rest v) (inc index))))
(reduce + evens))
(defn sum-of-odds [v]
(def odds (vector))
(loop [v v, index 1]
(when (seq v)
(if (odd? index)
(def odds (conj odds (first v))))
(recur (rest v) (inc index))))
(reduce + odds))
(defn player-two [v p1score p2score]
(if (not (empty? v))
(if (> (max (sum-of-odds (drop 1 v)) (sum-of-evens (drop 1 v))) (max (sum-of-odds (drop-last v)) (sum-of-evens (drop-last v))))
(player-one (drop-last v) p1score (+ p2score(last v)))
(player-one (drop 1 v) p1score (+ p2score (first v))))
(println "p1score" p1score "p2score" p2score)))
(defn player-one [v p1score p2score]
(if (not (empty? v))
(if (> (sum-of-odds v) (sum-of-evens v))
(player-two (drop 1 v) (+ p1score (first v)) p2score)
(player-two (drop-last v) (+ p1score (last v)) p2score))
(println "p1score" p1score "p2score" p2score)))
(defn -main [& args]
(let [v (vector-from-string (string-from-file "numbers.txt")) ]
(player-one v 0 0)))
So -main runs the player-one function first, and player-one calls player-two, and they both continue on until the end of the program. I would like to somehow implement multithreading to speed up the executing of this game with a higher amount of starting coins.
Your code is currently very unidiomatic.
A few remarks that hopefully help you getting into the right direction:
A def inside a defn (or def) is (almost) always wrong. You're thinking in terms of variable assignment and mutable variables here. This is not how Clojure works. Use variables in your recur instead, if you absolutely must, use a local atom (also almost always wrong, but less often wrong than def inside defn).
Your loops are unnecessarily complicated. You want to sum over the elements at even or odd indices? Use a combination of reduce, take-nth and rest:
(take-nth 2 [1 2 3])
;=> (1 3)
(take-nth 2 (rest [1 2 3 4]))
;=> (2 4)
The whole things looks like you're compiling this over and over again and then run the JVM with it. Am I right? The preferred way is to work at the REPL. How to access it, depends on which editing environment you use. There are many beginner-friendly REPLs out there. Gorilla REPL is one example.
Once you got your code and development workflow in better shape, you may want to explore functions like pmap and future for easy access to multi-threading. More advanced stuff involves a library called core.async, but that's probably not the ideal route for the beginner. You can also fall back to Java interop to create your threads. Again something that, while not really hard to do, requires a bit of experience with Clojure.
Hope that helps, even it is not a direct answer to your question.
First let's look at some issues in your example that will need to be addressed before parallelizing this code.
sum-of-evens is using def inside a function, which is almost always a mistake. This might seem to have the effect you want, but it's not the right way to achieve it. defs are typically used for namespace-level (at the same level as your function defns) values. We can refactor sum-of-evens to not rely on unintentionally side-effecty behavior via def:
(defn sum-of-evens [v]
(loop [v v
index 1
evens []]
(if (seq v)
(recur (rest v)
(inc index)
(if (even? index) ;; add a binding to loop, not a def
(conj evens (first v))
evens)) ;; pass unchanged value when necessary
(reduce + evens))))
But we can further simplify this function with keep-indexed:
(defn sum-of-evens [coll]
(->> coll
(keep-indexed (fn [i v] (when (even? (inc i))
v)))
(apply +)))
And when we do the same for sum-of-odds, we can see the functions are nearly identical except for the condition they use: odd? vs. even?. We can make another function that takes a predicate function:
(defn sum-by-index-pred [f coll]
(->> coll
(keep-indexed (fn [i v] (when (f i) v)))
(apply +)))
;; using partial application and function composition
(def sum-of-evens (partial sum-by-index-pred (comp even? inc)))
(def sum-of-odds (partial sum-by-index-pred (comp odd? inc)))
Looking at the implementation of player-one and player-two, they seem to be mutually recursive. I don't see how you could parallelize this to make it any faster because each turn is dependent on the previous turn's outcome; there's nothing to parallelize.
I'd suggest refactoring this so that your game rules and state are computed in one place, rather than mutually recursive functions.
(loop [scores (array-map :player-1 0 :player-2 0)
turns (cycle (keys scores))
vs (shuffle (range 100))]
(if (seq vs)
(let [higher-odds? (> (sum-of-odds vs) (sum-of-evens vs))
scores (if higher-odds?
(update scores (first turns) + (first vs))
(update scores (first turns) + (last vs)))
remain (if higher-odds?
(rest vs)
(butlast vs))]
(recur scores (rest turns) remain))
(prn scores)))
;; {:player-1 2624, :player-2 2326}
I'm not sure if this preserves your original game logic but it should be close, and it does generalize it for more than two players. Try adding :player-3 0 to the starting scores.
Consider a simple 2-player game played as follows: An even number of coins is laid out in a row. Taking turns, each player removes the coin on one of the ends of the row. The object is to have the highest value in coins when all coins have been taken.
Player one finds the sum of all of the even-numbered coins, and all the odd-numbered coins. If the sum of the odd numbered coins is higher, player one takes the leftmost coin; otherwise he takes the rightmost.
Player two now has a choice, with an odd number of coins. Taking either the first coin or the last coin will result in a slightly different list of coins for player one. Player two uses the result of a recursive search to determine whether to pick the first or the last coin.
And I want to be able to somehow implement multi-threading on the p2-helper recursive function, just now sure how. Any suggestions or ideas would be greatly appreciated, thanks!
(ns game.core
(:gen-class))
; function that returns the vector of a string (split up by spaces)
(defn vector-from-string [s]
(drop 1 (map read-string (clojure.string/split (clojure.string/trim-newline s) #" "))))
; function that returns the slurped string of a read-in file
(defn string-from-file [f]
(slurp f))
; function that returns the sum of all the odd-indexed items in a vector
(defn sum-of-evens [v]
(reduce + (take-nth 2 (rest v))))
; function that returns the sum of all the odd-indexed items in a vector
(defn sum-of-odds [v]
(reduce + (take-nth 2 v)))
; function that returns the vector that is left after player one moves, and then the coin that player one took
(defn p1 [v]
(if (> (sum-of-odds v) (sum-of-evens v))
[(drop 1 v) (first v)]
[(drop-last v) (last v)]))
; nearly identical to 'p1' but this function only returns the affected vector after player 1 has moved
(defn p2-p1 [v]
(if (even? (count v))
(if (> (sum-of-odds v) (sum-of-evens v))
(drop 1 v)
(drop-last v))
(drop 0 v)))
; recursive search for player two
(defn p2-helper [v]
(if (or (= (count v) 1) (= (count v) 0))
(reduce + v)
(max (+ (p2-helper (drop 1 (p2-p1 v))) (first (p2-p1 v))) (+ (p2-helper (drop-last (p2-p1 v))) (last (p2-p1 v))))))
; function that returns the vector that is left after player two moves, and then the coin that player two took
(defn p2 [v]
(if (> (+ (p2-helper (drop 1 (p2-p1 v))) (first (p2-p1 v))) (+ (p2-helper (drop-last (p2-p1 v))) (last (p2-p1 v))))
[(drop 1 v) (first v)]
[(drop-last v) (last v)]))
; function to play the game out until no coins are left
(defn play-game [v]
(def coins v)
(def p1score 0)
(def p2score 0)
(while (not (empty? coins))
(do
(let [[new-vec score] (p1 coins)]
(def coins new-vec)
(def p1score (+ p1score score)))
(let [[new-vec score] (p2 coins)]
(def coins new-vec)
(def p2score (+ p2score score)))))
(println "player 1 score:" p1score)
(println "player 2 score:" p2score))
; main
(defn -main [& args]
(let [v (vector-from-string (string-from-file "10.txt")) ]
(play-game v)))
An initial approach would be to just add #(future (p2-helpet ... around each recursive call. this will likely run too many threads and run slower.
a second approach might be to change the helpers to put work on a task queue and make some threads to process them. this will be better, though still might be slower.
I'd continue improving it by unrolling the recursion with a call to trampoline to stop it blowing the stack. then try just making the top level parallel, or just the two top levels.
I'm having trouble coding a tree search & replace algorithm. The input tree contains arbitrarily nested data items--eg, tree = (1 (2 3 (4 (5)) 6)), where 1 is the root, and each level down is embedded in parentheses. So 1 is at level#1; 2, 3, 4, 6 are at level#2 (under 1), and 5 is at level#3 (under 4). The entire tree is structured such that the car of any list is always a data item, which can be followed by other data items or subtrees. The problem is to find a data item in the tree matching (#'equal in my specific case) an input item, and replace the existing old item with a given new subtree--eg, (exchange subtree olditem tree ...). The tree therefore grows with each replacement. However, the search must proceed top-down in the tree, exchanging only the first such olditem found, and then exit.
Some observations?: 1) For binary trees, the search order (top-down visitation) is normally called level-order, the other possible search orders being preorder, inorder, and postorder, but my trees are not necessarily binary. 2) Something like a breadth-first-search algorithm might work, but the nodes are selected by tree traversal, rather than being generated. 3) The standard "substitute" function works only for sequences, not trees. 4) The "subst" function works for trees, but seems to traverse in a depth-first manner replacing all matching items, and has no :count keyword (like "substitute" does) to stop after the first replacement.
Any help coding or even framing a good approach would be appreciated. (Also curious why common-lisp does not have more "tree" functions for both lists and vectors.)
Maybe I shouldn't be doing this, cause you are supposed to do your homework yourself, but it would take me longer to explain what to do, than to show it.
Here is a breadth-first search and replace version:
(defun search-replace (item new-item lst)
(when (listp lst)
(let ((found-item (member item lst)))
(if found-item
(rplaca found-item new-item)
(some #'(lambda (sublst) (search-replace item new-item sublst)) lst) ))))
This function is destructive, i.e., it will modify the original list, because it uses rplaca, and it won't return the resulting list (you can add it at the end). You can also add other nice features, such as a test function (equal or whichever you need). It will work also with lists whose car is a sublist (in your example it's always an atom).
I hope it helps you get started.
#Leo. Like your concise solution--will have to study it for understanding. In the meantime here is another preliminary breadth-first search attempt:
(defun add-tree (newsubtree tree)
(let ((queue (make-array 0 :adjustable t :fill-pointer t))
(data (first newsubtree))
(index 0))
(vector-push-extend tree queue)
(loop until (= index (fill-pointer queue))
do (let ((current-node (elt queue index)))
(incf index)
(loop for child in (second current-node)
for i from 0
if (and (numberp child) (= child data))
do (setf (elt (second current-node) i) newsubtree)
(return-from add-tree tree)
else do (vector-push-extend child queue))))))
(add-tree '(2 (5 6)) '(0 ((1 (3 2 4)) 2)))
(0 ((1 (3 2 4)) (2 (5 6))))
Thanks for confirming my intuition that breadth-first was the way to approach this. (ps: this is not homework)
Here's a real breadth first search that actually does replace the shallowest leftmost occurrence. (Unfortunately #Leo's code, albeit slick, doesn't do that.)
For fun used a circular list as a queue:
(setf *print-circle* t)
(defun one-element-queue (item)
(let ((link (list item)))
(setf (cdr link) link)))
(defun enqueue (item &optional queue)
(cond ((null queue) (one-element-queue item))
(t (let ((new-link (cons item (cdr queue))))
(setf (cdr queue) new-link)))))
(defun enqueue-all (items &optional queue)
(dolist (item items queue) (setq queue (enqueue item queue))))
(defun dequeue (queue)
(cond ((eq queue (cdr queue)) (values (car queue) nil))
(t (let ((item (cadr queue)))
(setf (cdr queue) (cddr queue))
(values item queue)))))
(defun node-replace (new-item old-item node)
(let ((position (position old-item node :test #'equal)))
(when position (setf (nth position node) new-item))
position))
(defun tree-replace (new-item old-item tree)
(loop with queue = (enqueue tree) and node
while queue
do (multiple-value-setq (node queue) (dequeue queue))
until (node-replace new-item old-item node)
do (setq queue (enqueue-all (remove-if-not #'listp node) queue)))
tree)
(setq tree '(1 ((5 ((41))) 3 (4 (5)) 5)))
(print (tree-replace 42 5 tree))
I'm new to Common Lisp. In Haskell, you can do a little something like this:
Prelude> takeWhile (<= 10) [k | k <- [1..]]
[1,2,3,4,5,6,7,8,9,10]
Is this possible in Lisp? Not necessarily with an infinite list, but with any list.
You could use LOOP:
(setq *l1* (loop for x from 1 to 100 collect x))
(loop for x in *l1* while (<= x 10) collect x)
If you really need it as a separate function:
(defun take-while (pred list)
(loop for x in list
while (funcall pred x)
collect x))
And here we are:
T1> (take-while (lambda (x) (<= x 10)) *l1*)
(1 2 3 4 5 6 7 8 9 10)
But if we compare:
(loop for x in *l1* while (<= x 10) collect x)
(take-while (lambda (x) (<= x 10)) *l1*)
I think I would just stick with loop.
For infinite sequences, you could take a look at Series:
T1> (setq *print-length* 20)
20
T1> (setq *l1* (scan-range :from 1))
#Z(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 ...)
T1> (until-if (lambda (x) (> x 10)) *l1*)
#Z(1 2 3 4 5 6 7 8 9 10)
This should do...
(defun take-while (list test)
(and list (funcall test (car list))
(cons (car list) (take-while (cdr list) test))))
(take-while '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (lambda (x) (< x 10)))
--> (1 2 3 4 5 6 7 8 9)
However this "natural" implementation is not tail-recursive and could crash for big lists.
An explicit push-nreverse approach (a common pattern) could be
(defun take-while (list test)
(do ((res nil))
((or (null list) (not (funcall test (car list))))
(nreverse res))
(push (car list) res)
(setf list (cdr list))))
A recursive (but tail-recursive, therefore probably ok with most CL implementations) could IMO be the following:
(defun take-while (list test)
(labels ((rec (res x)
(if (and x (funcall test (car x)))
(rec (cons (car x) res) (cdr x))
(nreverse res))))
(rec nil list)))
Note that however it's not guaranteed that a common lisp implementation will handle tail-call optimizations.
The CL-LAZY library implements lazy calling for Common Lisp and provides a take-while function that is laziness aware. You can install it with Quicklisp and try it out.
Some languages provide a Haskell-style list API as 3rd party libraries, with or without support for infinite streams.
Some examples:
Clojure's sequences: take-while
Scala has something
Remember that takeWhile is relatively easy to implement over a sequence, and is given in Haskell as:
takeWhile _ [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
You can have a lazy evaluation in common lisp using closures (from Paul Graham's On Lisp):
(defun lazy-right-fold (comb &optional base)
"Lazy right fold on lists."
(labels ((rec (lst)
(if (null lst)
base
(funcall comb
(car lst)
#'(lambda () (rec (cdr lst)))))))
#'rec))
Then, take-while becomes:
(defun take-while (pred lst)
(lazy-right-fold #'(lambda (x f) (
(if (test x)
(cons x (funcall f))
(funcall f)))
nil))