ikarus/benchmarks/r6rs-benchmarks/matrix.ss

770 lines
31 KiB
Scheme

;;; MATRIX -- Obtained from Andrew Wright.
(library (r6rs-benchmarks matrix)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
; Chez-Scheme compatibility stuff:
(define (chez-box x) (cons x '()))
(define (chez-unbox x) (car x))
(define (chez-set-box! x y) (set-car! x y))
; Test that a matrix with entries in {+1, -1} is maximal among the matricies
; obtainable by
; re-ordering the rows
; re-ordering the columns
; negating any subset of the columns
; negating any subset of the rows
; Where we compare two matricies by lexicographically comparing the first row,
; then the next to last, etc., and we compare a row by lexicographically
; comparing the first entry, the second entry, etc., and we compare two
; entries by +1 > -1.
; Note, this scheme obeys the useful fact that if (append mat1 mat2) is
; maximal, then so is mat1. Thus, we can build up maximal matricies
; row by row.
;
; Once you have chosen the row re-ordering so that you know which row goes
; last, the set of columns to negate is fixed (since the last row must be
; all +1's).
;
; Note, the column ordering is really totally determined as follows:
; all columns for which the second row is +1 must come before all
; columns for which the second row is -1.
; among columns for which the second row is +1, all columns for which
; the third row is +1 come before those for which the third is
; -1, and similarly for columns in which the second row is -1.
; etc
; Thus, each succeeding row sorts columns withing refinings equivalence
; classes.
;
; Maximal? assumes that mat has atleast one row, and that the first row
; is all +1's.
(define maximal?
(lambda (mat)
(let pick-first-row
((first-row-perm
(gen-perms mat)))
(if first-row-perm
(and (zunda first-row-perm mat)
(pick-first-row (first-row-perm 'brother)))
#t))))
(define zunda
(lambda (first-row-perm mat)
(let* ((first-row
(first-row-perm 'now))
(number-of-cols
(length first-row))
(make-row->func
(lambda (if-equal if-different)
(lambda (row)
(let ((vec
(make-vector number-of-cols)))
(do ((i 0 (+ i 1))
(first first-row
(cdr first))
(row row
(cdr row)))
((= i number-of-cols))
(vector-set! vec
i
(if (= (car first) (car row))
if-equal
if-different)))
(lambda (i)
(vector-ref vec i))))))
(mat
(cdr mat)))
(zebra (first-row-perm 'child)
(make-row->func 1 -1)
(make-row->func -1 1)
mat
number-of-cols))))
(define zebra
(lambda (row-perm row->func+ row->func- mat number-of-cols)
(let _-*-
((row-perm
row-perm)
(mat
mat)
(partitions
(list (miota number-of-cols))))
(or (not row-perm)
(and
(zulu (car mat)
(row->func+ (row-perm 'now))
partitions
(lambda (new-partitions)
(_-*- (row-perm 'child)
(cdr mat)
new-partitions)))
(zulu (car mat)
(row->func- (row-perm 'now))
partitions
(lambda (new-partitions)
(_-*- (row-perm 'child)
(cdr mat)
new-partitions)))
(let ((new-row-perm
(row-perm 'brother)))
(or (not new-row-perm)
(_-*- new-row-perm
mat
partitions))))))))
(define zulu
(let ((cons-if-not-null
(lambda (lhs rhs)
(if (null? lhs)
rhs
(cons lhs rhs)))))
(lambda (old-row new-row-func partitions equal-cont)
(let _-*-
((p-in
partitions)
(old-row
old-row)
(rev-p-out
'()))
(let _-split-
((partition
(car p-in))
(old-row
old-row)
(plus
'())
(minus
'()))
(if (null? partition)
(let _-minus-
((old-row
old-row)
(m
minus))
(if (null? m)
(let ((rev-p-out
(cons-if-not-null
minus
(cons-if-not-null
plus
rev-p-out)))
(p-in
(cdr p-in)))
(if (null? p-in)
(equal-cont (reverse rev-p-out))
(_-*- p-in old-row rev-p-out)))
(or (= 1 (car old-row))
(_-minus- (cdr old-row)
(cdr m)))))
(let ((next
(car partition)))
(case (new-row-func next)
((1)
(and (= 1 (car old-row))
(_-split- (cdr partition)
(cdr old-row)
(cons next plus)
minus)))
((-1)
(_-split- (cdr partition)
old-row
plus
(cons next minus)))))))))))
(define all?
(lambda (ok? lst)
(let _-*-
((lst
lst))
(or (null? lst)
(and (ok? (car lst))
(_-*- (cdr lst)))))))
(define gen-perms
(lambda (objects)
(let _-*-
((zulu-future
objects)
(past
'()))
(if (null? zulu-future)
#f
(lambda (msg)
(case msg
((now)
(car zulu-future))
((brother)
(_-*- (cdr zulu-future)
(cons (car zulu-future)
past)))
((child)
(gen-perms
(fold past cons (cdr zulu-future))))
((puke)
(cons (car zulu-future)
(fold past cons (cdr zulu-future))))
(else
(fatal-error 'gen-perms "Bad msg: ~a" msg))))))))
(define fold
(lambda (lst folder state)
(let _-*-
((lst
lst)
(state
state))
(if (null? lst)
state
(_-*- (cdr lst)
(folder (car lst)
state))))))
(define miota
(lambda (len)
(let _-*-
((i 0))
(if (= i len)
'()
(cons i
(_-*- (+ i 1)))))))
(define proc->vector
(lambda (size proc)
(let ((res
(make-vector size)))
(do ((i 0
(+ i 1)))
((= i size))
(vector-set! res
i
(proc i)))
res)))
; Given a prime number P, return a procedure which, given a `maker' procedure,
; calls it on the operations for the field Z/PZ.
(define make-modular
(lambda (modulus)
(let* ((reduce
(lambda (x)
(modulo x modulus)))
(coef-zero?
(lambda (x)
(zero? (reduce x))))
(coef-+
(lambda (x y)
(reduce (+ x y))))
(coef-negate
(lambda (x)
(reduce (- x))))
(coef-*
(lambda (x y)
(reduce (* x y))))
(coef-recip
(let ((inverses
(proc->vector (- modulus 1)
(lambda (i)
(extended-gcd (+ i 1)
modulus
(lambda (gcd inverse ignore)
inverse))))))
; Coef-recip.
(lambda (x)
(let ((x
(reduce x)))
(vector-ref inverses (- x 1)))))))
(lambda (maker)
(maker 0 ; coef-zero
1 ; coef-one
coef-zero?
coef-+
coef-negate
coef-*
coef-recip)))))
; Extended Euclidean algorithm.
; (extended-gcd a b cont) computes the gcd of a and b, and expresses it
; as a linear combination of a and b. It returns calling cont via
; (cont gcd a-coef b-coef)
; where gcd is the GCD and is equal to a-coef * a + b-coef * b.
(define extended-gcd
(let ((n->sgn/abs
(lambda (x cont)
(if (>= x 0)
(cont 1 x)
(cons -1 (- x))))))
(lambda (a b cont)
(n->sgn/abs a
(lambda (p-a p)
(n->sgn/abs b
(lambda (q-b q)
(let _-*-
((p
p)
(p-a
p-a)
(p-b
0)
(q
q)
(q-a
0)
(q-b
q-b))
(if (zero? q)
(cont p p-a p-b)
(let ((mult
(quotient p q)))
(_-*- q
q-a
q-b
(- p (* mult q))
(- p-a (* mult q-a))
(- p-b (* mult q-b)))))))))))))
; Given elements and operations on the base field, return a procedure which
; computes the row-reduced version of a matrix over that field. The result
; is a list of rows where the first non-zero entry in each row is a 1 (in
; the coefficient field) and occurs to the right of all the leading non-zero
; entries of previous rows. In particular, the number of rows is the rank
; of the original matrix, and they have the same row-space.
; The items related to the base field which are needed are:
; coef-zero additive identity
; coef-one multiplicative identity
; coef-zero? test for additive identity
; coef-+ addition (two args)
; coef-negate additive inverse
; coef-* multiplication (two args)
; coef-recip multiplicative inverse
; Note, matricies are stored as lists of rows (i.e., lists of lists).
(define make-row-reduce
(lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
(lambda (mat)
(let _-*-
((mat
mat))
(if (or (null? mat)
(null? (car mat)))
'()
(let _-**-
((in
mat)
(out
'()))
(if (null? in)
(map
(lambda (x)
(cons coef-zero x))
(_-*- out))
(let* ((prow
(car in))
(pivot
(car prow))
(prest
(cdr prow))
(in
(cdr in)))
(if (coef-zero? pivot)
(_-**- in
(cons prest out))
(let ((zap-row
(map
(let ((mult
(coef-recip pivot)))
(lambda (x)
(coef-* mult x)))
prest)))
(cons (cons coef-one zap-row)
(map
(lambda (x)
(cons coef-zero x))
(_-*-
(fold in
(lambda (row mat)
(cons
(let ((first-col
(car row))
(rest-row
(cdr row)))
(if (coef-zero? first-col)
rest-row
(map
(let ((mult
(coef-negate first-col)))
(lambda (f z)
(coef-+ f
(coef-* mult z))))
rest-row
zap-row)))
mat))
out))))))))))))))
; Given elements and operations on the base field, return a procedure which
; when given a matrix and a vector tests to see if the vector is in the
; row-space of the matrix. This returned function is curried.
; The items related to the base field which are needed are:
; coef-zero additive identity
; coef-one multiplicative identity
; coef-zero? test for additive identity
; coef-+ addition (two args)
; coef-negate additive inverse
; coef-* multiplication (two args)
; coef-recip multiplicative inverse
; Note, matricies are stored as lists of rows (i.e., lists of lists).
(define make-in-row-space?
(lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
(let ((row-reduce
(make-row-reduce coef-zero
coef-one
coef-zero?
coef-+
coef-negate
coef-*
coef-recip)))
(lambda (mat)
(let ((mat
(row-reduce mat)))
(lambda (row)
(let _-*-
((row
row)
(mat
mat))
(if (null? row)
#t
(let ((r-first
(car row))
(r-rest
(cdr row)))
(cond ((coef-zero? r-first)
(_-*- r-rest
(map cdr
(if (or (null? mat)
(coef-zero? (caar mat)))
mat
(cdr mat)))))
((null? mat)
#f)
(else
(let* ((zap-row
(car mat))
(z-first
(car zap-row))
(z-rest
(cdr zap-row))
(mat
(cdr mat)))
(if (coef-zero? z-first)
#f
(_-*-
(map
(let ((mult
(coef-negate r-first)))
(lambda (r z)
(coef-+ r
(coef-* mult z))))
r-rest
z-rest)
(map cdr mat)))))))))))))))
; Given a prime number, return a procedure which takes integer matricies
; and returns their row-reduced form, modulo the prime.
(define make-modular-row-reduce
(lambda (modulus)
((make-modular modulus)
make-row-reduce)))
(define make-modular-in-row-space?
(lambda (modulus)
((make-modular modulus)
make-in-row-space?)))
; Usual utilities.
; Given a bound, find a prime greater than the bound.
(define find-prime
(lambda (bound)
(let* ((primes
(list 2))
(last
(chez-box primes))
(is-next-prime?
(lambda (trial)
(let _-*-
((primes
primes))
(or (null? primes)
(let ((p
(car primes)))
(or (< trial (* p p))
(and (not (zero? (modulo trial p)))
(_-*- (cdr primes))))))))))
(if (> 2 bound)
2
(let _-*-
((trial
3))
(if (is-next-prime? trial)
(let ((entry
(list trial)))
(set-cdr! (chez-unbox last) entry)
(chez-set-box! last entry)
(if (> trial bound)
trial
(_-*- (+ trial 2))))
(_-*- (+ trial 2))))))))
; Given the size of a square matrix consisting only of +1's and -1's,
; return an upper bound on the determinant.
(define det-upper-bound
(lambda (size)
(let ((main-part
(expt size
(quotient size 2))))
(if (even? size)
main-part
(* main-part
(do ((i 0 (+ i 1)))
((>= (* i i) size)
i)))))))
; Fold over all maximal matrices.
(define go
(lambda (number-of-cols inv-size folder state)
(let* ((in-row-space?
(make-modular-in-row-space?
(find-prime
(det-upper-bound inv-size))))
(make-tester
(lambda (mat)
(let ((tests
(let ((old-mat
(cdr mat))
(new-row
(car mat)))
(fold-over-subs-of-size old-mat
(- inv-size 2)
(lambda (sub tests)
(cons
(in-row-space?
(cons new-row sub))
tests))
'()))))
(lambda (row)
(let _-*-
((tests
tests))
(and (not (null? tests))
(or ((car tests) row)
(_-*- (cdr tests)))))))))
(all-rows ; all rows starting with +1 in decreasing order
(fold
(fold-over-rows (- number-of-cols 1)
cons
'())
(lambda (row rows)
(cons (cons 1 row)
rows))
'())))
(let _-*-
((number-of-rows
1)
(rev-mat
(list
(car all-rows)))
(possible-future
(cdr all-rows))
(state
state))
(let ((zulu-future
(remove-in-order
(if (< number-of-rows inv-size)
(in-row-space? rev-mat)
(make-tester rev-mat))
possible-future)))
(if (null? zulu-future)
(folder (reverse rev-mat)
state)
(let _-**-
((zulu-future
zulu-future)
(state
state))
(if (null? zulu-future)
state
(let ((rest-of-future
(cdr zulu-future)))
(_-**- rest-of-future
(let* ((first
(car zulu-future))
(new-rev-mat
(cons first rev-mat)))
(if (maximal? (reverse new-rev-mat))
(_-*- (+ number-of-rows 1)
new-rev-mat
rest-of-future
state)
state))))))))))))
(define go-folder
(lambda (mat bsize.blen.blist)
(let ((bsize
(car bsize.blen.blist))
(size
(length mat)))
(if (< size bsize)
bsize.blen.blist
(let ((blen
(cadr bsize.blen.blist))
(blist
(cddr bsize.blen.blist)))
(if (= size bsize)
(let ((blen
(+ blen 1)))
; (if
; (let _-*-
; ((blen
; blen))
; (or (< blen 10)
; (and (zero? (remainder blen 10))
; (_-*- (quotient blen 10)))))
;
; (begin
; (display blen)
; (display " of size ")
; (display bsize)
; (newline)))
(cons bsize
(cons blen
(cond ((< blen 3000)
(cons mat blist))
((= blen 3000)
(cons "..." blist))
(else
blist)))))
; (begin
; (newline)
; (display "First of size ")
; (display size)
; (display ":")
; (newline)
; (for-each
; (lambda (row)
; (display " ")
; (for-each
; (lambda (e)
; (case e
; ((1)
; (display " 1"))
; ((-1)
; (display " -1"))))
; row)
; (newline))
; mat)
(list size 1 mat)))))))
(define really-go
(lambda (number-of-cols inv-size)
(cddr
(go number-of-cols
inv-size
go-folder
(list -1 -1)))))
(define remove-in-order
(lambda (remove? lst)
(reverse
(fold lst
(lambda (e lst)
(if (remove? e)
lst
(cons e lst)))
'()))))
; The first fold-over-rows is slower than the second one, but folds
; over rows in lexical order (large to small).
(define fold-over-rows
(lambda (number-of-cols folder state)
(if (zero? number-of-cols)
(folder '()
state)
(fold-over-rows (- number-of-cols 1)
(lambda (tail state)
(folder (cons -1 tail)
state))
(fold-over-rows (- number-of-cols 1)
(lambda (tail state)
(folder (cons 1 tail)
state))
state)))))
; Fold over subsets of a given size.
(define fold-over-subs-of-size
(lambda (universe size folder state)
(let ((usize
(length universe)))
(if (< usize size)
state
(let _-*-
((size
size)
(universe
universe)
(folder
folder)
(csize
(- usize size))
(state
state))
(cond ((zero? csize)
(folder universe state))
((zero? size)
(folder '() state))
(else
(let ((first-u
(car universe))
(rest-u
(cdr universe)))
(_-*- size
rest-u
folder
(- csize 1)
(_-*- (- size 1)
rest-u
(lambda (tail state)
(folder (cons first-u tail)
state))
csize
state))))))))))
(define (main)
(run-benchmark
"matrix"
matrix-iters
(lambda (result)
(equal? result
'(((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 -1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 -1) (1 -1 1 -1 1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 1) (1 -1 1 1 -1) (1 -1 -1 -1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 1) (1 -1 1 1 1) (1 -1 -1 -1 -1)))))
(lambda (number-of-cols inv-size) (lambda () (really-go number-of-cols inv-size)))
5
5)))