I want to implement Heap's algorithm in Scheme (Gambit).
I read his paper and checked out lots of resources but I haven't found many functional language implementations.
I would like to at least get the number of possible permutations.
The next step would be to actually print out all possible permutations.
Here is what I have so far:
3 (define (heap lst n)
4 (if (= n 1)
5 0
6 (let ((i 1) (temp 0))
7 (if (< i n)
8 (begin
9 (heap lst (- n 1))
10 (cond
11 ; if even: 1 to n -1 consecutively cell selected
12 ((= 0 (modulo n 2))
13 ;(cons (car lst) (heap (cdr lst) (length (cdr lst)))))
14 (+ 1 (heap (cdr lst) (length (cdr lst)))))
15
16 ; if odd: first cell selectd
17 ((= 1 (modulo n 2))
18 ;(cons (car lst) (heap (cdr lst) (length (cdr lst)))))
19 (+ 1 (heap (car lst) 1)))
20 )
21 )
22 0
23 )
24 )
25 )
26 )
27
28 (define myLst '(a b c))
29
30 (display (heap myLst (length myLst)))
31 (newline)
I'm sure this is way off but it's as close as I could get.
Any help would be great, thanks.
Here's a 1-to-1 transcription of the algorithm described on the Wikipedia page. Since the algorithm makes heavy use of indexing I've used a vector as a data structure rather than a list:
(define (generate n A)
(cond
((= n 1) (display A)
(newline))
(else (let loop ((i 0))
(generate (- n 1) A)
(if (even? n)
(swap A i (- n 1))
(swap A 0 (- n 1)))
(if (< i (- n 2))
(loop (+ i 1))
(generate (- n 1) A))))))
and the swap helper procedure:
(define (swap A i1 i2)
(let ((tmp (vector-ref A i1)))
(vector-set! A i1 (vector-ref A i2))
(vector-set! A i2 tmp)))
Testing:
Gambit v4.8.4
> (generate 3 (vector 'a 'b 'c))
#(a b c)
#(b a c)
#(c a b)
#(a c b)
#(b c a)
#(c b a)
Related
When written this way the error says: 4 parts after if:
(define (rolling-window l size)
(if (< (length l) size) l
(take l size) (rolling-window (cdr l) size)))
and when there's another paranthesis to make it 3 parts:
(define (rolling-window l size)
(if (< (length l) size) l
((take l size) (rolling-window (cdr l) size))))
then it says: application: not a procedure;
How to write more than one expression in if's else in racket/scheme?
Well that's not really the question. The question is "How to build a rolling window procedure using racket?". Anyway, it looks like you're probably coming from another programming language. Processing linked lists can be a little tricky at first. But remember, to compute the length of a list, you have to iterate through the entire list. So using length is a bit of an anti-pattern here.
Instead, I would recommend you create an auxiliary procedure inside your rolling-window procedure which builds up the window as you iterate thru the list. This way you don't have to waste iterations counting elements of a list.
Then if your aux procedure ever returns and empty window, you know you're done computing the windows for the given input list.
(define (rolling-window n xs)
(define (aux n xs)
(let aux-loop ([n n] [xs xs] [k identity])
(cond [(= n 0) (k empty)] ;; done building sublist, return sublist
[(empty? xs) empty] ;; reached end of xs before n = 0, return empty window
[else (aux-loop (sub1 n) (cdr xs) (λ (rest) (k (cons (car xs) rest))))]))) ;; continue building sublist
(let loop ([xs xs] [window (aux n xs)] [k identity])
(cond ([empty? window] (k empty)) ;; empty window, done
([empty? xs] (k empty)) ;; empty input list, done
(else (loop (cdr xs) (aux n (cdr xs)) (λ (rest) (k (cons window rest)))))))) ;; continue building sublists
(rolling-window 3 '(1 2 3 4 5 6))
;; => '((1 2 3) (2 3 4) (3 4 5) (4 5 6))
It works for empty windows
(rolling-window 0 '(1 2 3 4 5 6))
;; => '()
And empty lists too
(rolling-window 3 '())
;; => '()
Here is an alternative:
#lang racket
(define (rolling-window n xs)
(define v (list->vector xs))
(define m (vector-length v))
(for/list ([i (max 0 (- m n -1))])
(vector->list (vector-copy v i (+ i n)))))
(rolling-window 3 '(a b c d e f g))
(rolling-window 3 '())
(rolling-window 0 '(a b c))
Output:
'((a b c) (b c d) (c d e) (d e f) (e f g))
'()
'(() () () ()) ; lack of spec makes this ok !
Following modification of OP's function works. It includes an outlist for which the initial default is empty list. Sublists are added to this outlist till (length l) is less than size.
(define (rolling-window l size (ol '()))
(if (< (length l) size) (reverse ol)
(rolling-window (cdr l) size (cons (take l size) ol))))
Testing:
(rolling-window '(1 2 3 4 5 6) 2)
(rolling-window '(1 2 3 4 5 6) 3)
(rolling-window '(1 2 3 4 5 6) 4)
Output:
'((1 2) (2 3) (3 4) (4 5) (5 6))
'((1 2 3) (2 3 4) (3 4 5) (4 5 6))
'((1 2 3 4) (2 3 4 5) (3 4 5 6))
Any improvements on this one?
(define (rolling-window l size)
(cond ((eq? l '()) '())
((< (length l) size) '())
((cons (take l size) (rolling-window (cdr l) size)))))
I need to write for school a function that can calculate numbers and ignore the letters. Do I need to make a case for every operation? I don't know how to start. For example:
(+ 1 A 2 X) = (3 A X)
(- A 5 1 A) = 4
(* 2 C 0) = 0
So I have done a part of the problem. The 2 functions DELNUM and DELSYM are for deleting the numbers respectively the symbol from a list. It's all working now, just for example like (- A 5 A) -> 5 isn't, because I need some conditions for that.
(defun delnum (l)
(remove-if-not #'symbolp l))
(delnum '(4 S 56 h ))
;;-> (S H)
(defun delsym (l)
(remove-if-not #'numberp l))
(delsym '(+ a 1 2 3 b))
;;-> (1 2 3)
(defun test (l)
(cond
((null l) nil)
((case (car l)
(+ (cons (apply #'+ (delsym l)) (delnum (cdr l))))
(- (cons (apply #'- (delsym l)) (delnum (cdr l))))
(* (cond ((eql (apply #'* (delsym l)) 0) 0)
( t (cons (apply #'* (delsym l)) (delnum (cdr l))))))
(/ (cond ((eql (car (delsym l)) 0) '(error division by zero))
((eql (find 0 (delsym l)) 0) '(error division by zero))
(t (cons (apply #'/ (delsym l)) (delnum (cdr l))))))))))
(test '(/ 0 )) ;-> (ERROR DIVISION BY ZERO)
(test '(+ 1 2 A)) ;-> (3 A)
(test '(- 6 5 A C)) ;-> (1 AC)
(test '(- 1 5 A C X 0)) ;-> (-4 A C X)
(test '(* 0 5 A C)) ;-> 0
(test '(* 10 5 A C)) ;-> (50 A C)
(test '(/ 12 0 V 1 2)) ;-> (ERROR DIVISION BY ZERO)
(test '(/ S 3 7 C)) ;-> (3/7 S C)
(test '(+ -A A 5)) ;-> it gotta display 5 or (5)
I wrote a program, that given two numbers that specify a range, should return the number (count) of numbers in that range that represented in octal form consist of a number of identical digits. For example 72->111 meets this criteria, because all the digits are the same. Examples of output:
(hw11 1 8) -> 7,(hw11 1 9) -> 8,(hw11 1 18) -> 9,(hw11 1 65) -> 14, and so on...
My problem is that to be correct my program must define only 2 procedures, and at the moment I have much more than that and have no idea how to make them less. So any help with rewriting the code is welcomed :). The code is below:
(define (count-digits n)
(if (<= n 0)
0
(+ 1 (count-digits (quotient n 10)))))
(define (toOct n)
(define (helper n octNumber i)
(if(<= n 0)
octNumber
(helper (quotient n 8)
(+ octNumber
(* (expt 10 i)
(remainder n 8)))
(+ i 1))))
(helper n 0 0))
(define (samedigits n)
(define (helper n i)
(if (<= n 0)
#t
(if (not (remainder n 10) i))
#f
(helper (quotient n 10) i))))
(helper n (remainder n 10))
)
(define (hw11 a b)
(define (helper a x count)
(if (> a x)
count
(if (samedigits (toOct x))
(helper a (- x 1) (+ count 1))
(helper a (- x 1) count))))
(helper a b 0))
You probably have restrictions and you didn't state which Scheme implementation you're using; the following is an example that has been tested on Racket and Guile:
(define (hw11 a b)
(define (iter i count)
(if (<= i b)
(let* ((octal (string->list (number->string i 8)))
(allc1 (make-list (length octal) (car octal))))
(iter (+ i 1) (if (equal? octal allc1) (+ count 1) count)))
count))
(iter a 0))
Testing:
> (hw11 1 8)
7
> (hw11 1 9)
8
> (hw11 1 18)
9
> (hw11 1 65)
14
I was asked to write a procedure that computes elements of Pascal's triangle by means of a recursive process. I may create a procedure that returns a single row in the triangle or a number within a particular row.
Here is my solution:
(define (f n)
(cond ((= n 1) '(1))
(else
(define (func i n l)
(if (> i n)
l
(func (+ i 1) n (cons (+ (convert (find (- i 1) (f (- n 1))))
(convert (find i (f (- n 1)))))
l))))
(func 1 n '()))))
(define (find n l)
(define (find i n a)
(if (or (null? a) (<= n 0))
'()
(if (>= i n)
(car a)
(find (+ i 1) n (cdr a)))))
(find 1 n l))
(define (convert l)
(if (null? l)
0
(+ l 0)))
This seems to work fine but it gets really inefficient to find elements of a larger row starting with (f 8). Is there a better procedure that solves this problem by means of a recursive process?
Also, how would I write it, if I want to use an iterative process (tail-recursion)?
There are several ways to optimize the algorithm, one of the best would be to use dynamic programming to efficiently calculate each value. Here is my own solution to a similar problem, which includes references to better understand this approach - it's a tail-recursive, iterative process. The key point is that it uses mutation operations for updating a vector of precomputed values, and it's a simple matter to adapt the implementation to print a list for a given row:
(define (f n)
(let ([table (make-vector n 1)])
(let outer ([i 1])
(when (< i n)
(let inner ([j 1] [previous 1])
(when (< j i)
(let ([current (vector-ref table j)])
(vector-set! table j (+ current previous))
(inner (add1 j) current))))
(outer (add1 i))))
(vector->list table)))
Alternatively, and borrowing from #Sylwester's solution we can write a purely functional tail-recursive iterative version that uses lists for storing the precomputed values; in my tests this is slower than the previous version:
(define (f n)
(define (aux tr tc prev acc)
(cond ((> tr n) '())
((and (= tc 1) (= tr n))
prev)
((= tc tr)
(aux (add1 tr) 1 (cons 1 acc) '(1)))
(else
(aux tr
(add1 tc)
(cdr prev)
(cons (+ (car prev) (cadr prev)) acc)))))
(if (= n 1)
'(1)
(aux 2 1 '(1 1) '(1))))
Either way it works as expected for larger inputs, it'll be fast for n values in the order of a couple of thousands:
(f 10)
=> '(1 9 36 84 126 126 84 36 9 1)
There are a number of soluitons presented already, and they do point out that usign dynamic programming is a good option here. I think that this can be written a bit more simply though. Here's what I'd do as a straightforward list-based solution. It's based on the observation that if row n is (a b c d e), then row n+1 is (a (+ a b) (+ b c) (+ c d) (+ d e) e). An easy easy to compute that is to iterate over the tails of (0 a b c d e) collecting ((+ 0 a) (+ a b) ... (+ d e) e).
(define (pascal n)
(let pascal ((n n) (row '(1)))
(if (= n 0) row
(pascal (- n 1)
(maplist (lambda (tail)
(if (null? (cdr tail)) 1
(+ (car tail)
(cadr tail))))
(cons 0 row))))))
(pascal 0) ;=> (1)
(pascal 1) ;=> (1 1)
(pascal 2) ;=> (1 2 1)
(pascal 3) ;=> (1 3 3 1)
(pascal 4) ;=> (1 4 6 4 1)
This made use of an auxiliary function maplist:
(define (maplist function list)
(if (null? list) list
(cons (function list)
(maplist function (cdr list)))))
(maplist reverse '(1 2 3))
;=> ((3 2 1) (3 2) (3))
Am in on the right track for programming the knapsack problem in scheme? My program doesn't have to account for objects "values" , only their weights. The goal is to take the best combination of items so that I have approximately half of the weight in my bag.
(define (split-equip wlst)
(define (sum lst)
(define (sum-h accum lst1)
(if (null? lst)
(/ accum (length lst))
(sum-h (+ (car lst1) accum) (cdr lst1))))
(sum-h 0 lst))
(define (split-equip-h)
(let ((target-w (/ (sum wlst) 2)))
I am tempted to write my program to output a list with all of the different combinations of weights possible and then traversing the list until I find the best set of weights, but not sure how to implement this.
Since this is already your second attempt at this (the first question was deleted), I'll show you a solution in Racket. You should read it like pseudo-code and translate it into the Scheme variant you have been taught.
Disclaimer: I suck at these kind of exercises. That should be another reason for you to understand and reformulate this. But the results of my code still seem correct.
Here's the code:
#lang racket
(define (knapsack lst)
(define half (/ (apply + lst) 2)) ; compute half of total
(printf "list : ~a\nhalf : ~a\n" lst half)
(define (combs lst1 (lst2 null)) ; compute all the combinations
(if (null? lst1)
(if (null? lst2)
null
(list (reverse lst2)))
(append
(combs (cdr lst1) lst2) ; case 1 -> we don't carry the iten
(combs (cdr lst1) (cons (car lst1) lst2))))) ; case 2 -> we do
(for/fold ((delta half) (res null)) ((c (in-list (combs lst)))) ; determine the best fit
(let* ((sm (apply + c)) (newdelta (abs (- half sm))))
(cond
((< newdelta delta) (values newdelta (list c)))
((= newdelta delta) (values delta (cons c res)))
(else (values delta res))))))
(time
(let-values (((delta res) (knapsack (cdr (range 0 24 3)))))
(printf "result: ~a\ndelta : ~a\n" res delta)))
and here's what it says:
list : (3 6 9 12 15 18 21)
half : 42
result: ((3 6 12 21) (3 6 15 18) (3 9 12 18) (3 18 21) (6 9 12 15) (6 15 21) (9 12 21) (9 15 18))
delta : 0
cpu time: 6 real time: 5 gc time: 0
Hope this helps. Don't hesitate to ask questions if there's something you don't get!