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))
Related
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.
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.
I'm new here, and I need help with a function that I'm writing in scheme.
Basically, it involves a search function that can work for either Breadth-First search or Depth-First Search. I think I got the Depth-First-Merge and Breadth-First Merge to work.
However, the problem is to modify the main Search to work as a "currying function" so that when algorithm-specific merge procedures (such as the depth-first-merge or the breadth-first-merge) are passed in as arguments, the search uses that specific type of search. The return
There's two files I have with it. Coins is okay, but search needs fixed. How do I modify the search function here to work as a curried version?
Here's my codes below. first one for search.ss. I made a search2 as an early attempt, but it didn't work. I need to make either search or search2 work as the curried search, (then delete the other). I'm not sure, but I think the merges and two searches are working.
;;;
;;; SEARCH:
;;; -- Non-curried version of generic search algorithm
;;; -- Can be customized for depth-first and breadth-first search
;;; -- You must convert it to a curried version so that
;;; - the function accepts 1 algorithm specific parameter and returns a function
;;; - that accepts 3 problem-specific parameters and returns a function
;;; - that accepths 1 instance specific parameter and performs the search
;;; -- The 5 parameters are described below
;;;
;;; Input:
;;; merge-queue
;;; -- algorithm specific
;;; -- procedure that takes a list of new paths and a queue
;;; and returns a new queue
;;; extend
;;; -- problem-specific
;;; -- procedure that takes a state and a list of visited states,
;;; and returns a list of states that are reachable in one move
;;; from the given state
;;; goal?
;;; -- problem-specific
;;; -- predicate that takes a state and returns true if the
;;; state is a goal state, false otherwise
;;; print-path
;;; -- problem-specific
;;; -- procedure that takes a state and prints out a state nicely
;;; init-state
;;; -- problem instance-specific
;;; -- an initial state to start the search from
;;;
;;; OUTPUT:
;;; -- When succeeded, a path from the initial state to a goal state
;;; -- When failed, #f
;;;
;;Either this or search2 needs to be rewritten into a curried version
;;To accept either depth-first-merge or breadth-first merge as merge procedures into merge-queue
(define search
(lambda (merge-queue init-config extend goal? print-state)
(letrec
((helper
(lambda (queue)
(newline)
(for-each
(lambda (p) (print-path p print-state))
queue)
(cond ((null? queue) #f)
((goal? (caar queue))
(print-state (caar queue))
(newline)
(let ((ans (reverse (car queue))))
(for-each (lambda (x) (print-state x) (newline)) ans)
ans))
(else
(let ((successors (extend (caar queue))))
(print-state (caar queue)) (newline)
(cond ((null? successors)
(helper (cdr queue)))
(else
(for-each (lambda (x) (print-state x) (newline))
successors)
(helper
(merge-queue (cdr queue)
(extend-path successors (car queue))))))))))))
(helper
(list (list (config->state init-config ))))))
(define search2
(lambda (merge-queue extend goal? print-path init-state)
(letrec
((search-helper
(lambda (queue visited)
(cond
((null? queue) #f)
((goal? (caar queue))
(begin
(print-path (car queue))
(car queue)))
(else
(let ((successors (extend (caar queue) visited)))
(cond
((null? successors)
(search-helper (cdr queue) visited))
(else
(let ((new-paths (extend-path successors (car queue))))
(search-helper
(merge-queue queue new-paths)
(cond
(merge-queue))
(append successors visited)))))))))))
(search-helper
(list (list init-state)) ; initial queue
(list init-state))))) ; initial visited
(define extend-path
(lambda (successors path)
(if (null? successors)
'()
(cons (cons (car successors) path)
(extend-path (cdr successors) path)))))
;; merge new extended paths to queue for depth first search
;; - uncomment and define your merge for depth first search
(define depth-first-merge
(lambda (queue paths)
(append! paths queue)))
;; merge new extended paths to queue for breadth first search
;; - uncomment and define your merge for breadth first search
(define breadth-first-merge
(lambda (queue paths)
(append! queue paths)))
;; customize the generic search for depth first search
;; - uncomment and define your depth-first-search in terms of your
;; curried version of search and depth-first-merge
;; Curry Methods are helpful to this.
(define depth-first-search (search depth-first-merge))
(lambda (extend goal? print-path)
(search (depth-first-merge extend goal? print-path))))
;; customize the generic search for breadth first search
;; - uncomment and define your breadth-first-search in terms of your
;; curried version of search and breadth-first-merge
(define breadth-first-search (search breadth-first-merge))
(lambda (extend goal? print-path)
(search (breadth-first-merge extend goal? print-path))))
And this is the Coins file code that is used to compliment the search code. They are in separate files and it loads search.ss (the above one) to work.
;; load algorithm specific code for search
(load "search.ss")
;;; Problem specific code for solving the old British coin problems
;;; using the curried version of the simple search procedure.
;;; The old British coin problem was discussed in the lecture.
;;;
;;; To solve the problem, load this file and run
;;; (coin-depth-first amount)
;;; or
;;; (coin-breadth-first amount)
;;; where, amount is replaced with some number, e.g., 48.
;;;
;;; Here, a state is represented as follows:
;;; (amount (coin1 coin2 ...))
;;;
;;; The car of the state represents how much change you need to pay further.
;;; The cadr of the state represents the combination of coins you used
;;; to pay so far. For example,
;;; (48 ())
;;; is the initial state for the amount of 48 cents and
;;; (0 (24 24)
;;; can be one of the goal states using two 24-cent coins.
;; There are 7 kinds of old British coins
(define old-british-coins '(120 30 24 12 6 3 1))
;; Or, you can do the same for US coins
(define us-coins '(100 50 25 10 5 1))
;; Here, we will do the old British coins
(define *coins* old-british-coins)
;; Is a state the goal state?
(define goal?
(lambda (state)
(zero? (car state))))
;; returns children of a state
(define extend
(lambda (state visited)
(let ((coins (applicable-coins state visited *coins*)))
(map
(lambda (coin)
(list (- (car state) coin)
(append (cadr state) (list coin))))
coins))))
;; find all applicable coins from a state
(define applicable-coins
(lambda (state visited coins)
(cond
((null? coins) '())
((<= (car coins) (car state))
(if (visited? state visited (car coins))
(applicable-coins state visited (cdr coins))
(cons (car coins) (applicable-coins state visited (cdr coins)))))
(else (applicable-coins state visited (cdr coins))))))
;; see if a state has been visited before
(define visited?
(lambda (state visited coin)
(cond
((null? visited) #f)
((= (- (car state) coin) (caar visited)) #t)
(else (visited? state (cdr visited) coin)))))
;; pretty-print a state
(define pretty-print-path
(lambda (path)
(pretty-print-state (car path))))
(define pretty-print-state
(lambda (state)
(let ((change (car state))
(coins (cadr state))
(total (apply + (cadr state))))
(printf
"===> Total of ~a paid with ~a, with remainder of ~a <===~%"
total coins change))))
;; customize the generic depth-first-search for coin problem
(define coin-depth-first-search
(depth-first-search extend goal? pretty-print-path))
;; instance of a coin problem using depth-first search
(define coin-depth-first
(lambda (amount)
(coin-depth-first-search (list amount '()))))
;; customize the generic breadth-first-search for coin problem
(define coin-breadth-first-search
(breadth-first-search extend goal? pretty-print-path))
;; instance of a coin problem with breadth-first search
(define coin-breadth-first
(lambda (amount)
(coin-breadth-first-search (list amount '()))))
Can someone please help me? I think all I need to get it to work is to find out how to make the search or search2 code become a curried version.
To curry a function means to redefine it in such a way that it takes a number of parameters less than the current definition and returns a new function that takes the rest of the parameters and perform the work of the first one. For instance, you can curry the following two-parameters summing function:
(define add
(lambda (a b)
(+ a b)))
(add 7 10) ;; => 17
in the following way:
(define add-to
(lambda (a)
(lambda (b)
(+ a b))))
((add-to 7) 10) ;; => 17
(define add-to-7 (add-to 7)) ;; we give a name to the function that add 7 to its argument
(add-to-7 8) ;; => 15
(add-to-7 9) ;; => 16
So, to transform the search2 function (you must extend that function since its last parameter is the problem instance specific one):
(define search2
(lambda (merge-queue extend goal? print-path init-state)
...body of search2...
as required, you could simply write something like this:
(define search2
(lambda (merge-queue)
(lambda (extend goal? print-path)
(lambda (init-state)
...body of search2...
and then, calling it with the correct number of parameters, you could obtain “partial” functions to be called later. For instance you can define a generic depth first search as:
(define depth-first-search (search2 depth-first-merge))
then you can define the depth first search specialized for the coin problem, given appropriate definitions for the coin functions:
(define coin-depth-first (depth-first-search coin-extend coin-goal? coin-print-path))
and finally you can call it with a certain amount to solve the problem:
(coin-depth-first 100)
I would like to get the position of any element in the list and get nil if the element isn't in the list. I did:
(defun myposition (letter list)
(cond
((atom list) nil)
((equal (car list) letter) 0)
((null (car list)) (myposition letter))
(t (1+ (myposition letter (cdr list)))) ) )
(myposition 'k '(g h i j k l)
4
(myposition 'p '(g h i j k l)
nil is not a number
When I replace ((atom list) nil) par ((atom list) 0), I get 6 instead nil
(myposition 'p '(g h i j k l)
6
In your first example, your function will recursively compute 1+1+1+1+0 = 4 to find the correct result.
In your second example, it will run through the whole list, add 1 per (non-matching) element, and finally add nil. So it actually computes 1+1+1+1+1+1+nil, which is incorrect since nil is not a number, hence the error message. If you replace nil by zero, it computes 1+1+1+1+1+1+0 which is wrong.
So your basic problem is that you recursively add 1 and, reaching the end of the list, you would like to throw away what you computed until then. But you have an addition pending which you cannot escape.
The easiest way is to change from a recursive to a tail-recursive solution, which is technically a plain goto. Here the addition is done by incrementing a variable, not by unwinding the call stack, which makes it easy to throw away the result from the previous additions and just return nil because there is no addition pending.
A (tail-)recursive solution could be:
(defun myposition (letter lst)
(labels ((sub (lst pos)
(cond
((null lst) nil)
((equal (car lst) letter) pos)
(t (sub (cdr lst) (1+ pos))))))
(if (atom lst) nil (sub lst 0))))
This will work in Common Lisp, but technically, if your implementation does no tail call optimisation, it might still blow the stack for large lists. That's why Common Lisp prefers iterative solutions, such as using the loop macro:
(defun myposition (letter lst)
(when (consp lst)
(loop for c in lst for i from 0
when (equal c letter) return i)))
I'm just starting with Scheme.
I'm trying to use some procedures from String Library.
Here's what I need:
input: "ccaAaAaAa"
function: generate all strings substituting all possible aAa to aBa, one substitution only
output: "ccaBaAaAa" and "ccaAaBaAa" and "ccaAaAaBa"
Is there any easy way to do that? Maybe a procedure that return a list of index of pattern found?
Apparently the searching function string-contains only returns the first occurrence.
What I thought is: after producing the first string "ccaBaAaAa", trim to the first index of the pattern found: the original "ccaAaAaAa" becomes "AaAaAa". Repeat (recursively).
Thanks.
string-contains won't give you a list of all occurrences of the substring, but it will tell you whether there is one, and if there is, what its index is. It also allows you to restrict the search to a particular range within the string. Based on this, if you get a match, you can recursively search the rest of the string until you no longer get a match.
From there, you can do the substitution for each match.
What is wrong by writing such a function?
(define (replace input)
(let loop ((done '())
(remaining (string->list input))
(output '()))
(if (pair? remaining)
(if (char=? #\a (car remaining))
(let ((remaining (cdr remaining)))
(if (pair? remaining)
(if (char=? #\A (car remaining))
(let ((remaining (cdr remaining)))
(if (pair? remaining)
(if (char=? #\a (car remaining))
(loop (append done (list #\a #\A))
remaining
(cons (list->string
(append done
(cons #\a
(cons #\B
remaining))))
output))
(loop (append done (list #\a #\A
(car remaining)))
(cdr remaining)
(reverse output)))
(reverse output)))
(loop (append done (list #\a (car remaining)))
(cdr remaining)
(reverse output)))
(reverse output)))
(loop (append done (list (car remaining)))
(cdr remaining)
(reverse output)))
(reverse output))))
(replace "ccaAaAaAa") ;=> ("ccaBaAaAa" "ccaAaBaAa" "ccaAaAaBa")
About 15 minutes work.
I thought there could be better string libraries that I didn't know about. But I end up doing what I'd proposed in the question. (For a general input case)
(define (aplicarRegra cadeia cadeiaOriginal regra n)
(let* ((antes (car regra))
(depois (cdr regra))
(index (string-contains cadeia antes))
(tamanho (string-length antes))
(diferenca (- (string-length cadeiaOriginal) (string-length cadeia))))
(if index
(let* ((cadeiaGerada (string-replace cadeiaOriginal depois (+ index diferenca) (+ index diferenca tamanho))))
(if(<= (string-length cadeiaGerada) n)
(lset-union equal? (list cadeiaGerada) (aplicarRegra(substring cadeia (+ 1 index)) cadeiaOriginal regra n))
(aplicarRegra (substring cadeia (+ 1 index)) cadeiaOriginal regra n)))
(list))))
But thanks anyway!