What is a smallest set of indices that allows to fully bind any pattern of 6-tuple in one hop? - algorithm

I am trying to build a 6-tuple store on top of wiredtiger. The tuples can be described as follow:
(graph, subject, predicate, object, alive, transaction)
Every tuple stored in the database is unique.
Queries are like regular SPARQL queries except that the database store 6 tuples.
Zero of more elements of a tuple can be variable. Here is an example query that allows to retrieve all changes introduces by a particular transaction P4X432:
SELECT ?graph ?subject ?predicate ?object ?alive
WHERE
{
?graph ?subject ?predicate ?object ?alive "P4X432"
}
Considering all possible patterns ends up with considering all combinations of:
(graph, subject, predicate, object, alive, transaction)
That is given by the following function:
def combinations(tab):
out = []
for i in range(1, len(tab) + 1):
out.extend(x for x in itertools.combinations(tab, i))
assert len(out) == 2**len(tab) - 1
return out
Where:
print(len(combinations(('graph', 'subject', 'predicate', 'object', 'alive', 'transaction'))))
Display:
63
That is there 63 combinations of the 6-tuples. I can complete each indices with the missing tuple item, e.g. the following combination:
('graph', 'predicate', 'transaction')
Will be associated with the following index:
('graph', 'predicate', 'transaction', 'subject', 'alive', 'object')
But I know there is a smaller subset of all permutations of the 6-tuple that has the following property:
A set of n-permutations of {1, 2, ..., n} where all combinations of {1, 2, ..., n} are prefix-permutation of at least one element of the set.
Otherwise said, all combinations have a permutation that is prefix of one element of the set.
I found using a brute force algorithm a set of size 25 (inferior to 63) that has that property:
((5 0 1 2 3 4) (4 5 0 1 2 3) (3 4 5 0 1 2) (2 3 4 5 0 1) (1 2 3 4 5 0) (0 1 2 3 4 5) (0 2 1 3 4 5) (0 3 2 1 5 4) (0 4 3 1 5 2) (0 4 2 3 1 5) (2 1 5 3 0 4) (3 2 1 5 0 4) (3 1 4 5 0 2) (3 1 5 4 2 0) (3 0 1 4 2 5) (3 5 2 0 1 4) (4 3 1 0 2 5) (4 2 1 5 3 0) (4 1 0 2 5 3) (4 5 2 1 0 3) (5 4 1 2 3 0) (5 3 0 1 4 2) (5 2 1 3 4 0) (5 1 2 4 0 3) (5 0 2 4 3 1))
Here is the r7rs scheme program I use to compute that solution:
(define-library (indices)
(export indices)
(export permutations)
(export combination)
(export combinations)
(export run)
(import (only (chezscheme) trace-define trace-lambda random trace-let))
(import (scheme base))
(import (scheme list))
(import (scheme comparator))
(import (scheme hash-table))
(import (scheme process-context))
(import (scheme write))
(begin
(define (combination k lst)
(cond
((= k 0) '(()))
((null? lst) '())
(else
(let ((head (car lst))
(tail (cdr lst)))
(append (map (lambda (y) (cons head y)) (combination (- k 1) tail))
(combination k tail))))))
(define (factorial n)
(let loop ((n n)
(out 1))
(if (= n 0)
out
(loop (- n 1) (* n out)))))
(define (%binomial-coefficient n k)
;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula
(let loop ((i 1)
(out 1))
(if (= i (+ k 1))
out
(loop (+ i 1) (* out (/ (- (+ n 1) i) i))))))
(define (memo proc)
(let ((m (make-hash-table (make-equal-comparator))))
(lambda args
(if (hash-table-contains? m args)
(hash-table-ref m args)
(let ((v (apply proc args)))
(hash-table-set! m args v)
v)))))
(define binomial-coefficient
(memo
(lambda (n k)
(cond
((= n k) 1)
((= k 0) 1)
(else (%binomial-coefficient n k))))))
;; k-combination ranking and unranking procedures according to
;; https://en.wikipedia.org/wiki/Combinatorial_number_system
(define (ranking lst)
(let loop ((lst (sort < lst)) ;; increasing sequence
(k 1)
(out 0))
(if (null? lst)
out
(loop (cdr lst) (+ k 1) (+ out (binomial-coefficient (car lst) k))))))
(define (%unranking k N)
(let loop ((n (- k 1)))
(if (< N (binomial-coefficient (+ n 1) k))
n
(loop (+ n 1)))))
(define (unranking k N)
(let loop ((k k)
(N N)
(out '()))
(if (= k 0)
out
(let ((m (%unranking k N)))
(loop (- k 1) (- N (binomial-coefficient m k)) (cons m out))))))
(define fresh-random
(let ((memo (make-hash-table (make-eqv-comparator))))
(lambda (n)
(when (= (hash-table-size memo) n)
(error 'oops "no more fresh number" n
))
(let loop ()
(let ((r (random n)))
(if (hash-table-contains? memo r)
(loop)
(begin (hash-table-set! memo r #t) r)))))))
(define (random-k-combination k n)
(unranking k (fresh-random (binomial-coefficient n k))))
(define (combinations lst)
(if (null? lst) '(())
(let* ((head (car lst))
(tail (cdr lst))
(s (combinations tail))
(v (map (lambda (x) (cons head x)) s)))
(append s v))))
;; (define (combinations lst)
;; (append-map (lambda (k) (combination k lst)) (iota (length lst))))
(define (permutations s)
;; http://rosettacode.org/wiki/Permutations#Scheme
(cond
((null? s) '(()))
((null? (cdr s)) (list s))
(else ;; extract each item in list in turn and permutations the rest
(let splice ((l '()) (m (car s)) (r (cdr s)))
(append
(map (lambda (x) (cons m x)) (permutations (append l r)))
(if (null? r) '()
(splice (cons m l) (car r) (cdr r))))))))
(define (shift lst index)
(append (drop lst index) (take lst index)))
(define (rotations lst)
(reverse! (map (lambda (index) (shift lst index)) (iota (length lst)))))
(define (prefix? lst other)
"Return #t if LST is prefix of OTHER"
(let prefix ((lst lst)
(other other))
(if (null? lst)
#t
(if (= (car lst) (car other))
(prefix (cdr lst) (cdr other))
#f))))
(define (indices lst)
(let ((candidates (permutations lst)))
(let loop ((out (rotations lst)) ;; all rotations are solutions
(combinations (combinations lst)))
(if (null? combinations)
(reverse! out)
(let ((permutations (permutations (car combinations))))
(if (any (lambda (s) (any (lambda (p) (prefix? p s)) permutations)) out)
;; there is an existing "solution" for the
;; permutations of COMBINATION move to the next
;; combination
(loop out (cdr combinations))
(loop (cons (find (lambda (c) (if (member c out)
#f
(any (lambda (p) (prefix? p c)) permutations)))
candidates)
out)
(cdr combinations))))))))
(define (permutation-prefix? c o)
(any (lambda (p) (prefix? p o)) (permutations c)))
(define (ok? combinations candidate)
(every (lambda (c) (any (lambda (p) (permutation-prefix? c p)) candidate)) combinations))
(define (run)
(let* ((n (string->number (cadr (command-line))))
(N (iota n))
(solution (indices N))
(min (length solution))
(rotations (rotations N))
(R (length rotations))
;; other stuff
(cx (combinations N))
(px (filter (lambda (x) (not (member x rotations))) (permutations N)))
;; other other stuff
(pn (length px))
(PN (iota pn)))
(display "(length solution) => ") (display (length solution))
(display "\n")
(display "(length rotations) => ") (display R)
(display "\n")
(let try ((x (- (length solution) 1)))
(let ((count (binomial-coefficient pn (- x R))))
(let loop ((index 0)
(cxx (map (lambda (x) (list-ref px x)) (random-k-combination (- x R) pn))))
(when (= (modulo index (expt 10 5)) 0)
(display "n=") (display n) (display " x=") (display x)
(display " ")
(display index) (display "/") (display count) (display "\n"))
(let ((candidate (append rotations cxx)))
(let ((continue? (not (ok? cx candidate))))
(if continue?
(loop (+ index 1)
(map (lambda (x) (list-ref px x)) (random-k-combination (- x R) pn)))
(begin (display "new solution n=") (display n)
(display " length=") (display x)
(display " ") (display candidate)
(display "\n")
(try (- x 1)))))))))))
))
With that list of permutations I can query any pattern.
I am wondering if there is a smaller set and whether there is definitive algorithm to compute that kind of set.

Based on this answer https://math.stackexchange.com/a/3146793/23663
The following program yields a solution that is a minimal solution according to math ™:
import itertools
import math
f = math.factorial
bc = lambda n, k: f(n) // f(k) // f(n-k) if k<n else 0
def pk(*args):
print(*args)
return args[-1]
def stringify(iterable):
return ''.join(str(x) for x in iterable)
def combinations(tab):
out = []
for i in range(1, len(tab) + 1):
out.extend(stringify(x) for x in itertools.combinations(tab, i))
assert len(out) == 2**len(tab) - 1
return out
def ok(solutions, tab):
cx = combinations(tab)
px = [stringify(x) for x in itertools.permutations(tab)]
for combination in cx:
pcx = [''.join(x) for x in itertools.permutations(combination)]
# check for existing solution
for solution in solutions:
if any(solution.startswith(p) for p in pcx):
# yeah, there is an existing solution
break
else:
print('failed with combination={}'.format(combination))
break
else:
return True
return False
def run(n):
tab = list(range(n))
cx = list(itertools.combinations(tab, n//2))
for c in cx:
L = [(i, i in c) for i in tab]
A = []
B = []
while True:
for i in range(len(L) - 1):
if (not L[i][1]) and L[i + 1][1]:
A.append(L[i + 1][0])
B.append(L[i][0])
L.remove((L[i + 1][0], True))
L.remove((L[i][0], False))
break
else:
break
l = [i for (i, _) in L]
yield A + l + B
for i in range(7):
tab = stringify(range(i))
solutions = [stringify(x) for x in run(i)]
assert ok(solutions, tab)
print("n={}, size={}, solutions={}".format(i, len(solutions), solutions))
The above program output is:
n=0, size=1, solutions=['']
n=1, size=1, solutions=['0']
n=2, size=2, solutions=['01', '10']
n=3, size=3, solutions=['012', '120', '201']
n=4, size=6, solutions=['0123', '2031', '3012', '1230', '1302', '2310']
n=5, size=10, solutions=['01234', '20341', '30142', '40123', '12340', '13402', '14203', '23410', '24013', '34021']
n=6, size=20, solutions=['012345', '301452', '401253', '501234', '203451', '240513', '250314', '340521', '350124', '450132', '123450', '142503', '152304', '134502', '135024', '145032', '234510', '235104', '245130', '345210']

Related

Luhn algorithm in scheme

When I have a number in my list that is greater than 9 I want to separate the
digits and add them to the running sum.
The code I have is giving me and error in my sum-list definition.
(define sum-list (lst)
(if (null lst)
0
(if (>9 car lst?)
(cons ((mod (car lst) 10)) + (* (remainder (/car lst 10) 10))))
(if (>9 cdr lst?)
(cons ((mod (cdr lst)10)) + (* (remainder (/cdr lst 10) 10))))
(+ (car lst) (sum-list (cdr lst)))))
I am getting an error"Expected only one expression after the name sum-list but found one extra part.
I wrote this now in mit-scheme. I split the problem in 2 subproblems -- to conver the number to the list of digits and then to sum the digits in the resulting list.
(define n->l
(lambda (n return)
((lambda (s) (s s n return))
(lambda (s n col)
(if (zero? n)
(col '())
(s s
(quotient n 10)
(lambda (rest)
(col (cons (remainder n 10) rest)))))))))
(define sum-digits
(lambda (n)
(n->l n (lambda (l) (fold-left + 0 l)))))
(sum-digits 100)
(sum-digits 123)

How to find partitions of a list in Scheme

Say there is any given list in Scheme. This list is ‘(2 3 4)
I want to find all possible partitions of this list. This means a partition where a list is separated into two subsets such that every element of the list must be in one or the other subsets but not both, and no element can be left out of a split.
So, given the list ‘(2 3 4), I want to find all such possible partitions. These partitions would be the following: {2, 3} and {4}, {2, 4} and {3}, and the final possible partition being {3, 4} and {2}.
I want to be able to recursively find all partitions given a list in Scheme, but I have no ideas on how to do so. Code or psuedocode will help me if anyone can provide it for me!
I do believe I will have to use lambda for my recursive function.
I discuss several different types of partitions at my blog, though not this specific one. As an example, consider that an integer partition is the set of all sets of positive integers that sum to the given integer. For instance, the partitions of 4 is the set of sets ((1 1 1 1) (1 1 2) (1 3) (2 2) (4)).
The process is building the partitions is recursive. There is a single partition of 0, the empty set (). There is a single partition of 1, the set (1). There are two partitions of 2, the sets (1 1) and (2). There are three partitions of 3, the sets (1 1 1), (1 2) and (3). There are five partitions of 4, the sets (1 1 1 1), (1 1 2), (1 3), (2 2), and (4). There are seven partitions of 5, the sets (1 1 1 1 1), (1 1 1 2), (1 2 2), (1 1 3), (1 4), (2 3) and (5). And so on. In each case, the next-larger set of partitions is determined by adding each integer x less than or equal to the desired integer n to all the sets formed by the partition of n − x, eliminating any duplicates. Here's how I implement that:
Petite Chez Scheme Version 8.4
Copyright (c) 1985-2011 Cadence Research Systems
> (define (set-cons x xs)
(if (member x xs) xs
(cons x xs)))
> (define (parts n)
(if (zero? n) (list (list))
(let x-loop ((x 1) (xs (list)))
(if (= x n) (cons (list n) xs)
(let y-loop ((yss (parts (- n x))) (xs xs))
(if (null? yss) (x-loop (+ x 1) xs)
(y-loop (cdr yss)
(set-cons (sort < (cons x (car yss)))
xs))))))))
> (parts 6)
((6) (3 3) (2 2 2) (2 4) (1 1 4) (1 1 2 2) (1 1 1 1 2)
(1 1 1 1 1 1) (1 1 1 3) (1 2 3) (1 5))
I'm not going to solve your homework for you, but your solution will be similar to the one given above. You need to state your algorithm in recursive fashion, then write code to implement that algorithm. Your recursion is going to be something like this: For each item in the set, add the item to each partition of the remaining items of the set, eliminating duplicates.
That will get you started. If you have specific questions, come back here for additional help.
EDIT: Here is my solution. I'll let you figure out how it works.
(define range (case-lambda ; start, start+step, ..., start+step<stop
((stop) (range 0 stop (if (negative? stop) -1 1)))
((start stop) (range start stop (if (< start stop) 1 -1)))
((start stop step) (let ((le? (if (negative? step) >= <=)))
(let loop ((x start) (xs (list)))
(if (le? stop x) (reverse xs) (loop (+ x step) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (sum xs) (apply + xs)) ; sum of elements of xs
(define digits (case-lambda ; list of base-b digits of n
((n) (digits n 10))
((n b) (do ((n n (quotient n b))
(ds (list) (cons (modulo n b) ds)))
((zero? n) ds)))))
(define (part k xs) ; k'th lexicographical left-partition of xs
(let loop ((ds (reverse (digits k 2))) (xs xs) (ys (list)))
(if (null? ds) (reverse ys)
(if (zero? (car ds))
(loop (cdr ds) (cdr xs) ys)
(loop (cdr ds) (cdr xs) (cons (car xs) ys))))))
(define (max-lcm xs) ; max lcm of part-sums of 2-partitions of xs
(let ((len (length xs)) (tot (sum xs)))
(apply max (map (lambda (s) (lcm s (- tot s)))
(map sum (map (lambda (k) (part k xs))
(range (expt 2 (- len 1)))))))))
(display (max-lcm '(2 3 4))) (newline) ; 20
(display (max-lcm '(2 3 4 6))) (newline) ; 56
You can find all 2-partitions of a list using the built-in combinations procedure. The idea is, for every element of a (len-k)-combination, there will be an element in the k-combination that complements it, producing a pair of lists whose union is the original list and intersection is the empty list.
For example:
(define (2-partitions lst)
(define (combine left right)
(map (lambda (x y) (list x y)) left right))
(let loop ((m (sub1 (length lst)))
(n 1))
(cond
((< m n) '())
((= m n)
(let* ((l (combinations lst m))
(half (/ (length l) 2)))
(combine (take l half)
(reverse (drop l half)))))
(else
(append
(combine (combinations lst m)
(reverse (combinations lst n)))
(loop (sub1 m) (add1 n)))))))
then you can build the partitions as:
(2-partitions '(2 3 4))
=> '(((2 3) (4))
((2 4) (3))
((3 4) (2)))
(2-partitions '(4 6 7 9))
=> '(((4 6 7) (9))
((4 6 9) (7))
((4 7 9) (6))
((6 7 9) (4))
((4 6) (7 9))
((4 7) (6 9))
((6 7) (4 9)))
Furthermore, you can find the max lcm of the partitions:
(define (max-lcm lst)
(define (local-lcm arg)
(lcm (apply + (car arg))
(apply + (cadr arg))))
(apply max (map local-lcm (2-partitions lst))))
For example:
(max-lcm '(2 3 4))
=> 20
(max-lcm '(4 6 7 9))
=> 165
To partition a list is straightforward recursive non-deterministic programming.
Given an element, we put it either into one bag, or the other.
The very first element will go into the first bag, without loss of generality.
The very last element must go into an empty bag only, if such is present at that time. Since we start by putting the first element into the first bag, it can only be the second:
(define (two-parts xs)
(if (or (null? xs) (null? (cdr xs)))
(list xs '())
(let go ((acc (list (list (car xs)) '())) ; the two bags
(xs (cdr xs)) ; the rest of list
(i (- (length xs) 1)) ; and its length
(z '()))
(if (= i 1) ; the last element in the list is reached:
(if (null? (cadr acc)) ; the 2nd bag is empty:
(cons (list (car acc) (list (car xs))) ; add only to the empty 2nd
z) ; otherwise,
(cons (list (cons (car xs) (car acc)) (cadr acc)) ; two solutions,
(cons (list (car acc) (cons (car xs) (cadr acc))) ; adding to
z))) ; either of the two bags;
(go (list (cons (car xs) (car acc)) (cadr acc)) ; all solutions after
(cdr xs) ; adding to the 1st bag
(- i 1) ; and then,
(go (list (car acc) (cons (car xs) (cadr acc))) ; all solutions
(cdr xs) ; after adding
(- i 1) ; to the 2nd instead
z))))))
And that's that!
In writing this I was helped by following this earlier related answer of mine.
Testing:
(two-parts (list 1 2 3))
; => '(((2 1) (3)) ((3 1) (2)) ((1) (3 2)))
(two-parts (list 1 2 3 4))
; => '(((3 2 1) (4))
; ((4 2 1) (3))
; ((2 1) (4 3))
; ((4 3 1) (2))
; ((3 1) (4 2))
; ((4 1) (3 2))
; ((1) (4 3 2)))
It is possible to reverse the parts before returning, or course; I wanted to keep the code short and clean, without the extraneous details.
edit: The code makes use of a technique by Richard Bird, of replacing (append (g A) (g B)) with (g' A (g' B z)) where (append (g A) y) = (g' A y) and the initial value for z is an empty list.
Another possibility is for the nested call to go to be put behind lambda (as the OP indeed suspected) and activated when the outer call to go finishes its job, making the whole function tail recursive, essentially in CPS style.

How to create a list like (3 3 3 2 2 1)

I'm trying to create a list like (3 3 3 2 2 1).
my code:
(define Func
(lambda (n F)
(define L
(lambda (n)
(if (< n 0)
(list)
(cons n (L (- n 1))) )))
(L n) ))
what I need to add to get it?
thank you
I would break it down into three functions.
(define (repeat e n) (if (= n 0) '() (cons e (repeat e (- n 1)))))
(define (count-down n) (if (= n 0) '() (cons n (count-down (- n 1)))))
(define (f n) (apply append (map (lambda (n) (repeat n n)) (count-down n))))
(f 3); => '(3 3 3 2 2 1)
Flattening this out into a single function would require something like this:
(define (g a b)
(if (= a 0) '()
(if (= b 0)
(g (- a 1) (- a 1))
(cons a (g a (- b 1))))))
(define (f n) (g n n))
(f 3) ;=> '(3 3 3 2 2 1)
Here is a tail recursive version. It does the iterations in reverse!
(define (numbers from to)
(define step (if (< from to) -1 1))
(define final (+ from step))
(let loop ((to to) (down to) (acc '()))
(cond ((= final to) acc)
((zero? down)
(let ((n (+ to step)))
(loop n n acc)))
(else
(loop to (- down 1) (cons to acc))))))
(numbers 3 1)
; ==> (3 3 3 2 2 1)
To make this work in standard Scheme you might need to change the define to let* as it's sure step is not available at the time final gets evaluated.
I would use a simple recursive procedure with build-list
(define (main n)
(if (= n 0)
empty
(append (build-list n (const n)) (main (sub1 n)))))
(main 3) ;; '(3 3 3 2 2 1)
(main 6) ;; '(6 6 6 6 6 6 5 5 5 5 5 4 4 4 4 3 3 3 2 2 1)
And here's a tail-recursive version
(define (main n)
(let loop ((m n) (k identity))
(if (= m 0)
(k empty)
(loop (sub1 m) (λ (xs) (k (append (build-list m (const m)) xs)))))))
(main 3) ;; '(3 3 3 2 2 1)
(main 6) ;; '(6 6 6 6 6 6 5 5 5 5 5 4 4 4 4 3 3 3 2 2 1)
(define (range n m)
(if (< n m)
(let up ((n n)) ; `n` shadowed in body of named let `up`
(if (= n m) (list n)
(cons n (up (+ n 1))) ))
(let down ((n n))
(if (= n m) (list n)
(cons n (down (- n 1))) ))))
(define (replicate n x)
(let rep ((m n)) ; Named let eliminating wrapper recursion
(if (= m 0) '() ; `replicate` partial function defined for
(cons x ; zero-inclusive natural numbers
(rep (- m 1)) ))))
(define (concat lst)
(if (null? lst) '()
(append (car lst)
(concat (cdr lst)) )))
(display
(concat ; `(3 3 3 2 2 1)`
(map (lambda (x) (replicate x x)) ; `((3 3 3) (2 2) (1))`
(range 3 1) ))) ; `(3 2 1)`
Alternative to concat:
(define (flatten lst)
(if (null? lst) '()
(let ((x (car lst))) ; Memoization of `(car lst)`
(if (list? x)
(append x (flatten (cdr lst)))
(cons x (flatten (cdr lst))) ))))
(display
(flatten '(1 2 (3 (4 5) 6) ((7)) 8)) ) ; `(1 2 3 (4 5) 6 (7) 8)`

Function in scheme that takes list as an input and outputs a function

I am trying to create an function which takes list as an input and outputs a function . I am confused with the recursion calls that has to be made to traverse through the list.
(define S ( buildfunc '(1 0 -2 -3 4) ) )
Eg:
a function would be produced that takes as input an integer and
adds 1 to it
squares the result
multiplies the square by 2,
multiplies that last result by 3,
and adds 4
If (S 4) is the output function the result would be : 154
4 + 1 = 5 --> 25 --> 25 * 2 = 50 --> 50 * 3 = 150 --> 150 + 4 ==> 154
The code which i am currently using is :
(define (s n) (lambda (L) (buildfunc n L)))
(define (buildfunc n L)
(cond
((null? L) '())
((equal? (car L) 0) (* n n))
((positive? (car L)) (+ n (car L)))
((negative? (car L)) (* n (car L)))
(else
(buildfunc n (cdr L)))))
(define C (s 3))
(C '(1 0 -2 -3 4))
Hmm. Here's how I'd go about solving this:
(define (buildfunc cmds)
(define (process cmd value)
(cond ((zero? cmd) (* value value))
((positive? cmd) (+ value cmd))
((negative? cmd) (* value (- cmd)))))
(lambda (n)
(foldl process n cmds)))
Example usage:
> ((buildfunc '(1 0 -2 -3 4)) 4)
154
Update: you can certainly unroll the foldl into a manual loop, like so:
(define (buildfunc cmds)
(define (process cmd value)
(cond ((zero? cmd) (* value value))
((positive? cmd) (+ value cmd))
((negative? cmd) (* value (- cmd)))))
(lambda (n)
(let loop ((value n)
(cmds cmds))
(if (null? cmds)
value
(loop (process (car cmds) value) (cdr cmds))))))

How to find amicable pairs in scheme?

I am new in scheme.
How to find "amicable pais"?
(define (SumCD n)
(define s 1 )
(set! m (quotient n 2))
(while (<= i m)
(if (=(modulo n i) 0)
(set! s (+ s i)))
(set! i (+ i 1))
)
)
And in main program I want to check (if (m=SumCD n) and (n=SumCD m)) then m and n is a amicable pair.
How can I do this?
Excessive use of set! indicates an imperative style of programming, which is usually discouraged in Scheme. Here's a Racket-specific implementation of sum-of-divisors that does not use set! at all.
(define (sum-of-divisors n)
(define-values (q r) (integer-sqrt/remainder n))
(for/fold ((sum (if (and (zero? r) (> q 1)) (add1 q) 1)))
((i (in-range 2 q))
#:when (zero? (modulo n i)))
(+ sum i (quotient n i))))
Equivalent version in standard R6RS/R7RS Scheme, if you're not using Racket:
(define (sum-of-divisors n)
(define-values (q r) (exact-integer-sqrt n))
(let loop ((sum (if (and (zero? r) (> q 1)) (+ q 1) 1))
(i 2))
(cond ((>= i q) sum)
((zero? (modulo n i))
(loop (+ sum i (quotient n i)) (+ i 1)))
(else (loop sum (+ i 1))))))
Note that this is not equivalent to the set!-based version you have. What this code actually does is create an inner function, loop, that gets tail-called with new arguments each time.
Now, we can define amicable? and perfect? accordingly:
(define (amicable? n)
(define sum (sum-of-divisors n))
(and (not (= n sum))
(= n (sum-of-divisors sum))))
(define (perfect? n)
(= n (sum-of-divisors n)))
If you really want to test two numbers to see if they are an amicable pair, you can do this:
(define (amicable-pair? a b)
(and (not (= a b))
(= a (sum-of-divisors b))
(= b (sum-of-divisors a))))
Update for OP's new question about how to use this to find amicable pairs between m and n. First, let's define a variant of amicable? that returns a number's amicable "peer":
(define (amicable-peer n)
(define sum (sum-of-divisors n))
(and (not (= n sum))
(= n (sum-of-divisors sum))
sum))
If you're using Racket, use this:
(define (amicable-pairs-between m n)
(for*/list ((i (in-range m (add1 n)))
(peer (in-value (amicable-peer i)))
#:when (and peer (<= m peer n) (< i peer)))
(cons i peer)))
If you're not using Racket, use this:
(define (amicable-pairs-between m n)
(let loop ((result '())
(i n))
(if (< i m)
result
(let ((peer (amicable-peer i)))
(if (and peer (<= m peer n) (< i peer))
(loop (cons (cons i peer) result) (- i 1))
(loop result (- i 1)))))))
The way this works, is that because lists are built from right-to-left, I've decided to count downward from n through to m, keeping only numbers that have an amicable peer, and where the peer is within range. The (< i peer) check is to ensure that the amicable pair only appears once in the results.
Example:
> (amicable-pairs-between 0 10000)
((220 . 284) (1184 . 1210) (2620 . 2924) (5020 . 5564) (6232 . 6368))
More OP updates (wherein he asked what the difference between a recursive version and an accumulative version is). The version of amicable-pairs-between I wrote above is accumulative. A recursive version would look like this:
(define (amicable-pairs-between m n)
(let recur ((i m))
(if (> i n)
'()
(let ((peer (amicable-peer i)))
(if (and peer (<= m peer n) (< i peer))
(cons (cons i peer) (recur (+ i 1)))
(recur (+ i 1)))))))
Note that there is no result accumulator this time. However, it's not tail-recursive any more.
Your program doesn't work: i is never initialized. And it's very poor style; proper Scheme programs seldom use while or set!. Let's go back to the beginning.
A perfect number is equal to the sum of its proper divisors; for instance, the divisors of 28 are 1, 2, 4, 7, and 14, and 1 + 2 + 4 + 7 + 14 = 28, so 28 is a perfect number. Two numbers m and n form an amicable pair if the sum of the divisors of m equals n and the sum of the divisors of n equals m; for instance, 220 has divisors 1, 2, 4, 5, 10, 11, 20, 22, 44, 55, 110 which sum to 284, and 284 has divisors 1, 2, 4, 71, 142 which sum to 220, so 220 and 284 form an amicable pair.
A simple way to compute the divisors of a number n is try each integer from 1 to ⌊n/2⌋ and see if it divides n:
(define (divisors n)
(let loop ((i 1) (ds (list)))
(cond ((< n (+ i i)) (reverse ds))
((zero? (modulo n i))
(loop (+ i 1) (cons i ds)))
(else (loop (+ i 1) ds)))))
> (divisors 220)
(1 2 4 5 10 11 20 22 44 55 110)
> (divisors 284)
(1 2 4 71 142)
> (divisors 36)
(1 2 3 4 6 9 12 18)
Note that we are excluding n from the list of divisors of n; that's what we want when computing amicable pairs, but in some cases you might want to add n to the list of divisors of n. Instead of making a list of divisors, we can compute their sum:
(define (sum-div n)
(let loop ((i 1) (s 0))
(cond ((< n (+ i i)) s)
((zero? (modulo n i))
(loop (+ i 1) (+ s i)))
(else (loop (+ i 1) s)))))
> (sum-div 220)
284
> (sum-div 284)
220
> (sum-div 36)
55
Instead of counting up to ⌊n/2⌋, it is faster to note that divisors appear in pairs, so it is only necessary to count up to the square root of n; be careful when n is a perfect square to include exactly one instance of the square root in the sum:
(define (divisors n)
(let loop ((i 2) (ds (list 1)))
(cond ((<= n (* i i))
(sort < (if (= n (* i i)) (cons i ds) ds)))
((zero? (modulo n i))
(loop (+ i 1) (cons i (cons (/ n i) ds))))
(else (loop (+ i 1) ds)))))
(define (sum-div n)
(let loop ((i 2) (s 1))
(cond ((<= n (* i i))
(if (= n (* i i)) (+ i s) s))
((zero? (modulo n i))
(loop (+ i 1) (+ s i (/ n i))))
(else (loop (+ i 1) s)))))
> (divisors 220)
(1 2 4 5 10 11 20 22 44 55 110)
> (divisors 284)
(1 2 4 71 142)
> (divisors 36)
(1 2 3 4 6 9 12 18)
> (sum-div 220)
284
> (sum-div 284)
220
> (sum-div 36)
55
If you know the prime factorization of n, it is easy to find the divisors of n: simply take the products of the members of the powerset of the factor of n, eliminating duplicates.
(define (but-last xs)
(if (null? xs) (error 'but-last "empty list")
(reverse (cdr (reverse xs)))))
(define (unique eql? xs)
(cond ((null? xs) '())
((null? (cdr xs)) xs)
((eql? (car xs) (cadr xs)) (unique eql? (cdr xs)))
(else (cons (car xs) (unique eql? (cdr xs))))))
(define (power-set xs)
(if (null? xs) (list (list))
(let ((rest (power-set (cdr xs))))
(append (map (lambda (x) (cons (car xs) x)) rest) rest))))
(define (divisors n)
(but-last (unique = (sort <
(map (lambda (xs) (apply * xs))
(power-set (factors n)))))))
> (divisors 220)
(1 2 4 5 10 11 20 22 44 55 110)
> (divisors 284)
(1 2 4 71 142)
> (divisors 36)
(1 2 3 4 6 9 12 18)
It is even easier to find the sum of the divisors of n if you know the prime factorization of n by examining the multiplicities of the factors of n:
(define (sum-div n)
(define (div f x) (/ (- (expt f (+ x 1)) 1) (- f 1)))
(let ((fs (factors n)))
(let loop ((f (car fs)) (fs (cdr fs)) (x 1) (s 1))
(cond ((null? fs) (- (* s (div f x)) n))
((= (car fs) f) (loop f (cdr fs) (+ x 1) s))
(else (loop (car fs) (cdr fs) 1 (* s (div f x))))))))
> (sum-div 220)
284
> (sum-div 284)
220
> (sum-div 36)
55
A simple method to find the factors of a number n uses a prime wheel; this is slow if n is a large prime or semi-prime but reasonable otherwise:
(define (factors n)
(define (last-pair xs) (if (null? (cdr xs)) xs (last-pair (cdr xs))))
(define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)
(let ((wheel (cons 1 (cons 2 (cons 2 (cycle 4 2 4 2 4 6 2 6))))))
(let loop ((n (abs n)) (f 2) (wheel wheel) (fs (list)))
(cond ((< n (* f f)) (if (= n 1) fs (reverse (cons n fs))))
((zero? (modulo n f)) (loop (/ n f) f wheel (cons f fs)))
(else (loop n (+ f (car wheel)) (cdr wheel) fs))))))
Given all this, it is easy to determine if a number n is perfect, or if it is part of an amicable pair:
(define (perfect? n)
(= n (sum-div n)))
(define (amicable? n)
(let ((s (sum-div n)))
(and (< 1 s) (= (sum-div s) n))))
> (perfect? 6)
#t
> (perfect? 28)
#t
> (amicable? 220)
#t
> (amicable? 284)
#t
It is also easy to find the perfect numbers and amicable pairs less than some limit:
(define (perfect limit)
(let loop ((n 2) (ps (list)))
(cond ((< limit n) (reverse ps))
((= n (sum-div n))
(loop (+ n 1) (cons n ps)))
(else (loop (+ n 1) ps)))))
(define (amicable limit)
(let loop ((n 2) (as (list)))
(if (< limit n) (reverse as)
(let ((s (sum-div n)))
(if (and (< n s) (= n (sum-div s)))
(loop (+ n 1) (cons (list n s) as))
(loop (+ n 1) as))))))
> (perfect 10000)
(6 28 496 8128)
> (amicable 10000)
((220 284) (1184 1210) (2620 2924) (5020 5564) (6232 6368))
Instead of factoring each number up to a limit, it is much faster to find the sums of the divisors of all numbers up to a limit by sieving: Make a vector from 1 to the limit, each item initialized to 1. Then, for each i from 2 to the limit, add i to each multiple of i:
(define (make-sum-divs n)
(let ((s (make-vector (+ n 1) 0)))
(do ((i 1 (+ i 1))) ((< n i) s)
(do ((j (+ i i) (+ j i))) ((< n j))
(vector-set! s j (+ i (vector-ref s j)))))))
(define max-sum-div 1000)
(define sum-divs (make-sum-divs max-sum-div))
Given the sieve, it is easy to find perfect numbers and amicable pairs:
(define (perfect limit)
(when (< max-sum-div limit)
(set! max-sum-div limit)
(set! sum-divs (make-sum-divs max-sum-div)))
(let loop ((n 2) (ps (list)))
(cond ((< limit n) (reverse ps))
((= n (vector-ref sum-divs n))
(loop (+ n 1) (cons n ps)))
(else (loop (+ n 1) ps)))))
(define (pairs limit)
(when (< max-sum-div limit)
(set! max-sum-div limit)
(set! sum-divs (make-sum-divs max-sum-div)))
(let loop ((n 2) (as (list)))
(if (< limit n) (reverse as)
(let ((s (vector-ref sum-divs n)))
(if (and (< s max-sum-div) (< n s)
(= n (vector-ref sum-divs s)))
(loop (+ n 1) (cons (list n s) as))
(loop (+ n 1) as))))))
> (perfect 1000000)
(6 28 496 8128)
> (pairs 1000000)
((220 284) (1184 1210) (2620 2924) (5020 5564) (6232 6368)
(10744 10856) (12285 14595) (17296 18416) (63020 76084)
(66928 66992) (67095 71145) (69615 87633) (79750 88730)
(100485 124155) (122265 139815) (122368 123152)
(141664 153176) (142310 168730) (171856 176336)
(176272 180848) (185368 203432) (196724 202444)
(280540 365084) (308620 389924) (319550 430402)
(356408 399592) (437456 455344) (469028 486178)
(503056 514736) (522405 525915) (600392 669688)
(609928 686072) (624184 691256) (635624 712216)
(643336 652664) (667964 783556) (726104 796696)
(802725 863835) (879712 901424) (898216 980984))
The sieving method is much faster than either of the other two methods. On my computer, it takes twelve seconds to compute the amicable pairs less than a million using trial division to find the divisors, and about the same amount of time for the factoring method, but only about a second-and-a-half to sieve the divisor sums to a million and another half-a-second to find the amicable pairs, a total of two seconds.
In addition to amicable pairs, there exist amicable chains that cycle back to the start after more than two items. For instance, the numbers 12496, 14288, 15472, 14536, and 14264 form an amicable chain of length 5, since sum-div(12496) = 14288, sum-div(14288) = 15472, sum-div(15472) = 14536, sum-div(14536) = 14264, and sum-div(14264) = 12496. The program to find amicable chains is a variant of the program to find amicable pairs:
(define (chain n limit)
(when (< max-sum-div limit)
(set! max-sum-div limit)
(set! sum-divs (make-sum-divs max-sum-div)))
(let loop ((s (vector-ref sum-divs n)) (cs (list n)))
(cond ((= s n) (reverse cs))
((not (< n s limit)) (list))
((member s cs) (list))
(else (loop (vector-ref sum-divs s) (cons s cs))))))
(define (chains limit)
(when (< max-sum-div limit)
(set! max-sum-div limit)
(set! sum-divs (make-sum-divs max-sum-div)))
(let loop ((n 2) (cs (list)))
(if (< limit n) (reverse cs)
(let ((c (chain n limit)))
(if (null? c) (loop (+ n 1) cs)
(loop (+ n 1) (cons c cs)))))))
> (sort (lambda (a b) (< (length a) (length b))) (chains 1000000))
((6) (28) (496) (8128) (220 284) (1184 1210) (2620 2924)
(5020 5564) (6232 6368) (10744 10856) (12285 14595)
(17296 18416) (63020 76084) (66928 66992) (67095 71145)
(69615 87633) (79750 88730) (100485 124155) (122265 139815)
(122368 123152) (141664 153176) (142310 168730)
(171856 176336) (176272 180848) (185368 203432)
(196724 202444) (280540 365084) (308620 389924)
(319550 430402) (356408 399592) (437456 455344)
(469028 486178) (503056 514736) (522405 525915)
(600392 669688) (609928 686072) (624184 691256)
(635624 712216) (643336 652664) (667964 783556)
(726104 796696) (802725 863835) (879712 901424)
(898216 980984) (12496 14288 15472 14536 14264)
(14316 19116 31704 47616 83328 177792 295488 629072 589786
294896 358336 418904 366556 274924 275444 243760 376736
381028 285778 152990 122410 97946 48976 45946 22976 22744
19916 17716))
The four perfect numbers form amicable chains of length 1, there are 40 amicable pairs, there is an amicable chain of length 5 mentioned above, and notice the spectacular amicable chain of length 28 that starts at 14316.
I just try to find amicable pairs between M and N
(define (find-amicable-pairs M N)
(< M N)
(define i M)
(define a 0)
(do ()
[(= i N)]
(set! a (sum-of-divisors i))
(if (and(= i (sum-of-divisors a)) (< i a))
(and (display i)
(display " and ")
(display a)
(newline))
#f)
(set! i (+ i 1))))
Thanks for your thoughts on this!

Resources