From ac78347d597678a89a7875e0c83040bc615cf01e Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Sun, 9 Dec 2018 17:16:52 -0500 Subject: [PATCH] Remove temp file --- test-matrix.scm | 881 ------------------------------------------------ 1 file changed, 881 deletions(-) delete mode 100644 test-matrix.scm diff --git a/test-matrix.scm b/test-matrix.scm deleted file mode 100644 index 401719f5..00000000 --- a/test-matrix.scm +++ /dev/null @@ -1,881 +0,0 @@ -;;; MATRIX -- Obtained from Andrew Wright. - -(import (scheme base) (scheme read) (scheme write) (scheme time)) - -;;;; We need R6RS div and mod for this benchmark. -; -;(define (div x y) -; (cond ((and (exact-integer? x) -; (exact-integer? y) -; (>= x 0)) -; (quotient x y)) -; ((< y 0) -; ;; x < 0, y < 0 -; (let* ((q (quotient x y)) -; (r (- x (* q y)))) -; (if (= r 0) -; q -; (+ q 1)))) -; (else -; ;; x < 0, y > 0 -; (let* ((q (quotient x y)) -; (r (- x (* q y)))) -; (if (= r 0) -; q -; (- q 1)))))) -; -;(define (mod x y) -; (cond ((and (exact-integer? x) -; (exact-integer? y) -; (>= x 0)) -; (remainder x y)) -; ((< y 0) -; ;; x < 0, y < 0 -; (let* ((q (quotient x y)) -; (r (- x (* q y)))) -; (if (= r 0) -; 0 -; (- r y)))) -; (else -; ;; x < 0, y > 0 -; (let* ((q (quotient x y)) -; (r (- x (* q y)))) -; (if (= r 0) -; 0 -; (+ r y)))))) -; -;;; 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))) -;(make-row->func 1 -1) - (zebra (first-row-perm 'child) - (make-row->func 1 -1) - (make-row->func -1 1) - mat - number-of-cols)))) - -;; TODO: with this test code, why is the fast-eq inlined???? -(write (zunda 1 -1)) - -(define zebra - (lambda (row-perm row->func+ row->func- mat number-of-cols) - (write (list row-perm row->func+ row->func- 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 -; (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) -; (mod 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 -; (div 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? (mod 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 -; (div 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? (mod blen 10)) -; ;; (_-*- (div 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) -; (let* ((count (read)) -; (input1 (read)) -; (input2 (read)) -; (output (read)) -; (s3 (number->string count)) -; (s2 (number->string input2)) -; (s1 (number->string input1)) -; (name "matrix")) -; (run-r7rs-benchmark -; (string-append name ":" s1 ":" s2 ":" s3) -; count -; (lambda () (really-go (hide count input1) (hide count input2))) -; (lambda (result) (equal? result output))))) -; -;;;; The following code is appended to all benchmarks. -; -;;;; Given an integer and an object, returns the object -;;;; without making it too easy for compilers to tell -;;;; the object will be returned. -; -;(define (hide r x) -; (call-with-values -; (lambda () -; (values (vector values (lambda (x) x)) -; (if (< r 100) 0 1))) -; (lambda (v i) -; ((vector-ref v i) x)))) -; -;;;; Given the name of a benchmark, -;;;; the number of times it should be executed, -;;;; a thunk that runs the benchmark once, -;;;; and a unary predicate that is true of the -;;;; correct results the thunk may return, -;;;; runs the benchmark for the number of specified iterations. -; -;(define (run-r7rs-benchmark name count thunk ok?) -; -; ;; Rounds to thousandths. -; (define (rounded x) -; (/ (round (* 1000 x)) 1000)) -; -; (display "Running ") -; (display name) -; (newline) -; (flush-output-port (current-output-port)) -; (let* ((j/s (jiffies-per-second)) -; (t0 (current-second)) -; (j0 (current-jiffy))) -; (let loop ((i 0) -; (result #f)) -; (cond ((< i count) -; (loop (+ i 1) (thunk))) -; ((ok? result) -; (let* ((j1 (current-jiffy)) -; (t1 (current-second)) -; (jifs (- j1 j0)) -; (secs (inexact (/ jifs j/s))) -; (secs2 (rounded (- t1 t0)))) -; (display "Elapsed time: ") -; (write secs) -; (display " seconds (") -; (write secs2) -; (display ") for ") -; (display name) -; (newline) -; (display "+!CSVLINE!+") -; (display (this-scheme-implementation-name)) -; (display ",") -; (display name) -; (display ",") -; (display secs) -; (newline) -; (flush-output-port (current-output-port))) -; result) -; (else -; (display "ERROR: returned incorrect result: ") -; (write result) -; (newline) -; (flush-output-port (current-output-port)) -; result))))) -;(define (this-scheme-implementation-name) -; (string-append "cyclone-" (Cyc-version))) -;(main)