suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

one more benchmark from Marc's set

Browse Source 
svn: r4146
This commit is contained in:
Matthew Flatt 2006-08-26 22:45:51 +00:00
parent c5f7f80108
commit fb6d1ac40e
16 changed files with 3044 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/tests/mzscheme/benchmarks/common/README.txt
View File

@ -34,6 +34,7 @@ All benchmarks must be run from the directory containing this file.
Most bechmarks were obtained from Most bechmarks were obtained from
http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/ http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/
http://www.ccs.neu.edu/home/will/GC/sourcecode.html http://www.ccs.neu.edu/home/will/GC/sourcecode.html
Marc Feeley (who has all of them and more)
Files that end in ".sch" are supposed to be standard Scheme plus `time'. Files that end in ".sch" are supposed to be standard Scheme plus `time'.
Files that end in ".ss" are MzScheme wrapper modules or helper scripts. Files that end in ".ss" are MzScheme wrapper modules or helper scripts.

10
collects/tests/mzscheme/benchmarks/common/auto.ss
View File

@ -178,7 +178,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
run-exe/time run-exe/time
extract-time-times extract-time-times
clean-up-bin clean-up-bin
'(cpstack ctak puzzle triangle)) '(cpstack ctak maze puzzle triangle))
(make-impl 'gambit (make-impl 'gambit
(run-mk "mk-gambit.ss") (run-mk "mk-gambit.ss")
run-gambit-exe run-gambit-exe
@ -190,7 +190,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
run-larceny run-larceny
extract-larceny-times extract-larceny-times
clean-up-fasl clean-up-fasl
'()))) '(maze))))
(define obsolte-impls '(mzscheme mzscheme-j mzscheme3m-tl mzc)) (define obsolte-impls '(mzscheme mzscheme-j mzscheme3m-tl mzc))
@ -206,12 +206,18 @@ exec mzscheme -qu "$0" ${1+"$@"}
earley earley
fft fft
graphs graphs
lattice
maze
mazefun
nboyer nboyer
nestedloop nestedloop
nfa nfa
nucleic2 nucleic2
paraffins
peval
puzzle puzzle
sboyer sboyer
scheme
sort1 sort1
tak tak
takl takl

215
collects/tests/mzscheme/benchmarks/common/lattice.sch Normal file
View File

@ -0,0 +1,215 @@
;;; LATTICE -- Obtained from Andrew Wright.
; Given a comparison routine that returns one of
; less
; more
; equal
; uncomparable
; return a new comparison routine that applies to sequences.
(define lexico
(lambda (base)
(define lex-fixed
(lambda (fixed lhs rhs)
(define check
(lambda (lhs rhs)
(if (null? lhs)
fixed
(let ((probe
(base (car lhs)
(car rhs))))
(if (or (eq? probe 'equal)
(eq? probe fixed))
(check (cdr lhs)
(cdr rhs))
'uncomparable)))))
(check lhs rhs)))
(define lex-first
(lambda (lhs rhs)
(if (null? lhs)
'equal
(let ((probe
(base (car lhs)
(car rhs))))
(case probe
((less more)
(lex-fixed probe
(cdr lhs)
(cdr rhs)))
((equal)
(lex-first (cdr lhs)
(cdr rhs)))
((uncomparable)
'uncomparable))))))
lex-first))
(define (make-lattice elem-list cmp-func)
(cons elem-list cmp-func))
(define lattice->elements car)
(define lattice->cmp cdr)
; Select elements of a list which pass some test.
(define zulu-select
(lambda (test lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons head ac)
ac))
(cdr lst)))))
(select-a '() lst)))
(define reverse!
(letrec ((rotate
(lambda (fo fum)
(let ((next (cdr fo)))
(set-cdr! fo fum)
(if (null? next)
fo
(rotate next fo))))))
(lambda (lst)
(if (null? lst)
'()
(rotate lst '())))))
; Select elements of a list which pass some test and map a function
; over the result. Note, only efficiency prevents this from being the
; composition of select and map.
(define select-map
(lambda (test func lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons (func head)
ac)
ac))
(cdr lst)))))
(select-a '() lst)))
; This version of map-and tail-recurses on the last test.
(define map-and
(lambda (proc lst)
(if (null? lst)
#t
(letrec ((drudge
(lambda (lst)
(let ((rest (cdr lst)))
(if (null? rest)
(proc (car lst))
(and (proc (car lst))
(drudge rest)))))))
(drudge lst)))))
(define (maps-1 source target pas new)
(let ((scmp (lattice->cmp source))
(tcmp (lattice->cmp target)))
(let ((less
(select-map
(lambda (p)
(eq? 'less
(scmp (car p) new)))
cdr
pas))
(more
(select-map
(lambda (p)
(eq? 'more
(scmp (car p) new)))
cdr
pas)))
(zulu-select
(lambda (t)
(and
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(less equal)))
less)
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(more equal)))
more)))
(lattice->elements target)))))
(define (maps-rest source target pas rest to-1 to-collect)
(if (null? rest)
(to-1 pas)
(let ((next (car rest))
(rest (cdr rest)))
(to-collect
(map
(lambda (x)
(maps-rest source target
(cons
(cons next x)
pas)
rest
to-1
to-collect))
(maps-1 source target pas next))))))
(define (maps source target)
(make-lattice
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x) (list (map cdr x)))
(lambda (x) (apply append x)))
(lexico (lattice->cmp target))))
(define (count-maps source target)
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x) 1)
sum))
(define (sum lst)
(if (null? lst)
0
(+ (car lst) (sum (cdr lst)))))
(define (run)
(let* ((l2
(make-lattice '(low high)
(lambda (lhs rhs)
(case lhs
((low)
(case rhs
((low)
'equal)
((high)
'less)
(else
(error 'make-lattice "base" rhs))))
((high)
(case rhs
((low)
'more)
((high)
'equal)
(else
(error 'make-lattice "base" rhs))))
(else
(error 'make-lattice "base" lhs))))))
(l3 (maps l2 l2))
(l4 (maps l3 l3)))
(count-maps l2 l2)
(count-maps l3 l3)
(count-maps l2 l3)
(count-maps l3 l2)
(count-maps l4 l4)))
(time (run))

2
collects/tests/mzscheme/benchmarks/common/lattice.ss Normal file
View File

@ -0,0 +1,2 @@
(module lattice "wrap.ss")

680
collects/tests/mzscheme/benchmarks/common/maze.sch Normal file
View File

@ -0,0 +1,680 @@
;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
;------------------------------------------------------------------------------
; Was file "rand.scm".
; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit
;;; Rehacked by Olin 4/1995.
(define (random-state n)
(cons n #f))
(define (rand state)
(let ((seed (car state))
(A 2813) ; 48271
(M 8388607) ; 2147483647
(Q 2787) ; 44488
(R 2699)) ; 3399
(let* ((hi (quotient seed Q))
(lo (modulo seed Q))
(test (- (* A lo) (* R hi)))
(val (if (> test 0) test (+ test M))))
(set-car! state val)
val)))
(define (random-int n state)
(modulo (rand state) n))
; poker test
; seed 1
; cards 0-9 inclusive (random 10)
; five cards per hand
; 10000 hands
;
; Poker Hand Example Probability Calculated
; 5 of a kind (aaaaa) 0.0001 0
; 4 of a kind (aaaab) 0.0045 0.0053
; Full house (aaabb) 0.009 0.0093
; 3 of a kind (aaabc) 0.072 0.0682
; two pairs (aabbc) 0.108 0.1104
; Pair (aabcd) 0.504 0.501
; Bust (abcde) 0.3024 0.3058
; (define (random n)
; (let* ((M 2147483647)
; (slop (modulo M n)))
; (let loop ((r (rand)))
; (if (> r slop)
; (modulo r n)
; (loop (rand))))))
;
; (define (rngtest)
; (display "implementation ")
; (srand 1)
; (let loop ((n 0))
; (if (< n 10000)
; (begin
; (rand)
; (loop (1+ n)))))
; (if (= *seed* 399268537)
; (display "looks correct.")
; (begin
; (display "failed.")
; (newline)
; (display " current seed ") (display *seed*)
; (newline)
; (display " correct seed 399268537")))
; (newline))
;------------------------------------------------------------------------------
; Was file "uf.scm".
;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;; Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;; Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;; Unions the two sets -- SET1 and SET2 are now considered the same set
;;; by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;; Returns true <==> the two sets are the same.
;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.
;;; The speed of the algorithm comes because when we chase links to find
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
(define (base-set nelts) (cons nelts '()))
;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.
(define (get-set-root s)
(let lp ((r s)) ; Find the last pair
(let ((next (cdr r))) ; in the list. That's
(cond ((pair? next) (lp next)) ; the root r.
(else
(if (not (eq? r s)) ; Now zip down the list again,
(let lp ((x s)) ; changing everyone's cdr to r.
(let ((next (cdr x)))
(cond ((not (eq? r next))
(set-cdr! x r)
(lp next))))))
r))))) ; Then return r.
(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
(define (set-size s) (car (get-set-root s)))
(define (union! s1 s2)
(let* ((r1 (get-set-root s1))
(r2 (get-set-root s2))
(n1 (set-size r1))
(n2 (set-size r2))
(n (+ n1 n2)))
(cond ((> n1 n2)
(set-cdr! r2 r1)
(set-car! r1 n))
(else
(set-cdr! r1 r2)
(set-car! r2 n)))))
;------------------------------------------------------------------------------
; Was file "maze.scm".
;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions
; (define-record wall
; owner ; Cell that owns this wall.
; neighbor ; The other cell bordering this wall.
; bit) ; Integer -- a bit identifying this wall in OWNER's cell.
; (define-record cell
; reachable ; Union/find set -- all reachable cells.
; id ; Identifying info (e.g., the coords of the cell).
; (walls -1) ; A bitset telling which walls are still standing.
; (parent #f) ; For DFS spanning tree construction.
; (mark #f)) ; For marking the solution path.
(define (make-wall owner neighbor bit)
(vector 'wall owner neighbor bit))
(define (wall:owner o) (vector-ref o 1))
(define (set-wall:owner o v) (vector-set! o 1 v))
(define (wall:neighbor o) (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o) (vector-ref o 3))
(define (set-wall:bit o v) (vector-set! o 3 v))
(define (make-cell reachable id)
(vector 'cell reachable id -1 #f #f))
(define (cell:reachable o) (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o) (vector-ref o 2))
(define (set-cell:id o v) (vector-set! o 2 v))
(define (cell:walls o) (vector-ref o 3))
(define (set-cell:walls o v) (vector-set! o 3 v))
(define (cell:parent o) (vector-ref o 4))
(define (set-cell:parent o v) (vector-set! o 4 v))
(define (cell:mark o) (vector-ref o 5))
(define (set-cell:mark o v) (vector-set! o 5 v))
;;; Iterates in reverse order.
(define (vector-for-each proc v)
(let lp ((i (- (vector-length v) 1)))
(cond ((>= i 0)
(proc (vector-ref v i))
(lp (- i 1))))))
;;; Randomly permute a vector.
(define (permute-vec! v random-state)
(let lp ((i (- (vector-length v) 1)))
(cond ((> i 1)
(let ((elt-i (vector-ref v i))
(j (random-int i random-state))) ; j in [0,i)
(vector-set! v i (vector-ref v j))
(vector-set! v j elt-i))
(lp (- i 1)))))
v)
;;; This is the core of the algorithm.
(define (dig-maze walls ncells)
(call-with-current-continuation
(lambda (quit)
(vector-for-each
(lambda (wall) ; For each wall,
(let* ((c1 (wall:owner wall)) ; find the cells on
(set1 (cell:reachable c1))
(c2 (wall:neighbor wall)) ; each side of the wall
(set2 (cell:reachable c2)))
;; If there is no path from c1 to c2, knock down the
;; wall and union the two sets of reachable cells.
;; If the new set of reachable cells is the whole set
;; of cells, quit.
(if (not (set-equal? set1 set2))
(let ((walls (cell:walls c1))
(wall-mask (bitwise-not (wall:bit wall))))
(union! set1 set2)
(set-cell:walls c1 (bitwise-and walls wall-mask))
(if (= (set-size set1) ncells) (quit #f))))))
walls))))
;;; Some simple DFS routines useful for determining path length
;;; through the maze.
;;; Build a DFS tree from ROOT.
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.
(define (dfs-maze maze root do-children)
(let search ((node root) (parent #f))
(set-cell:parent node parent)
(do-children (lambda (child)
(if (not (eq? child parent))
(search child node)))
maze node)))
;;; Move the root to NEW-ROOT.
(define (reroot-maze new-root)
(let lp ((node new-root) (new-parent #f))
(let ((old-parent (cell:parent node)))
(set-cell:parent node new-parent)
(if old-parent (lp old-parent node)))))
;;; How far from CELL to the root?
(define (path-length cell)
(do ((len 0 (+ len 1))
(node (cell:parent cell) (cell:parent node)))
((not node) len)))
;;; Mark the nodes from NODE back to root. Used to mark the winning path.
(define (mark-path node)
(let lp ((node node))
(set-cell:mark node #t)
(cond ((cell:parent node) => lp))))
;------------------------------------------------------------------------------
; Was file "harr.scm".
;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - define-record
;;; ___ ___ ___
;;; / \ / \ / \
;;; ___/ A \___/ A \___/ A \___
;;; / \ / \ / \ / \
;;; / A \___/ A \___/ A \___/ A \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;; Center coord row/column
;;; ------------ ----------
;;; (x, y) -> (y/2, x/3)
;;; (3c, 2r + c&1) <- (r, c)
; (define-record harr
; nrows
; ncols
; elts)
(define (make-harr nrows ncols elts)
(vector 'harr nrows ncols elts))
(define (harr:nrows o) (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o) (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o) (vector-ref o 3))
(define (set-harr:elts o v) (vector-set! o 3 v))
(define (harr r c)
(make-harr r c (make-vector (* r c))))
(define (href ha x y)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c))))
(define (hset! ha x y val)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-set! (harr:elts ha)
(+ (* (harr:ncols ha) r) c)
val)))
(define (href/rc ha r c)
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c)))
;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).
(define (harr-tabulate nrows ncols proc)
(let ((v (make-vector (* nrows ncols))))
(do ((r (- nrows 1) (- r 1)))
((< r 0))
(do ((c 0 (+ c 1))
(i (* r ncols) (+ i 1)))
((= c ncols))
(vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
(make-harr nrows ncols v)))
(define (harr-for-each proc harr)
(vector-for-each proc (harr:elts harr)))
;------------------------------------------------------------------------------
; Was file "hex.scm".
;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.
;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;; (translate (point 2 1) maze))
;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;; means the first, third, ... columns (indices 0, 2, ...).
;;; - An odd column is one whose column index is odd. That
;;; means the second, fourth... columns (indices 1, 3, ...).
;;; The even/odd flip-flop is confusing; be careful to keep it
;;; straight. The *even* columns are the low ones. The *odd*
;;; columns are the high ones.
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; 0 1 2 3
(define south-west 1)
(define south 2)
(define south-east 4)
(define (gen-maze-array r c)
(harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
;;; This could be made more efficient.
(define (make-wall-vec harr)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(xmax (* 3 (- ncols 1)))
;; Accumulate walls.
(walls '())
(add-wall (lambda (o n b) ; owner neighbor bit
(set! walls (cons (make-wall o n b) walls)))))
;; Do everything but the bottom row.
(do ((x (* (- ncols 1) 3) (- x 3)))
((< x 0))
(do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
(- y 2)))
((<= y 1)) ; Don't do bottom row.
(let ((hex (href harr x y)))
(if (not (zero? x))
(add-wall hex (href harr (- x 3) (- y 1)) south-west))
(add-wall hex (href harr x (- y 2)) south)
(if (< x xmax)
(add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
;; Do the SE and SW walls of the odd columns on the bottom row.
;; If the rightmost bottom hex lies in an odd column, however,
;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
(if (> ncols 1)
(let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
;; Do rightmost odd col.
(let ((rmoc-hex (href harr rmoc-x 1)))
(if (< rmoc-x xmax) ; Not a corner -- do E wall.
(add-wall rmoc-hex (href harr xmax 0) south-east))
(add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
(do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
(- x 6)))
((< x 3)) ; 3 is X coord of leftmost odd column.
(add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
(add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
(list->vector walls)))
;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop.
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
(define (pick-entrances harr)
(dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
(let ((nrows (harr:nrows harr))
(ncols (harr:ncols harr)))
(let tp-lp ((max-len -1)
(entrance #f)
(exit #f)
(tcol (- ncols 1)))
(if (< tcol 0) (vector entrance exit)
(let ((top-cell (href/rc harr (- nrows 1) tcol)))
(reroot-maze top-cell)
(let ((result
(let bt-lp ((max-len max-len)
(entrance entrance)
(exit exit)
(bcol (- ncols 1)))
; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
(if (< bcol 0) (vector max-len entrance exit)
(let ((this-len (path-length (href/rc harr 0 bcol))))
(if (> this-len max-len)
(bt-lp this-len tcol bcol (- bcol 1))
(bt-lp max-len entrance exit (- bcol 1))))))))
(let ((max-len (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(tp-lp max-len entrance exit (- tcol 1)))))))))
;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
(let* ((walls (cell:walls cell))
(id (cell:id cell))
(x (car id))
(y (cdr id))
(nr (harr:nrows harr))
(nc (harr:ncols harr))
(maxy (* 2 (- nr 1)))
(maxx (* 3 (- nc 1))))
(if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
(if (not (bit-test walls south)) (proc (href harr x (- y 2))))
(if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
(if (and (> x 0) ; Not in first column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((nw (href harr (- x 3) (+ y 1))))
(if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
;; N neighbor, if there is one (we may be on top row).
(if (< y maxy) ; Not on top row
(let ((n (href harr x (+ y 2))))
(if (not (bit-test (cell:walls n) south)) (proc n))))
;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
(if (and (< x maxx) ; Not in last column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((ne (href harr (+ x 3) (+ y 1))))
(if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
;;; The top-level
(define (make-maze nrows ncols)
(let* ((cells (gen-maze-array nrows ncols))
(walls (permute-vec! (make-wall-vec cells) (random-state 20))))
(dig-maze walls (* nrows ncols))
(let ((result (pick-entrances cells)))
(let ((entrance (vector-ref result 0))
(exit (vector-ref result 1)))
(let* ((exit-cell (href/rc cells 0 exit))
(walls (cell:walls exit-cell)))
(reroot-maze (href/rc cells (- nrows 1) entrance))
(mark-path exit-cell)
(set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
(vector cells entrance exit))))))
(define (pmaze nrows ncols)
(let ((result (make-maze nrows ncols)))
(let ((cells (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(print-hexmaze cells entrance))))
;------------------------------------------------------------------------------
; Was file "hexprint.scm".
;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - hex array code
;;; - hex cell code
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; Top part of top row looks like this:
;;; _ _ _ _
;;; _/ \_/ \/ \_/ \
;;; /
(define output #f) ; the list of all characters written out, in reverse order.
(define (write-ch c)
(set! output (cons c output)))
(define (print-hexmaze harr entrance)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(ncols2 (* 2 (quotient ncols 2))))
;; Print out the flat tops for the top row's odd cols.
(do ((c 1 (+ c 2)))
((>= c ncols))
; (display " ")
(write-ch #\space)
(write-ch #\space)
(write-ch #\space)
(write-ch (if (= c entrance) #\space #\_)))
; (newline)
(write-ch #\newline)
;; Print out the slanted tops for the top row's odd cols
;; and the flat tops for the top row's even cols.
(write-ch #\space)
(do ((c 0 (+ c 2)))
((>= c ncols2))
; (format #t "~a/~a\\"
; (if (= c entrance) #\space #\_)
; (dot/space harr (- nrows 1) (+ c 1)))
(write-ch (if (= c entrance) #\space #\_))
(write-ch #\/)
(write-ch (dot/space harr (- nrows 1) (+ c 1)))
(write-ch #\\))
(if (odd? ncols)
(write-ch (if (= entrance (- ncols 1)) #\space #\_)))
; (newline)
(write-ch #\newline)
(do ((r (- nrows 1) (- r 1)))
((< r 0))
;; Do the bottoms for row r's odd cols.
(write-ch #\/)
(do ((c 1 (+ c 2)))
((>= c ncols2))
;; The dot/space for the even col just behind c.
(write-ch (dot/space harr r (- c 1)))
(display-hexbottom (cell:walls (href/rc harr r c))))
(cond ((odd? ncols)
(write-ch (dot/space harr r (- ncols 1)))
(write-ch #\\)))
; (newline)
(write-ch #\newline)
;; Do the bottoms for row r's even cols.
(do ((c 0 (+ c 2)))
((>= c ncols2))
(display-hexbottom (cell:walls (href/rc harr r c)))
;; The dot/space is for the odd col just after c, on row below.
(write-ch (dot/space harr (- r 1) (+ c 1))))
(cond ((odd? ncols)
(display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
((not (zero? r)) (write-ch #\\)))
; (newline)
(write-ch #\newline))))
(define (bit-test j bit)
(not (zero? (bitwise-and j bit))))
;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
(if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
(write-ch (if (bit-test hexwalls south-west) #\\ #\space))
(write-ch (if (bit-test hexwalls south ) #\_ #\space))
(write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;------------------------------------------------------------------------------
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 1000) (v 0))
(if (zero? n)
v
(begin
(set! output '())
(pmaze 20 (if input 7 0))
(loop (- n 1) output))))))

2
collects/tests/mzscheme/benchmarks/common/maze.ss Normal file
View File

@ -0,0 +1,2 @@
(module maze "wrap.ss")

206
collects/tests/mzscheme/benchmarks/common/mazefun.sch Normal file
View File

@ -0,0 +1,206 @@
;;; MAZEFUN -- Constructs a maze in a purely functional way,
;;; written by Marc Feeley.
(define iota
(lambda (n)
(iota-iter n '())))
(define iota-iter
(lambda (n lst)
(if (= n 0)
lst
(iota-iter (- n 1) (cons n lst)))))
(define foldr
(lambda (f base lst)
(define foldr-aux
(lambda (lst)
(if (null? lst)
base
(f (car lst) (foldr-aux (cdr lst))))))
(foldr-aux lst)))
(define foldl
(lambda (f base lst)
(define foldl-aux
(lambda (base lst)
(if (null? lst)
base
(foldl-aux (f base (car lst)) (cdr lst)))))
(foldl-aux base lst)))
(define for
(lambda (lo hi f)
(define for-aux
(lambda (lo)
(if (< lo hi)
(cons (f lo) (for-aux (+ lo 1)))
'())))
(for-aux lo)))
(define concat
(lambda (lists)
(foldr append '() lists)))
(define list-read
(lambda (lst i)
(if (= i 0)
(car lst)
(list-read (cdr lst) (- i 1)))))
(define list-write
(lambda (lst i val)
(if (= i 0)
(cons val (cdr lst))
(cons (car lst) (list-write (cdr lst) (- i 1) val)))))
(define list-remove-pos
(lambda (lst i)
(if (= i 0)
(cdr lst)
(cons (car lst) (list-remove-pos (cdr lst) (- i 1))))))
(define duplicates?
(lambda (lst)
(if (null? lst)
#f
(or (member (car lst) (cdr lst))
(duplicates? (cdr lst))))))
; Manipulation de matrices.
(define make-matrix
(lambda (n m init)
(for 0 n (lambda (i) (for 0 m (lambda (j) (init i j)))))))
(define matrix-read
(lambda (mat i j)
(list-read (list-read mat i) j)))
(define matrix-write
(lambda (mat i j val)
(list-write mat i (list-write (list-read mat i) j val))))
(define matrix-size
(lambda (mat)
(cons (length mat) (length (car mat)))))
(define matrix-map
(lambda (f mat)
(map (lambda (lst) (map f lst)) mat)))
(define initial-random 0)
(define next-random
(lambda (current-random)
(remainder (+ (* current-random 3581) 12751) 131072)))
(define shuffle
(lambda (lst)
(shuffle-aux lst initial-random)))
(define shuffle-aux
(lambda (lst current-random)
(if (null? lst)
'()
(let ((new-random (next-random current-random)))
(let ((i (modulo new-random (length lst))))
(cons (list-read lst i)
(shuffle-aux (list-remove-pos lst i)
new-random)))))))
(define make-maze
(lambda (n m) ; n and m must be odd
(if (not (and (odd? n) (odd? m)))
'error
(let ((cave
(make-matrix n m (lambda (i j)
(if (and (even? i) (even? j))
(cons i j)
#f))))
(possible-holes
(concat
(for 0 n (lambda (i)
(concat
(for 0 m (lambda (j)
(if (equal? (even? i) (even? j))
'()
(list (cons i j)))))))))))
(cave-to-maze (pierce-randomly (shuffle possible-holes) cave))))))
(define cave-to-maze
(lambda (cave)
(matrix-map (lambda (x) (if x '_ '*)) cave)))
(define pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(matrix-write cave i j pos))))
(define pierce-randomly
(lambda (possible-holes cave)
(if (null? possible-holes)
cave
(let ((hole (car possible-holes)))
(pierce-randomly (cdr possible-holes)
(try-to-pierce hole cave))))))
(define try-to-pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(let ((ncs (neighboring-cavities pos cave)))
(if (duplicates?
(map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs))
cave
(pierce pos
(foldl (lambda (c nc) (change-cavity c nc pos))
cave
ncs)))))))
(define change-cavity
(lambda (cave pos new-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
(define change-cavity-aux
(lambda (cave pos new-cavity-id old-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(let ((cavity-id (matrix-read cave i j)))
(if (equal? cavity-id old-cavity-id)
(foldl (lambda (c nc)
(change-cavity-aux c nc new-cavity-id old-cavity-id))
(matrix-write cave i j new-cavity-id)
(neighboring-cavities pos cave))
cave)))))
(define neighboring-cavities
(lambda (pos cave)
(let ((size (matrix-size cave)))
(let ((n (car size)) (m (cdr size)))
(let ((i (car pos)) (j (cdr pos)))
(append (if (and (> i 0) (matrix-read cave (- i 1) j))
(list (cons (- i 1) j))
'())
(if (and (< i (- n 1)) (matrix-read cave (+ i 1) j))
(list (cons (+ i 1) j))
'())
(if (and (> j 0) (matrix-read cave i (- j 1)))
(list (cons i (- j 1)))
'())
(if (and (< j (- m 1)) (matrix-read cave i (+ j 1)))
(list (cons i (+ j 1)))
'())))))))
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 500) (v 0))
(if (zero? n)
v
(loop (- n 1)
(make-maze 11 (if input 11 0)))))))

2
collects/tests/mzscheme/benchmarks/common/mazefun.ss Normal file
View File

@ -0,0 +1,2 @@
(module mazefun "wrap.ss")

35
collects/tests/mzscheme/benchmarks/common/nqueens.sch Normal file
View File

@ -0,0 +1,35 @@
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
(define trace? #f)
(define (nqueens n)
(define (1-to n)
(let loop ((i n) (l '()))
(if (= i 0) l (loop (- i 1) (cons i l)))))
(define (try x y z)
(if (null? x)
(if (null? y)
(begin (if trace? (begin (write z) (newline))) 1)
0)
(+ (if (ok? (car x) 1 z)
(try (append (cdr x) y) '() (cons (car x) z))
0)
(try (cdr x) (cons (car x) y) z))))
(define (ok? row dist placed)
(if (null? placed)
#t
(and (not (= (car placed) (+ row dist)))
(not (= (car placed) (- row dist)))
(ok? row (+ dist 1) (cdr placed)))))
(try (1-to n) '() '()))
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(if (zero? n)
v
(loop (- n 1) (nqueens (if input 8 0)))))))

2
collects/tests/mzscheme/benchmarks/common/nqueens.ss Normal file
View File

@ -0,0 +1,2 @@
(module nqueens "wrap.ss")

175
collects/tests/mzscheme/benchmarks/common/paraffins.sch Normal file
View File

@ -0,0 +1,175 @@
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
(define (gen n)
(let* ((n/2 (quotient n 2))
(radicals (make-vector (+ n/2 1) '(H))))
(define (rads-of-size n)
(let loop1 ((ps
(three-partitions (- n 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(cons (vector 'C
(car rads1)
(car rads2)
(car rads3))
(loop4 (cdr rads3)
lst))))))))))))
(define (bcp-generator j)
(if (odd? j)
'()
(let loop1 ((rads1
(vector-ref radicals (quotient j 2)))
(lst
'()))
(if (null? rads1)
lst
(let loop2 ((rads2
rads1)
(lst
(loop1 (cdr rads1)
lst)))
(if (null? rads2)
lst
(cons (vector 'BCP
(car rads1)
(car rads2))
(loop2 (cdr rads2)
lst))))))))
(define (ccp-generator j)
(let loop1 ((ps
(four-partitions (- j 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2))
(nc4 (vector-ref p 3)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(let loop5 ((rads4
(if (= nc3 nc4)
rads3
(vector-ref radicals nc4)))
(lst
(loop4 (cdr rads3)
lst)))
(if (null? rads4)
lst
(cons (vector 'CCP
(car rads1)
(car rads2)
(car rads3)
(car rads4))
(loop5 (cdr rads4)
lst))))))))))))))
(let loop ((i 1))
(if (> i n/2)
(vector (bcp-generator n)
(ccp-generator n))
(begin
(vector-set! radicals i (rads-of-size i))
(loop (+ i 1)))))))
(define (three-partitions m)
(let loop1 ((lst '())
(nc1 (quotient m 3)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (quotient (- m nc1) 2)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
(- nc2 1)))))))
(define (four-partitions m)
(let loop1 ((lst '())
(nc1 (quotient m 4)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (quotient (- m nc1) 3)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2)))))
(let loop3 ((lst lst)
(nc3 (quotient (- m (+ nc1 nc2)) 2)))
(if (< nc3 start)
(loop2 lst (- nc2 1))
(loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
(- nc3 1))))))))))
(define (nb n)
(let ((x (gen n)))
(+ (length (vector-ref x 0))
(length (vector-ref x 1)))))
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 100) (v 0))
(if (zero? n)
v
(loop (- n 1) (nb (if input 17 0)))))))

2
collects/tests/mzscheme/benchmarks/common/paraffins.ss Normal file
View File

@ -0,0 +1,2 @@
(module paraffins "wrap.ss")

635
collects/tests/mzscheme/benchmarks/common/peval.sch Normal file
View File

@ -0,0 +1,635 @@
;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley.
;------------------------------------------------------------------------------
; Utilities
(define (every? pred? l)
(let loop ((l l))
(or (null? l) (and (pred? (car l)) (loop (cdr l))))))
(define (some? pred? l)
(let loop ((l l))
(if (null? l) #f (or (pred? (car l)) (loop (cdr l))))))
(define (map2 f l1 l2)
(let loop ((l1 l1) (l2 l2))
(if (pair? l1)
(cons (f (car l1) (car l2)) (loop (cdr l1) (cdr l2)))
'())))
(define (get-last-pair l)
(let loop ((l l))
(let ((x (cdr l))) (if (pair? x) (loop x) l))))
;------------------------------------------------------------------------------
;
; The partial evaluator.
(define (partial-evaluate proc args)
(peval (alphatize proc '()) args))
(define (alphatize exp env) ; return a copy of 'exp' where each bound var has
(define (alpha exp) ; been renamed (to prevent aliasing problems)
(cond ((const-expr? exp)
(quot (const-value exp)))
((symbol? exp)
(let ((x (assq exp env))) (if x (cdr x) exp)))
((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
(cons (car exp) (map alpha (cdr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (new-variables (map car (cadr exp)) env)))
(list (car exp)
(map (lambda (x)
(list (cdr (assq (car x) new-env))
(if (eq? (car exp) 'let)
(alpha (cadr x))
(alphatize (cadr x) new-env))))
(cadr exp))
(alphatize (caddr exp) new-env))))
((eq? (car exp) 'lambda)
(let ((new-env (new-variables (cadr exp) env)))
(list 'lambda
(map (lambda (x) (cdr (assq x new-env))) (cadr exp))
(alphatize (caddr exp) new-env))))
(else
(map alpha exp))))
(alpha exp))
(define (const-expr? expr) ; is 'expr' a constant expression?
(and (not (symbol? expr))
(or (not (pair? expr))
(eq? (car expr) 'quote))))
(define (const-value expr) ; return the value of a constant expression
(if (pair? expr) ; then it must be a quoted constant
(cadr expr)
expr))
(define (quot val) ; make a quoted constant whose value is 'val'
(list 'quote val))
(define (new-variables parms env)
(append (map (lambda (x) (cons x (new-variable x))) parms) env))
(define *current-num* 0)
(define (new-variable name)
(set! *current-num* (+ *current-num* 1))
(string->symbol
(string-append (symbol->string name)
"_"
(number->string *current-num*))))
;------------------------------------------------------------------------------
;
; (peval proc args) will transform a procedure that is known to be called
; with constants as some of its arguments into a specialized procedure that
; is 'equivalent' but accepts only the non-constant parameters. 'proc' is the
; list representation of a lambda-expression and 'args' is a list of values,
; one for each parameter of the lambda-expression. A special value (i.e.
; 'not-constant') is used to indicate an argument that is not a constant.
; The returned procedure is one that has as parameters the parameters of the
; original procedure which are NOT passed constants. Constants will have been
; substituted for the constant parameters that are referenced in the body
; of the procedure.
;
; For example:
;
; (peval
; '(lambda (x y z) (f z x y)) ; the procedure
; (list 1 not-constant #t)) ; the knowledge about x, y and z
;
; will return: (lambda (y) (f '#t '1 y))
(define (peval proc args)
(simplify!
(let ((parms (cadr proc)) ; get the parameter list
(body (caddr proc))) ; get the body of the procedure
(list 'lambda
(remove-constant parms args) ; remove the constant parameters
(beta-subst ; in the body, replace variable refs to the constant
body ; parameters by the corresponding constant
(map2 (lambda (x y) (if (not-constant? y) '(()) (cons x (quot y))))
parms
args))))))
(define not-constant (list '?)) ; special value indicating non-constant parms.
(define (not-constant? x) (eq? x not-constant))
(define (remove-constant l a) ; remove from list 'l' all elements whose
(cond ((null? l) ; corresponding element in 'a' is a constant
'())
((not-constant? (car a))
(cons (car l) (remove-constant (cdr l) (cdr a))))
(else
(remove-constant (cdr l) (cdr a)))))
(define (extract-constant l a) ; extract from list 'l' all elements whose
(cond ((null? l) ; corresponding element in 'a' is a constant
'())
((not-constant? (car a))
(extract-constant (cdr l) (cdr a)))
(else
(cons (car l) (extract-constant (cdr l) (cdr a))))))
(define (beta-subst exp env) ; return a modified 'exp' where each var named in
(define (bs exp) ; 'env' is replaced by the corresponding expr (it
(cond ((const-expr? exp) ; is assumed that the code has been alphatized)
(quot (const-value exp)))
((symbol? exp)
(let ((x (assq exp env)))
(if x (cdr x) exp)))
((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
(cons (car exp) (map bs (cdr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(list (car exp)
(map (lambda (x) (list (car x) (bs (cadr x)))) (cadr exp))
(bs (caddr exp))))
((eq? (car exp) 'lambda)
(list 'lambda
(cadr exp)
(bs (caddr exp))))
(else
(map bs exp))))
(bs exp))
;------------------------------------------------------------------------------
;
; The expression simplifier.
(define (simplify! exp) ; simplify the expression 'exp' destructively (it
; is assumed that the code has been alphatized)
(define (simp! where env)
(define (s! where)
(let ((exp (car where)))
(cond ((const-expr? exp)) ; leave constants the way they are
((symbol? exp)) ; leave variable references the way they are
((eq? (car exp) 'if) ; dead code removal for conditionals
(s! (cdr exp)) ; simplify the predicate
(if (const-expr? (cadr exp)) ; is the predicate a constant?
(begin
(set-car! where
(if (memq (const-value (cadr exp)) '(#f ())) ; false?
(if (= (length exp) 3) ''() (cadddr exp))
(caddr exp)))
(s! where))
(for-each! s! (cddr exp)))) ; simplify consequent and alt.
((eq? (car exp) 'begin)
(for-each! s! (cdr exp))
(let loop ((exps exp)) ; remove all useless expressions
(if (not (null? (cddr exps))) ; not last expression?
(let ((x (cadr exps)))
(loop (if (or (const-expr? x)
(symbol? x)
(and (pair? x) (eq? (car x) 'lambda)))
(begin (set-cdr! exps (cddr exps)) exps)
(cdr exps))))))
(if (null? (cddr exp)) ; only one expression in the begin?
(set-car! where (cadr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (cons exp env)))
(define (keep i)
(if (>= i (length (cadar where)))
'()
(let* ((var (car (list-ref (cadar where) i)))
(val (cadr (assq var (cadar where))))
(refs (ref-count (car where) var))
(self-refs (ref-count val var))
(total-refs (- (car refs) (car self-refs)))
(oper-refs (- (cadr refs) (cadr self-refs))))
(cond ((= total-refs 0)
(keep (+ i 1)))
((or (const-expr? val)
(symbol? val)
(and (pair? val)
(eq? (car val) 'lambda)
(= total-refs 1)
(= oper-refs 1)
(= (car self-refs) 0))
(and (caddr refs)
(= total-refs 1)))
(set-car! where
(beta-subst (car where)
(list (cons var val))))
(keep (+ i 1)))
(else
(cons var (keep (+ i 1))))))))
(simp! (cddr exp) new-env)
(for-each! (lambda (x) (simp! (cdar x) new-env)) (cadr exp))
(let ((to-keep (keep 0)))
(if (< (length to-keep) (length (cadar where)))
(begin
(if (null? to-keep)
(set-car! where (caddar where))
(set-car! (cdar where)
(map (lambda (v) (assq v (cadar where))) to-keep)))
(s! where))
(if (null? to-keep)
(set-car! where (caddar where)))))))
((eq? (car exp) 'lambda)
(simp! (cddr exp) (cons exp env)))
(else
(for-each! s! exp)
(cond ((symbol? (car exp)) ; is the operator position a var ref?
(let ((frame (binding-frame (car exp) env)))
(if frame ; is it a bound variable?
(let ((proc (bound-expr (car exp) frame)))
(if (and (pair? proc)
(eq? (car proc) 'lambda)
(some? const-expr? (cdr exp)))
(let* ((args (arg-pattern (cdr exp)))
(new-proc (peval proc args))
(new-args (remove-constant (cdr exp) args)))
(set-car! where
(cons (add-binding new-proc frame (car exp))
new-args)))))
(set-car! where
(constant-fold-global (car exp) (cdr exp))))))
((not (pair? (car exp))))
((eq? (caar exp) 'lambda)
(set-car! where
(list 'let
(map2 list (cadar exp) (cdr exp))
(caddar exp)))
(s! where)))))))
(s! where))
(define (remove-empty-calls! where env)
(define (rec! where)
(let ((exp (car where)))
(cond ((const-expr? exp))
((symbol? exp))
((eq? (car exp) 'if)
(rec! (cdr exp))
(rec! (cddr exp))
(rec! (cdddr exp)))
((eq? (car exp) 'begin)
(for-each! rec! (cdr exp)))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (cons exp env)))
(remove-empty-calls! (cddr exp) new-env)
(for-each! (lambda (x) (remove-empty-calls! (cdar x) new-env))
(cadr exp))))
((eq? (car exp) 'lambda)
(rec! (cddr exp)))
(else
(for-each! rec! (cdr exp))
(if (and (null? (cdr exp)) (symbol? (car exp)))
(let ((frame (binding-frame (car exp) env)))
(if frame ; is it a bound variable?
(let ((proc (bound-expr (car exp) frame)))
(if (and (pair? proc)
(eq? (car proc) 'lambda))
(begin
(set! changed? #t)
(set-car! where (caddr proc))))))))))))
(rec! where))
(define changed? #f)
(let ((x (list exp)))
(let loop ()
(set! changed? #f)
(simp! x '())
(remove-empty-calls! x '())
(if changed? (loop) (car x)))))
(define (ref-count exp var) ; compute how many references to variable 'var'
(let ((total 0) ; are contained in 'exp'
(oper 0)
(always-evaled #t))
(define (rc exp ae)
(cond ((const-expr? exp))
((symbol? exp)
(if (eq? exp var)
(begin
(set! total (+ total 1))
(set! always-evaled (and ae always-evaled)))))
((eq? (car exp) 'if)
(rc (cadr exp) ae)
(for-each (lambda (x) (rc x #f)) (cddr exp)))
((eq? (car exp) 'begin)
(for-each (lambda (x) (rc x ae)) (cdr exp)))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(for-each (lambda (x) (rc (cadr x) ae)) (cadr exp))
(rc (caddr exp) ae))
((eq? (car exp) 'lambda)
(rc (caddr exp) #f))
(else
(for-each (lambda (x) (rc x ae)) exp)
(if (symbol? (car exp))
(if (eq? (car exp) var) (set! oper (+ oper 1)))))))
(rc exp #t)
(list total oper always-evaled)))
(define (binding-frame var env)
(cond ((null? env) #f)
((or (eq? (caar env) 'let) (eq? (caar env) 'letrec))
(if (assq var (cadar env)) (car env) (binding-frame var (cdr env))))
((eq? (caar env) 'lambda)
(if (memq var (cadar env)) (car env) (binding-frame var (cdr env))))
(else
(/ 0)
'(fatal-error "ill-formed environment"))))
(define (bound-expr var frame)
(cond ((or (eq? (car frame) 'let) (eq? (car frame) 'letrec))
(cadr (assq var (cadr frame))))
((eq? (car frame) 'lambda)
not-constant)
(else
(/ 0)
'(fatal-error "ill-formed frame"))))
(define (add-binding val frame name)
(define (find-val val bindings)
(cond ((null? bindings) #f)
((equal? val (cadar bindings)) ; *kludge* equal? is not exactly what
(caar bindings)) ; we want...
(else
(find-val val (cdr bindings)))))
(or (find-val val (cadr frame))
(let ((var (new-variable name)))
(set-cdr! (get-last-pair (cadr frame)) (list (list var val)))
var)))
(define (for-each! proc! l) ; call proc! on each CONS CELL in the list 'l'
(if (not (null? l))
(begin (proc! l) (for-each! proc! (cdr l)))))
(define (arg-pattern exps) ; return the argument pattern (i.e. the list of
(if (null? exps) ; constants in 'exps' but with the not-constant
'() ; value wherever the corresponding expression in
(cons (if (const-expr? (car exps)) ; 'exps' is not a constant)
(const-value (car exps))
not-constant)
(arg-pattern (cdr exps)))))
;------------------------------------------------------------------------------
;
; Knowledge about primitive procedures.
(define *primitives*
(list
(cons 'car (lambda (args)
(and (= (length args) 1)
(pair? (car args))
(quot (car (car args))))))
(cons 'cdr (lambda (args)
(and (= (length args) 1)
(pair? (car args))
(quot (cdr (car args))))))
(cons '+ (lambda (args)
(and (every? number? args)
(quot (sum args 0)))))
(cons '* (lambda (args)
(and (every? number? args)
(quot (product args 1)))))
(cons '- (lambda (args)
(and (> (length args) 0)
(every? number? args)
(quot (if (null? (cdr args))
(- (car args))
(- (car args) (sum (cdr args) 0)))))))
(cons '/ (lambda (args)
(and (> (length args) 1)
(every? number? args)
(quot (if (null? (cdr args))
(/ (car args))
(/ (car args) (product (cdr args) 1)))))))
(cons '< (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (< (car args) (cadr args))))))
(cons '= (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (= (car args) (cadr args))))))
(cons '> (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (> (car args) (cadr args))))))
(cons 'eq? (lambda (args)
(and (= (length args) 2)
(quot (eq? (car args) (cadr args))))))
(cons 'not (lambda (args)
(and (= (length args) 1)
(quot (not (car args))))))
(cons 'null? (lambda (args)
(and (= (length args) 1)
(quot (null? (car args))))))
(cons 'pair? (lambda (args)
(and (= (length args) 1)
(quot (pair? (car args))))))
(cons 'symbol? (lambda (args)
(and (= (length args) 1)
(quot (symbol? (car args))))))
)
)
(define (sum lst n)
(if (null? lst)
n
(sum (cdr lst) (+ n (car lst)))))
(define (product lst n)
(if (null? lst)
n
(product (cdr lst) (* n (car lst)))))
(define (reduce-global name args)
(let ((x (assq name *primitives*)))
(and x ((cdr x) args))))
(define (constant-fold-global name exprs)
(define (flatten args op)
(cond ((null? args)
'())
((and (pair? (car args)) (eq? (caar args) op))
(append (flatten (cdar args) op) (flatten (cdr args) op)))
(else
(cons (car args) (flatten (cdr args) op)))))
(let ((args (if (or (eq? name '+) (eq? name '*)) ; associative ops
(flatten exprs name)
exprs)))
(or (and (every? const-expr? args)
(reduce-global name (map const-value args)))
(let ((pattern (arg-pattern args)))
(let ((non-const (remove-constant args pattern))
(const (map const-value (extract-constant args pattern))))
(cond ((eq? name '+) ; + is commutative
(let ((x (reduce-global '+ const)))
(if x
(let ((y (const-value x)))
(cons '+
(if (= y 0) non-const (cons x non-const))))
(cons name args))))
((eq? name '*) ; * is commutative
(let ((x (reduce-global '* const)))
(if x
(let ((y (const-value x)))
(cons '*
(if (= y 1) non-const (cons x non-const))))
(cons name args))))
((eq? name 'cons)
(cond ((and (const-expr? (cadr args))
(null? (const-value (cadr args))))
(list 'list (car args)))
((and (pair? (cadr args))
(eq? (car (cadr args)) 'list))
(cons 'list (cons (car args) (cdr (cadr args)))))
(else
(cons name args))))
(else
(cons name args))))))))
;------------------------------------------------------------------------------
;
; Examples:
(define (try-peval proc args)
(partial-evaluate proc args))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example1
'(lambda (a b c)
(if (null? a) b (+ (car a) c))))
;(try-peval example1 (list '(10 11) not-constant '1))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example2
'(lambda (x y)
(let ((q (lambda (a b) (if (< a 0) b (- 10 b)))))
(if (< x 0) (q (- y) (- x)) (q y x)))))
;(try-peval example2 (list not-constant '1))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example3
'(lambda (l n)
(letrec ((add-list
(lambda (l n)
(if (null? l)
'()
(cons (+ (car l) n) (add-list (cdr l) n))))))
(add-list l n))))
;(try-peval example3 (list not-constant '1))
;(try-peval example3 (list '(1 2 3) not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example4
'(lambda (exp env)
(letrec ((eval
(lambda (exp env)
(letrec ((eval-list
(lambda (l env)
(if (null? l)
'()
(cons (eval (car l) env)
(eval-list (cdr l) env))))))
(if (symbol? exp) (lookup exp env)
(if (not (pair? exp)) exp
(if (eq? (car exp) 'quote) (car (cdr exp))
(apply (eval (car exp) env)
(eval-list (cdr exp) env)))))))))
(eval exp env))))
;(try-peval example4 (list 'x not-constant))
;(try-peval example4 (list '(f 1 2 3) not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example5
'(lambda (a b)
(letrec ((funct
(lambda (x)
(+ x b (if (< x 1) 0 (funct (- x 1)))))))
(funct a))))
;(try-peval example5 (list '5 not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example6
'(lambda ()
(letrec ((fib
(lambda (x)
(if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))
(fib 10))))
;(try-peval example6 '())
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example7
'(lambda (input)
(letrec ((copy (lambda (in)
(if (pair? in)
(cons (copy (car in))
(copy (cdr in)))
in))))
(copy input))))
;(try-peval example7 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example8
'(lambda (input)
(letrec ((reverse (lambda (in result)
(if (pair? in)
(reverse (cdr in) (cons (car in) result))
result))))
(reverse input '()))))
;(try-peval example8 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define (test init)
(set! *current-num* init)
(list (try-peval example1 (list '(10 11) not-constant '1))
(try-peval example2 (list not-constant '1))
(try-peval example3 (list not-constant '1))
(try-peval example3 (list '(1 2 3) not-constant))
(try-peval example4 (list 'x not-constant))
(try-peval example4 (list '(f 1 2 3) not-constant))
(try-peval example5 (list '5 not-constant))
(try-peval example6 '())
(try-peval
example7
(list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
(try-peval
example8
(list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))))
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 20) (v 0))
(if (zero? n)
v
(loop (- n 1) (test (if input 0 17)))))))

2
collects/tests/mzscheme/benchmarks/common/peval.ss Normal file
View File

@ -0,0 +1,2 @@
(module peval "wrap.ss")

1075
collects/tests/mzscheme/benchmarks/common/scheme.sch Normal file
View File

File diff suppressed because it is too large Load Diff

2
collects/tests/mzscheme/benchmarks/common/scheme.ss Normal file
View File

@ -0,0 +1,2 @@
(module scheme "wrap.ss")