Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding gabriel benchmarks.

Browse source
This commit is contained in:
Alex Shinn 2012-08-26 12:23:56 +09:00
parent b31b52909e
commit c48915563b
37 changed files with 20632 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -215,6 +215,9 @@ test-libs: chibi-scheme$(EXE)
test: chibi-scheme$(EXE)
$(CHIBI) -xscheme tests/r5rs-tests.scm
bench-gabriel: chibi-scheme$(EXE)
./benchmarks/gabriel/run.sh
########################################################################
# Packaging

33
benchmarks/gabriel/chibi-prelude.scm Normal file
View file

@ -0,0 +1,33 @@
(import (chibi time) (scheme cxr) (srfi 33))
(define (timeval->milliseconds tv)
(quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv))
1000))
(define (time* thunk)
(call-with-output-string
(lambda (out)
(let* ((orig-output-port (current-output-port))
(_ (current-output-port out))
(start (car (get-time-of-day)))
(result (thunk))
(end (car (get-time-of-day)))
(_ (current-output-port orig-output-port))
(msecs (- (timeval->milliseconds end)
(timeval->milliseconds start))))
(display "user: ")
(display msecs)
(display " system: 0")
(display " real: ")
(display msecs)
(display " gc: 0")
(newline)
(display "result: ")
(write result)
(newline)
result))))
(define-syntax time
(syntax-rules ()
((_ expr) (time* (lambda () expr)))))

623
benchmarks/gabriel/conform.sch Normal file
View file

@ -0,0 +1,623 @@
;
; conform.scm [portable/R^399RS version]
; By Jim Miller [mods by oz]
; [call to run-benchmark added by wdc 14 Feb 1997]
; (declare (usual-integrations))
;; SORT
(define (vector-copy v)
(let* ((length (vector-length v))
(result (make-vector length)))
(let loop ((n 0))
(vector-set! result n (vector-ref v n))
(if (= n length)
v
(loop (+ n 1))))))
(define (sort 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)))))
(cond ((or (pair? obj) (null? obj))
(loop obj))
((vector? obj)
(sort! (vector-copy obj) pred))
(else
(error "sort: argument should be a list or vector" obj))))
;; This merge sort is stable for partial orders (for predicates like
;; <=, rather than like <).
(define (sort! v pred)
(define (sort-internal! vec temp low high)
(if (< low high)
(let* ((middle (quotient (+ low high) 2))
(next (+ middle 1)))
(sort-internal! temp vec low middle)
(sort-internal! temp vec next high)
(let loop ((p low) (p1 low) (p2 next))
(if (not (> p high))
(cond ((> p1 middle)
(vector-set! vec p (vector-ref temp p2))
(loop (+ p 1) p1 (+ p2 1)))
((or (> p2 high)
(pred (vector-ref temp p1)
(vector-ref temp p2)))
(vector-set! vec p (vector-ref temp p1))
(loop (+ p 1) (+ p1 1) p2))
(else
(vector-set! vec p (vector-ref temp p2))
(loop (+ p 1) p1 (+ p2 1)))))))))
(if (not (vector? v))
(error "sort!: argument not a vector" v))
(sort-internal! v
(vector-copy v)
0
(- (vector-length v) 1))
v)
;; SET OPERATIONS
; (representation as lists with distinct elements)
(define (adjoin element set)
(if (memq element set) set (cons element set)))
(define (eliminate element set)
(cond ((null? set) set)
((eq? element (car set)) (cdr set))
(else (cons (car set) (eliminate element (cdr set))))))
(define (intersect list1 list2)
(let loop ((l list1))
(cond ((null? l) '())
((memq (car l) list2) (cons (car l) (loop (cdr l))))
(else (loop (cdr l))))))
(define (union list1 list2)
(if (null? list1)
list2
(union (cdr list1)
(adjoin (car list1) list2))))
;; GRAPH NODES
; (define-structure
; (internal-node
; (print-procedure (unparser/standard-method
; 'graph-node
; (lambda (state node)
; (unparse-object state (internal-node-name node))))))
; name
; (green-edges '())
; (red-edges '())
; blue-edges)
; Above is MIT version; below is portable
(define make-internal-node vector)
(define (internal-node-name node) (vector-ref node 0))
(define (internal-node-green-edges node) (vector-ref node 1))
(define (internal-node-red-edges node) (vector-ref node 2))
(define (internal-node-blue-edges node) (vector-ref node 3))
(define (set-internal-node-name! node name) (vector-set! node 0 name))
(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges))
(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges))
(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges))
; End of portability stuff
(define (make-node name . blue-edges) ; User's constructor
(let ((name (if (symbol? name) (symbol->string name) name))
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
(make-internal-node name '() '() blue-edges)))
(define (copy-node node)
(make-internal-node (name node) '() '() (blue-edges node)))
; Selectors
(define name internal-node-name)
(define (make-edge-getter selector)
(lambda (node)
(if (or (none-node? node) (any-node? node))
(error "Can't get edges from the ANY or NONE nodes")
(selector node))))
(define red-edges (make-edge-getter internal-node-red-edges))
(define green-edges (make-edge-getter internal-node-green-edges))
(define blue-edges (make-edge-getter internal-node-blue-edges))
; Mutators
(define (make-edge-setter mutator!)
(lambda (node value)
(cond ((any-node? node) (error "Can't set edges from the ANY node"))
((none-node? node) 'OK)
(else (mutator! node value)))))
(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
;; BLUE EDGES
; (define-structure
; (blue-edge
; (print-procedure
; (unparser/standard-method
; 'blue-edge
; (lambda (state edge)
; (unparse-object state (blue-edge-operation edge))))))
; operation arg-node res-node)
; Above is MIT version; below is portable
(define make-blue-edge vector)
(define (blue-edge-operation edge) (vector-ref edge 0))
(define (blue-edge-arg-node edge) (vector-ref edge 1))
(define (blue-edge-res-node edge) (vector-ref edge 2))
(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value))
(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value))
(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value))
; End of portability stuff
; Selectors
(define operation blue-edge-operation)
(define arg-node blue-edge-arg-node)
(define res-node blue-edge-res-node)
; Mutators
(define set-arg-node! set-blue-edge-arg-node!)
(define set-res-node! set-blue-edge-res-node!)
; Higher level operations on blue edges
(define (lookup-op op node)
(let loop ((edges (blue-edges node)))
(cond ((null? edges) '())
((eq? op (operation (car edges))) (car edges))
(else (loop (cdr edges))))))
(define (has-op? op node)
(not (null? (lookup-op op node))))
; Add a (new) blue edge to a node
; (define (adjoin-blue-edge! blue-edge node)
; (let ((current-one (lookup-op (operation blue-edge) node)))
; (cond ((null? current-one)
; (set-blue-edges! node
; (cons blue-edge (blue-edges node))))
; ((and (eq? (arg-node current-one) (arg-node blue-edge))
; (eq? (res-node current-one) (res-node blue-edge)))
; 'OK)
; (else (error "Two non-equivalent blue edges for op"
; blue-edge node)))))
;; GRAPHS
; (define-structure
; (internal-graph
; (print-procedure
; (unparser/standard-method 'graph
; (lambda (state edge)
; (unparse-object state (map name (internal-graph-nodes edge)))))))
; nodes already-met already-joined)
; Above is MIT version; below is portable
(define make-internal-graph vector)
(define (internal-graph-nodes graph) (vector-ref graph 0))
(define (internal-graph-already-met graph) (vector-ref graph 1))
(define (internal-graph-already-joined graph) (vector-ref graph 2))
(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes))
; End of portability stuff
; Constructor
(define (make-graph . nodes)
(make-internal-graph nodes (make-empty-table) (make-empty-table)))
; Selectors
(define graph-nodes internal-graph-nodes)
(define already-met internal-graph-already-met)
(define already-joined internal-graph-already-joined)
; Higher level functions on graphs
(define (add-graph-nodes! graph nodes)
(set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))
(define (copy-graph g)
(define (copy-list l) (vector->list (list->vector l)))
(make-internal-graph
(copy-list (graph-nodes g))
(already-met g)
(already-joined g)))
(define (clean-graph g)
(define (clean-node node)
(if (not (or (any-node? node) (none-node? node)))
(begin
(set-green-edges! node '())
(set-red-edges! node '()))))
(for-each clean-node (graph-nodes g))
g)
(define (canonicalize-graph graph classes)
(define (fix node)
(define (fix-set object selector mutator)
(mutator object
(map (lambda (node)
(find-canonical-representative node classes))
(selector object))))
(if (not (or (none-node? node) (any-node? node)))
(begin
(fix-set node green-edges set-green-edges!)
(fix-set node red-edges set-red-edges!)
(for-each
(lambda (blue-edge)
(set-arg-node! blue-edge
(find-canonical-representative (arg-node blue-edge) classes))
(set-res-node! blue-edge
(find-canonical-representative (res-node blue-edge) classes)))
(blue-edges node))))
node)
(define (fix-table table)
(define (canonical? node) (eq? node (find-canonical-representative node classes)))
(define (filter-and-fix predicate-fn update-fn list)
(let loop ((list list))
(cond ((null? list) '())
((predicate-fn (car list))
(cons (update-fn (car list)) (loop (cdr list))))
(else (loop (cdr list))))))
(define (fix-line line)
(filter-and-fix
(lambda (entry) (canonical? (car entry)))
(lambda (entry) (cons (car entry)
(find-canonical-representative (cdr entry) classes)))
line))
(if (null? table)
'()
(cons (car table)
(filter-and-fix
(lambda (entry) (canonical? (car entry)))
(lambda (entry) (cons (car entry) (fix-line (cdr entry))))
(cdr table)))))
(make-internal-graph
(map (lambda (class) (fix (car class))) classes)
(fix-table (already-met graph))
(fix-table (already-joined graph))))
;; USEFUL NODES
(define none-node (make-node 'none #t))
(define (none-node? node) (eq? node none-node))
(define any-node (make-node 'any '()))
(define (any-node? node) (eq? node any-node))
;; COLORED EDGE TESTS
(define (green-edge? from-node to-node)
(cond ((any-node? from-node) #f)
((none-node? from-node) #t)
((memq to-node (green-edges from-node)) #t)
(else #f)))
(define (red-edge? from-node to-node)
(cond ((any-node? from-node) #f)
((none-node? from-node) #t)
((memq to-node (red-edges from-node)) #t)
(else #f)))
;; SIGNATURE
; Return signature (i.e. <arg, res>) given an operation and a node
(define sig
(let ((none-comma-any (cons none-node any-node)))
(lambda (op node) ; Returns (arg, res)
(let ((the-edge (lookup-op op node)))
(if (not (null? the-edge))
(cons (arg-node the-edge) (res-node the-edge))
none-comma-any)))))
; Selectors from signature
(define (arg pair) (car pair))
(define (res pair) (cdr pair))
;; CONFORMITY
(define (conforms? t1 t2)
(define nodes-with-red-edges-out '())
(define (add-red-edge! from-node to-node)
(set-red-edges! from-node (adjoin to-node (red-edges from-node)))
(set! nodes-with-red-edges-out
(adjoin from-node nodes-with-red-edges-out)))
(define (greenify-red-edges! from-node)
(set-green-edges! from-node
(append (red-edges from-node) (green-edges from-node)))
(set-red-edges! from-node '()))
(define (delete-red-edges! from-node)
(set-red-edges! from-node '()))
(define (does-conform t1 t2)
(cond ((or (none-node? t1) (any-node? t2)) #t)
((or (any-node? t1) (none-node? t2)) #f)
((green-edge? t1 t2) #t)
((red-edge? t1 t2) #t)
(else
(add-red-edge! t1 t2)
(let loop ((blues (blue-edges t2)))
(if (null? blues)
#t
(let* ((current-edge (car blues))
(phi (operation current-edge)))
(and (has-op? phi t1)
(does-conform
(res (sig phi t1))
(res (sig phi t2)))
(does-conform
(arg (sig phi t2))
(arg (sig phi t1)))
(loop (cdr blues)))))))))
(let ((result (does-conform t1 t2)))
(for-each (if result greenify-red-edges! delete-red-edges!)
nodes-with-red-edges-out)
result))
(define (equivalent? a b)
(and (conforms? a b) (conforms? b a)))
;; EQUIVALENCE CLASSIFICATION
; Given a list of nodes, return a list of equivalence classes
(define (classify nodes)
(let node-loop ((classes '())
(nodes nodes))
(if (null? nodes)
(map (lambda (class)
(sort class
(lambda (node1 node2)
(< (string-length (name node1))
(string-length (name node2))))))
classes)
(let ((this-node (car nodes)))
(define (add-node classes)
(cond ((null? classes) (list (list this-node)))
((equivalent? this-node (caar classes))
(cons (cons this-node (car classes))
(cdr classes)))
(else (cons (car classes)
(add-node (cdr classes))))))
(node-loop (add-node classes)
(cdr nodes))))))
; Given a node N and a classified set of nodes,
; find the canonical member corresponding to N
(define (find-canonical-representative element classification)
(let loop ((classes classification))
(cond ((null? classes) (error "Can't classify" element))
((memq element (car classes)) (car (car classes)))
(else (loop (cdr classes))))))
; Reduce a graph by taking only one member of each equivalence
; class and canonicalizing all outbound pointers
(define (reduce graph)
(let ((classes (classify (graph-nodes graph))))
(canonicalize-graph graph classes)))
;; TWO DIMENSIONAL TABLES
(define (make-empty-table) (list 'TABLE))
(define (lookup table x y)
(let ((one (assq x (cdr table))))
(if one
(let ((two (assq y (cdr one))))
(if two (cdr two) #f))
#f)))
(define (insert! table x y value)
(define (make-singleton-table x y)
(list (cons x y)))
(let ((one (assq x (cdr table))))
(if one
(set-cdr! one (cons (cons y value) (cdr one)))
(set-cdr! table (cons (cons x (make-singleton-table y value))
(cdr table))))))
;; MEET/JOIN
; These update the graph when computing the node for node1*node2
(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2)
(make-blue-edge op
(arg-fn graph (arg sig1) (arg sig2))
(res-fn graph (res sig1) (res sig2))))
(define (meet graph node1 node2)
(cond ((eq? node1 node2) node1)
((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize
((none-node? node1) node2)
((none-node? node2) node1)
((lookup (already-met graph) node1 node2)) ; return it if found
((conforms? node1 node2) node2)
((conforms? node2 node1) node1)
(else
(let ((result
(make-node (string-append "(" (name node1) " ^ " (name node2) ")"))))
(add-graph-nodes! graph result)
(insert! (already-met graph) node1 node2 result)
(set-blue-edges! result
(map
(lambda (op)
(blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
(intersect (map operation (blue-edges node1))
(map operation (blue-edges node2)))))
result))))
(define (join graph node1 node2)
(cond ((eq? node1 node2) node1)
((any-node? node1) node2)
((any-node? node2) node1)
((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize
((lookup (already-joined graph) node1 node2)) ; return it if found
((conforms? node1 node2) node1)
((conforms? node2 node1) node2)
(else
(let ((result
(make-node (string-append "(" (name node1) " v " (name node2) ")"))))
(add-graph-nodes! graph result)
(insert! (already-joined graph) node1 node2 result)
(set-blue-edges! result
(map
(lambda (op)
(blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
(union (map operation (blue-edges node1))
(map operation (blue-edges node2)))))
result))))
;; MAKE A LATTICE FROM A GRAPH
(define (make-lattice g print?)
(define (step g)
(let* ((copy (copy-graph g))
(nodes (graph-nodes copy)))
(for-each (lambda (first)
(for-each (lambda (second)
(meet copy first second)
(join copy first second))
nodes))
nodes)
copy))
(define (loop g count)
(if print? (display count))
(let ((lattice (step g)))
(if print? (begin (display " -> ")
(display (length (graph-nodes lattice)))))
(let* ((new-g (reduce lattice))
(new-count (length (graph-nodes new-g))))
(if (= new-count count)
(begin
(if print? (newline))
new-g)
(begin
(if print? (begin (display " -> ")
(display new-count) (newline)))
(loop new-g new-count))))))
(let ((graph
(apply make-graph
(adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
(loop graph (length (graph-nodes graph)))))
;; DEBUG and TEST
(define a '())
(define b '())
(define c '())
(define d '())
(define (reset)
(set! a (make-node 'a))
(set! b (make-node 'b))
(set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
(set-blue-edges! b (list (make-blue-edge 'phi any-node a)
(make-blue-edge 'theta any-node b)))
(set! c (make-node "c"))
(set! d (make-node "d"))
(set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
(set-blue-edges! d (list (make-blue-edge 'phi any-node c)
(make-blue-edge 'theta any-node d)))
'(made a b c d))
(define (test)
(reset)
(map name
(graph-nodes
(make-lattice (make-graph a b c d any-node none-node) #t))))
;;; note printflag #t
;(define (time-test)
; (let ((t (runtime)))
; (let ((ans (test)))
; (cons ans (- (runtime) t)))))
;
; run and make sure result is correct
;
(define (go)
(reset)
(let ((result '("(((b v d) ^ a) v c)"
"(c ^ d)"
"(b v (a ^ d))"
"((a v d) ^ b)"
"(b v d)"
"(b ^ (a v c))"
"(a v (c ^ d))"
"((b v d) ^ a)"
"(c v (a v d))"
"(a v c)"
"(d v (b ^ (a v c)))"
"(d ^ (a v c))"
"((a ^ d) v c)"
"((a ^ b) v d)"
"(((a v d) ^ b) v (a ^ d))"
"(b ^ d)"
"(b v (a v d))"
"(a ^ c)"
"(b ^ (c v d))"
"(a ^ b)"
"(a v b)"
"((a ^ d) ^ b)"
"(a ^ d)"
"(a v d)"
"d"
"(c v d)"
"a"
"b"
"c"
"any"
"none")))
(if (equal? (test) result)
(display " ok.")
(display " um."))
(newline)))
;[mods made by wdc]
;(go)
;(exit)
(time (let loop ((n 10))
(if (zero? n)
'done
(begin
(go)
(loop (- n 1))))))

34
benchmarks/gabriel/cpstack.sch Normal file
View file

@ -0,0 +1,34 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: cpstak.sch
; Description: continuation-passing version of TAK
; Author: Will Clinger
; Created: 20-Aug-87
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
;;; A good test of first class procedures and tail recursion.
(define (cpstak x y z)
(define (tak x y z k)
(if (not (< y x))
(k z)
(tak (- x 1)
y
z
(lambda (v1)
(tak (- y 1)
z
x
(lambda (v2)
(tak (- z 1)
x
y
(lambda (v3)
(tak v1 v2 v3 k)))))))))
(tak x y z (lambda (a) a)))
;;; call: (cpstak 18 12 6)
(time (cpstak 18 12 2))

61
benchmarks/gabriel/ctak.sch Normal file
View file

@ -0,0 +1,61 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: ctak.sch
; Description: The ctak benchmark
; Author: Richard Gabriel
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:53:02 (Bob Shaw)
; 24-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The original version of this benchmark used a continuation mechanism that
; is less powerful than call-with-current-continuation and also relied on
; dynamic binding, which is not provided in standard Scheme. Since the
; intent of the benchmark seemed to be to test non-local exits, the dynamic
; binding has been replaced here by lexical binding.
; For Scheme the comment that follows should read:
;;; CTAK -- A version of the TAK procedure that uses continuations.
;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
(define (ctak x y z)
(call-with-current-continuation
(lambda (k)
(ctak-aux k x y z))))
(define (ctak-aux k x y z)
(cond ((not (< y x)) ;xy
(k z))
(else (call-with-current-continuation
(ctak-aux
k
(call-with-current-continuation
(lambda (k)
(ctak-aux k
(- x 1)
y
z)))
(call-with-current-continuation
(lambda (k)
(ctak-aux k
(- y 1)
z
x)))
(call-with-current-continuation
(lambda (k)
(ctak-aux k
(- z 1)
x
y))))))))
;;; call: (ctak 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 8) (v 0))
(if (zero? n)
v
(loop (- n 1)
(ctak 18 12 (if input 6 0)))))))

97
benchmarks/gabriel/dderiv.sch Normal file
View file

@ -0,0 +1,97 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: dderiv.sch
; Description: DDERIV benchmark from the Gabriel tests
; Author: Vaughan Pratt
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:53:29 (Bob Shaw)
; 23-Jul-87 (Will Clinger)
; 9-Feb-88 (Will Clinger)
; Language: Scheme (but see note below)
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Note: This benchmark uses property lists. The procedures that must
; be supplied are get and put, where (put x y z) is equivalent to Common
; Lisp's (setf (get x y) z).
;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
;;; This benchmark is a variant of the simple symbolic derivative program
;;; (DERIV). The main change is that it is `table-driven.' Instead of using a
;;; large COND that branches on the CAR of the expression, this program finds
;;; the code that will take the derivative on the property list of the atom in
;;; the CAR position. So, when the expression is (+ . <rest>), the code
;;; stored under the atom '+ with indicator DERIV will take <rest> and
;;; return the derivative for '+. The way that MacLisp does this is with the
;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
;;; atomic name in that it expects an argument list and the compiler compiles
;;; code, but the name of the function with that code is stored on the
;;; property list of FOO under the indicator BAR, in this case. You may have
;;; to do something like:
;;; :property keyword is not Common Lisp.
; Returns the wrong answer for quotients.
; Fortunately these aren't used in the benchmark.
(define pg-alist '())
(define (put sym d what)
(set! pg-alist (cons (cons sym what) pg-alist)))
(define (get sym d)
(cdr (assq sym pg-alist)))
(define (dderiv-aux a)
(list '/ (dderiv a) a))
(define (f+dderiv a)
(cons '+ (map dderiv a)))
(define (f-dderiv a)
(cons '- (map dderiv a)))
(define (*dderiv a)
(list '* (cons '* a)
(cons '+ (map dderiv-aux a))))
(define (/dderiv a)
(list '-
(list '/
(dderiv (car a))
(cadr a))
(list '/
(car a)
(list '*
(cadr a)
(cadr a)
(dderiv (cadr a))))))
(define (dderiv a)
(cond
((not (pair? a))
(cond ((eq? a 'x) 1) (else 0)))
(else (let ((dderiv (get (car a) 'dderiv)))
(cond (dderiv (dderiv (cdr a)))
(else 'error))))))
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
(put '- 'dderiv f-dderiv) ; install procedure on the property list
(put '* 'dderiv *dderiv) ; install procedure on the property list
(put '/ 'dderiv /dderiv) ; install procedure on the property list
;;; call: (run)
(time (run))

59
benchmarks/gabriel/deriv.sch Normal file
View file

@ -0,0 +1,59 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: deriv.sch
; Description: The DERIV benchmark from the Gabriel tests.
; Author: Vaughan Pratt
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:53:50 (Bob Shaw)
; 23-Jul-87 (Will Clinger)
; 9-Feb-88 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
;;; It uses a simple subset of Lisp and does a lot of CONSing.
; Returns the wrong answer for quotients.
; Fortunately these aren't used in the benchmark.
(define (deriv-aux a) (list '/ (deriv a) a))
(define (deriv a)
(cond
((not (pair? a))
(cond ((eq? a 'x) 1) (else 0)))
((eq? (car a) '+)
(cons '+ (map deriv (cdr a))))
((eq? (car a) '-)
(cons '- (map deriv
(cdr a))))
((eq? (car a) '*)
(list '*
a
(cons '+ (map deriv-aux (cdr a)))))
((eq? (car a) '/)
(list '-
(list '/
(deriv (cadr a))
(caddr a))
(list '/
(cadr a)
(list '*
(caddr a)
(caddr a)
(deriv (caddr a))))))
(else 'error)))
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;;; call: (run)
(time (run))

70
benchmarks/gabriel/destruct.sch Normal file
View file

@ -0,0 +1,70 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: destruct.sch
; Description: DESTRUCTIVE benchmark from Gabriel tests
; Author: Bob Shaw, HPLabs/ATC
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:54:12 (Bob Shaw)
; 23-Jul-87 (Will Clinger)
; 22-Jan-88 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; append! is no longer a standard Scheme procedure, so it must be defined
; for implementations that don't already have it.
(define (my-append! x y)
(if (null? x)
y
(do ((a x b)
(b (cdr x) (cdr b)))
((null? b)
(set-cdr! a y)
x))))
;;; DESTRU -- Destructive operation benchmark
(define (destructive n m)
(let ((l (do ((i 10 (- i 1))
(a '() (cons '() a)))
((= i 0) a))))
(do ((i n (- i 1)))
((= i 0))
(cond ((null? (car l))
(do ((l l (cdr l)))
((null? l))
(or (car l)
(set-car! l (cons '() '())))
(my-append! (car l)
(do ((j m (- j 1))
(a '() (cons '() a)))
((= j 0) a)))))
(else
(do ((l1 l (cdr l1))
(l2 (cdr l) (cdr l2)))
((null? l2))
(set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
(a (car l2) (cdr a)))
((zero? j) a)
(set-car! a i))
(let ((n (quotient (length (car l1)) 2)))
(cond ((= n 0) (set-car! l1 '())
(car l1))
(else
(do ((j n (- j 1))
(a (car l1) (cdr a)))
((= j 1)
(let ((x (cdr a)))
(set-cdr! a '())
x))
(set-car! a i))))))))))))
;;; call: (destructive 600 50)
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 10) (v 0))
(if (zero? n)
'v
(loop (- n 1)
(destructive (if input 600 0) 500))))))

57
benchmarks/gabriel/div.sch Normal file
View file

@ -0,0 +1,57 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: div.sch
; Description: DIV benchmarks
; Author: Richard Gabriel
; Created: 8-Apr-85
; Modified: 19-Jul-85 18:28:01 (Bob Shaw)
; 23-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
;;; This file contains a recursive as well as an iterative test.
(define (create-n n)
(do ((n n (- n 1))
(a '() (cons '() a)))
((= n 0) a)))
(define *ll* (create-n 200))
(define (iterative-div2 l)
(do ((l l (cddr l))
(a '() (cons (car l) a)))
((null? l) a)))
(define (recursive-div2 l)
(cond ((null? l) '())
(else (cons (car l) (recursive-div2 (cddr l))))))
(define (test-1 l)
(do ((i 3000 (- i 1)))
((= i 0))
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)))
(define (test-2 l)
(do ((i 3000 (- i 1)))
((= i 0))
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)))
;;; for the iterative test call: (test-1 *ll*)
;;; for the recursive test call: (test-2 *ll*)
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 10) (v 0))
(if (zero? n)
v
(loop (- n 1)
(cons
(test-1 (if input *ll* '()))
(test-2 (if input *ll* '()))))))))

649
benchmarks/gabriel/earley.sch Normal file
View file

@ -0,0 +1,649 @@
;;; EARLEY -- Earley's parser, written by Marc Feeley.
; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $
; 990708 / lth -- changed 'main' to 'earley-benchmark'.
;
; (make-parser grammar lexer) is used to create a parser from the grammar
; description `grammar' and the lexer function `lexer'.
;
; A grammar is a list of definitions. Each definition defines a non-terminal
; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
; A given non-terminal can only be defined once. The first non-terminal
; defined is the grammar's goal. Each rule is a possibly empty list of
; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
; can be any scheme value. Note that all grammar symbols are treated as
; non-terminals. This is fine though because the lexer will be outputing
; non-terminals.
;
; The lexer defines what a token is and the mapping between tokens and
; the grammar's non-terminals. It is a function of one argument, the input,
; that returns the list of tokens corresponding to the input. Each token is
; represented by a list. The first element is some `user-defined' information
; associated with the token and the rest represents the token's class(es) (as a
; list of non-terminals that this token corresponds to).
;
; The result of `make-parser' is a function that parses the single input it
; is given into the grammar's goal. The result is a `parse' which can be
; manipulated with the procedures: `parse->parsed?', `parse->trees'
; and `parse->nb-trees' (see below).
;
; Let's assume that we want a parser for the grammar
;
; S -> x = E
; E -> E + E | V
; V -> V y |
;
; and that the input to the parser is a string of characters. Also, assume we
; would like to map the characters `x', `y', `+' and `=' into the corresponding
; non-terminals in the grammar. Such a parser could be created with
;
; (make-parser
; '(
; (s (x = e))
; (e (e + e) (v))
; (v (v y) ())
; )
; (lambda (str)
; (map (lambda (char)
; (list char ; user-info = the character itself
; (case char
; ((#\x) 'x)
; ((#\y) 'y)
; ((#\+) '+)
; ((#\=) '=)
; (else (fatal-error "lexer error")))))
; (string->list str)))
; )
;
; An alternative definition (that does not check for lexical errors) is
;
; (make-parser
; '(
; (s (#\x #\= e))
; (e (e #\+ e) (v))
; (v (v #\y) ())
; )
; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
; )
;
; To help with the rest of the discussion, here are a few definitions:
;
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
; It indicates a point between two input tokens (0 = beginning, `n' = end).
; For example, if `n' = 4, there are 5 input pointers:
;
; input token1 token2 token3 token4
; input pointers 0 1 2 3 4
;
; A configuration indicates the extent to which a given rule is parsed (this
; is the common `dot notation'). For simplicity, a configuration is
; represented as an integer, with successive configurations in the same
; rule associated with successive integers. It is assumed that the grammar
; has been extended with rules to aid scanning. These rules are of the
; form `nt ->', and there is one such rule for every non-terminal. Note
; that these rules are special because they only apply when the corresponding
; non-terminal is returned by the lexer.
;
; A configuration set is a configuration grouped with the set of input pointers
; representing where the head non-terminal of the configuration was predicted.
;
; Here are the rules and configurations for the grammar given above:
;
; S -> . \
; 0 |
; x -> . |
; 1 |
; = -> . |
; 2 |
; E -> . |
; 3 > special rules (for scanning)
; + -> . |
; 4 |
; V -> . |
; 5 |
; y -> . |
; 6 /
; S -> . x . = . E .
; 7 8 9 10
; E -> . E . + . E .
; 11 12 13 14
; E -> . V .
; 15 16
; V -> . V . y .
; 17 18 19
; V -> .
; 20
;
; Starters of the non-terminal `nt' are configurations that are leftmost
; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
; configurations that are rightmost in any rule for `nt'. Predictors of the
; non-terminal `nt' are configurations that are directly to the left of `nt'
; in any rule.
;
; For the grammar given above,
;
; Starters of V = (17 20)
; Enders of V = (5 19 20)
; Predictors of V = (15 17)
(define (make-parser grammar lexer)
(define (non-terminals grammar) ; return vector of non-terminals in grammar
(define (add-nt nt nts)
(if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
(let def-loop ((defs grammar) (nts '()))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def))
(nts (add-nt head nts)))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nts nts))
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts))))
(def-loop (cdr defs) nts))))
(list->vector (reverse nts))))) ; goal non-terminal must be at index 0
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (nb-configurations grammar) ; return nb of configurations in grammar
(let def-loop ((defs grammar) (nb-confs 0))
(if (pair? defs)
(let ((def (car defs)))
(let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nb-confs nb-confs))
(if (pair? l)
(loop (cdr l) (+ nb-confs 1))
(rule-loop (cdr rules) (+ nb-confs 1)))))
(def-loop (cdr defs) nb-confs))))
nb-confs)))
; First, associate a numeric identifier to every non-terminal in the
; grammar (with the goal non-terminal associated with 0).
;
; So, for the grammar given above we get:
;
; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
(let* ((nts (non-terminals grammar)) ; id map = list of non-terms
(nb-nts (vector-length nts)) ; the number of non-terms
(nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
(starters (make-vector nb-nts '())) ; starters for every non-term
(enders (make-vector nb-nts '())) ; enders for every non-term
(predictors (make-vector nb-nts '())) ; predictors for every non-term
(steps (make-vector nb-confs #f)) ; what to do in a given conf
(names (make-vector nb-confs #f))) ; name of rules
(define (setup-tables grammar nts starters enders predictors steps names)
(define (add-conf conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))
(let ((nb-nts (vector-length nts)))
(let nt-loop ((i (- nb-nts 1)))
(if (>= i 0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) 0))
(vector-set! enders i (list i))
(nt-loop (- i 1)))))
(let def-loop ((defs grammar) (conf (vector-length nts)))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
(if (pair? rules)
(let ((rule (car rules)))
(vector-set! names conf (list head rule-num))
(add-conf conf head nts starters)
(let loop ((l rule) (conf conf))
(if (pair? l)
(let ((nt (car l)))
(vector-set! steps conf (ind nt nts))
(add-conf conf nt nts predictors)
(loop (cdr l) (+ conf 1)))
(begin
(vector-set! steps conf (- (ind head nts) nb-nts))
(add-conf conf head nts enders)
(rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
(def-loop (cdr defs) conf))))))))
; Now, for each non-terminal, compute the starters, enders and predictors and
; the names and steps tables.
(setup-tables grammar nts starters enders predictors steps names)
; Build the parser description
(let ((parser-descr (vector lexer
nts
starters
enders
predictors
steps
names)))
(lambda (input)
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (comp-tok tok nts) ; transform token to parsing format
(let loop ((l1 (cdr tok)) (l2 '()))
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i
(loop (cdr l1) (cons i l2))
(loop (cdr l1) l2)))
(cons (car tok) (reverse l2)))))
(define (input->tokens input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
(define (make-states nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks 1) #f)))
(let loop ((i nb-toks))
(if (>= i 0)
(let ((v (make-vector (+ nb-confs 1) #f)))
(vector-set! v 0 -1)
(vector-set! states i v)
(loop (- i 1)))
states))))
(define (conf-set-get state conf)
(vector-ref state (+ conf 1)))
(define (conf-set-get* state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num 6) #f)))
(vector-set! conf-set 1 -3) ; old elems tail (points to head)
(vector-set! conf-set 2 -1) ; old elems head
(vector-set! conf-set 3 -1) ; new elems tail (points to head)
(vector-set! conf-set 4 -1) ; new elems head
(vector-set! state (+ conf 1) conf-set)
conf-set))))
(define (conf-set-merge-new! conf-set)
(vector-set! conf-set
(+ (vector-ref conf-set 1) 5)
(vector-ref conf-set 4))
(vector-set! conf-set 1 (vector-ref conf-set 3))
(vector-set! conf-set 3 -1)
(vector-set! conf-set 4 -1))
(define (conf-set-head conf-set)
(vector-ref conf-set 2))
(define (conf-set-next conf-set i)
(vector-ref conf-set (+ i 5)))
(define (conf-set-member? state conf i)
(let ((conf-set (vector-ref state (+ conf 1))))
(if conf-set
(conf-set-next conf-set i)
#f)))
(define (conf-set-adjoin state conf-set conf i)
(let ((tail (vector-ref conf-set 3))) ; put new element at tail
(vector-set! conf-set (+ i 5) -1)
(vector-set! conf-set (+ tail 5) i)
(vector-set! conf-set 3 i)
(if (< tail 0)
(begin
(vector-set! conf-set 0 (vector-ref state 0))
(vector-set! state 0 conf)))))
(define (conf-set-adjoin* states state-num l i)
(let ((state (vector-ref states state-num)))
(let loop ((l1 l))
(if (pair? l1)
(let* ((conf (car l1))
(conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1))))))))
(define (conf-set-adjoin** states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let* ((state* (vector-ref states* state-num))
(conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i))
#t)
#f)))
(define (conf-set-union state conf-set conf other-set)
(let loop ((i (conf-set-head other-set)))
(if (>= i 0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i))))))
(define (forw states state-num starters enders predictors steps nts)
(define (predict state state-num conf-set conf nt starters enders)
; add configurations which start the non-terminal `nt' to the
; right of the dot
(let loop1 ((l (vector-ref starters nt)))
(if (pair? l)
(let* ((starter (car l))
(starter-set (conf-set-get* state state-num starter)))
(if (not (conf-set-next starter-set state-num))
(begin
(conf-set-adjoin state starter-set starter state-num)
(loop1 (cdr l)))
(loop1 (cdr l))))))
; check for possible completion of the non-terminal `nt' to the
; right of the dot
(let loop2 ((l (vector-ref enders nt)))
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let* ((next (+ conf 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next conf-set)
(loop2 (cdr l)))
(loop2 (cdr l)))))))
(define (reduce states state state-num conf-set head preds)
; a non-terminal is now completed so check for reductions that
; are now possible at the configurations `preds'
(let loop1 ((l preds))
(if (pair? l)
(let ((pred (car l)))
(let loop2 ((i head))
(if (>= i 0)
(let ((pred-set (conf-set-get (vector-ref states i) pred)))
(if pred-set
(let* ((next (+ pred 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next pred-set)))
(loop2 (conf-set-next conf-set i)))
(loop1 (cdr l))))))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
(let loop ()
(let ((conf (vector-ref state 0)))
(if (>= conf 0)
(let* ((step (vector-ref steps conf))
(conf-set (vector-ref state (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(if (>= step 0)
(predict state state-num conf-set conf step starters enders)
(let ((preds (vector-ref predictors (+ step nb-nts))))
(reduce states state state-num conf-set head preds)))
(loop)))))))
(define (forward starters enders predictors steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(states (make-states nb-toks nb-confs))
(goal-starters (vector-ref starters 0)))
(conf-set-adjoin* states 0 goal-starters 0) ; predict goal
(forw states 0 starters enders predictors steps nts)
(let loop ((i 0))
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
(forw states (+ i 1) starters enders predictors steps nts)
(loop (+ i 1)))))
states))
(define (produce conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf 1)))
(if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
(let loop1 ((l (vector-ref enders (vector-ref steps prev))))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)))
(if (>= k 0)
(begin
(and (>= k i)
(conf-set-adjoin** states states* k prev i)
(conf-set-adjoin** states states* j ender k))
(loop2 (conf-set-next ender-set k)))
(loop1 (cdr l))))
(loop1 (cdr l)))))))))
(define (back states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
(let loop1 ()
(let ((conf (vector-ref state* 0)))
(if (>= conf 0)
(let* ((conf-set (vector-ref state* (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state* 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(let loop2 ((i head))
(if (>= i 0)
(begin
(produce conf i state-num enders steps
toks states states* nb-nts)
(loop2 (conf-set-next conf-set i)))
(loop1)))))))))
(define (backward states enders steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(nb-nts (vector-length nts))
(states* (make-states nb-toks nb-confs))
(goal-enders (vector-ref enders 0)))
(let loop1 ((l goal-enders))
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin** states states* nb-toks conf 0)
(loop1 (cdr l)))))
(let loop2 ((i nb-toks))
(if (>= i 0)
(begin
(back states states* i enders steps nb-nts toks)
(loop2 (- i 1)))))
states*))
(define (parsed? nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
#t
(loop (cdr l))))
#f)))
#f)))
(define (deriv-trees conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name ; `conf' is at the start of a rule (either special or not)
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf 1)))
(let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
(l2 '()))
(if (pair? l1)
(let* ((ender (car l1))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (l2 l2))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((prev-trees
(deriv-trees prev i k enders steps names
toks states nb-nts))
(ender-trees
(deriv-trees ender k j enders steps names
toks states nb-nts)))
(let loop3 ((l3 ender-trees) (l2 l2))
(if (pair? l3)
(let ((ender-tree (list (car l3))))
(let loop4 ((l4 prev-trees) (l2 l2))
(if (pair? l4)
(loop4 (cdr l4)
(cons (append (car l4)
ender-tree)
l2))
(loop3 (cdr l3) l2))))
(loop2 (conf-set-next ender-set k) l2))))
(loop2 (conf-set-next ender-set k) l2))
(loop1 (cdr l1) l2)))
(loop1 (cdr l1) l2)))
l2))))))
(define (deriv-trees* nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (trees '()))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(append (deriv-trees conf i j enders steps names
toks states nb-nts)
trees))
(loop (cdr l) trees)))
trees)))
#f)))
(define (nb-deriv-trees conf i j enders steps toks states nb-nts)
(let ((prev (- conf 1)))
(if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
1
(let loop1 ((l (vector-ref enders (vector-ref steps prev)))
(n 0))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (n n))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((nb-prev-trees
(nb-deriv-trees prev i k enders steps
toks states nb-nts))
(nb-ender-trees
(nb-deriv-trees ender k j enders steps
toks states nb-nts)))
(loop2 (conf-set-next ender-set k)
(+ n (* nb-prev-trees nb-ender-trees))))
(loop2 (conf-set-next ender-set k) n))
(loop1 (cdr l) n)))
(loop1 (cdr l) n)))
n)))))
(define (nb-deriv-trees* nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (nb-trees 0))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(+ (nb-deriv-trees conf i j enders steps
toks states nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees)))
#f)))
(let* ((lexer (vector-ref parser-descr 0))
(nts (vector-ref parser-descr 1))
(starters (vector-ref parser-descr 2))
(enders (vector-ref parser-descr 3))
(predictors (vector-ref parser-descr 4))
(steps (vector-ref parser-descr 5))
(names (vector-ref parser-descr 6))
(toks (input->tokens input lexer nts)))
(vector nts
starters
enders
predictors
steps
names
toks
(backward (forward starters enders predictors steps nts toks)
enders steps nts toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))
(define (parse->parsed? parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(states (vector-ref parse 7))
(parsed? (vector-ref parse 8)))
(parsed? nt i j nts enders states)))
(define (parse->trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(names (vector-ref parse 5))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(deriv-trees* (vector-ref parse 9)))
(deriv-trees* nt i j nts enders steps names toks states)))
(define (parse->nb-trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(nb-deriv-trees* (vector-ref parse 10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))
(define (test k)
(let ((p (make-parser '( (s (a) (s s)) )
(lambda (l) (map (lambda (x) (list x x)) l)))))
(let ((x (p (vector->list (make-vector k 'a)))))
(length (parse->trees x 's 0 k)))))
(time (test 12))

117
benchmarks/gabriel/fft.sch Normal file
View file

@ -0,0 +1,117 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: fft.cl
; Description: FFT benchmark from the Gabriel tests.
; Author: Harry Barrow
; Created: 8-Apr-85
; Modified: 6-May-85 09:29:22 (Bob Shaw)
; 11-Aug-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define pi (atan 0 -1))
;;; FFT -- This is an FFT benchmark written by Harry Barrow.
;;; It tests a variety of floating point operations,
;;; including array references.
(define *re* (make-vector 1025 0.0))
(define *im* (make-vector 1025 0.0))
(define (fft areal aimag)
(let ((ar 0)
(ai 0)
(i 0)
(j 0)
(k 0)
(m 0)
(n 0)
(le 0)
(le1 0)
(ip 0)
(nv2 0)
(nm1 0)
(ur 0)
(ui 0)
(wr 0)
(wi 0)
(tr 0)
(ti 0))
;; initialize
(set! ar areal)
(set! ai aimag)
(set! n (vector-length ar))
(set! n (- n 1))
(set! nv2 (quotient n 2))
(set! nm1 (- n 1))
(set! m 0) ;compute m = log(n)
(set! i 1)
(let loop ()
(if (< i n)
(begin (set! m (+ m 1))
(set! i (+ i i))
(loop))))
(cond ((not (= n (expt 2 m)))
(error "array size not a power of two.")))
;; interchange elements in bit-reversed order
(set! j 1)
(set! i 1)
(let l3 ()
(cond ((< i j)
(set! tr (vector-ref ar j))
(set! ti (vector-ref ai j))
(vector-set! ar j (vector-ref ar i))
(vector-set! ai j (vector-ref ai i))
(vector-set! ar i tr)
(vector-set! ai i ti)))
(set! k nv2)
(let l6 ()
(cond ((< k j)
(set! j (- j k))
(set! k (/ k 2))
(l6))))
(set! j (+ j k))
(set! i (+ i 1))
(cond ((< i n)
(l3))))
(do ((l 1 (+ l 1))) ;loop thru stages (syntax converted
((> l m)) ; from old MACLISP style \bs)
(set! le (expt 2 l))
(set! le1 (quotient le 2))
(set! ur 1.0)
(set! ui 0.)
(set! wr (cos (/ pi le1)))
(set! wi (sin (/ pi le1)))
;; loop thru butterflies
(do ((j 1 (+ j 1)))
((> j le1))
;; do a butterfly
(do ((i j (+ i le)))
((> i n))
(set! ip (+ i le1))
(set! tr (- (* (vector-ref ar ip) ur)
(* (vector-ref ai ip) ui)))
(set! ti (+ (* (vector-ref ar ip) ui)
(* (vector-ref ai ip) ur)))
(vector-set! ar ip (- (vector-ref ar i) tr))
(vector-set! ai ip (- (vector-ref ai i) ti))
(vector-set! ar i (+ (vector-ref ar i) tr))
(vector-set! ai i (+ (vector-ref ai i) ti))))
(set! tr (- (* ur wr) (* ui wi)))
(set! ti (+ (* ur wi) (* ui wr)))
(set! ur tr)
(set! ui ti))
#t))
;;; the timer which does 10 calls on fft
(define (fft-bench)
(do ((ntimes 0 (+ ntimes 1)))
((= ntimes 1000))
(fft *re* *im*)))
;;; call: (fft-bench)
(time (fft-bench))

645
benchmarks/gabriel/graphs.sch Normal file
View file

@ -0,0 +1,645 @@
; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
; and to expand the four macros below.
; Modified 11 June 1997 by Will Clinger to eliminate assertions
; and to replace a use of "recur" with a named let.
;
; Performance note: (graphs-benchmark 7) allocates
; 34509143 pairs
; 389625 vectors with 2551590 elements
; 56653504 closures (not counting top level and known procedures)
; End of new code.
;;; ==== std.ss ====
; (define-syntax assert
; (syntax-rules ()
; ((assert test info-rest ...)
; #f)))
;
; (define-syntax deny
; (syntax-rules ()
; ((deny test info-rest ...)
; #f)))
;
; (define-syntax when
; (syntax-rules ()
; ((when test e-first e-rest ...)
; (if test
; (begin e-first
; e-rest ...)))))
;
; (define-syntax unless
; (syntax-rules ()
; ((unless test e-first e-rest ...)
; (if (not test)
; (begin e-first
; e-rest ...)))))
;;; ==== util.ss ====
; Fold over list elements, associating to the left.
(define fold
(lambda (lst folder state)
'(assert (list? lst)
lst)
'(assert (procedure? folder)
folder)
(do ((lst lst
(cdr lst))
(state state
(folder (car lst)
state)))
((null? lst)
state))))
; Given the size of a vector and a procedure which
; sends indices to desired vector elements, create
; and return the vector.
(define proc->vector
(lambda (size f)
'(assert (and (integer? size)
(exact? size)
(>= size 0))
size)
'(assert (procedure? f)
f)
(if (zero? size)
(vector)
(let ((x (make-vector size (f 0))))
(let loop ((i 1))
(if (< i size) (begin ; [wdc - was when]
(vector-set! x i (f i))
(loop (+ i 1)))))
x))))
(define vector-fold
(lambda (vec folder state)
'(assert (vector? vec)
vec)
'(assert (procedure? folder)
folder)
(let ((len
(vector-length vec)))
(do ((i 0
(+ i 1))
(state state
(folder (vector-ref vec i)
state)))
((= i len)
state)))))
(define vec-map
(lambda (vec proc)
(proc->vector (vector-length vec)
(lambda (i)
(proc (vector-ref vec i))))))
; Given limit, return the list 0, 1, ..., limit-1.
(define giota
(lambda (limit)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
(let _-*-
((limit
limit)
(res
'()))
(if (zero? limit)
res
(let ((limit
(- limit 1)))
(_-*- limit
(cons limit res)))))))
; Fold over the integers [0, limit).
(define gnatural-fold
(lambda (limit folder state)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? folder)
folder)
(do ((i 0
(+ i 1))
(state state
(folder i state)))
((= i limit)
state))))
; Iterate over the integers [0, limit).
(define gnatural-for-each
(lambda (limit proc!)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? proc!)
proc!)
(do ((i 0
(+ i 1)))
((= i limit))
(proc! i))))
(define natural-for-all?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let _-*-
((i 0))
(or (= i limit)
(and (ok? i)
(_-*- (+ i 1)))))))
(define natural-there-exists?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let _-*-
((i 0))
(and (not (= i limit))
(or (ok? i)
(_-*- (+ i 1)))))))
(define there-exists?
(lambda (lst ok?)
'(assert (list? lst)
lst)
'(assert (procedure? ok?)
ok?)
(let _-*-
((lst lst))
(and (not (null? lst))
(or (ok? (car lst))
(_-*- (cdr lst)))))))
;;; ==== ptfold.ss ====
; Fold over the tree of permutations of a universe.
; Each branch (from the root) is a permutation of universe.
; Each node at depth d corresponds to all permutations which pick the
; elements spelled out on the branch from the root to that node as
; the first d elements.
; Their are two components to the state:
; The b-state is only a function of the branch from the root.
; The t-state is a function of all nodes seen so far.
; At each node, b-folder is called via
; (b-folder elem b-state t-state deeper accross)
; where elem is the next element of the universe picked.
; If b-folder can determine the result of the total tree fold at this stage,
; it should simply return the result.
; If b-folder can determine the result of folding over the sub-tree
; rooted at the resulting node, it should call accross via
; (accross new-t-state)
; where new-t-state is that result.
; Otherwise, b-folder should call deeper via
; (deeper new-b-state new-t-state)
; where new-b-state is the b-state for the new node and new-t-state is
; the new folded t-state.
; At the leaves of the tree, t-folder is called via
; (t-folder b-state t-state accross)
; If t-folder can determine the result of the total tree fold at this stage,
; it should simply return that result.
; If not, it should call accross via
; (accross new-t-state)
; Note, fold-over-perm-tree always calls b-folder in depth-first order.
; I.e., when b-folder is called at depth d, the branch leading to that
; node is the most recent calls to b-folder at all the depths less than d.
; This is a gross efficiency hack so that b-folder can use mutation to
; keep the current branch.
(define fold-over-perm-tree
(lambda (universe b-folder b-state t-folder t-state)
'(assert (list? universe)
universe)
'(assert (procedure? b-folder)
b-folder)
'(assert (procedure? t-folder)
t-folder)
(let _-*-
((universe
universe)
(b-state
b-state)
(t-state
t-state)
(accross
(lambda (final-t-state)
final-t-state)))
(if (null? universe)
(t-folder b-state t-state accross)
(let _-**-
((in
universe)
(out
'())
(t-state
t-state))
(let* ((first
(car in))
(rest
(cdr in))
(accross
(if (null? rest)
accross
(lambda (new-t-state)
(_-**- rest
(cons first out)
new-t-state)))))
(b-folder first
b-state
t-state
(lambda (new-b-state new-t-state)
(_-*- (fold out cons rest)
new-b-state
new-t-state
accross))
accross)))))))
;;; ==== minimal.ss ====
; A directed graph is stored as a connection matrix (vector-of-vectors)
; where the first index is the `from' vertex and the second is the `to'
; vertex. Each entry is a bool indicating if the edge exists.
; The diagonal of the matrix is never examined.
; Make-minimal? returns a procedure which tests if a labelling
; of the vertices is such that the matrix is minimal.
; If it is, then the procedure returns the result of folding over
; the elements of the automoriphism group. If not, it returns #f.
; The folding is done by calling folder via
; (folder perm state accross)
; If the folder wants to continue, it should call accross via
; (accross new-state)
; If it just wants the entire minimal? procedure to return something,
; it should return that.
; The ordering used is lexicographic (with #t > #f) and entries
; are examined in the following order:
; 1->0, 0->1
;
; 2->0, 0->2
; 2->1, 1->2
;
; 3->0, 0->3
; 3->1, 1->3
; 3->2, 2->3
; ...
(define make-minimal?
(lambda (max-size)
'(assert (and (integer? max-size)
(exact? max-size)
(>= max-size 0))
max-size)
(let ((iotas
(proc->vector (+ max-size 1)
giota))
(perm
(make-vector max-size 0)))
(lambda (size graph folder state)
'(assert (and (integer? size)
(exact? size)
(<= 0 size max-size))
size
max-size)
'(assert (vector? graph)
graph)
'(assert (procedure? folder)
folder)
(fold-over-perm-tree (vector-ref iotas size)
(lambda (perm-x x state deeper accross)
(case (cmp-next-vertex graph perm x perm-x)
((less)
#f)
((equal)
(vector-set! perm x perm-x)
(deeper (+ x 1)
state))
((more)
(accross state))
;(else
; (assert #f))
))
0
(lambda (leaf-depth state accross)
'(assert (eqv? leaf-depth size)
leaf-depth
size)
(folder perm state accross))
state)))))
; Given a graph, a partial permutation vector, the next input and the next
; output, return 'less, 'equal or 'more depending on the lexicographic
; comparison between the permuted and un-permuted graph.
(define cmp-next-vertex
(lambda (graph perm x perm-x)
(let ((from-x
(vector-ref graph x))
(from-perm-x
(vector-ref graph perm-x)))
(let _-*-
((y
0))
(if (= x y)
'equal
(let ((x->y?
(vector-ref from-x y))
(perm-y
(vector-ref perm y)))
(cond ((eq? x->y?
(vector-ref from-perm-x perm-y))
(let ((y->x?
(vector-ref (vector-ref graph y)
x)))
(cond ((eq? y->x?
(vector-ref (vector-ref graph perm-y)
perm-x))
(_-*- (+ y 1)))
(y->x?
'less)
(else
'more))))
(x->y?
'less)
(else
'more))))))))
;;; ==== rdg.ss ====
; Fold over rooted directed graphs with bounded out-degree.
; Size is the number of vertices (including the root). Max-out is the
; maximum out-degree for any vertex. Folder is called via
; (folder edges state)
; where edges is a list of length size. The ith element of the list is
; a list of the vertices j for which there is an edge from i to j.
; The last vertex is the root.
(define fold-over-rdg
(lambda (size max-out folder state)
'(assert (and (exact? size)
(integer? size)
(> size 0))
size)
'(assert (and (exact? max-out)
(integer? max-out)
(>= max-out 0))
max-out)
'(assert (procedure? folder)
folder)
(let* ((root
(- size 1))
(edge?
(proc->vector size
(lambda (from)
(make-vector size #f))))
(edges
(make-vector size '()))
(out-degrees
(make-vector size 0))
(minimal-folder
(make-minimal? root))
(non-root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #t)
state)
(accross #t))))
(lambda (size)
(minimal-folder size
edge?
cont
#t))))
(root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #t)
state)
(case (cmp-next-vertex edge? perm root root)
((less)
#f)
((equal more)
(accross #t))
;(else
; (assert #f))
))))
(lambda ()
(minimal-folder root
edge?
cont
#t)))))
(let _-*-
((vertex
0)
(state
state))
(cond ((not (non-root-minimal? vertex))
state)
((= vertex root)
'(assert
(begin
(gnatural-for-each root
(lambda (v)
'(assert (= (vector-ref out-degrees v)
(length (vector-ref edges v)))
v
(vector-ref out-degrees v)
(vector-ref edges v))))
#t))
(let ((reach?
(make-reach? root edges))
(from-root
(vector-ref edge? root)))
(let _-*-
((v
0)
(outs
0)
(efr
'())
(efrr
'())
(state
state))
(cond ((not (or (= v root)
(= outs max-out)))
(vector-set! from-root v #t)
(let ((state
(_-*- (+ v 1)
(+ outs 1)
(cons v efr)
(cons (vector-ref reach? v)
efrr)
state)))
(vector-set! from-root v #f)
(_-*- (+ v 1)
outs
efr
efrr
state)))
((and (natural-for-all? root
(lambda (v)
(there-exists? efrr
(lambda (r)
(vector-ref r v)))))
(root-minimal?))
(vector-set! edges root efr)
(folder
(proc->vector size
(lambda (i)
(vector-ref edges i)))
state))
(else
state)))))
(else
(let ((from-vertex
(vector-ref edge? vertex)))
(let _-**-
((sv
0)
(outs
0)
(state
state))
(if (= sv vertex)
(begin
(vector-set! out-degrees vertex outs)
(_-*- (+ vertex 1)
state))
(let* ((state
; no sv->vertex, no vertex->sv
(_-**- (+ sv 1)
outs
state))
(from-sv
(vector-ref edge? sv))
(sv-out
(vector-ref out-degrees sv))
(state
(if (= sv-out max-out)
state
(begin
(vector-set! edges
sv
(cons vertex
(vector-ref edges sv)))
(vector-set! from-sv vertex #t)
(vector-set! out-degrees sv (+ sv-out 1))
(let* ((state
; sv->vertex, no vertex->sv
(_-**- (+ sv 1)
outs
state))
(state
(if (= outs max-out)
state
(begin
(vector-set! from-vertex sv #t)
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(let ((state
; sv->vertex, vertex->sv
(_-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
(vector-set! from-vertex sv #f)
state)))))
(vector-set! out-degrees sv sv-out)
(vector-set! from-sv vertex #f)
(vector-set! edges
sv
(cdr (vector-ref edges sv)))
state)))))
(if (= outs max-out)
state
(begin
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(vector-set! from-vertex sv #t)
(let ((state
; no sv->vertex, vertex->sv
(_-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! from-vertex sv #f)
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
state)))))))))))))
; Given a vector which maps vertex to out-going-edge list,
; return a vector which gives reachability.
(define make-reach?
(lambda (size vertex->out)
(let ((res
(proc->vector size
(lambda (v)
(let ((from-v
(make-vector size #f)))
(vector-set! from-v v #t)
(for-each
(lambda (x)
(vector-set! from-v x #t))
(vector-ref vertex->out v))
from-v)))))
(gnatural-for-each size
(lambda (m)
(let ((from-m
(vector-ref res m)))
(gnatural-for-each size
(lambda (f)
(let ((from-f
(vector-ref res f)))
(if (vector-ref from-f m); [wdc - was when]
(begin
(gnatural-for-each size
(lambda (t)
(if (vector-ref from-m t)
(begin ; [wdc - was when]
(vector-set! from-f t #t)))))))))))))
res)))
;;; ==== test input ====
; Produces all directed graphs with N vertices, distinguished root,
; and out-degree bounded by 2, upto isomorphism (there are 44).
;(define go
; (let ((N 7))
; (fold-over-rdg N
; 2
; cons
; '())))
(let ((input (with-input-from-file "input.txt" read)))
(time
(length
(let loop ((n 3) (v 0))
(if (zero? n)
v
(loop (- n 1)
(fold-over-rdg (if input 6 0)
2
cons
'())))))))

6489
benchmarks/gabriel/kanren.sch Normal file
View file

File diff suppressed because it is too large Load diff

215
benchmarks/gabriel/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))

205
benchmarks/gabriel/lattice2.sch Normal file
View file

@ -0,0 +1,205 @@
;; Like "lattice.sch", but uses `reverse' instead of
;; defining `reverse!' (to avoid `set-cdr!')
;;; 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)))
; 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))

680
benchmarks/gabriel/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 (vec-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)
(vec-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)
(vec-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)
(list->string v)
(begin
(set! output '())
(pmaze 20 (if input 7 0))
(loop (- n 1) output))))))

683
benchmarks/gabriel/maze2.sch Normal file
View file

@ -0,0 +1,683 @@
;; Like "maze.sch", but avoids `set-car!' and `set-cdr!' by using
;; vectors for mutable records.
;;; 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)
(vector n))
(define (rand state)
(let ((seed (vector-ref state 0))
(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))))
(vector-set! state 0 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) (vector 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 (vector-ref r 1))) ; in the list. That's
(cond ((vector? 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 (vector-ref x 1)))
(cond ((not (eq? r next))
(vector-set! x 1 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) (vector-ref (get-set-root s) 0))
(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)
(vector-set! r2 1 r1)
(vector-set! r1 1 n))
(else
(vector-set! r1 1 r2)
(vector-set! r2 1 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 (vec-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)
(vec-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)
(vec-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)
(list->string v)
(begin
(set! output '())
(pmaze 20 (if input 7 0))
(loop (- n 1) output))))))

206
benchmarks/gabriel/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)))))))

759
benchmarks/gabriel/nboyer.sch Normal file
View file

@ -0,0 +1,759 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: nboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024 520,000
; 1 591777 2,085,000
; 2 1813975 5,175,000
; 3 5375678
; 4 16445406
; 5 51507739
; Nboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (nboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(time (test-boyer n))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (sub1 x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a)
(zero))
(equal (sub1 b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))
(nboyer-benchmark 4)

64
benchmarks/gabriel/nestedloop.sch Normal file
View file

@ -0,0 +1,64 @@
;; Imperative body:
(define (loops n)
(let ((result 0))
(let loop1 ((i1 1))
(if (> i1 n)
'done
(begin
(let loop2 ((i2 1))
(if (> i2 n)
'done
(begin
(let loop3 ((i3 1))
(if (> i3 n)
'done
(begin
(let loop4 ((i4 1))
(if (> i4 n)
'done
(begin
(let loop5 ((i5 1))
(if (> i5 n)
'done
(begin
(let loop6 ((i6 1))
(if (> i6 n)
'done
(begin
(set! result (+ result 1))
(loop6 (+ i6 1)))))
(loop5 (+ i5 1)))))
(loop4 (+ i4 1)))))
(loop3 (+ i3 1)))))
(loop2 (+ i2 1)))))
(loop1 (+ i1 1)))))
result))
;; Functional body:
(define (func-loops n)
(let loop1 ((i1 1)(result 0))
(if (> i1 n)
result
(let loop2 ((i2 1)(result result))
(if (> i2 n)
(loop1 (+ i1 1) result)
(let loop3 ((i3 1)(result result))
(if (> i3 n)
(loop2 (+ i2 1) result)
(let loop4 ((i4 1)(result result))
(if (> i4 n)
(loop3 (+ i3 1) result)
(let loop5 ((i5 1)(result result))
(if (> i5 n)
(loop4 (+ i4 1) result)
(let loop6 ((i6 1)(result result))
(if (> i6 n)
(loop5 (+ i5 1) result)
(loop6 (+ i6 1) (+ result 1)))))))))))))))
(let ((cnt (if (with-input-from-file "input.txt" read) 18 1)))
(time (list
(loops cnt)
(func-loops cnt))))

53
benchmarks/gabriel/nfa.sch Normal file
View file

@ -0,0 +1,53 @@
; The recursive-nfa benchmark. (Figure 45, page 143.)
;; Changed by Matthew 2006/08/21 to move string->list out of the loop
(define (recursive-nfa input)
(define (state0 input)
(or (state1 input) (state3 input) #f))
(define (state1 input)
(and (not (null? input))
(or (and (char=? (car input) #\a)
(state1 (cdr input)))
(and (char=? (car input) #\c)
(state1 input))
(state2 input))))
(define (state2 input)
(and (not (null? input))
(char=? (car input) #\b)
(not (null? (cdr input)))
(char=? (cadr input) #\c)
(not (null? (cddr input)))
(char=? (caddr input) #\d)
'state2))
(define (state3 input)
(and (not (null? input))
(or (and (char=? (car input) #\a)
(state3 (cdr input)))
(state4 input))))
(define (state4 input)
(and (not (null? input))
(char=? (car input) #\b)
(not (null? (cdr input)))
(char=? (cadr input) #\c)
'state4))
(or (state0 input)
'fail))
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
(let loop ((n 150000))
(if (zero? n)
'done
(begin
(recursive-nfa input)
(loop (- n 1)))))))

1
benchmarks/gabriel/nothing.sch Normal file
View file

@ -0,0 +1 @@
(time 1)

36
benchmarks/gabriel/nqueens.sch Normal file
View file

@ -0,0 +1,36 @@
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt)
(define trace? #f)
(define (nqueens n)
(define (one-to n)
(let loop ((i n) (l '()))
(if (= i 0) l (loop (- i 1) (cons i l)))))
(define (try-it 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-it (append (cdr x) y) '() (cons (car x) z))
0)
(try-it (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-it (one-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)))))))

3508
benchmarks/gabriel/nucleic2.sch Normal file
View file

File diff suppressed because it is too large Load diff

175
benchmarks/gabriel/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)))))))

633
benchmarks/gabriel/peval.sch Normal file
View file

@ -0,0 +1,633 @@
;;; 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
'(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
'(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 60) (v 0))
(if (zero? n)
v
(loop (- n 1) (test (if input 0 17)))))))

171
benchmarks/gabriel/puzzle.sch Normal file
View file

@ -0,0 +1,171 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: puzzle.sch
; Description: PUZZLE benchmark
; Author: Richard Gabriel, after Forrest Baskett
; Created: 12-Apr-85
; Modified: 12-Apr-85 14:20:23 (Bob Shaw)
; 11-Aug-87 (Will Clinger)
; 22-Jan-88 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (iota n)
(do ((n n (- n 1))
(list '() (cons (- n 1) list)))
((zero? n) list)))
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(define size 1048575)
(define classmax 3)
(define typemax 12)
(define *iii* 0)
(define *kount* 0)
(define *d* 8)
(define *piececount* (make-vector (+ classmax 1) 0))
(define *class* (make-vector (+ typemax 1) 0))
(define *piecemax* (make-vector (+ typemax 1) 0))
(define *puzzle* (make-vector (+ size 1)))
(define *p* (make-vector (+ typemax 1)))
(define nothing
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
(iota (+ typemax 1))))
(define (fit i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((or (> k end)
(and (vector-ref (vector-ref *p* i) k)
(vector-ref *puzzle* (+ j k))))
(if (> k end) #t #f)))))
(define (place i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #t)
#t)))
(vector-set! *piececount*
(vector-ref *class* i)
(- (vector-ref *piececount* (vector-ref *class* i)) 1))
(do ((k j (+ k 1)))
((or (> k size) (not (vector-ref *puzzle* k)))
; (newline)
; (display "*Puzzle* filled")
(if (> k size) 0 k)))))
(define (puzzle-remove i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #f)
#f)))
(vector-set! *piececount*
(vector-ref *class* i)
(+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
(define (trial j)
(let ((k 0))
(call-with-current-continuation
(lambda (return)
(do ((i 0 (+ i 1)))
((> i typemax) (set! *kount* (+ *kount* 1)) '())
(cond
((not
(zero?
(vector-ref *piececount* (vector-ref *class* i))))
(cond
((fit i j)
(set! k (place i j))
(cond
((or (trial k) (zero? k))
;(trial-output (+ i 1) (+ k 1))
(set! *kount* (+ *kount* 1))
(return #t))
(else (puzzle-remove i j))))))))))))
(define (trial-output x y)
(newline)
(display (string-append "Piece "
(number->string x '(int))
" at "
(number->string y '(int))
".")))
(define (definePiece iclass ii jj kk)
(let ((index 0))
(do ((i 0 (+ i 1)))
((> i ii))
(do ((j 0 (+ j 1)))
((> j jj))
(do ((k 0 (+ k 1)))
((> k kk))
(set! index (+ i (* *d* (+ j (* *d* k)))))
(vector-set! (vector-ref *p* *iii*) index #t))))
(vector-set! *class* *iii* iclass)
(vector-set! *piecemax* *iii* index)
(cond ((not (= *iii* typemax))
(set! *iii* (+ *iii* 1))))))
(define (start)
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! *puzzle* m #t))
(do ((i 1 (+ i 1)))
((> i 5))
(do ((j 1 (+ j 1)))
((> j 5))
(do ((k 1 (+ k 1)))
((> k 5))
(vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
(do ((i 0 (+ i 1)))
((> i typemax))
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! (vector-ref *p* i) m #f)))
(set! *iii* 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(vector-set! *piececount* 0 13)
(vector-set! *piececount* 1 3)
(vector-set! *piececount* 2 1)
(vector-set! *piececount* 3 1)
(let ((m (+ (* *d* (+ *d* 1)) 1))
(n 0))
(cond ((fit 0 m) (set! n (place 0 m)))
(else (begin (newline) (display "Error."))))
(cond ((trial n)
(begin (newline)
(display "Success in ")
(write *kount*)
(display " trials.")
(newline)
'ok))
(else (begin (newline) (display "Failure."))))))
;;; call: (start)
(time (start))

16
benchmarks/gabriel/run.sh Executable file
View file

@ -0,0 +1,16 @@
#!/bin/sh
BENCHDIR=$(dirname $0)
if [ "${BENCHDIR%%/*}" == "." ]; then
BENCHDIR=$(pwd)${BENCHDIR#.}
fi
CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel}
CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME"
cd $BENCHDIR
for t in *.sch; do
echo "${t%%.sch}"
LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \
$CHIBI -I"$CHIBIHOME/lib" -lchibi-prelude.scm $t
done
cd -

774
benchmarks/gabriel/sboyer.sch Normal file
View file

@ -0,0 +1,774 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: sboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
;;; "sharing cons".
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024
; 1 591777
; 2 1813975
; 3 5375678
; 4 16445406
; 5 51507739
; Sboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (sboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(time (test-boyer n))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
(define (id x) x)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (sub1 x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a)
(zero))
(equal (sub1 b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
; The next procedure is Henry Baker's sharing CONS, which avoids
; allocation if the result is already in hand.
; The REWRITE and REWRITE-ARGS procedures have been modified to
; use SCONS instead of CONS.
(define (scons x y original)
(if (and (eq? x (car original))
(eq? y (cdr original)))
original
(cons x y)))
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (scons (car term)
(rewrite-args (cdr term))
term)
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (scons (rewrite (car lst))
(rewrite-args (cdr lst))
lst))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite ( apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))
(sboyer-benchmark 5)

1077
benchmarks/gabriel/scheme.sch Normal file
View file

File diff suppressed because it is too large Load diff

1083
benchmarks/gabriel/scheme2.sch Normal file
View file

File diff suppressed because it is too large Load diff

147
benchmarks/gabriel/sort1.sch Normal file
View file

@ -0,0 +1,147 @@
; This benchmark uses the code for Larceny's standard sort procedure.
;
; Usage:
; (sort-benchmark sorter n)
;
; where
; sorter is a sort procedure (usually sort or sort1) whose calling
; convention is compatible with Larceny's
; n is the number of fixnums to sort
(define sort1
(let ()
;;; File : sort.scm
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;; Updated: 11 June 1991
;
; $Id: sort.sch 264 1998-12-14 16:44:08Z lth $
;
; Code originally obtained from Scheme Repository, since hacked.
;
; Sort and Sort! will sort lists and vectors. The former returns a new
; data structure; the latter sorts the data structure in-place. A
; mergesort algorithm is used.
; Destructive merge of two sorted lists.
(define (merge!! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)) ))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)) )) )
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
; Sort procedure which copies the input list and then sorts the
; new list imperatively. Due to Richard O'Keefe; algorithm
; attributed to D.H.D. Warren
(define (sort!! seq less?)
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(merge!! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(if (less? y x)
(begin
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else
'())))
(step (length seq)))
(define (sort! seq less?)
(cond ((null? seq)
seq)
((pair? seq)
(sort!! seq less?))
((vector? seq)
(do ((l (sort!! (vector->list seq) less?) (cdr l))
(i 0 (+ i 1)))
((null? l) seq)
(vector-set! seq i (car l))))
(else
(error "sort!: not a valid sequence: " seq))))
(define (sort seq less?)
(cond ((null? seq)
seq)
((pair? seq)
(sort!! (list-copy seq) less?))
((vector? seq)
(list->vector (sort!! (vector->list seq) less?)))
(else
(error "sort: not a valid sequence: " seq))))
; eof
; This is pretty much optimal for Larceny.
(define (list-copy l)
(define (loop l prev)
(if (null? l)
#t
(let ((q (cons (car l) '())))
(set-cdr! prev q)
(loop (cdr l) q))))
(if (null? l)
l
(let ((first (cons (car l) '())))
(loop (cdr l) first)
first)))
sort))
(define *rand* 21)
(define (randm m)
(set! *rand* (remainder (* *rand* 17) m))
*rand*)
(define (rgen n m)
(let loop ((n n) (l '()))
(if (zero? n)
l
(loop (- n 1) (cons (randm m) l)))))
(define (sort-benchmark sorter n)
(let ((l (rgen n 1000000)))
(time (length (sorter l <)))))
(sort-benchmark sort1 1000000)

28
benchmarks/gabriel/tak.sch Normal file
View file

@ -0,0 +1,28 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: tak.sch
; Description: TAK benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 09:58:18 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAK -- A vanilla version of the TAKeuchi function
(define (tak x y z)
(if (not (< y x))
z
(tak (tak (- x 1) y z)
(tak (- y 1) z x)
(tak (- z 1) x y))))
;;; call: (tak 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

43
benchmarks/gabriel/takl.sch Normal file
View file

@ -0,0 +1,43 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: takl.sch
; Description: TAKL benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:07:00 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAKL -- The TAKeuchi function using lists as counters.
(define (listn n)
(if (not (= 0 n))
(cons n (listn (- n 1)))
'()))
(define l18l (listn 18))
(define l12l (listn 12))
(define l6l (listn 2))
(define (mas x y z)
(if (not (shorterp y x))
z
(mas (mas (cdr x)
y z)
(mas (cdr y)
z x)
(mas (cdr z)
x y))))
(define (shorterp x y)
(and (not (null? y))
(or (null? x)
(shorterp (cdr x)
(cdr y)))))
;;; call: (mas 18l 12l 6l)
(let ((v (if (with-input-from-file "input.txt" read) l6l '())))
(time (mas l18l l12l v)))

525
benchmarks/gabriel/takr.sch Normal file
View file

@ -0,0 +1,525 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: takr.sch
; Description: TAKR benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:12:43 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
;;; memory effects. Results should be the same as for TAK on stack machines.
;;; Distribution of calls is not completely flat.
(define (tak0 x y z)
(cond ((not (< y x)) z)
(else (tak1 (tak37 (- x 1) y z)
(tak11 (- y 1) z x)
(tak17 (- z 1) x y)))))
(define (tak1 x y z)
(cond ((not (< y x)) z)
(else (tak2 (tak74 (- x 1) y z)
(tak22 (- y 1) z x)
(tak34 (- z 1) x y)))))
(define (tak2 x y z)
(cond ((not (< y x)) z)
(else (tak3 (tak11 (- x 1) y z)
(tak33 (- y 1) z x)
(tak51 (- z 1) x y)))))
(define (tak3 x y z)
(cond ((not (< y x)) z)
(else (tak4 (tak48 (- x 1) y z)
(tak44 (- y 1) z x)
(tak68 (- z 1) x y)))))
(define (tak4 x y z)
(cond ((not (< y x)) z)
(else (tak5 (tak85 (- x 1) y z)
(tak55 (- y 1) z x)
(tak85 (- z 1) x y)))))
(define (tak5 x y z)
(cond ((not (< y x)) z)
(else (tak6 (tak22 (- x 1) y z)
(tak66 (- y 1) z x)
(tak2 (- z 1) x y)))))
(define (tak6 x y z)
(cond ((not (< y x)) z)
(else (tak7 (tak59 (- x 1) y z)
(tak77 (- y 1) z x)
(tak19 (- z 1) x y)))))
(define (tak7 x y z)
(cond ((not (< y x)) z)
(else (tak8 (tak96 (- x 1) y z)
(tak88 (- y 1) z x)
(tak36 (- z 1) x y)))))
(define (tak8 x y z)
(cond ((not (< y x)) z)
(else (tak9 (tak33 (- x 1) y z)
(tak99 (- y 1) z x)
(tak53 (- z 1) x y)))))
(define (tak9 x y z)
(cond ((not (< y x)) z)
(else (tak10 (tak70 (- x 1) y z)
(tak10 (- y 1) z x)
(tak70 (- z 1) x y)))))
(define (tak10 x y z)
(cond ((not (< y x)) z)
(else (tak11 (tak7 (- x 1) y z)
(tak21 (- y 1) z x)
(tak87 (- z 1) x y)))))
(define (tak11 x y z)
(cond ((not (< y x)) z)
(else (tak12 (tak44 (- x 1) y z)
(tak32 (- y 1) z x)
(tak4 (- z 1) x y)))))
(define (tak12 x y z)
(cond ((not (< y x)) z)
(else (tak13 (tak81 (- x 1) y z)
(tak43 (- y 1) z x)
(tak21 (- z 1) x y)))))
(define (tak13 x y z)
(cond ((not (< y x)) z)
(else (tak14 (tak18 (- x 1) y z)
(tak54 (- y 1) z x)
(tak38 (- z 1) x y)))))
(define (tak14 x y z)
(cond ((not (< y x)) z)
(else (tak15 (tak55 (- x 1) y z)
(tak65 (- y 1) z x)
(tak55 (- z 1) x y)))))
(define (tak15 x y z)
(cond ((not (< y x)) z)
(else (tak16 (tak92 (- x 1) y z)
(tak76 (- y 1) z x)
(tak72 (- z 1) x y)))))
(define (tak16 x y z)
(cond ((not (< y x)) z)
(else (tak17 (tak29 (- x 1) y z)
(tak87 (- y 1) z x)
(tak89 (- z 1) x y)))))
(define (tak17 x y z)
(cond ((not (< y x)) z)
(else (tak18 (tak66 (- x 1) y z)
(tak98 (- y 1) z x)
(tak6 (- z 1) x y)))))
(define (tak18 x y z)
(cond ((not (< y x)) z)
(else (tak19 (tak3 (- x 1) y z)
(tak9 (- y 1) z x)
(tak23 (- z 1) x y)))))
(define (tak19 x y z)
(cond ((not (< y x)) z)
(else (tak20 (tak40 (- x 1) y z)
(tak20 (- y 1) z x)
(tak40 (- z 1) x y)))))
(define (tak20 x y z)
(cond ((not (< y x)) z)
(else (tak21 (tak77 (- x 1) y z)
(tak31 (- y 1) z x)
(tak57 (- z 1) x y)))))
(define (tak21 x y z)
(cond ((not (< y x)) z)
(else (tak22 (tak14 (- x 1) y z)
(tak42 (- y 1) z x)
(tak74 (- z 1) x y)))))
(define (tak22 x y z)
(cond ((not (< y x)) z)
(else (tak23 (tak51 (- x 1) y z)
(tak53 (- y 1) z x)
(tak91 (- z 1) x y)))))
(define (tak23 x y z)
(cond ((not (< y x)) z)
(else (tak24 (tak88 (- x 1) y z)
(tak64 (- y 1) z x)
(tak8 (- z 1) x y)))))
(define (tak24 x y z)
(cond ((not (< y x)) z)
(else (tak25 (tak25 (- x 1) y z)
(tak75 (- y 1) z x)
(tak25 (- z 1) x y)))))
(define (tak25 x y z)
(cond ((not (< y x)) z)
(else (tak26 (tak62 (- x 1) y z)
(tak86 (- y 1) z x)
(tak42 (- z 1) x y)))))
(define (tak26 x y z)
(cond ((not (< y x)) z)
(else (tak27 (tak99 (- x 1) y z)
(tak97 (- y 1) z x)
(tak59 (- z 1) x y)))))
(define (tak27 x y z)
(cond ((not (< y x)) z)
(else (tak28 (tak36 (- x 1) y z)
(tak8 (- y 1) z x)
(tak76 (- z 1) x y)))))
(define (tak28 x y z)
(cond ((not (< y x)) z)
(else (tak29 (tak73 (- x 1) y z)
(tak19 (- y 1) z x)
(tak93 (- z 1) x y)))))
(define (tak29 x y z)
(cond ((not (< y x)) z)
(else (tak30 (tak10 (- x 1) y z)
(tak30 (- y 1) z x)
(tak10 (- z 1) x y)))))
(define (tak30 x y z)
(cond ((not (< y x)) z)
(else (tak31 (tak47 (- x 1) y z)
(tak41 (- y 1) z x)
(tak27 (- z 1) x y)))))
(define (tak31 x y z)
(cond ((not (< y x)) z)
(else (tak32 (tak84 (- x 1) y z)
(tak52 (- y 1) z x)
(tak44 (- z 1) x y)))))
(define (tak32 x y z)
(cond ((not (< y x)) z)
(else (tak33 (tak21 (- x 1) y z)
(tak63 (- y 1) z x)
(tak61 (- z 1) x y)))))
(define (tak33 x y z)
(cond ((not (< y x)) z)
(else (tak34 (tak58 (- x 1) y z)
(tak74 (- y 1) z x)
(tak78 (- z 1) x y)))))
(define (tak34 x y z)
(cond ((not (< y x)) z)
(else (tak35 (tak95 (- x 1) y z)
(tak85 (- y 1) z x)
(tak95 (- z 1) x y)))))
(define (tak35 x y z)
(cond ((not (< y x)) z)
(else (tak36 (tak32 (- x 1) y z)
(tak96 (- y 1) z x)
(tak12 (- z 1) x y)))))
(define (tak36 x y z)
(cond ((not (< y x)) z)
(else (tak37 (tak69 (- x 1) y z)
(tak7 (- y 1) z x)
(tak29 (- z 1) x y)))))
(define (tak37 x y z)
(cond ((not (< y x)) z)
(else (tak38 (tak6 (- x 1) y z)
(tak18 (- y 1) z x)
(tak46 (- z 1) x y)))))
(define (tak38 x y z)
(cond ((not (< y x)) z)
(else (tak39 (tak43 (- x 1) y z)
(tak29 (- y 1) z x)
(tak63 (- z 1) x y)))))
(define (tak39 x y z)
(cond ((not (< y x)) z)
(else (tak40 (tak80 (- x 1) y z)
(tak40 (- y 1) z x)
(tak80 (- z 1) x y)))))
(define (tak40 x y z)
(cond ((not (< y x)) z)
(else (tak41 (tak17 (- x 1) y z)
(tak51 (- y 1) z x)
(tak97 (- z 1) x y)))))
(define (tak41 x y z)
(cond ((not (< y x)) z)
(else (tak42 (tak54 (- x 1) y z)
(tak62 (- y 1) z x)
(tak14 (- z 1) x y)))))
(define (tak42 x y z)
(cond ((not (< y x)) z)
(else (tak43 (tak91 (- x 1) y z)
(tak73 (- y 1) z x)
(tak31 (- z 1) x y)))))
(define (tak43 x y z)
(cond ((not (< y x)) z)
(else (tak44 (tak28 (- x 1) y z)
(tak84 (- y 1) z x)
(tak48 (- z 1) x y)))))
(define (tak44 x y z)
(cond ((not (< y x)) z)
(else (tak45 (tak65 (- x 1) y z)
(tak95 (- y 1) z x)
(tak65 (- z 1) x y)))))
(define (tak45 x y z)
(cond ((not (< y x)) z)
(else (tak46 (tak2 (- x 1) y z)
(tak6 (- y 1) z x)
(tak82 (- z 1) x y)))))
(define (tak46 x y z)
(cond ((not (< y x)) z)
(else (tak47 (tak39 (- x 1) y z)
(tak17 (- y 1) z x)
(tak99 (- z 1) x y)))))
(define (tak47 x y z)
(cond ((not (< y x)) z)
(else (tak48 (tak76 (- x 1) y z)
(tak28 (- y 1) z x)
(tak16 (- z 1) x y)))))
(define (tak48 x y z)
(cond ((not (< y x)) z)
(else (tak49 (tak13 (- x 1) y z)
(tak39 (- y 1) z x)
(tak33 (- z 1) x y)))))
(define (tak49 x y z)
(cond ((not (< y x)) z)
(else (tak50 (tak50 (- x 1) y z)
(tak50 (- y 1) z x)
(tak50 (- z 1) x y)))))
(define (tak50 x y z)
(cond ((not (< y x)) z)
(else (tak51 (tak87 (- x 1) y z)
(tak61 (- y 1) z x)
(tak67 (- z 1) x y)))))
(define (tak51 x y z)
(cond ((not (< y x)) z)
(else (tak52 (tak24 (- x 1) y z)
(tak72 (- y 1) z x)
(tak84 (- z 1) x y)))))
(define (tak52 x y z)
(cond ((not (< y x)) z)
(else (tak53 (tak61 (- x 1) y z)
(tak83 (- y 1) z x)
(tak1 (- z 1) x y)))))
(define (tak53 x y z)
(cond ((not (< y x)) z)
(else (tak54 (tak98 (- x 1) y z)
(tak94 (- y 1) z x)
(tak18 (- z 1) x y)))))
(define (tak54 x y z)
(cond ((not (< y x)) z)
(else (tak55 (tak35 (- x 1) y z)
(tak5 (- y 1) z x)
(tak35 (- z 1) x y)))))
(define (tak55 x y z)
(cond ((not (< y x)) z)
(else (tak56 (tak72 (- x 1) y z)
(tak16 (- y 1) z x)
(tak52 (- z 1) x y)))))
(define (tak56 x y z)
(cond ((not (< y x)) z)
(else (tak57 (tak9 (- x 1) y z)
(tak27 (- y 1) z x)
(tak69 (- z 1) x y)))))
(define (tak57 x y z)
(cond ((not (< y x)) z)
(else (tak58 (tak46 (- x 1) y z)
(tak38 (- y 1) z x)
(tak86 (- z 1) x y)))))
(define (tak58 x y z)
(cond ((not (< y x)) z)
(else (tak59 (tak83 (- x 1) y z)
(tak49 (- y 1) z x)
(tak3 (- z 1) x y)))))
(define (tak59 x y z)
(cond ((not (< y x)) z)
(else (tak60 (tak20 (- x 1) y z)
(tak60 (- y 1) z x)
(tak20 (- z 1) x y)))))
(define (tak60 x y z)
(cond ((not (< y x)) z)
(else (tak61 (tak57 (- x 1) y z)
(tak71 (- y 1) z x)
(tak37 (- z 1) x y)))))
(define (tak61 x y z)
(cond ((not (< y x)) z)
(else (tak62 (tak94 (- x 1) y z)
(tak82 (- y 1) z x)
(tak54 (- z 1) x y)))))
(define (tak62 x y z)
(cond ((not (< y x)) z)
(else (tak63 (tak31 (- x 1) y z)
(tak93 (- y 1) z x)
(tak71 (- z 1) x y)))))
(define (tak63 x y z)
(cond ((not (< y x)) z)
(else (tak64 (tak68 (- x 1) y z)
(tak4 (- y 1) z x)
(tak88 (- z 1) x y)))))
(define (tak64 x y z)
(cond ((not (< y x)) z)
(else (tak65 (tak5 (- x 1) y z)
(tak15 (- y 1) z x)
(tak5 (- z 1) x y)))))
(define (tak65 x y z)
(cond ((not (< y x)) z)
(else (tak66 (tak42 (- x 1) y z)
(tak26 (- y 1) z x)
(tak22 (- z 1) x y)))))
(define (tak66 x y z)
(cond ((not (< y x)) z)
(else (tak67 (tak79 (- x 1) y z)
(tak37 (- y 1) z x)
(tak39 (- z 1) x y)))))
(define (tak67 x y z)
(cond ((not (< y x)) z)
(else (tak68 (tak16 (- x 1) y z)
(tak48 (- y 1) z x)
(tak56 (- z 1) x y)))))
(define (tak68 x y z)
(cond ((not (< y x)) z)
(else (tak69 (tak53 (- x 1) y z)
(tak59 (- y 1) z x)
(tak73 (- z 1) x y)))))
(define (tak69 x y z)
(cond ((not (< y x)) z)
(else (tak70 (tak90 (- x 1) y z)
(tak70 (- y 1) z x)
(tak90 (- z 1) x y)))))
(define (tak70 x y z)
(cond ((not (< y x)) z)
(else (tak71 (tak27 (- x 1) y z)
(tak81 (- y 1) z x)
(tak7 (- z 1) x y)))))
(define (tak71 x y z)
(cond ((not (< y x)) z)
(else (tak72 (tak64 (- x 1) y z)
(tak92 (- y 1) z x)
(tak24 (- z 1) x y)))))
(define (tak72 x y z)
(cond ((not (< y x)) z)
(else (tak73 (tak1 (- x 1) y z)
(tak3 (- y 1) z x)
(tak41 (- z 1) x y)))))
(define (tak73 x y z)
(cond ((not (< y x)) z)
(else (tak74 (tak38 (- x 1) y z)
(tak14 (- y 1) z x)
(tak58 (- z 1) x y)))))
(define (tak74 x y z)
(cond ((not (< y x)) z)
(else (tak75 (tak75 (- x 1) y z)
(tak25 (- y 1) z x)
(tak75 (- z 1) x y)))))
(define (tak75 x y z)
(cond ((not (< y x)) z)
(else (tak76 (tak12 (- x 1) y z)
(tak36 (- y 1) z x)
(tak92 (- z 1) x y)))))
(define (tak76 x y z)
(cond ((not (< y x)) z)
(else (tak77 (tak49 (- x 1) y z)
(tak47 (- y 1) z x)
(tak9 (- z 1) x y)))))
(define (tak77 x y z)
(cond ((not (< y x)) z)
(else (tak78 (tak86 (- x 1) y z)
(tak58 (- y 1) z x)
(tak26 (- z 1) x y)))))
(define (tak78 x y z)
(cond ((not (< y x)) z)
(else (tak79 (tak23 (- x 1) y z)
(tak69 (- y 1) z x)
(tak43 (- z 1) x y)))))
(define (tak79 x y z)
(cond ((not (< y x)) z)
(else (tak80 (tak60 (- x 1) y z)
(tak80 (- y 1) z x)
(tak60 (- z 1) x y)))))
(define (tak80 x y z)
(cond ((not (< y x)) z)
(else (tak81 (tak97 (- x 1) y z)
(tak91 (- y 1) z x)
(tak77 (- z 1) x y)))))
(define (tak81 x y z)
(cond ((not (< y x)) z)
(else (tak82 (tak34 (- x 1) y z)
(tak2 (- y 1) z x)
(tak94 (- z 1) x y)))))
(define (tak82 x y z)
(cond ((not (< y x)) z)
(else (tak83 (tak71 (- x 1) y z)
(tak13 (- y 1) z x)
(tak11 (- z 1) x y)))))
(define (tak83 x y z)
(cond ((not (< y x)) z)
(else (tak84 (tak8 (- x 1) y z)
(tak24 (- y 1) z x)
(tak28 (- z 1) x y)))))
(define (tak84 x y z)
(cond ((not (< y x)) z)
(else (tak85 (tak45 (- x 1) y z)
(tak35 (- y 1) z x)
(tak45 (- z 1) x y)))))
(define (tak85 x y z)
(cond ((not (< y x)) z)
(else (tak86 (tak82 (- x 1) y z)
(tak46 (- y 1) z x)
(tak62 (- z 1) x y)))))
(define (tak86 x y z)
(cond ((not (< y x)) z)
(else (tak87 (tak19 (- x 1) y z)
(tak57 (- y 1) z x)
(tak79 (- z 1) x y)))))
(define (tak87 x y z)
(cond ((not (< y x)) z)
(else (tak88 (tak56 (- x 1) y z)
(tak68 (- y 1) z x)
(tak96 (- z 1) x y)))))
(define (tak88 x y z)
(cond ((not (< y x)) z)
(else (tak89 (tak93 (- x 1) y z)
(tak79 (- y 1) z x)
(tak13 (- z 1) x y)))))
(define (tak89 x y z)
(cond ((not (< y x)) z)
(else (tak90 (tak30 (- x 1) y z)
(tak90 (- y 1) z x)
(tak30 (- z 1) x y)))))
(define (tak90 x y z)
(cond ((not (< y x)) z)
(else (tak91 (tak67 (- x 1) y z)
(tak1 (- y 1) z x)
(tak47 (- z 1) x y)))))
(define (tak91 x y z)
(cond ((not (< y x)) z)
(else (tak92 (tak4 (- x 1) y z)
(tak12 (- y 1) z x)
(tak64 (- z 1) x y)))))
(define (tak92 x y z)
(cond ((not (< y x)) z)
(else (tak93 (tak41 (- x 1) y z)
(tak23 (- y 1) z x)
(tak81 (- z 1) x y)))))
(define (tak93 x y z)
(cond ((not (< y x)) z)
(else (tak94 (tak78 (- x 1) y z)
(tak34 (- y 1) z x)
(tak98 (- z 1) x y)))))
(define (tak94 x y z)
(cond ((not (< y x)) z)
(else (tak95 (tak15 (- x 1) y z)
(tak45 (- y 1) z x)
(tak15 (- z 1) x y)))))
(define (tak95 x y z)
(cond ((not (< y x)) z)
(else (tak96 (tak52 (- x 1) y z)
(tak56 (- y 1) z x)
(tak32 (- z 1) x y)))))
(define (tak96 x y z)
(cond ((not (< y x)) z)
(else (tak97 (tak89 (- x 1) y z)
(tak67 (- y 1) z x)
(tak49 (- z 1) x y)))))
(define (tak97 x y z)
(cond ((not (< y x)) z)
(else (tak98 (tak26 (- x 1) y z)
(tak78 (- y 1) z x)
(tak66 (- z 1) x y)))))
(define (tak98 x y z)
(cond ((not (< y x)) z)
(else (tak99 (tak63 (- x 1) y z)
(tak89 (- y 1) z x)
(tak83 (- z 1) x y)))))
(define (tak99 x y z)
(cond ((not (< y x)) z)
(else (tak0 (tak0 (- x 1) y z)
(tak0 (- y 1) z x)
(tak0 (- z 1) x y)))))
;;; call: (tak0 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak0 18 12 (if input 6 0)))))))

528
benchmarks/gabriel/takr2.sch Normal file
View file

@ -0,0 +1,528 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: takr.sch
; Description: TAKR benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:12:43 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
;;; memory effects. Results should be the same as for TAK on stack machines.
;;; Distribution of calls is not completely flat.
(define (tak x y z)
(define (tak0 x y z)
(cond ((not (< y x)) z)
(else (tak1 (tak37 (- x 1) y z)
(tak11 (- y 1) z x)
(tak17 (- z 1) x y)))))
(define (tak1 x y z)
(cond ((not (< y x)) z)
(else (tak2 (tak74 (- x 1) y z)
(tak22 (- y 1) z x)
(tak34 (- z 1) x y)))))
(define (tak2 x y z)
(cond ((not (< y x)) z)
(else (tak3 (tak11 (- x 1) y z)
(tak33 (- y 1) z x)
(tak51 (- z 1) x y)))))
(define (tak3 x y z)
(cond ((not (< y x)) z)
(else (tak4 (tak48 (- x 1) y z)
(tak44 (- y 1) z x)
(tak68 (- z 1) x y)))))
(define (tak4 x y z)
(cond ((not (< y x)) z)
(else (tak5 (tak85 (- x 1) y z)
(tak55 (- y 1) z x)
(tak85 (- z 1) x y)))))
(define (tak5 x y z)
(cond ((not (< y x)) z)
(else (tak6 (tak22 (- x 1) y z)
(tak66 (- y 1) z x)
(tak2 (- z 1) x y)))))
(define (tak6 x y z)
(cond ((not (< y x)) z)
(else (tak7 (tak59 (- x 1) y z)
(tak77 (- y 1) z x)
(tak19 (- z 1) x y)))))
(define (tak7 x y z)
(cond ((not (< y x)) z)
(else (tak8 (tak96 (- x 1) y z)
(tak88 (- y 1) z x)
(tak36 (- z 1) x y)))))
(define (tak8 x y z)
(cond ((not (< y x)) z)
(else (tak9 (tak33 (- x 1) y z)
(tak99 (- y 1) z x)
(tak53 (- z 1) x y)))))
(define (tak9 x y z)
(cond ((not (< y x)) z)
(else (tak10 (tak70 (- x 1) y z)
(tak10 (- y 1) z x)
(tak70 (- z 1) x y)))))
(define (tak10 x y z)
(cond ((not (< y x)) z)
(else (tak11 (tak7 (- x 1) y z)
(tak21 (- y 1) z x)
(tak87 (- z 1) x y)))))
(define (tak11 x y z)
(cond ((not (< y x)) z)
(else (tak12 (tak44 (- x 1) y z)
(tak32 (- y 1) z x)
(tak4 (- z 1) x y)))))
(define (tak12 x y z)
(cond ((not (< y x)) z)
(else (tak13 (tak81 (- x 1) y z)
(tak43 (- y 1) z x)
(tak21 (- z 1) x y)))))
(define (tak13 x y z)
(cond ((not (< y x)) z)
(else (tak14 (tak18 (- x 1) y z)
(tak54 (- y 1) z x)
(tak38 (- z 1) x y)))))
(define (tak14 x y z)
(cond ((not (< y x)) z)
(else (tak15 (tak55 (- x 1) y z)
(tak65 (- y 1) z x)
(tak55 (- z 1) x y)))))
(define (tak15 x y z)
(cond ((not (< y x)) z)
(else (tak16 (tak92 (- x 1) y z)
(tak76 (- y 1) z x)
(tak72 (- z 1) x y)))))
(define (tak16 x y z)
(cond ((not (< y x)) z)
(else (tak17 (tak29 (- x 1) y z)
(tak87 (- y 1) z x)
(tak89 (- z 1) x y)))))
(define (tak17 x y z)
(cond ((not (< y x)) z)
(else (tak18 (tak66 (- x 1) y z)
(tak98 (- y 1) z x)
(tak6 (- z 1) x y)))))
(define (tak18 x y z)
(cond ((not (< y x)) z)
(else (tak19 (tak3 (- x 1) y z)
(tak9 (- y 1) z x)
(tak23 (- z 1) x y)))))
(define (tak19 x y z)
(cond ((not (< y x)) z)
(else (tak20 (tak40 (- x 1) y z)
(tak20 (- y 1) z x)
(tak40 (- z 1) x y)))))
(define (tak20 x y z)
(cond ((not (< y x)) z)
(else (tak21 (tak77 (- x 1) y z)
(tak31 (- y 1) z x)
(tak57 (- z 1) x y)))))
(define (tak21 x y z)
(cond ((not (< y x)) z)
(else (tak22 (tak14 (- x 1) y z)
(tak42 (- y 1) z x)
(tak74 (- z 1) x y)))))
(define (tak22 x y z)
(cond ((not (< y x)) z)
(else (tak23 (tak51 (- x 1) y z)
(tak53 (- y 1) z x)
(tak91 (- z 1) x y)))))
(define (tak23 x y z)
(cond ((not (< y x)) z)
(else (tak24 (tak88 (- x 1) y z)
(tak64 (- y 1) z x)
(tak8 (- z 1) x y)))))
(define (tak24 x y z)
(cond ((not (< y x)) z)
(else (tak25 (tak25 (- x 1) y z)
(tak75 (- y 1) z x)
(tak25 (- z 1) x y)))))
(define (tak25 x y z)
(cond ((not (< y x)) z)
(else (tak26 (tak62 (- x 1) y z)
(tak86 (- y 1) z x)
(tak42 (- z 1) x y)))))
(define (tak26 x y z)
(cond ((not (< y x)) z)
(else (tak27 (tak99 (- x 1) y z)
(tak97 (- y 1) z x)
(tak59 (- z 1) x y)))))
(define (tak27 x y z)
(cond ((not (< y x)) z)
(else (tak28 (tak36 (- x 1) y z)
(tak8 (- y 1) z x)
(tak76 (- z 1) x y)))))
(define (tak28 x y z)
(cond ((not (< y x)) z)
(else (tak29 (tak73 (- x 1) y z)
(tak19 (- y 1) z x)
(tak93 (- z 1) x y)))))
(define (tak29 x y z)
(cond ((not (< y x)) z)
(else (tak30 (tak10 (- x 1) y z)
(tak30 (- y 1) z x)
(tak10 (- z 1) x y)))))
(define (tak30 x y z)
(cond ((not (< y x)) z)
(else (tak31 (tak47 (- x 1) y z)
(tak41 (- y 1) z x)
(tak27 (- z 1) x y)))))
(define (tak31 x y z)
(cond ((not (< y x)) z)
(else (tak32 (tak84 (- x 1) y z)
(tak52 (- y 1) z x)
(tak44 (- z 1) x y)))))
(define (tak32 x y z)
(cond ((not (< y x)) z)
(else (tak33 (tak21 (- x 1) y z)
(tak63 (- y 1) z x)
(tak61 (- z 1) x y)))))
(define (tak33 x y z)
(cond ((not (< y x)) z)
(else (tak34 (tak58 (- x 1) y z)
(tak74 (- y 1) z x)
(tak78 (- z 1) x y)))))
(define (tak34 x y z)
(cond ((not (< y x)) z)
(else (tak35 (tak95 (- x 1) y z)
(tak85 (- y 1) z x)
(tak95 (- z 1) x y)))))
(define (tak35 x y z)
(cond ((not (< y x)) z)
(else (tak36 (tak32 (- x 1) y z)
(tak96 (- y 1) z x)
(tak12 (- z 1) x y)))))
(define (tak36 x y z)
(cond ((not (< y x)) z)
(else (tak37 (tak69 (- x 1) y z)
(tak7 (- y 1) z x)
(tak29 (- z 1) x y)))))
(define (tak37 x y z)
(cond ((not (< y x)) z)
(else (tak38 (tak6 (- x 1) y z)
(tak18 (- y 1) z x)
(tak46 (- z 1) x y)))))
(define (tak38 x y z)
(cond ((not (< y x)) z)
(else (tak39 (tak43 (- x 1) y z)
(tak29 (- y 1) z x)
(tak63 (- z 1) x y)))))
(define (tak39 x y z)
(cond ((not (< y x)) z)
(else (tak40 (tak80 (- x 1) y z)
(tak40 (- y 1) z x)
(tak80 (- z 1) x y)))))
(define (tak40 x y z)
(cond ((not (< y x)) z)
(else (tak41 (tak17 (- x 1) y z)
(tak51 (- y 1) z x)
(tak97 (- z 1) x y)))))
(define (tak41 x y z)
(cond ((not (< y x)) z)
(else (tak42 (tak54 (- x 1) y z)
(tak62 (- y 1) z x)
(tak14 (- z 1) x y)))))
(define (tak42 x y z)
(cond ((not (< y x)) z)
(else (tak43 (tak91 (- x 1) y z)
(tak73 (- y 1) z x)
(tak31 (- z 1) x y)))))
(define (tak43 x y z)
(cond ((not (< y x)) z)
(else (tak44 (tak28 (- x 1) y z)
(tak84 (- y 1) z x)
(tak48 (- z 1) x y)))))
(define (tak44 x y z)
(cond ((not (< y x)) z)
(else (tak45 (tak65 (- x 1) y z)
(tak95 (- y 1) z x)
(tak65 (- z 1) x y)))))
(define (tak45 x y z)
(cond ((not (< y x)) z)
(else (tak46 (tak2 (- x 1) y z)
(tak6 (- y 1) z x)
(tak82 (- z 1) x y)))))
(define (tak46 x y z)
(cond ((not (< y x)) z)
(else (tak47 (tak39 (- x 1) y z)
(tak17 (- y 1) z x)
(tak99 (- z 1) x y)))))
(define (tak47 x y z)
(cond ((not (< y x)) z)
(else (tak48 (tak76 (- x 1) y z)
(tak28 (- y 1) z x)
(tak16 (- z 1) x y)))))
(define (tak48 x y z)
(cond ((not (< y x)) z)
(else (tak49 (tak13 (- x 1) y z)
(tak39 (- y 1) z x)
(tak33 (- z 1) x y)))))
(define (tak49 x y z)
(cond ((not (< y x)) z)
(else (tak50 (tak50 (- x 1) y z)
(tak50 (- y 1) z x)
(tak50 (- z 1) x y)))))
(define (tak50 x y z)
(cond ((not (< y x)) z)
(else (tak51 (tak87 (- x 1) y z)
(tak61 (- y 1) z x)
(tak67 (- z 1) x y)))))
(define (tak51 x y z)
(cond ((not (< y x)) z)
(else (tak52 (tak24 (- x 1) y z)
(tak72 (- y 1) z x)
(tak84 (- z 1) x y)))))
(define (tak52 x y z)
(cond ((not (< y x)) z)
(else (tak53 (tak61 (- x 1) y z)
(tak83 (- y 1) z x)
(tak1 (- z 1) x y)))))
(define (tak53 x y z)
(cond ((not (< y x)) z)
(else (tak54 (tak98 (- x 1) y z)
(tak94 (- y 1) z x)
(tak18 (- z 1) x y)))))
(define (tak54 x y z)
(cond ((not (< y x)) z)
(else (tak55 (tak35 (- x 1) y z)
(tak5 (- y 1) z x)
(tak35 (- z 1) x y)))))
(define (tak55 x y z)
(cond ((not (< y x)) z)
(else (tak56 (tak72 (- x 1) y z)
(tak16 (- y 1) z x)
(tak52 (- z 1) x y)))))
(define (tak56 x y z)
(cond ((not (< y x)) z)
(else (tak57 (tak9 (- x 1) y z)
(tak27 (- y 1) z x)
(tak69 (- z 1) x y)))))
(define (tak57 x y z)
(cond ((not (< y x)) z)
(else (tak58 (tak46 (- x 1) y z)
(tak38 (- y 1) z x)
(tak86 (- z 1) x y)))))
(define (tak58 x y z)
(cond ((not (< y x)) z)
(else (tak59 (tak83 (- x 1) y z)
(tak49 (- y 1) z x)
(tak3 (- z 1) x y)))))
(define (tak59 x y z)
(cond ((not (< y x)) z)
(else (tak60 (tak20 (- x 1) y z)
(tak60 (- y 1) z x)
(tak20 (- z 1) x y)))))
(define (tak60 x y z)
(cond ((not (< y x)) z)
(else (tak61 (tak57 (- x 1) y z)
(tak71 (- y 1) z x)
(tak37 (- z 1) x y)))))
(define (tak61 x y z)
(cond ((not (< y x)) z)
(else (tak62 (tak94 (- x 1) y z)
(tak82 (- y 1) z x)
(tak54 (- z 1) x y)))))
(define (tak62 x y z)
(cond ((not (< y x)) z)
(else (tak63 (tak31 (- x 1) y z)
(tak93 (- y 1) z x)
(tak71 (- z 1) x y)))))
(define (tak63 x y z)
(cond ((not (< y x)) z)
(else (tak64 (tak68 (- x 1) y z)
(tak4 (- y 1) z x)
(tak88 (- z 1) x y)))))
(define (tak64 x y z)
(cond ((not (< y x)) z)
(else (tak65 (tak5 (- x 1) y z)
(tak15 (- y 1) z x)
(tak5 (- z 1) x y)))))
(define (tak65 x y z)
(cond ((not (< y x)) z)
(else (tak66 (tak42 (- x 1) y z)
(tak26 (- y 1) z x)
(tak22 (- z 1) x y)))))
(define (tak66 x y z)
(cond ((not (< y x)) z)
(else (tak67 (tak79 (- x 1) y z)
(tak37 (- y 1) z x)
(tak39 (- z 1) x y)))))
(define (tak67 x y z)
(cond ((not (< y x)) z)
(else (tak68 (tak16 (- x 1) y z)
(tak48 (- y 1) z x)
(tak56 (- z 1) x y)))))
(define (tak68 x y z)
(cond ((not (< y x)) z)
(else (tak69 (tak53 (- x 1) y z)
(tak59 (- y 1) z x)
(tak73 (- z 1) x y)))))
(define (tak69 x y z)
(cond ((not (< y x)) z)
(else (tak70 (tak90 (- x 1) y z)
(tak70 (- y 1) z x)
(tak90 (- z 1) x y)))))
(define (tak70 x y z)
(cond ((not (< y x)) z)
(else (tak71 (tak27 (- x 1) y z)
(tak81 (- y 1) z x)
(tak7 (- z 1) x y)))))
(define (tak71 x y z)
(cond ((not (< y x)) z)
(else (tak72 (tak64 (- x 1) y z)
(tak92 (- y 1) z x)
(tak24 (- z 1) x y)))))
(define (tak72 x y z)
(cond ((not (< y x)) z)
(else (tak73 (tak1 (- x 1) y z)
(tak3 (- y 1) z x)
(tak41 (- z 1) x y)))))
(define (tak73 x y z)
(cond ((not (< y x)) z)
(else (tak74 (tak38 (- x 1) y z)
(tak14 (- y 1) z x)
(tak58 (- z 1) x y)))))
(define (tak74 x y z)
(cond ((not (< y x)) z)
(else (tak75 (tak75 (- x 1) y z)
(tak25 (- y 1) z x)
(tak75 (- z 1) x y)))))
(define (tak75 x y z)
(cond ((not (< y x)) z)
(else (tak76 (tak12 (- x 1) y z)
(tak36 (- y 1) z x)
(tak92 (- z 1) x y)))))
(define (tak76 x y z)
(cond ((not (< y x)) z)
(else (tak77 (tak49 (- x 1) y z)
(tak47 (- y 1) z x)
(tak9 (- z 1) x y)))))
(define (tak77 x y z)
(cond ((not (< y x)) z)
(else (tak78 (tak86 (- x 1) y z)
(tak58 (- y 1) z x)
(tak26 (- z 1) x y)))))
(define (tak78 x y z)
(cond ((not (< y x)) z)
(else (tak79 (tak23 (- x 1) y z)
(tak69 (- y 1) z x)
(tak43 (- z 1) x y)))))
(define (tak79 x y z)
(cond ((not (< y x)) z)
(else (tak80 (tak60 (- x 1) y z)
(tak80 (- y 1) z x)
(tak60 (- z 1) x y)))))
(define (tak80 x y z)
(cond ((not (< y x)) z)
(else (tak81 (tak97 (- x 1) y z)
(tak91 (- y 1) z x)
(tak77 (- z 1) x y)))))
(define (tak81 x y z)
(cond ((not (< y x)) z)
(else (tak82 (tak34 (- x 1) y z)
(tak2 (- y 1) z x)
(tak94 (- z 1) x y)))))
(define (tak82 x y z)
(cond ((not (< y x)) z)
(else (tak83 (tak71 (- x 1) y z)
(tak13 (- y 1) z x)
(tak11 (- z 1) x y)))))
(define (tak83 x y z)
(cond ((not (< y x)) z)
(else (tak84 (tak8 (- x 1) y z)
(tak24 (- y 1) z x)
(tak28 (- z 1) x y)))))
(define (tak84 x y z)
(cond ((not (< y x)) z)
(else (tak85 (tak45 (- x 1) y z)
(tak35 (- y 1) z x)
(tak45 (- z 1) x y)))))
(define (tak85 x y z)
(cond ((not (< y x)) z)
(else (tak86 (tak82 (- x 1) y z)
(tak46 (- y 1) z x)
(tak62 (- z 1) x y)))))
(define (tak86 x y z)
(cond ((not (< y x)) z)
(else (tak87 (tak19 (- x 1) y z)
(tak57 (- y 1) z x)
(tak79 (- z 1) x y)))))
(define (tak87 x y z)
(cond ((not (< y x)) z)
(else (tak88 (tak56 (- x 1) y z)
(tak68 (- y 1) z x)
(tak96 (- z 1) x y)))))
(define (tak88 x y z)
(cond ((not (< y x)) z)
(else (tak89 (tak93 (- x 1) y z)
(tak79 (- y 1) z x)
(tak13 (- z 1) x y)))))
(define (tak89 x y z)
(cond ((not (< y x)) z)
(else (tak90 (tak30 (- x 1) y z)
(tak90 (- y 1) z x)
(tak30 (- z 1) x y)))))
(define (tak90 x y z)
(cond ((not (< y x)) z)
(else (tak91 (tak67 (- x 1) y z)
(tak1 (- y 1) z x)
(tak47 (- z 1) x y)))))
(define (tak91 x y z)
(cond ((not (< y x)) z)
(else (tak92 (tak4 (- x 1) y z)
(tak12 (- y 1) z x)
(tak64 (- z 1) x y)))))
(define (tak92 x y z)
(cond ((not (< y x)) z)
(else (tak93 (tak41 (- x 1) y z)
(tak23 (- y 1) z x)
(tak81 (- z 1) x y)))))
(define (tak93 x y z)
(cond ((not (< y x)) z)
(else (tak94 (tak78 (- x 1) y z)
(tak34 (- y 1) z x)
(tak98 (- z 1) x y)))))
(define (tak94 x y z)
(cond ((not (< y x)) z)
(else (tak95 (tak15 (- x 1) y z)
(tak45 (- y 1) z x)
(tak15 (- z 1) x y)))))
(define (tak95 x y z)
(cond ((not (< y x)) z)
(else (tak96 (tak52 (- x 1) y z)
(tak56 (- y 1) z x)
(tak32 (- z 1) x y)))))
(define (tak96 x y z)
(cond ((not (< y x)) z)
(else (tak97 (tak89 (- x 1) y z)
(tak67 (- y 1) z x)
(tak49 (- z 1) x y)))))
(define (tak97 x y z)
(cond ((not (< y x)) z)
(else (tak98 (tak26 (- x 1) y z)
(tak78 (- y 1) z x)
(tak66 (- z 1) x y)))))
(define (tak98 x y z)
(cond ((not (< y x)) z)
(else (tak99 (tak63 (- x 1) y z)
(tak89 (- y 1) z x)
(tak83 (- z 1) x y)))))
(define (tak99 x y z)
(cond ((not (< y x)) z)
(else (tak0 (tak0 (- x 1) y z)
(tak0 (- y 1) z x)
(tak0 (- z 1) x y)))))
(tak0 x y z))
;;; call: (tak0 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

85
benchmarks/gabriel/triangle.sch Normal file
View file

@ -0,0 +1,85 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: triangle.sch
; Description: TRIANGLE benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:30:32 (Bob Shaw)
; 11-Aug-87 (Will Clinger)
; 22-Jan-88 (Will Clinger)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TRIANG -- Board game benchmark.
(define *board* (make-vector 16 1))
(define *sequence* (make-vector 14 0))
(define *a* (make-vector 37))
(define *b* (make-vector 37))
(define *c* (make-vector 37))
(define *answer* '())
(define *final* '())
(define (last-position)
(do ((i 1 (+ i 1)))
((or (= i 16) (= 1 (vector-ref *board* i)))
(if (= i 16) 0 i))))
(define (ttry i depth)
(cond ((= depth 14)
(let ((lp (last-position)))
(if (not (member lp *final*))
(set! *final* (cons lp *final*))))
(set! *answer*
(cons (cdr (vector->list *sequence*)) *answer*))
#t)
((and (= 1 (vector-ref *board* (vector-ref *a* i)))
(= 1 (vector-ref *board* (vector-ref *b* i)))
(= 0 (vector-ref *board* (vector-ref *c* i))))
(vector-set! *board* (vector-ref *a* i) 0)
(vector-set! *board* (vector-ref *b* i) 0)
(vector-set! *board* (vector-ref *c* i) 1)
(vector-set! *sequence* depth i)
(do ((j 0 (+ j 1))
(depth (+ depth 1)))
((or (= j 36) (ttry j depth)) #f))
(vector-set! *board* (vector-ref *a* i) 1)
(vector-set! *board* (vector-ref *b* i) 1)
(vector-set! *board* (vector-ref *c* i) 0) '())
(else #f)))
(define (gogogo i)
(let ((*answer* '())
(*final* '()))
(ttry i 1)))
(for-each (lambda (i x) (vector-set! *a* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(1 2 4 3 5 6 1 3 6 2 5 4 11 12
13 7 8 4 4 7 11 8 12 13 6 10
15 9 14 13 13 14 15 9 10
6 6))
(for-each (lambda (i x) (vector-set! *b* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(2 4 7 5 8 9 3 6 10 5 9 8
12 13 14 8 9 5 2 4 7 5 8
9 3 6 10 5 9 8 12 13 14
8 9 5 5))
(for-each (lambda (i x) (vector-set! *c* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(4 7 11 8 12 13 6 10 15 9 14 13
13 14 15 9 10 6 1 2 4 3 5 6 1
3 6 2 5 4 11 12 13 7 8 4 4))
(vector-set! *board* 5 0)
;;; call: (gogogo 22))
(time (let loop ((n 100000))
(if (zero? n)
'done
(begin
(gogogo 22)
(loop (- n 1))))))