I am trying to multiply in Scheme using recursion, and I am able to do so with positive numbers but not negatives (they get stuck in an infinite loop). I assume the problem comes in the 3rd and 4th lines, which I wrote in an attempt to be able to handle negatives. Any help would be appreciated :)
(define Multiply(lambda (x y)
(if (eq? x 0) 0 (if (eq? y 0) 0 ;if either x or y are zero, return 0
(if (> 0 x) (- 0 (+ x (Multiply x (- y 1))))
(if (> 0 y) (- 0 (+ x (Multiply x (- y 1))))
(+ x (Multiply x (- y 1)))))))))
Since multiplication is associative, you can have
x * (-1 * y) = (x * -1) * y
With this in mind, you can convert y to positive whenever it is less than zero, by multiplying both x and y with -1.
Consider the following:
(define (multiply x y)
(cond
((zero? x) 0)
((zero? y) 0)
((< y 0)
(multiply (- x) (- y)))
(else
(+ x (multiply x (sub1 y))))))
Related
I'm starting to coding in Scheme and I wan't to know if a number is "abundante". A number x is "abundante" if the sum of its dividers is greater than the double of x.
So this is my code:
#lang scheme
(define (abundante x)
(cond
((= x 0) #f)
((= x 1) #f)
((> (apply +(divisores x)) (doble x)) #t)
(else #f)
)
)
;aux functions
(define (doble x) (* x 2))
(define (divisores x)
(cond
((= x 1) '(1))
(else (cons 1 (divisores-aux x 2)))
)
)
(define (divisores-aux x y)
(cond
((= x y) '(x))
((integer? (/ x y))(cons y (divisores-aux x (+ y 1))))
(else (divisores-aux x (+ y 1)))
)
)
As you can see, I have 3 auxiliary functions:
1) Doble x: Return the double of x
2) Divisores x: Return the dividers of x
2.1) Divisores-aux x y: Check if x/y is a integer number, then goes for y+1
But I got the problem when Divisores-aux reach x = y. I want to return x because x its a divider of itself but DrRacket prints the follow error:
+: contract violation
expected: number?
given: y
argument position: 6th
other arguments...:
And indicates me that the error was produced on apply +(divisores x)
If I return null or '() everything goes fine, but obviously I don't get the correct result.
Thanks in advance
There's a bug in the base case of divisores-aux, in here:
'(x)
The above expression will return a list with the symbol x as its single member (to understand why, read about quoting in the docs). What you meant to say was this, that creates a list with the value of the x variable:
(list x)
Also, it's better to use remainder to test if a number is divided by another. This should fix the issues:
(define (divisores-aux x y)
(cond
((= x y) (list x))
((zero? (remainder x y)) (cons y (divisores-aux x (+ y 1))))
(else (divisores-aux x (+ y 1)))))
Now abundante works as expected:
(abundante 42)
=> #t
(abundante 45)
=> #f
Structure and Interpretation of Computer Programs gives this implementation of Ackermann's function:
(define (A x y)
(cond ((= y 0) 0)
((= x 0) (* 2 y))
((= y 1) 2)
(else (A (- x 1) (A x (- y 1))))))
Exercise 1.10 asks for the "concise mathematical definitions" of the following functions that call A:
(define (f n) (A 0 n))
(define (g n) (A 1 n))
(define (h n) (A 2 n))
The outputs of f and g for integers 1 - 4 are recognizable as 2n and 2^n. But h is 2^(2^n-1), a formula I could not recognize just by looking for a pattern in the outputs. How is one meant to complete this exercise? Is there a method for deriving the mathematical notation, perhaps based on the notation for Ackermann's function?
The book has already introduced the substitution method, so it's not wrong to use that.
Start with (A 0 n)
This is
(cond ((= n 0) 0)
((= 0 0) (* 2 n))
((= 0 1) 2)
(else (A (- 0 1) (A 0 (- n 1)))))
which is clearly 2n.
Next, (A 1 n) is
(cond ((= n 0) 0)
((= 1 0) (* 2 n))
((= n 1) 2)
(else (A (- 1 1) (A 1 (- n 1))))))
which is
(A 0 (A 1 (- n 1)))
or, taking advantage of the previous step,
(* 2 (A 1 (- n 1))
That is,
A 1 n = 2 * (A 1 (n-1))
= 2 * 2 * (A 1 (n-2))
= ...
Since we know that A x 1 = 2 for all x, we see that
A 1 n = 2 * 2 * ... * 2
with n factors, i.e. 2n.
Applying similar reasoning to the last case left as an exercise.
Having already figured out that (f n) = (* 2 n) and (g n) = (expt 2 n) we can use that information along with the definition of A to figure out what (A 2 n) will be:
Putting in x=2:
(define (A2 y)
(cond ((= y 0) 0)
((= y 1) 2)
(else (A 1 (A2 (- y 1))))))
Putting in the fact (A 1 n) = (expt 2 n)
(define (A2 y)
(cond ((= y 0) 0)
((= y 1) 2)
(else (expt 2 (A2 (- y 1))))))
from this you can see the recursion pattern more clearly that A2 gives nested powers of two like 2^(2^(2^2)). I think your answer 2^(2^n-1) may be wrong.
You can use scheme itself to help find answers to this:
(define (*^ x y) `(* ,x ,y))
(define (A x y)
(cond ((= y 0) 0)
((= x 0) (*^ 2 y))
((= y 1) 2)
(else (A (- x 1) (A x (- y 1))))))
;> (A 0 100)
;'(* 2 100)
;> (A 0 234)
;'(* 2 234)
suggests (A 0 n) = (* 2 n).
(define (*^ x y) `(* ,x ,y))
(define (A x y)
(cond ((= x 0) (*^ 2 y))
((= y 0) 0)
((= y 1) 2)
(else (A (- x 1) (A x (- y 1))))))
;> (A 1 10)
;'(* 2 (* 2 (* 2 (* 2 (* 2 (* 2 (* 2 (* 2 (* 2 2)))))))))
;> (A 1 5)
;'(* 2 (* 2 (* 2 (* 2 2))))
reordered the rules to avoid an error. we can see its doing *2 n times, so 2^n.
(define (*^ x y) `(* ,x ,y))
(define (A x y)
(cond ((= x 0) (*^ 2 y))
((= x 1) `(expt 2 ,y))
((= y 0) 0)
((= y 1) 2)
(else (A (- x 1) (A x (- y 1))))))
;> (A 2 5)
;'(expt 2 (expt 2 (expt 2 (expt 2 2))))
;> (A 2 6)
;'(expt 2 (expt 2 (expt 2 (expt 2 (expt 2 2)))))
This confirms the idea that we get a tower of exponents.
foo(x Y) is a procedure that has to solve this problem in the
Picture.
Here is my Scheme Code:
(define foo
(lambda (x y)
(if (<= y 0) (x) 0)
(if (<= x 0) (y) 0)
(if (>= x y) (+ x foo ((- x 1) (- y 2))) 0)
(if (< x y) (+ y foo ((- x 2) (- y 3))) 0)))
when it test it for (foo 5 6) => it prints the same exact numbers, instead of 12 !! I don't know why it is not going through the recursive call..
There is no recursive calls here. For it to be a call you need to have parentheses around it like (foo (- x 2) (- y 3))
Only the last if is regarded as becoming the result of the procedure. All the previous ones return a value and since it's not the last it discards the result and continues to the next. In order for several conditions to mean something they must be nested. Thus instead of the 0 you put the entire next if.
(define (foo x y)
(if (<= x 0)
x
(if (<= y 0)
y
...)))
There is also cond that makes a flatter structure that works as if-elseif-else in other languages.
(define (foo x y)
(cond
((<= x 0) x)
((<= y 0) y)
...
(else ...)))
I wanted to tell sbcl that the following function will only be called with fixnum values for which the result fits in a fixnum:
(defun layer (x y z n)
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
My first attempt was to do
(defun layer (x y z n)
(declare (fixnum x y z n))
(the fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
But that return type declaration doesn't promise that all intermediate results will also be fixnums, as I found out by looking at the wonderfully useful compilation notes sbcl produced. So then I did this:
(defmacro fixnum+ (&rest args)
(reduce
(lambda (x y) `(the fixnum (+ ,x ,y)))
args))
(defmacro fixnum* (&rest args)
(reduce
(lambda (x y) `(the fixnum (* ,x ,y)))
args))
(defun layer (x y z n)
(declare (fixnum x y z n))
(fixnum+ (fixnum* 2 (fixnum+ (fixnum* x y) (fixnum* y z) (fixnum* x z)))
(fixnum* 4 (fixnum+ x y z n -2) (the fixnum (1- n)))))
And that worked just fine. My question is: is there an easier, more idiomatic way to do this?
For example, maybe I can redeclare the types of +, -, *, 1- to promise fixnum results? (I know that's a bad idea in general, but I might want to do it in certain programs.) CHICKEN scheme has (declare (fixnum-arithmetic)) that does what I want: it (unsafely) assumes that the results of all arithmetic operations on fixnums are fixnums.
You can declare types for functions using FTYPE.
Example:
(defun foo (a b)
(declare (ftype (function (&rest fixnum) fixnum) + * 1-)
(type fixnum a b)
(inline + * 1-)
(optimize (speed 3) (safety 0) (debug 0) (space 0)))
(+ a (* a (1- b))))
Does that make a difference?
In his book ANSI Common Lisp, Paul Graham shows the macro with-type, that wraps an expression and all its sub-expressions inthe forms, also ensuring that operators given more than two arguments are properly handled.
E.g. (with-type fixnum (+ 1 2 3)) will expand to the form
(the fixnum (+ (the fixnum (+ (the fixnum 1) (the fixnum 2)))
(the fixnum 3))
The code for the macro with helper functions is
(defmacro with-type (type expr)
`(the ,type ,(if (atom expr)
expr
(expand-call type (binarize expr)))))
(defun expand-call (type expr)
`(,(car expr) ,#(mapcar #'(lambda (a)
`(with-type ,type ,a))
(cdr expr))))
(defun binarize (expr)
(if (and (nthcdr 3 expr)
(member (car expr) '(+ - * /)))
(destructuring-bind (op a1 a2 . rest) expr
(binarize `(,op (,op ,a1 ,a2) ,#rest)))
expr))
A link to the code from the book in found at http://www.paulgraham.com/acl.html
A comment in the code states that "This code is copyright 1995 by Paul Graham, but anyone who wants
to use it is free to do so."
Try this:
(defun layer (x y z n)
(declare (optimize speed) (fixnum x y z n))
(logand most-positive-fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
See SBCL User Manual, Sec 6.3 Modular arithmetic.
Edit:
As mentioned in the comments, SBCL-1.1.9 (or later) is required for this to work. Also, it's possible to shave another ~40% time off by inlining the subroutines:
;;; From: https://gist.github.com/oantolin/6073417
(declaim (optimize (speed 3) (safety 0)))
(defmacro with-type (type expr)
(if (atom expr)
expr
(let ((op (car expr)))
(reduce
(lambda (x y)
`(the ,type
(,op ,#(if x (list x) '())
(with-type ,type ,y))))
(cdr expr)
:initial-value nil))))
(defun layer (x y z n)
(declare (fixnum x y z n))
(with-type fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(defun cubes (n)
(declare (fixnum n))
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n) do
(incf (elt count (layer x y z k)))))))
count))
(defun first-time (x)
(declare (fixnum x))
(loop for n of-type fixnum = 1000 then (* 2 n)
for k = (position x (cubes n))
until k
finally (return k)))
;;; With modarith and inlining
(defun first-time/inline (x)
(declare (fixnum x))
(labels
((layer (x y z n)
(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(cubes (n)
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n)
do (incf (elt count (layer x y z k)))))))
count)))
(declare (inline layer cubes))
(loop for n of-type fixnum = 1000 then (* 2 n)
thereis (position x (cubes n)))))
#+(or)
(progn
(time (print (first-time 1000)))
(time (print (first-time/inline 1000))))
;; 18522
;; Evaluation took:
;; 0.448 seconds of real time
;; 0.448028 seconds of total run time (0.448028 user, 0.000000 system)
;; 100.00% CPU
;; 1,339,234,815 processor cycles
;; 401,840 bytes consed
;;
;;
;; 18522
;; Evaluation took:
;; 0.259 seconds of real time
;; 0.260016 seconds of total run time (0.260016 user, 0.000000 system)
;; 100.39% CPU
;; 776,585,475 processor cycles
;; 381,024 bytes consed
Declaring the layer function inline results in a much faster speed even when block compilation is on.
On my Apple Air M1 with layer inlined and block compilation on it runs in 0.06 second under the Arm64 version of SBCL 2.1.2.
CL-USER> (time (first-time 1000))
Evaluation took:
0.060 seconds of real time
0.060558 seconds of total run time (0.060121 user, 0.000437 system)
101.67% CPU
303,456 bytes consed
I've just remembered that declaring the count array in cube should help as well.
(declare (type (simple-array fixnum (*)) count))
Without inlining the layer function it is around 0.2 second.
CL-USER> (time (first-time 1000))
Evaluation took:
0.201 seconds of real time
0.201049 seconds of total run time (0.200497 user, 0.000552 system)
100.00% CPU
251,488 bytes consed
Or converting the layer function to a macro makes it even faster.
(defmacro layer (x y z n)
(declare (fixnum x y z n))
`(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* ,x ,y) (* ,y ,z) (* ,x ,z)))
(* 4 (+ ,x ,y ,z ,n -2) (1- ,n)))))
CL-USER> (time (first-time 1000))
Evaluation took:
0.047 seconds of real time
0.047032 seconds of total run time (0.046854 user, 0.000178 system)
100.00% CPU
312,576 bytes consed
Benchmarked with trivial-benchmark on average it runs just bellow 0.04 second:
CL-USER> (benchmark:with-timing (100) (first-time 1000))
- SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION
REAL-TIME 100 3.985173 0.039528 0.06012 0.039595 0.039852 0.002046
RUN-TIME 100 3.985848 0.039534 0.06014 0.039605 0.039858 0.002048
USER-RUN-TIME 100 3.975407 0.039466 0.059829 0.039519 0.039754 0.002026
SYSTEM-RUN-TIME 100 0.010469 0.00005 0.000305 0.000088 0.000105 0.00005
PAGE-FAULTS 100 0 0 0 0 0 0.0
GC-RUN-TIME 100 0 0 0 0 0 0.0
BYTES-CONSED 100 50200736 273056 504320 504320 502007.38 23010.477
EVAL-CALLS 100 0 0 0 0 0 0.0
I'm trying to learn some functional programming and am doing project euler problems in scheme (racket) to get me started. I'm currently on problem 15 and I think I have a correct function for computing the number of paths in the lattice. Problem is that for large number of gridSize the function takes very long time to run.
(define uniqueTraverse
(lambda (x y gridSize)
(cond
((and (eq? x gridSize) (eq? y gridSize)) 1)
((eq? x gridSize) (uniqueTraverse x (+ y 1) gridSize))
((eq? y gridSize) (uniqueTraverse (+ x 1) y gridSize))
(else (+ (uniqueTraverse (+ x 1) y gridSize)
(uniqueTraverse x (+ y 1) gridSize))))))
I'm trying to figure out how to make this function tail call recursive but I don't know how to do it. I need some help getting started on how to think about optimizing functions like this using tail call optimization.
The problem is that you recompute the same results over and over again.
To solve this, you don't need tail calls - you need to remember old
results and return them without recomputing them. This technique is called memoization.
This is one solution:
#lang racket
(define old-results (make-hash))
(define uniqueTraverse
(lambda (x y gridSize)
(define old-result (hash-ref old-results (list x y) 'unknown))
(cond
; if the result is unknown, compute and remember it
[(eq? old-result 'unknown)
(define new-result
(cond
((and (eq? x gridSize) (eq? y gridSize)) 1)
((eq? x gridSize) (uniqueTraverse x (+ y 1) gridSize))
((eq? y gridSize) (uniqueTraverse (+ x 1) y gridSize))
(else (+ (uniqueTraverse (+ x 1) y gridSize)
(uniqueTraverse x (+ y 1) gridSize)))))
(hash-set! old-results (list x y) new-result)
new-result]
; otherwise just return the old result
[else old-result])))
(uniqueTraverse 0 0 2)
Memoization is one way, another is to use a different data representation.
I used the grid represented as a matrix, or vector of vectors.
Then set the value of the top row to 1 (as there is only on path on the top edge.
After that the next row ther first of the row is one, the second is the value of the entry in the column one above, plus the entry of or value before it in the row,
Recurse for each of the points in the row, and then for each row.
The answer then is the last point in the last row when you are done recursing.
For a 3x3 grid
1 1 1
1 2 3
1 3 6
6
Where the keys are very close together, (continuous, or nearly so) a vector representation is going to be more performant than a hash.
(define (make-lattice-point-square n)
(let ((lps (make-vector (+ n 1))))
(let loop ((i 0))
(if (> i n)
lps
(begin
(vector-set! lps i (make-vector (+ n 1)))
(loop (++ i)))))))
(define (lattice-ref lat x y)
;; where x is row, y is column thought it's not really important
(vector-ref (vector-ref lat y) x))
(define (lattice-set! lat x y value)
(vector-set! (vector-ref lat y) x value))
;; paths through a point are equal the the paths through the above point,
;; plus the paths through the left, those along the top and left edges
;; only have one possible path through them
(define (ways-exit-lattice n)
(let ((lps (make-lattice-point-square n)))
(letrec
((helper
(lambda (x y)
(if (or (= x 0) (= y 0))
(lattice-set! lps x y 1)
(lattice-set! lps x y
(+ (lattice-ref lps (- x 1) y)
(lattice-ref lps x (- y 1)))))))
(lattice-walker
(lambda (x y)
(cond ((and (= x n) (= y n))
(begin (helper x y) (lattice-ref lps x y)))
((= y n)
(begin
(helper x y)
(lattice-walker (++ x) 0)))
(else
(begin
(helper x y)
(lattice-walker x (++ y))))))))
(lattice-walker 0 0))))
notice all the calls to latice-walker are tail calls.
using RSR5 compliant scheme