From fb6d1ac40e18adface1b9c83d6e9aa5eb4f00acf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 26 Aug 2006 22:45:51 +0000 Subject: [PATCH] one more benchmark from Marc's set svn: r4146 --- .../mzscheme/benchmarks/common/README.txt | 1 + .../tests/mzscheme/benchmarks/common/auto.ss | 10 +- .../mzscheme/benchmarks/common/lattice.sch | 215 ++++ .../mzscheme/benchmarks/common/lattice.ss | 2 + .../tests/mzscheme/benchmarks/common/maze.sch | 680 +++++++++++ .../tests/mzscheme/benchmarks/common/maze.ss | 2 + .../mzscheme/benchmarks/common/mazefun.sch | 206 ++++ .../mzscheme/benchmarks/common/mazefun.ss | 2 + .../mzscheme/benchmarks/common/nqueens.sch | 35 + .../mzscheme/benchmarks/common/nqueens.ss | 2 + .../mzscheme/benchmarks/common/paraffins.sch | 175 +++ .../mzscheme/benchmarks/common/paraffins.ss | 2 + .../mzscheme/benchmarks/common/peval.sch | 635 ++++++++++ .../tests/mzscheme/benchmarks/common/peval.ss | 2 + .../mzscheme/benchmarks/common/scheme.sch | 1075 +++++++++++++++++ .../mzscheme/benchmarks/common/scheme.ss | 2 + 16 files changed, 3044 insertions(+), 2 deletions(-) create mode 100644 collects/tests/mzscheme/benchmarks/common/lattice.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/lattice.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/maze.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/maze.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/mazefun.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/mazefun.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/nqueens.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/nqueens.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/paraffins.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/paraffins.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/peval.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/peval.ss create mode 100644 collects/tests/mzscheme/benchmarks/common/scheme.sch create mode 100644 collects/tests/mzscheme/benchmarks/common/scheme.ss diff --git a/collects/tests/mzscheme/benchmarks/common/README.txt b/collects/tests/mzscheme/benchmarks/common/README.txt index 69341a6fe1..96a9d4dec2 100644 --- a/collects/tests/mzscheme/benchmarks/common/README.txt +++ b/collects/tests/mzscheme/benchmarks/common/README.txt @@ -34,6 +34,7 @@ All benchmarks must be run from the directory containing this file. Most bechmarks were obtained from 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 + 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 ".ss" are MzScheme wrapper modules or helper scripts. diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss index dc21b21805..a53f778a3d 100755 --- a/collects/tests/mzscheme/benchmarks/common/auto.ss +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -178,7 +178,7 @@ exec mzscheme -qu "$0" ${1+"$@"} run-exe/time extract-time-times clean-up-bin - '(cpstack ctak puzzle triangle)) + '(cpstack ctak maze puzzle triangle)) (make-impl 'gambit (run-mk "mk-gambit.ss") run-gambit-exe @@ -190,7 +190,7 @@ exec mzscheme -qu "$0" ${1+"$@"} run-larceny extract-larceny-times clean-up-fasl - '()))) + '(maze)))) (define obsolte-impls '(mzscheme mzscheme-j mzscheme3m-tl mzc)) @@ -206,12 +206,18 @@ exec mzscheme -qu "$0" ${1+"$@"} earley fft graphs + lattice + maze + mazefun nboyer nestedloop nfa nucleic2 + paraffins + peval puzzle sboyer + scheme sort1 tak takl diff --git a/collects/tests/mzscheme/benchmarks/common/lattice.sch b/collects/tests/mzscheme/benchmarks/common/lattice.sch new file mode 100644 index 0000000000..0880254160 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/lattice.sch @@ -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)) diff --git a/collects/tests/mzscheme/benchmarks/common/lattice.ss b/collects/tests/mzscheme/benchmarks/common/lattice.ss new file mode 100644 index 0000000000..333eadfa9f --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/lattice.ss @@ -0,0 +1,2 @@ + +(module lattice "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/maze.sch b/collects/tests/mzscheme/benchmarks/common/maze.sch new file mode 100644 index 0000000000..f873245ea0 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/maze.sch @@ -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)))))) diff --git a/collects/tests/mzscheme/benchmarks/common/maze.ss b/collects/tests/mzscheme/benchmarks/common/maze.ss new file mode 100644 index 0000000000..cd9dd723c9 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/maze.ss @@ -0,0 +1,2 @@ + +(module maze "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/mazefun.sch b/collects/tests/mzscheme/benchmarks/common/mazefun.sch new file mode 100644 index 0000000000..bec2f56e67 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/mazefun.sch @@ -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))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/mazefun.ss b/collects/tests/mzscheme/benchmarks/common/mazefun.ss new file mode 100644 index 0000000000..8c21660459 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/mazefun.ss @@ -0,0 +1,2 @@ + +(module mazefun "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/nqueens.sch b/collects/tests/mzscheme/benchmarks/common/nqueens.sch new file mode 100644 index 0000000000..fc5fdb8d9b --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nqueens.sch @@ -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))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/nqueens.ss b/collects/tests/mzscheme/benchmarks/common/nqueens.ss new file mode 100644 index 0000000000..de43a29c50 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nqueens.ss @@ -0,0 +1,2 @@ + +(module nqueens "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/paraffins.sch b/collects/tests/mzscheme/benchmarks/common/paraffins.sch new file mode 100644 index 0000000000..708a85adcc --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/paraffins.sch @@ -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))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/paraffins.ss b/collects/tests/mzscheme/benchmarks/common/paraffins.ss new file mode 100644 index 0000000000..e5c0de450c --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/paraffins.ss @@ -0,0 +1,2 @@ + +(module paraffins "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/peval.sch b/collects/tests/mzscheme/benchmarks/common/peval.sch new file mode 100644 index 0000000000..2a7b04dfa0 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/peval.sch @@ -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))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/peval.ss b/collects/tests/mzscheme/benchmarks/common/peval.ss new file mode 100644 index 0000000000..20426697b5 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/peval.ss @@ -0,0 +1,2 @@ + +(module peval "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/scheme.sch b/collects/tests/mzscheme/benchmarks/common/scheme.sch new file mode 100644 index 0000000000..d720832d9e --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/scheme.sch @@ -0,0 +1,1075 @@ +;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley. + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-eval expr) + (let ((code (scheme-comp expr scheme-global-environment))) + (code #f))) + +(define scheme-global-environment + (cons '() ; environment chain + '())) ; macros + +(define (scheme-add-macro name proc) + (set-cdr! scheme-global-environment + (cons (cons name proc) (cdr scheme-global-environment))) + name) + +(define (scheme-error msg . args) + (/ 0)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (lst->vector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro? (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro? (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + x + (let ((y (cons name '()))) + (set! scheme-global-variables (cons y scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (cdr i)) + +(define (scheme-global-var-set! i val) + (set-cdr! i val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +(def-proc 'set-car! set-car!) +(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +;(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define expr1 + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + string